"======================================================================
|
|   Class 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.
|
| 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: #Class
		 instanceVariableNames: 'name comment category environment classVariables sharedPools'
		 classVariableNames: ''
		 poolDictionaries: ''
		 category: 'Language-Implementation'
!

Class comment: 
'I am THE class object.  My instances are the classes of the system.
I provide information commonly attributed to classes: namely, the
class name, class comment (you wouldn''t be reading this if it
weren''t for me), a list of the instance variables of the class, and
the class category.' !


!Class methodsFor: 'accessing instances and variables'!

name
    "Answer the class name"
    ^name
!

comment
    "Answer the class comment"
    ^comment
!

comment: aString
    "Change the class name"
    comment := aString
!

environment
    ^environment
!

environment: aNamespace
    "Set the receiver's environment to aNamespace and recompile everything"
    environment := aNamespace.
    self asClass compileAll; compileAllSubclasses.
    self asMetaclass compileAll; compileAllSubclasses.
!

category
    "Answer the class category"
    ^category
!

category: aString
    "Change the class category to aString"
    category := aString
! !



!Class methodsFor: 'accessing instances and variables'!

addClassVarName: aString
    "Add a class variable with the given name to the class pool dictionary"
    | sym |
    sym := aString asSymbol.	"### maybe this should remain a string? "
    (classVariables notNil and: [classVariables includesKey: sym])
    	     ifTrue: [ ^self error: 'class variable already present' ].

    classVariables at: sym put: nil
!

removeClassVarName: aString
    "Removes the class variable from the class, error if not present, or
     still in use."
    | sym |
    sym := aString asSymbol.	"### maybe this should remain a string? "
    " ### test for use in sub method "
    (classVariables notNil and: [classVariables includesKey: sym])
    	ifTrue: [ ^classVariables removeKey: sym ].

	self error: 'class variable not present' 
!

classPool
    "Answer the class pool dictionary"
    classVariables isNil ifTrue: [ classVariables := Dictionary new ].
    ^classVariables
!

classVarNames
    "Answer the names of the variables in the class pool dictionary"
    ^classVariables notNil
	ifTrue: [ classVariables keys ]
	ifFalse: [ Set new ].
!

allClassVarNames
    "Answer the names of the variables in the receiver's class pool dictionary
     and in each of the superclasses' class pool dictionaries"
    | superVarNames |
    superVarNames :=  self classVarNames.
    self allSuperclasses do: [ :each |
	superVarNames addAll: each classVarNames].
    ^superVarNames.  
!

addSharedPool: aDictionary
    "Add the given shared pool to the list of the class' pool dictionaries"
    (sharedPools includes: aDictionary)
    	ifFalse: [ sharedPools := sharedPools copyWith: aDictionary ]
!

removeSharedPool: aDictionary
    "Remove the given dictionary to the list of the class' pool dictionaries"
    sharedPools := sharedPools copyWithout: aDictionary
!

sharedPools
    "Return the names of the shared pools defined by the class"
    | s |
    s := Set new.
    sharedPools notNil ifTrue: [
	self environment associationsDo: [ :each |
	    (sharedPools includes: each value)
		ifTrue: [ s add: each key ]
	]
    ].
    ^s
!

initialize			"redefined in children (?)"
    ^self
! !



!Class methodsFor: 'testing'!

= aClass
    "Returns true if the two class objects are to be considered equal."
    "^(aClass isKindOf: Class) and: [name = aClass name]"
    ^self == aClass
! !



!Class methodsFor: 'instance creation - alternative'!

categoriesFor: method are: categories
    "Don't use this, it is only present to file in from IBM Smalltalk"
    (self >> method) methodCategory: (categories at: 1)
!

subclass: classNameString instanceVariableNames: stringInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^self
	subclass: classNameString
	instanceVariableNames: stringInstVarNames
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category'
!

subclass: classNameString classInstanceVariableNames: stringClassInstVarNames instanceVariableNames: stringInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^(self
	subclass: classNameString
	instanceVariableNames: stringInstVarNames
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category')
	classInstanceVariableNames: stringClassInstVarNames;
	yourself
!

variableSubclass: classNameString instanceVariableNames: stringInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^self
	variableSubclass: classNameString
	instanceVariableNames: stringInstVarNames
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category'
!

variableSubclass: classNameString classInstanceVariableNames: stringClassInstVarNames instanceVariableNames: stringInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^(self
	variableSubclass: classNameString
	instanceVariableNames: stringInstVarNames
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category')
	classInstanceVariableNames: stringClassInstVarNames;
	yourself
!

variableByteSubclass: classNameString classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^self
	variableByteSubclass: classNameString
	instanceVariableNames: ''
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category'
!

variableByteSubclass: classNameString classInstanceVariableNames: stringClassInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^(self
	variableByteSubclass: classNameString
	instanceVariableNames: ''
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category')
	classInstanceVariableNames: stringClassInstVarNames;
	yourself
!

variableLongSubclass: classNameString classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^self
	variableWordSubclass: classNameString
	instanceVariableNames: ''
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category'
!

variableLongSubclass: classNameString classInstanceVariableNames: stringClassInstVarNames classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames
    "Don't use this, it is only present to file in from IBM Smalltalk"
    ^(self
	variableWordSubclass: classNameString
	instanceVariableNames: ''
	classVariableNames: stringOfClassVarNames
	poolDictionaries: stringOfPoolNames
	category: 'no category')
	classInstanceVariableNames: stringClassInstVarNames;
	yourself
! !


!Class methodsFor: 'instance creation'!

extend
    "Redefine a version of the receiver in the current namespace.  Note:
    this method can bite you in various ways when sent to system classes;
    read the section on namespaces in the manual for some examples of the
    problems you can encounter."

    | method args |
    method := self kindOfSubclass,
	'instanceVariableNames:classVariableNames:poolDictionaries:category:'.

    args := (Array with: self name asSymbol), #('' '' '' 'Extensions').

    ^self
        perform: method asSymbol
        withArguments: args
!

subclass: classNameString
    instanceVariableNames: stringInstVarNames
    classVariableNames: stringOfClassVarNames
    poolDictionaries: stringOfPoolNames
    category: categoryNameString
    "Define a fixed subclass of the receiver with the given name, instance
     variables, class variables, pool dictionaries and category. If the
     class is already defined, if necessary, recompile everything needed."

    | meta |
    KernelInitialized ifFalse: [
	^(Smalltalk at: classNameString) category: categoryNameString
    ].
    meta := self metaclassFor: classNameString.
    ^meta name: classNameString
	  environment: Namespace current
	  subclassOf: self
	  instanceVariableNames: stringInstVarNames
	  variable: false
	  words: false
	  pointers: true
	  classVariableNames: stringOfClassVarNames
	  poolDictionaries: stringOfPoolNames
	  category: categoryNameString
!

variableSubclass: classNameString
    instanceVariableNames: stringInstVarNames
    classVariableNames: stringOfClassVarNames
    poolDictionaries: stringOfPoolNames
    category: categoryNameString
    "Define a variable pointer subclass of the receiver with the given
     name, instance variables, class variables, pool dictionaries and
     category. If the class is already defined, if necessary, recompile
     everything needed."

    | meta |
    KernelInitialized ifFalse: [
	^(Smalltalk at: classNameString) category: categoryNameString
    ].
    meta := self metaclassFor: classNameString.
    ^meta name: classNameString
	  environment: Namespace current
	  subclassOf: self
	  instanceVariableNames: stringInstVarNames
	  variable: true
	  words: false
	  pointers: true
	  classVariableNames: stringOfClassVarNames
	  poolDictionaries: stringOfPoolNames
	  category: categoryNameString
!

variableWordSubclass: classNameString
  instanceVariableNames: stringInstVarNames
  classVariableNames: stringOfClassVarNames
  poolDictionaries: stringOfPoolNames
  category: categoryNameString
    "Define a word variable subclass of the receiver with the given
     name, instance variables (must be ''), class variables, pool
     dictionaries and category. If the class is already defined, if
     necessary, recompile everything needed."

    | meta |
    KernelInitialized ifFalse: [
	^(Smalltalk at: classNameString) category: categoryNameString
    ].

    meta := self metaclassFor: classNameString.
    ^meta name: classNameString
	    environment: Namespace current
	    subclassOf: self
	    instanceVariableNames: stringInstVarNames
	    variable: true
	    words: true
	    pointers: false
	    classVariableNames: stringOfClassVarNames
	    poolDictionaries: stringOfPoolNames
	    category: categoryNameString
!

variableByteSubclass: classNameString
  instanceVariableNames: stringInstVarNames
  classVariableNames: stringOfClassVarNames
  poolDictionaries: stringOfPoolNames
  category: categoryNameString
    "Define a byte variable subclass of the receiver with the given
     name, instance variables (must be ''), class variables, pool
     dictionaries and category. If the class is already defined, if
     necessary, recompile everything needed."

    | meta |
    KernelInitialized ifFalse: [
	^(Smalltalk at: classNameString) category: categoryNameString
    ].

    meta := self metaclassFor: classNameString.
    ^meta name: classNameString
	    environment: Namespace current
	    subclassOf: self
	    instanceVariableNames: stringInstVarNames
	    variable: true
	    words: false
	    pointers: false
	    classVariableNames: stringOfClassVarNames
	    poolDictionaries: stringOfPoolNames
	    category: categoryNameString
! !



!Class methodsFor: 'printing'!

article
    "Answer an article (`a' or `an') which is ok for the receiver's name"
    | name |
    name := self name.
    ^(name at: 1) isVowel ifTrue: [ 'an' ] ifFalse: [ 'a' ].
!

printOn: aStream
    "Print a representation of the receiver on aStream"
    aStream nextPutAll: self name
!

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



!Class methodsFor: 'private'!

classInstanceVariableNames: stringClassInstVarNames
    self class instanceVariableNames: stringClassInstVarNames
!

setClassVariables: aDictionary
    classVariables := aDictionary.
!

setName: aString
    name := aString.
!

setEnvironment: aNamespace
    environment := aNamespace.
!

setSharedPools: anArray
    "Private - Set the receiver's shared pools to be those in anArray"
    sharedPools := anArray
!

sharedPoolDictionaries
    "Return the shared pools (not the names!) defined by the class"
    ^sharedPools
!

metaclassFor: classNameString
    "Create a Metaclass object for the given class name. The metaclass
     is a subclass of the receiver's metaclass"
    | className class |
    className := classNameString asSymbol.
    class := Smalltalk
	classAt: className 
	ifAbsent: [ ^Metaclass subclassOf: self class ].

    ^class class
! !


!Class methodsFor: 'testing functionality'!

asClass
    ^self
!

isClass
    ^true
! !


!Class methodsFor: 'filing'!

fileOutHeaderOn: aFileStream
    "Write date and time stamp to aFileStream"
    | now |
    aFileStream nextPutAll: '"Filed out from ';
	nextPutAll: Smalltalk version;
	nextPutAll: ' on '.
    now := Date dateAndTimeNow.
    aFileStream print: (now at: 1);
	nextPutAll:  '  ';
	print: (now at: 2);
	nextPutAll: '"!

'!

fileOutDeclarationOn: aFileStream
    "File out class definition to aFileStream"
    | aSet printFormattedSet |
    self isMetaclass ifTrue: [ ^self].

    printFormattedSet := [ 
	aFileStream nextPutAll: ''''. 
	(aSet isEmpty) not ifTrue: [
	    aSet do: [ :element |
		aFileStream nextPutAll: element; space ]. 
	    aFileStream nextPutAll: ''''.
	].
    ].

    aFileStream print: self superclass; space;
	nextPutAll: self kindOfSubclass; space;
	store: name asSymbol.

    aFileStream nl; tab; nextPutAll: 'instanceVariableNames: '.
	((aSet := self instVarNames ) isEmpty)
	    ifTrue:[aFileStream nextPutAll: '''''']
	    ifFalse: printFormattedSet.

    aFileStream nl; tab; nextPutAll: 'classVariableNames: '.
	(aSet := self classVarNames) isEmpty
	    ifTrue:[aFileStream nextPutAll: '''''']
	    ifFalse: printFormattedSet.

    aFileStream nl; tab; nextPutAll: 'poolDictionaries: '.
	(aSet := self sharedPools) isEmpty
	    ifTrue:[aFileStream nextPutAll: '''''']
	    ifFalse: printFormattedSet.

    aFileStream nl; tab; nextPutAll: 'category: ';
	store: category;
	nextPut: $!;
	nl; nl;
	print: self;
	nextPutAll: ' comment: ';
	nl;
	store: self comment;
	nextPut: $!;
	nl; nl.

    ((aSet := self class instVarNames) isEmpty)
	ifTrue:[ ^self ].

    aFileStream print: self class; nextPutAll: ' instanceVariableNames: '.
    printFormattedSet value.
    aFileStream nextPut: $!; nl; nl.
!

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

    self fileOutHeaderOn: aFileStream. 
    self fileOutDeclarationOn: aFileStream.

    self class collectCategories do:
	[ :category | self class fileOutCategory: category toStream: aFileStream ].

    self collectCategories do:
	[ :category | self fileOutCategory: category toStream: aFileStream ].

    (self class includesSelector: #initialize) ifTrue: [
	aFileStream nl; print: self; nextPutAll: ' initialize!'.
    ].
    aFileStream nl
! !