"======================================================================
|
|   Metaclass Method Definitions
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Steve Byrne, Brad Diller and Paolo Bonzini.
|
| This file is part of the GNU Smalltalk class library.
|
| The GNU Smalltalk class library is free software; you can redistribute it
| and/or modify it under the terms of the GNU Lesser General Public License
| as published by the Free Software Foundation; either version 2.1, or (at
| your option) any later version.
| 
| The GNU Smalltalk class library is distributed in the hope that it will be
| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
| General Public License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LESSER.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"


ClassDescription subclass: #Metaclass
		 instanceVariableNames: 'instanceClass'
		 classVariableNames: ''
		 poolDictionaries: ''
		 category: 'Language-Implementation'
!

Metaclass comment: 
'I am the root of the class hierarchy.  My instances are metaclasses, one for
each real class.  My instances have a single instance, which they hold
onto, which is the class that they are the metaclass of.  I provide methods
for creation of actual class objects from metaclass object, and the creation
of metaclass objects, which are my instances.  If this is confusing to you,
it should be...the Smalltalk metaclass system is strange and complex.' !


!Metaclass class methodsFor: 'instance creation'!

subclassOf: superMeta
    "Answer a new metaclass representing a subclass of superMeta"

    | newMeta |
    newMeta := self new.
    newMeta superclass: superMeta.
    superMeta addSubclass: newMeta.
    newMeta initMetaclass: superMeta.
    ^newMeta
! !



!Metaclass methodsFor: 'delegation'!

addClassVarName: aString
    "Add a class variable with the given name to the class pool dictionary"
    
    ^self instanceClass addClassVarName: aString
!

removeClassVarName: aString
    "Removes the class variable from the class, error if not present, or
     still in use."

    ^self instanceClass removeClassVarName: aString
!

name
    "Answer the class name - it has none, actually"
    ^nil
!

category
    "Answer the class category"
    ^self asClass category
!

comment
    "Answer the class comment"
    ^self asClass comment
!

environment
    "Answer the namespace in which the receiver is implemented"
    ^self asClass environment
!

classPool
    "Answer the class pool dictionary"

    ^self instanceClass classPool
!

classVarNames
    "Answer the names of the variables in the class pool dictionary"

    ^self instanceClass classVarNames
!

allClassVarNames
    "Answer the names of the variables in the receiver's class pool dictionary
     and in each of the superclasses' class pool dictionaries"

    ^self instanceClass allClassVarNames
!

addSharedPool: aDictionary
    "Add the given shared pool to the list of the class' pool dictionaries"

    ^self instanceClass addSharedPool: aDictionary
!

removeSharedPool: aDictionary
    "Remove the given dictionary to the list of the class' pool dictionaries"

    ^self instanceClass removeSharedPool: aDictionary
!

sharedPools
    "Return the names of the shared pools defined by the class"

    ^self instanceClass sharedPools
!

allSharedPools
    "Return the names of the shared pools defined by the class and any of
     its superclasses"

    ^self instanceClass allSharedPools
! !


!Metaclass methodsFor: 'basic'!

instanceVariableNames: classInstVarNames

    "Set the class-instance variables for the receiver to be those
     in classInstVarNames"

    | variableArray variableString |
    variableString := self superclass instanceVariableString,
	classInstVarNames.
    variableArray := self parseVariableString: variableString.

    1 to: variableArray size do:
	[ :i | variableArray at: i put: (variableArray at: i) asSymbol ].

    "If instance variables change, update  instance variables and
     instance spec of the class and all its subclasses "

    variableArray = self allInstVarNames ifTrue: [ ^self ].

    self
	updateInstanceVars: variableArray 
	variable: false
	words: false
	pointers: true.

    "If no variable has been removed, no need to recompile"
    (self allInstVarNames allSatisfy: [ :each | variableArray includes: each ])
	ifTrue: [ ^self ].
	
    Transcript nextPutAll: 'Recompiling Classes...'; nl.
    self compileAll.
    self compileAllSubclasses
!

name: newName
    environment: aNamespace
    subclassOf: superclass
    instanceVariableNames: stringOfInstVarNames
    variable: variableBoolean
    words: wordBoolean
    pointers: pointerBoolean
    classVariableNames: stringOfClassVarNames
    poolDictionaries: stringOfPoolNames
    category: categoryName

    "Private - create a full featured class and install it, or change an
     existing one"

    | aClass variableString variableArray sharedPoolNames poolName poolDict 
      className classVarDict  needToRecompileMetaclasses needToRecompileClasses |

    "Initialize a metaclass"

    className := newName asSymbol.
    aClass := aNamespace hereAt: className ifAbsent: [ nil ].
    aClass isNil ifTrue: [
	^self newMeta: className
	    environment: aNamespace
	    subclassOf: superclass
	    instanceVariableNames: stringOfInstVarNames
	    variable: variableBoolean
	    words: wordBoolean
	    pointers: pointerBoolean
	    classVariableNames: stringOfClassVarNames
	    poolDictionaries: stringOfPoolNames
	    category: categoryName
    ].

    needToRecompileMetaclasses := false.

    (aClass isVariable & aClass isBits) ifTrue: [
	(variableBoolean not | pointerBoolean) ifTrue: [
	    ^self error: 'Cannot change non-pointer subclass to pointer subclass'
	].
	aClass isWords ~~ wordBoolean ifTrue: [
	    ^self error: 'Cannot change representation of non-pointer subclass'
	]
    ].

    "Inherit instance variables from parent"
    variableString := superclass notNil 
	ifTrue: [ superclass instanceVariableString, stringOfInstVarNames ]
	ifFalse: [ stringOfInstVarNames ].

    variableArray := self parseVariableString: variableString.
    1 to: variableArray size do:
	[ :i | variableArray at: i put: (variableArray at: i) asSymbol ].

    "If instance or indexed variables change, update 
     instance variables and instance spec of the class and all its subclasses "

    (needToRecompileClasses := variableArray ~= aClass allInstVarNames
	| (aClass environment ~~ aNamespace)) 

	| (aClass isVariable ~~ variableBoolean)
	| (aClass isWords ~~ wordBoolean )
	| (aClass isPointers ~~ pointerBoolean)
	    ifTrue: [
	        aClass instanceCount > 0 ifTrue: [ Smalltalk compact ].
		aClass
		    updateInstanceVars: variableArray 
		    variable: variableBoolean
		    words: wordBoolean
		    pointers: pointerBoolean
	    ].

   needToRecompileMetaclasses := aClass environment ~~ aNamespace.
		
   classVarDict := (self parseToDict: stringOfClassVarNames).

   aClass classPool isNil 
       ifTrue: [ aClass setClassVariables: classVarDict ]
       ifFalse: [
	    classVarDict keysDo: [ :key |
		 (aClass classPool includesKey: key)
		     ifFalse: [ aClass addClassVarName: key ]
	    ]. 

	    aClass classPool keys do: [ :aKey |
		 (classVarDict includesKey: aKey)
		     ifFalse: [
			 aClass removeClassVarName: aKey.
			 needToRecompileMetaclasses := true
		     ]
	    ]
	].

    sharedPoolNames := self parseVariableString: stringOfPoolNames.
    1 to: sharedPoolNames size do: [ :i |
	poolName := (sharedPoolNames at: i) asSymbol.

	poolDict := aNamespace
	   at: poolName
	   ifAbsent: [ ^self error: 'Pool ', poolName , ' does not exist' ].

	sharedPoolNames at: i put: poolDict
    ].
    aClass sharedPoolDictionaries isNil 
	ifTrue: [ aClass setSharedPools: sharedPoolNames ]
	ifFalse: [
	    sharedPoolNames do: [ :dict |
		(aClass sharedPoolDictionaries includes: dict)
		    ifFalse: [ aClass addSharedPool: dict ]
	    ].

	    aClass sharedPoolDictionaries copy do: [ :dict |
		(sharedPoolNames includes: dict)
		    ifFalse: [
			aClass removeSharedPool: dict.
			needToRecompileMetaclasses := true
		    ]
	    ]
	].

    (aClass superclass ~~ superclass) ifTrue: [
	 "Fix references between classes..."
	 aClass superclass removeSubclass: aClass.
	 superclass addSubclass: aClass.
	 aClass superclass: superclass.
	 needToRecompileClasses := true.

	 "...and between metaclasses..."
	 self superclass removeSubclass: self.
	 superclass class addSubclass: self.
	 self superclass: superclass class.
	 needToRecompileMetaclasses := true.
    ].

    aClass category: categoryName.

    "Please note that I need to recompile the classes in this sequence;
    otherwise, the same error is propagated to each selector which is compiled
    after an error is detected even though there are no further compilation 
    errors. Apparently, there is a bug in the primitive compileString.  This
    can be cleaned up later"
	 
    (needToRecompileClasses | needToRecompileMetaclasses)
	ifTrue: [
	    Transcript nextPutAll: 'Recompiling Classes...'; nl.
	    aClass compileAll.
	    needToRecompileMetaclasses
		ifTrue: [ aClass class compileAll ].

	    aClass compileAllSubclasses.
	    needToRecompileMetaclasses
		ifTrue: [ aClass class compileAllSubclasses ]
       ].

    Behavior flushCache.
    ^aClass
!


newMeta: className
    environment: aNamespace
    subclassOf: superclass
    instanceVariableNames: stringOfInstVarNames
    variable: variableBoolean
    words: wordBoolean
    pointers: pointerBoolean
    classVariableNames: stringOfClassVarNames
    poolDictionaries: stringOfPoolNames
    category: categoryName

    "Private - create a full featured class and install it"

    | aClass variableString variableArray sharedPoolNames poolName poolDict |

    sharedPoolNames := self parseVariableString: stringOfPoolNames.
    1 to: sharedPoolNames size do: [ :i |
	poolName := (sharedPoolNames at: i) asSymbol.
	poolDict := aNamespace
	    at: poolName
	    ifAbsent: [ ^self error: 'Pool ', poolName , ' does not exist' ].

	sharedPoolNames at: i put: poolDict
    ].
    aClass := self new.
    instanceClass := aClass.
    aNamespace at: className put: aClass.
    aClass superclass: superclass.
    aClass setName: className.
    superclass notNil
	ifTrue: [
	    "Inherit instance variables from parent"
	    variableString := superclass instanceVariableString.
	    superclass addSubclass: aClass
	]
	ifFalse: [ variableString := '' ].

    variableString := variableString , stringOfInstVarNames.
    variableArray := self parseVariableString: variableString.
    1 to: variableArray size do:
	[ :i | variableArray at: i put: (variableArray at: i) asSymbol ].

    Behavior flushCache.
    ^aClass
	setEnvironment: aNamespace;
	setInstanceVariables: variableArray;
	setInstanceSpec: variableBoolean
	    words: wordBoolean
	    pointers: pointerBoolean
	    instVars: variableArray size;
	setClassVariables: (self parseToDict: stringOfClassVarNames);
	setSharedPools: sharedPoolNames;
	category: categoryName;
	yourself
! !



!Metaclass methodsFor: 'accessing'!

primaryInstance
    "Answer the only instance of the metaclass - present for compatibility"
    ^instanceClass
!

soleInstance
    "Answer the only instance of the metaclass - present for compatibility"
    ^instanceClass
!

instanceClass
    "Answer the only instance of the metaclass"
    ^instanceClass
! !




!Metaclass methodsFor: 'printing'!

nameIn: aNamespace
    "Answer the class name when the class is referenced from aNamespace
     - a dummy one, since Behavior does not support names."
    ^self environment == aNamespace
	ifTrue: [ self printString ]
	ifFalse: [ self environment storeString, ' ', self printString ]
!

printOn: aStream
    "Print a represention of the receiver on aStream"
    instanceClass printOn: aStream.
    aStream nextPutAll: ' class'
!

storeOn: aStream
    "Store Smalltalk code compiling to the receiver on aStream"
    self printOn: aStream
! !



!Metaclass methodsFor: 'private'!

initMetaclass: superclass
    instanceVariables := superclass allInstVarNames.
    instanceSpec := superclass instanceSpec
!

parseVariableString: aString
    | stream tokens |
    stream := TokenStream on: aString.
    tokens := stream contents.
    "Smalltalk verboseExecTracing: true."
    tokens do: [ :token | self isLegalIdentifier: token ].
    "Smalltalk verboseExecTracing: false."
    ^tokens
!

parseToDict: aString
    | tokenArray dict |
    tokenArray := self parseVariableString: aString.
    dict := Dictionary new.
    tokenArray do:
    	[ :element | dict at: element asSymbol put: nil ].
    ^dict
!

isLegalIdentifier: token
    "Token is a string or string-oid"
    | firstTime |
    firstTime := true.
    token do: [ :ch |
	(ch isLetter | (firstTime not and: [ ch = $_ | ch isDigit ]))
	    ifFalse: [ ^self error: 'Invalid Smalltalk identifier: ', token printString ].

	firstTime := false
    ].
    ^true
!
	       

growClassInstance
    | newClass numInstVars |
    newClass := self new.
    numInstVars := self instSize.
    numInstVars printNl.
    1 to: numInstVars - 1 do:
	[ :i | newClass instVarAt: i put: 
		   (instanceClass instVarAt: i) ].

    instanceClass become: newClass.
! !

!Metaclass methodsFor: 'testing functionality'!

asClass
    ^instanceClass
!

isMetaclass
    ^true
! !


!Metaclass methodsFor: 'filing'!

fileOutOn: aFileStream
    "File out complete class description:  class definition, class and
     instance methods"

    instanceClass fileOutOn: aFileStream
! !