"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

Class subclass:#Metaclass

       instanceVariableNames:''

       classVariableNames:''

       poolDictionaries:''

       category:'Kernel-Classes'

!

Metaclass comment:'

COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

'!

!Metaclass class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1988 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

version

"

"

!

documentation

"

    every classes class is a subclass of Metaclass.

    Metaclass provides support for creating new (sub)classes and/or 

    changing the definition of an already existing class.

"

! !

!Metaclass methodsFor:'creating classes'!

name:newName inEnvironment:aSystemDictionary

	     subclassOf:aClass

	     instanceVariableNames:stringOfInstVarNames

	     variable:variableBoolean

	     words:wordsBoolean

	     pointers:pointersBoolean

	     classVariableNames:stringOfClassVarNames

	     poolDictionaries:stringOfPoolNames

	     category:categoryString

	     comment:commentString

	     changed:changed

    "this is the main workhorse for installing new classes - special care

     has to be taken, when changing an existing classes definition. In this

     case, some or all of the methods and subclasses methods have to be

     recompiled.

     Also, the old class(es) are still kept (but not accessable as a global),

     to allow existing instances some life. 

     This might change in the future.

    "

    |newClass newMetaclass nInstVars nameString classSymbol oldClass 

     classVarChange instVarChange superClassChange newComment

     changeSet1 changeSet2 offset oldOffsets newOffsets addedNames

     anyChange oldInstVars newInstVars oldClassVars newClassVars upd superFlags newFlags|

    "NOTICE:

     this method is too complex and should be splitted into managable pieces ...

     I dont like it anymore :-) 

     (However, its a good test for the compilers ability to handle big, complex methods ;-)

    "

    newName = aClass name ifTrue:[

	self error:'trying to create circular class definition'.

	^ nil

    ].

    "check for invalid subclassing of UndefinedObject and SmallInteger"

    aClass canBeSubclassed ifFalse:[

	self error:('it is not possible to subclass ' , aClass name).

    ].

    nInstVars := stringOfInstVarNames countWords.

    nameString := newName asString.

    classSymbol := newName asSymbol.

    newComment := commentString.

    "look, if it already exists as a class"

    oldClass := aSystemDictionary at:classSymbol ifAbsent:[nil].

    oldClass isBehavior ifFalse:[

	oldClass := nil.

    ] ifTrue:[

	oldClass superclass notNil ifTrue:[

	    oldClass allSuperclasses do:[:cls |

		cls name = nameString ifTrue:[

		    self error:'trying to create circular class definition'.

		    ^ nil

		]

	    ]

	].

	aClass superclass notNil ifTrue:[

	    aClass allSuperclasses do:[:cls |

		cls name = nameString ifTrue:[

		    self error:'trying to create circular class definition'.

		    ^ nil

		]

	    ].

	].

	newComment isNil ifTrue:[

	    newComment := oldClass comment

	].

	"

	 warn, if it exists with different category and different instvars,

	 and the existing is not an autoload class.

	 Usually, this indicates that someone wants to create a new class with

	 a name, which already exists (it happened a few times to myself, while 

	 I wanted to create a new class called ReturnNode ...).

	 This will be much less of a problem, once multiple name spaces are

	 implemented and classes can be put into separate packages.

	"

	oldClass isLoaded ifTrue:[

	    oldClass category ~= categoryString ifTrue:[

		oldClass instanceVariableString asCollectionOfWords 

		~= stringOfInstVarNames asCollectionOfWords ifTrue:[

		    (self confirm:'a class named ' , oldClass name , ' already exists -

create (i.e. change) anyway ?' withCRs)

		    ifFalse:[

			^ nil

		    ]

		]

	    ]

	]

    ].

    "

     Check for some 'considered bad-style' things, like lower case names.

     But only do these checks for new classes - 

     - thus, once confirmed, the warnings will not come again and again.

     NOTICE:

     the outer codeview a chance to highlight the error.

     (but thats how its defined in the book - maybe I will change anyway).

    "

    oldClass isNil ifTrue:[

	]

    ].

    "create the metaclass first"

    newMetaclass := Metaclass new.

    newMetaclass setSuperclass:(aClass class).

    newMetaclass instSize:(aClass class instSize).

    newMetaclass setName:(nameString , 'class') asSymbol.

    newMetaclass classVariableString:'' "stringOfClassVarNames".

    newMetaclass setComment:newComment category:categoryString.

    newClass := newMetaclass new.

    newClass setSuperclass:aClass.

    newClass instSize:(aClass instSize + nInstVars).

    newClass setName:classSymbol.

    newClass setComment:newComment category:categoryString.

    "

     Allowing non-booleans as variableBoolean

     is a hack for backward (ST-80) compatibility:

     ST-80 code will pass true or false as variableBoolean,

     while ST/X also calls it with symbols such as #float, #double etc.

    "

    (variableBoolean == true) ifTrue:[

	pointersBoolean ifTrue:[

	    newFlags := Behavior flagPointers

	] ifFalse:[

	    wordsBoolean ifTrue:[

		newFlags := Behavior flagWords

	    ] ifFalse:[

		newFlags := Behavior flagBytes

	    ]

	]

    ] ifFalse:[

	(variableBoolean == #float) ifTrue:[

	    newFlags := Behavior flagFloats

	] ifFalse:[

	    (variableBoolean == #double) ifTrue:[

		newFlags := Behavior flagDoubles

	    ] ifFalse:[

		(variableBoolean == #long) ifTrue:[

		    newFlags := Behavior flagLongs

		] ifFalse:[

		    newFlags := Behavior flagNotIndexed   

		]

	    ]

	].

    ].

    superFlags := aClass flags bitAnd:(Behavior maskIndexType bitInvert). "preserve other bits"

    oldClass notNil ifTrue:[

	oldClass isBuiltInClass ifTrue:[

	    "

	     special care when redefining Method, Block and other built-in classes,

	     which might have other flag bits ...

	    "

	    newFlags := newFlags bitOr:(oldClass flags bitAnd:(Behavior maskIndexType bitInvert))

	]

    ].

    newClass flags:(newFlags bitOr:superFlags). "preserve  inherited special bits"

    (nInstVars ~~ 0) ifTrue:[

	newClass instanceVariableString:stringOfInstVarNames

    ].

    oldClass notNil ifTrue:[

	"setting first will make new class clear obsolete classvars"

	newClass setClassVariableString:(oldClass classVariableString)

    ].

    newClass classVariableString:stringOfClassVarNames.

    "

     for new classes, we are almost done here

     (also for autoloaded classes)

    "

    (oldClass isNil or:[oldClass isLoaded not]) ifTrue:[

	oldClass isNil ifTrue:[

	    self addChangeRecordForClass:newClass.

	].

	commentString notNil ifTrue:[

	    newClass comment:commentString

	].

	aSystemDictionary at:classSymbol put:newClass.

	aSystemDictionary changed:#newClass with:newClass.

	^ newClass

    ].

    "

     here comes the hard part - we are actually changing the

     definition of an existing class ....

     Try hard to get away WITHOUT recompiling, since it makes all

     compiled code into interpreted ...

    "

    oldInstVars := oldClass instanceVariableString asCollectionOfWords.

    newInstVars := newClass instanceVariableString asCollectionOfWords.

    oldClassVars := oldClass classVariableString asCollectionOfWords.

    newClassVars := newClass classVariableString asCollectionOfWords.

    "

     we are on the bright side of life, if the instance layout and

     inheritance do not change.

     In this case, we can go ahead and patch the class object.

    "

    (oldClass superclass == newClass superclass) ifTrue:[

      (oldClass instSize == newClass instSize) ifTrue:[

	(oldClass flags == newClass flags) ifTrue:[

	  (oldClass name = newClass name) ifTrue:[

	    (oldInstVars = newInstVars) ifTrue:[

	      (newComment ~= oldClass comment) ifTrue:[

		  oldClass setComment:newComment.        "writes a change-chunk"

		  oldClass changed:#comment with:oldClass comment.

		  self addChangeRecordForClassComment:oldClass.

	      ]. 

	      (oldClassVars = newClassVars) ifTrue:[

		"

		 really no change (just comment and/or category)

		"

		anyChange := false.

		oldClass instanceVariableString:(newClass instanceVariableString).

		oldClass setClassVariableString:(newClass classVariableString).

		oldClass category ~= categoryString ifTrue:[

		    oldClass category:categoryString. 

		    self addChangeRecordForClass:newClass.

		    "notify change of organization"

		    aSystemDictionary changed

		].

		"notify change of class"

"/                oldClass changed.

		^ oldClass

	      ].

	      "

	       when we arrive here, class variables have changed

	      "

	      oldClass category ~= categoryString ifTrue:[

		  "notify change of organization"

		  oldClass category:categoryString. 

		  "notify change of organization"

		  aSystemDictionary changed

	      ].

	      "

	       set class variable string; 

	       this also updates the set of class variables

	       by creating new / deleting obsolete ones.

	      "

	      oldClass classVariableString:stringOfClassVarNames.

	      "

	       get the set of changed class variables

	      "

	      changeSet1 := Set new.

	      oldClassVars do:[:nm |

		  (newClassVars includes:nm) ifFalse:[

		      changeSet1 add:nm

		  ]

	      ].

	      newClassVars do:[:nm |

		  (oldClassVars includes:nm) ifFalse:[

		      changeSet1 add:nm

		  ]

	      ].

	      "

	       recompile all methods accessing set of changed classvars

	       here and also in all subclasses ...

	      "

	      "

	       dont update change file for the recompilation

	      "

	      upd := Class updateChanges:false.

	      [

" "

		  Transcript showCr:'recompiling class & inst methods accessing ' , changeSet1 printString.

		  Transcript endEntry.

" "

		  oldClass withAllSubclasses do:[:aClass |

		      aClass class recompileMethodsAccessingAny:changeSet1.

		      aClass recompileMethodsAccessingAny:changeSet1.

		  ].

	      ] valueNowOrOnUnwindDo:[

		  Class updateChanges:upd.

	      ].

	      "notify change of class"

	      self addChangeRecordForClass:oldClass.

	      oldClass changed:#definition.

	      ^ oldClass

	    ]

	  ]

	]

      ]

    ].

    "

     here we enter the darkness of mordor ...

     since instance variable layout and/or inheritance has changed.

    "

    (newComment ~= oldClass comment) ifTrue:[

	newClass comment:newComment

    ].

    superClassChange := oldClass superclass ~~ newClass superclass.

    "

     dont allow built-in classes to be modified this way

    "

    (oldClass notNil and:[oldClass isBuiltInClass and:[superClassChange]]) ifTrue:[

	self error:'the inheritance of this class is fixed - you cannot change it'.

	^ oldClass

    ].

    "

     catch special case, where superclass changed its layout and thus

     forced redefinition of this class; 

     only log if this is not the case.

    "

    (superClassChange 

     and:[(oldClass superclass isNil or:[oldClass superclass name = newClass superclass name])

     and:[(oldClassVars = newClassVars) 

     and:[(oldInstVars = newInstVars)

     and:[newComment = oldClass comment]]]]) ifFalse:[

	self addChangeRecordForClass:newClass.

    ].

    "

     care for class methods ...

    "

    changeSet1 := Set new.

    classVarChange := false.

    superClassChange ifTrue:[

	"

	 superclass changed:

	 must recompile all class methods accessing ANY classvar

	 (

	  actually, we could be less strict and handle the case where

	  both the old and the new superclass have a common ancestor,

	  and both have no new classvariables in between.

	  This would speedup the case when a class is inserted into

	  the inheritance chain.

	 )

	"

	oldClass allClassVarNames do:[:nm | changeSet1 add:nm].

	newClass allClassVarNames do:[:nm | changeSet1 add:nm].

" "

	Transcript showCr:'recompiling class methods accessing any classvar'.

	Transcript endEntry.

" "

	self copyInvalidatedMethodsFrom:(oldClass class) 

				    for:newMetaclass 

			   accessingAny:changeSet1

				orSuper:true.

	newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).

    ] ifFalse:[

	"

	 same superclass, find out which classvars have changed

	"

	classVarChange := oldClassVars ~= newClassVars.

	classVarChange ifTrue:[

	    oldClassVars do:[:nm |

		(newClassVars includes:nm) ifFalse:[

		    changeSet1 add:nm

		]

	    ].

	    newClassVars do:[:nm |

		(oldClassVars includes:nm) ifFalse:[

		    changeSet1 add:nm

		]

	    ].

	].

	classVarChange ifTrue:[

	    "

	     must recompile some class-methods

	    "

" "

	    Transcript showCr:'recompiling class methods accessing ' , changeSet1 printString.

	    Transcript endEntry.

" "

	    self copyInvalidatedMethodsFrom:(oldClass class) for:newMetaclass accessingAny:changeSet1.

	    newMetaclass recompileInvalidatedMethods:(Metaclass compiledMethodAt:#invalidMethod).

	] ifFalse:[

	    "

	     class methods still work

	    "

	    self copyMethodsFrom:(oldClass class) for:newMetaclass

	].

    ].

    "

     care for instance methods ...

    "

    changeSet2 := Set new.

    superClassChange ifTrue:[

	"superclass changed,

	 must recompile all methods accessing any class or instvar.

	 If number of instvars (i.e. the instances instSize) is the same,

	 we can limit the set of recompiled instance methods to those methods,

	 which refer to an instvar with a different inst-index

	"