"
 COPYRIGHT (c) 1989-93 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.
"

ClassDescription subclass:#Class
       instanceVariableNames:'classvars comment subclasses classFileName'
       classVariableNames:'updatingChanges'
       poolDictionaries:''
       category:'Kernel-Classes'
!

Class comment:'

COPYRIGHT (c) 1989-93 by Claus Gittinger
              All Rights Reserved

This class adds more functionality to classes; minimum stuff has already
been defined in Behavior; this one adds naming, categories etc.
also changes management and recompilation is defined here.

For a minimum system, the compiler generates classes as instances of
Behavior - this excludes all name, source info etc., however, the more 
usual case is to create instances of Class.

Instance variables:

classvars       <String>        the names of the class variables
comment         <String>        the classes comment
subclasses      <Collection>    cached collection of subclasses
                                (currently unused - but will be soon)
classFileName   <String>        the file (or nil) where the classes
                                sources are found

Class variables:

updatingChanges <Boolean>       true if the changes-file shall be updated

WARNING: layout known by compiler and runtime system

$Header: /cvs/stx/stx/libbasic/Class.st,v 1.3 1993-10-13 00:15:14 claus Exp $
written Spring 89 by claus
'!

!Class class methodsFor:'initialization'!

initialize
    "the classvariable 'updatingChanges' controls if changes are put
     into the changes-file; normally this variable is set to true, but
     for example during fileIn or when changes are applied, it is set to false
     to prevent changes file from getting too much junk."
     
    updatingChanges := true
! !

!Class class methodsFor:'creating new classes'!

new
    "creates and returs a new class"

    |newClass|

    newClass := super new.
    newClass setComment:(self comment)
               category:(self category).
    ^ newClass
! !

!Class methodsFor:'autoload check'!

isLoaded
    "return true, if the class has been loaded; redefined in Autoload;
     see comment there"

    ^ true
!

autoload
    "force autoloading - do nothing here; redefined in Autoload;
     see comment there"

    ^ self
! !

!Class methodsFor:'subclass creation'!

subclass:t instanceVariableNames:f
              classVariableNames:d
                poolDictionaries:s
                        category:cat

    "create a new class as a subclass of an existing class (the receiver).
     The subclass will have indexed variables if the receiving-class has."

    self isVariable ifFalse:[
        ^ self class
            name:t
            inEnvironment:Smalltalk
            subclassOf:self
            instanceVariableNames:f
            variable:false
            words:true
            pointers:true
            classVariableNames:d
            poolDictionaries:s
            category:cat
            comment:nil
            changed:false
    ].
    self isBytes ifTrue:[
        ^ self
            variableByteSubclass:t
            instanceVariableNames:f
            classVariableNames:d
            poolDictionaries:s
            category:cat
    ].
    self isLongs ifTrue:[
        ^ self
            variableLongSubclass:t
            instanceVariableNames:f
            classVariableNames:d
            poolDictionaries:s
            category:cat
    ].
    self isFloats ifTrue:[
        ^ self
            variableFloatSubclass:t
            instanceVariableNames:f
            classVariableNames:d
            poolDictionaries:s
            category:cat
    ].
    self isDoubles ifTrue:[
        ^ self
            variableDoubleSubclass:t
            instanceVariableNames:f
            classVariableNames:d
            poolDictionaries:s
            category:cat
    ].
    self isWords ifTrue:[
        ^ self
            variableWordSubclass:t
            instanceVariableNames:f
            classVariableNames:d
            poolDictionaries:s
            category:cat
    ].
    ^ self
        variableSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat
!

variableSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable pointer variables"

    self isVariable ifTrue:[
        self isPointers ifFalse:[
            ^ self error:
                'cannot make a variable pointer subclass of a variable non-pointer class'
        ]
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:true
        words:false
        pointers:true
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
!

variableByteSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable byte-sized nonpointer variables"

    self isVariable ifTrue:[
        self isBytes ifFalse:[
            ^ self error:
                'cannot make a variable byte subclass of a variable non-byte class'
        ].
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:true
        words:false
        pointers:false
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
!

variableWordSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable word-sized nonpointer variables"

    self isVariable ifTrue:[
        self isWords ifFalse:[
            ^ self error:
                'cannot make a variable word subclass of a variable non-word class'
        ].
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:true
        words:true
        pointers:false
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
!

variableLongSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable long-sized nonpointer variables"

    self isVariable ifTrue:[
        self isLongs ifFalse:[
            ^ self error:
                'cannot make a variable long subclass of a variable non-long class'
        ].
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:#long 
        words:false
        pointers:false
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
!

variableFloatSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable float-sized nonpointer variables"

    self isVariable ifTrue:[
        self isFloats ifFalse:[
            ^ self error:
                'cannot make a variable float subclass of a variable non-float class'
        ].
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:#float 
        words:false
        pointers:false
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
!

variableDoubleSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s
        category:cat

    "create a new class as a subclass of an existing class (the receiver) 
     in which the subclass has indexable double-sized nonpointer variables"

    self isVariable ifTrue:[
        self isDoubles ifFalse:[
            ^ self error:
                'cannot make a variable double subclass of a variable non-double class'
        ].
    ].

    ^ self class
        name:t
        inEnvironment:Smalltalk
        subclassOf:self
        instanceVariableNames:f
        variable:#double 
        words:false
        pointers:false
        classVariableNames:d
        poolDictionaries:s
        category:cat
        comment:nil
        changed:false
! !

!Class methodsFor:'ST/V subclass creation'!

subclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s

    "this methods allows fileIn of ST/V classes 
     (which seem to have no category)"

    ^ self subclass:t 
           instanceVariableNames:f
           classVariableNames:d
           poolDictionaries:s
           category:'ST/V classes'
!

variableByteSubclass:t
        classVariableNames:d
        poolDictionaries:s

    "this methods allows fileIn of ST/V variable byte classes 
     (which seem to have no category and no instvars)"

    ^ self variableByteSubclass:t 
           instanceVariableNames:''
           classVariableNames:d
           poolDictionaries:s
           category:'ST/V classes'
!

variableSubclass:t
        instanceVariableNames:f
        classVariableNames:d
        poolDictionaries:s

    "this methods allows fileIn of ST/V variable pointer classes 
     (which seem to have no category)"

    ^ self variableSubclass:t 
           instanceVariableNames:f
           classVariableNames:d
           poolDictionaries:s
           category:'ST/V classes'
! !

!Class methodsFor:'accessing'!

classVariableString
    "return a string of the class variables names "

    classvars isNil ifTrue:[^ ''].
    ^ classvars
!

classVarNames
    "return a collection of the class variable name-strings"

    ^ self addClassVarNamesTo:(OrderedCollection new)
!

allClassVarNames
    "return a collection of all the class variable name-strings
     this includes all superclass-class variables"

    ^ self addAllClassVarNamesTo:(OrderedCollection new)
!

instVarNames
    "return a collection of the instance variable name-strings"

    ^ self addInstVarNamesTo:(OrderedCollection new)
!

allInstVarNames
    "return a collection of all the instance variable name-strings
     this includes all superclass-instance variables"

    ^ self addAllInstVarNamesTo:(OrderedCollection new)
!

comment
    "return the comment (aString) of the class"

    ^ comment
!

setComment:aString
    "set the comment of the class to be the argument, aString;
     do NOT create a change record"

    comment := aString
!

comment:aString
    "set the comment of the class to be the argument, aString;
     create a change record"

    comment := aString.
    self addChangeRecordForClassComment:self
!

definition
    "return an expression-string to define myself"

    |s|

    s := WriteStream on:(String new).
    self fileOutDefinitionOn:s.
    ^ s contents

    "Object definition"
    "Point definition"
!

setComment:com category:categoryStringOrSymbol
    "set the comment and category of the class;
     do NOT create a change record"

    comment := com.
    category := categoryStringOrSymbol asSymbol
!

setName:aString
    "set the classes name"

    name := aString
!

setClassVariableString:aString
    "set the classes classvarnames string"

    classvars := aString
!

classVariableString:aString
    "set the classes classvarnames string;
     initialize new class variables with nil, clear and remove
     old ones"

    |prevVarNames varNames|

    "ignore for metaclasses except the one"
    (self isMeta "isKindOf:Metaclass") ifTrue:[
        (self == Metaclass) ifFalse:[
            ^ self
        ]
    ].
    (classvars = aString) ifFalse:[
        prevVarNames := self classVarNames.
        classvars := aString.
        varNames := self classVarNames.

        "new ones get initialized to nil;
         - old ones are nilled and removed from Smalltalk"

        varNames do:[:aName |
            (prevVarNames includes:aName) ifFalse:[
                "a new one"
                Smalltalk at:(self name , ':' , aName) asSymbol put:nil.
            ] ifTrue:[
                prevVarNames remove:aName
            ]
        ].
        "left overs are gone"
        prevVarNames do:[:aName |
            Smalltalk at:(self name , ':' , aName) asSymbol put:nil.
            Smalltalk removeKey:(self name , ':' , aName) asSymbol
        ].
        Smalltalk changed
    ]
!

addClassVarName:aString
    "add a class variable"

    (self classVarNames includes:aString) ifFalse:[
        self classVariableString:(self classVariableString , ' ' , aString)
    ]
! !

!Class methodsFor:'adding/removing'!

addSelector:newSelector withMethod:newMethod
    "add the method given by 2nd argument under the selector given by
     1st argument to the methodDictionary"

    |index oldSelectorArray oldMethodArray
     newSelectorArray newMethodArray nargs|

    (newSelector isMemberOf:Symbol) ifFalse:[^ self error:'invalid selector'].
    newMethod isNil ifTrue:[^ self error:'invalid method'].

    index := selectors identityIndexOf:newSelector startingAt:1.
    (index == 0) ifTrue:[
        newSelectorArray := selectors copyWith:newSelector.
        newMethodArray := methods copyWith:newMethod.
        "keep a reference so they wont go away ..."
        oldSelectorArray := selectors.
        oldMethodArray := methods.
        selectors := newSelectorArray.
        methods := newMethodArray
    ] ifFalse:[
        methods at:index put:newMethod
    ].

    nargs := newSelector nArgsIfSelector.

    "actually, we would do better with less flushing ..."
    ObjectMemory flushMethodCache.
    ObjectMemory flushInlineCachesWithArgs:nargs.

    self addChangeRecordForMethod:newMethod
!

removeSelector:aSelector
    "remove the selector, aSelector and its associated method 
     from the methodDictionary"

    |index oldSelectorArray oldMethodArray 
     newSelectorArray newMethodArray nargs|

    index := selectors identityIndexOf:aSelector startingAt:1.
    (index ~~ 0) ifTrue:[
        newSelectorArray := selectors copyWithoutIndex:index.
        newMethodArray := methods copyWithoutIndex:index.
        oldSelectorArray := selectors.
        oldMethodArray := methods.
        selectors := newSelectorArray.
        methods := newMethodArray.
"
        nargs := aSelector nArgsIfSelector.
        ObjectMemory flushMethodCacheFor:self.
        ObjectMemory flushInlineCachesWithArgs:nargs.
"
        "actually, we would do better with less flushing ..."
        ObjectMemory flushCaches.

        self addChangeRecordForRemoveSelector:aSelector
    ]
! !

!Class methodsFor:'changes management'!

updateChanges:aBoolean
    "turn on/off changes management"

    |prev|

    prev := updatingChanges.
    updatingChanges := aBoolean.
    ^ prev
!

changesStream
    "return a Stream for the changes file"

    |aStream|

    updatingChanges ifTrue:[
        aStream := FileStream oldFileNamed:'changes'.
        aStream isNil ifTrue:[
            aStream := FileStream newFileNamed:'changes'.
            aStream isNil ifTrue:[
                self error:'cannot update changes file'
            ]
        ] ifFalse:[
            aStream setToEnd
        ]
    ].
    ^ aStream
!

addChangeRecordForMethod:aMethod
    "add a method-change-record to the changes file"

    |aStream p|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        p := aStream position.
        self fileOutMethod:aMethod on:aStream.
        aStream cr.
        aStream close.
        Project current notNil ifTrue:[
            Project current changeSet addMethodChange:aMethod in:self
        ]
    ]
!

addChangeRecordForRemoveSelector:aSelector
    "add a method-remove-record to the changes file"

    |aStream|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        self printClassNameOn:aStream.
        aStream nextPutAll:(' removeSelector:#' , aSelector).
        aStream nextPut:(aStream class chunkSeparator).
        aStream cr.
        aStream close
    ]
!

addChangeRecordForClass:aClass
    "add a class-definition-record to the changes file"

    |aStream|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        aClass fileOutDefinitionOn:aStream.
        aStream nextPut:(aStream class chunkSeparator).
        aStream cr.
        aStream close
    ]
!

addChangeRecordForClassInstvars:aClass
    "add a class-instvars-record to the changes file"

    |aStream|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        aClass fileOutClassInstVarDefinitionOn:aStream.
        aStream nextPut:$!!.
        aStream cr.
        aStream close
    ]
!

addChangeRecordForClassComment:aClass
    "add a class-comment-record to the changes file"

    |aStream|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        aClass fileOutCommentOn:aStream.
        aStream nextPut:$!!.
        aStream cr.
        aStream close
    ]
!

addChangeRecordForSnapshot
    "add a snapshot-record to the changes file"

    |aStream|

    aStream := self changesStream.
    aStream notNil ifTrue:[
        aStream nextPutAll:('''---- snapshot ' ,
                            Date today printString , ' ' ,
                            Time now printString ,
                            ' ----''!!').
        aStream cr.
        aStream close
    ]
! !

!Class methodsFor:'compiling'!

compile:code
    "compile code, aString for this class; if sucessful update method
     dictionary."

    (Smalltalk at:#Compiler) compile:code forClass:self
!

compile:code notifying:requestor
    "compile code, aString for this class; on any error, notify
     requestor, anObject with the error reason"

    (Smalltalk at:#Compiler) compile:code forClass:self notifying:requestor
!

recompileMethodsAccessingAny:setOfNames
    "recompile all methods accessing a variable from setOfNames"

    |p|

    self selectors do:[:aSelector |
        |m|

        m := self compiledMethodAt:aSelector.
        p := Parser parseMethod:(m source) in:self.
        (p isNil or:[p usedVars notNil and:[p usedVars includesAny:setOfNames]]) ifTrue:[
            self recompile:aSelector
        ]
    ]
!

recompile:aSelector
    "recompile the method associated with the argument, aSelector;
     used when a superclass changes instances and we have to recompile
     subclasses"

    |cat code upd|

    upd := Class updateChanges:false.
    [
        cat := (self compiledMethodAt:aSelector) category.
        code := self sourceCodeAt:aSelector.
        (Smalltalk at:#Compiler) compile:code forClass:self inCategory:cat
    ] valueNowOrOnUnwindDo:[
        Class updateChanges:upd
    ]
!

recompile
    "recompile all methods
     used when a class changes instances and therefore all methods
     have to be recompiled"

    self selectors do:[:aSelector |
        self recompile:aSelector
    ]
!

recompileAll
    "recompile this class and all subclasses"

    |classes|

    classes := self subclasses.
    self recompile.
    classes do:[:aClass |
        aClass recompileAll
    ]
!

recompileInvalidatedMethods
    "recompile all invalidated methods"

    |trap trapCode trapByteCode|

    trap := Method compiledMethodAt:#invalidMethod.
    trapCode := trap code.
    trapByteCode := trap byteCode.

    self selectors do:[:aSelector |
        |m|

        m := self compiledMethodAt:aSelector.
        ((m code == trapCode) and:[m byteCode == trapByteCode]) ifTrue:[
            self recompile:aSelector
        ]
    ]
! !

!Class methodsFor:'queries'!

isClass
    "return true, if the receiver is some kind of class (real class, not
     just behavior);
     true is returned here - the method is redefined from Object"

    ^ true
!

categories
    "Return a Collection of all method-category strings known in class"

    |newList cat|

    newList := OrderedCollection new.
    methods do:[:aMethod |
        cat := aMethod category.
        newList indexOf:cat ifAbsent:[newList add:cat]
    ].
    ^ newList
!

allCategories
    "Return a Collection of all method-category strings known in class
     and all superclasses"

    ^ self addAllCategoriesTo:(OrderedCollection new)
! !

!Class methodsFor:'private'!

addFromString:aString to:aCollection
    "helper - take individual words from the first argument, aString
     and add them as strings to the 2nd argument, aCollection.
     return aCollection"

    |start stop strLen|

    aString isNil ifFalse:[
        start := 1.
        strLen := aString size.
        [start <= strLen] whileTrue:[
            (aString at:start) isSeparator ifTrue:[
                start := start + 1
            ] ifFalse:[
                stop := aString indexOfSeparatorStartingAt:start.
                stop == 0 ifTrue:[
                    stop := strLen + 1
                ].
                aCollection add:(aString copyFrom:start to:(stop - 1)).
                start := stop
            ]
        ]
    ].
    ^ aCollection
!

addInstVarNamesTo:aCollection
    "add the name-strings of the instance variables
     to the argument, aCollection. Return aCollection"

    ^ self addFromString:instvars to:aCollection
!

addClassVarNamesTo:aCollection
    "add the name-strings of the class varvariables
     to the argument, aCollection. Return aCollection"

    ^ self addFromString:classvars to:aCollection
!

addAllInstVarNamesTo:aCollection
    "add the name-strings of the instance variables and of the inst-vars
     of all superclasses to the argument, aCollection. Return aCollection"

    (superclass notNil) ifTrue:[
        superclass addAllInstVarNamesTo:aCollection
    ].
    ^ self addInstVarNamesTo:aCollection
!

addAllClassVarNamesTo:aCollection
    "add the name-strings of the class variables and of the class-vars
     of all superclasses to the argument, aCollection. Return aCollection"

    (superclass notNil) ifTrue:[
        superclass addAllClassVarNamesTo:aCollection
    ].
    ^ self addClassVarNamesTo:aCollection
!

addCategoriesTo:aCollection
    "helper - add categories to the argument, aCollection"

    |cat|

    methods do:[:aMethod |
        cat := aMethod category.
        (aCollection detect:[:element | cat = element]
                     ifNone:[nil])
            isNil ifTrue:[
                aCollection add:cat
        ]
    ].
    ^ aCollection
!

addAllCategoriesTo:aCollection
    "helper - add categories and all superclasses categories
     to the argument, aCollection"

    (superclass notNil) ifTrue:[
        superclass addAllCategoriesTo:aCollection
    ].
    ^ self addCategoriesTo:aCollection
! !

!Class methodsFor:'fileIn interface'!

methodsFor:aCategory
    "return a ClassCategoryReader to read in and compile methods for me"

    ^ ClassCategoryReader class:self category:aCategory
!

publicMethodsFor:aCategory
    "this method allows fileIn of ENVY methods - currently we do not support method visibility.
     return a ClassCategoryReader to read in and compile methods for me."

    ^ self methodsFor:aCategory
!

privateMethodsFor:aCategory
    "this method allows fileIn of ENVY methods - currently we do not support method visibility.
     return a ClassCategoryReader to read in and compile methods for me."

    ^ self methodsFor:aCategory
!

binaryMethods
    "return a ClassCategoryReader to read in binary methods for me"

    ^ BinaryClassCategoryReader class:self category:'binary'
!

methods
    "this method allows fileIn of ST/V methods -
     return a ClassCategoryReader to read in and compile methods for me."

    ^ ClassCategoryReader class:self category:'ST/V methods'
! !

!Class methodsFor:'fileOut'!

printClassNameOn:aStream
    "helper for fileOut - print my name if I am not a Metaclass;
     otherwise my name without -class followed by space-class"

    (self isMeta "isMemberOf:Metaclass") ifTrue:[
        aStream nextPutAll:(name copyFrom:1 to:(name size - 5)).
        aStream nextPutAll:' class'
    ] ifFalse:[
        name printOn:aStream
    ]
!

printNameArray:anArray on:aStream indent:indent
    "print an array of strings separated by spaces; when the stream
     defines a lineLength, break when this limit is reached; indent
     every line; used to printOut instanve variable names"

    |thisName nextName arraySize lenMax pos mustBreak line spaces|

    arraySize := 0.
    anArray notNil ifTrue:[
        arraySize := anArray size
    ].
    arraySize ~~ 0 ifTrue:[
        pos := indent.
        lenMax := aStream lineLength.
        thisName := anArray at:1.
        line := ''.
        1 to:arraySize do:[:index |
            line := line , thisName.
            pos := pos + thisName size.
            (index == arraySize) ifFalse:[
                nextName := anArray at:(index + 1).
                mustBreak := false.
                (lenMax > 0) ifTrue:[
                    ((pos + nextName size) > lenMax) ifTrue:[
                        mustBreak := true
                    ]
                ].
                mustBreak ifTrue:[
                    aStream nextPutAll:line.
                    aStream cr.
                    spaces isNil ifTrue:[
                        spaces := String new:indent
                    ].
                    line := spaces.
                    pos := indent
                ] ifFalse:[
                    line := line , ' '.
                    pos := pos + 1
                ].
                thisName := nextName
            ]
        ].
        aStream nextPutAll:line
    ]
!

printClassVarNamesOn:aStream indent:indent
    "print the class variable names indented and breaking at line end"

    self printNameArray:(self classVarNames) on:aStream indent:indent
!

printInstVarNamesOn:aStream indent:indent
    "print the instance variable names indented and breaking at line end"

    self printNameArray:(self instVarNames) on:aStream indent:indent
!

printHierarchyOn:aStream
    "print my class hierarchy on aStream"

    self printHierarchyAnswerIndentOn:aStream
!

printHierarchyAnswerIndentOn:aStream
    "print my class hierarchy on aStream - return indent
     recursively calls itself to print superclass and use returned indent
     for my description - used in the browser"

    |indent|

    indent := 0.
    (superclass notNil) ifTrue:[
        indent := (superclass printHierarchyAnswerIndentOn:aStream) + 2
    ].
    aStream nextPutAll:(String new:indent).
    aStream nextPutAll:name.
    aStream nextPutAll:' ('.
    self printInstVarNamesOn:aStream indent:(indent + name size + 2).
    aStream nextPutAll:')'.
    aStream cr.
    ^ indent
!
    
printFullHierarchyOn:aStream indent:indent
    "print myself and all subclasses on aStream.
     recursively calls itself to print subclasses. 
     Can be used to print hierarchy on the printer."

    aStream nextPutAll:(String new:indent).
    aStream bold.
    aStream nextPutAll:name.
    aStream normal.
    aStream nextPutAll:' ('.
    self printInstVarNamesOn:aStream indent:(indent + name size + 2).
    aStream nextPutAll:')'.
    aStream cr.

    (self subclasses sort:[:a :b | a name < b name]) do:[:aSubclass |
        aSubclass printFullHierarchyOn:aStream indent:(indent + 2)
    ]

    "|printStream|
     printStream := Printer new.
     Object printFullHierarchyOn:printStream indent:0.
     printStream close"
!

fileOutCommentOn:aStream
    "print an expression on aStream to define my comment"

    aStream nextPutAll:name.
    aStream nextPutAll:' comment:'.
    comment isNil ifTrue:[
        aStream nextPutAll:''''''
    ] ifFalse:[
        aStream nextPutAll:(comment storeString)
    ].
    aStream cr
!

fileOutDefinitionOn:aStream
    "print an expression to define myself on aStream"

    |isVar line|

    superclass isNil ifTrue:[
        line := 'Object'
    ] ifFalse:[
        line := (superclass name)
    ].
    superclass isNil ifTrue:[
        isVar := self isVariable
    ] ifFalse:[
        "I cant remember what this is for ?"
        isVar := (self isVariable and:[superclass isVariable not])
    ].
    isVar ifTrue:[
        self isBytes ifTrue:[
            line := line , ' variableByteSubclass:#'
        ] ifFalse:[
            self isWords ifTrue:[
                line := line , ' variableWordSubclass:#'
            ] ifFalse:[
                self isLongs ifTrue:[
                    line := line , ' variableLongSubclass:#'
                ] ifFalse:[
                    self isFloats ifTrue:[
                        line := line , ' variableFloatSubclass:#'
                    ] ifFalse:[
                        self isDoubles ifTrue:[
                            line := line , ' variableDoubleSubclass:#'
                        ] ifFalse:[
                            line := line , ' variableSubclass:#'
                        ]
                    ]
                ]
            ]
        ]
    ] ifFalse:[
        line := line , ' subclass:#'
    ].
    line := line , name.
    aStream nextPutAll:line.

    aStream crTab. 
    aStream nextPutAll:' instanceVariableNames:'''.
    self printInstVarNamesOn:aStream indent:16.
    aStream nextPutAll:''''.

    aStream crTab.
    aStream nextPutAll:' classVariableNames:'''.
    self printClassVarNamesOn:aStream indent:16.
    aStream nextPutAll:''''.

    aStream crTab.
    aStream nextPutAll:' poolDictionaries:'''''.

    aStream crTab.
    aStream nextPutAll:' category:'.
    category isNil ifTrue:[
        aStream nextPutAll:''''''
    ] ifFalse:[
        aStream nextPutAll:(category asString storeString)
    ].
    aStream cr
!

fileOutClassInstVarDefinitionOn:aStream
    aStream nextPutAll:(name , ' class instanceVariableNames:''').
    self class printInstVarNamesOn:aStream indent:8.
    aStream nextPutAll:''''
!

fileOutCategory:aCategory on:aStream
    "file out all methods belonging to aCategory, aString onto aStream"

    |nMethods count|

    methods notNil ifTrue:[
        nMethods := 0.
        methods do:[:aMethod |
            (aCategory = aMethod category) ifTrue:[
                nMethods := nMethods + 1
            ]
        ].
        (nMethods ~~ 0) ifTrue:[
            aStream nextPut:$!!.
            self printClassNameOn:aStream.
            aStream nextPutAll:' methodsFor:'''.
            aCategory notNil ifTrue:[
                aStream nextPutAll:aCategory
            ].
            aStream nextPut:$'. aStream nextPut:$!!. aStream cr.
            aStream cr.
            count := 1.
            methods do:[:aMethod |
                (aCategory = aMethod category) ifTrue:[
                    aStream nextChunkPut:(aMethod source).
                    (count ~~ nMethods) ifTrue:[
                        aStream cr.
                        aStream cr
                    ].
                    count := count + 1
                ]
            ].
            aStream space.
            aStream nextPut:$!!.
            aStream cr
        ]
    ]
!

fileOutMethod:aMethod on:aStream
    "file out the method, aMethod onto aStream"

    |cat|

    methods notNil ifTrue:[
        aStream nextPut:$!!.
        self printClassNameOn:aStream.
        aStream nextPutAll:' methodsFor:'''.
        cat := aMethod category.
        cat notNil ifTrue:[
            aStream nextPutAll:cat
        ].
        aStream nextPut:$'.
        aStream nextPut:$!!.
        aStream cr.
        aStream cr.
        aStream nextChunkPut:(aMethod source).
        aStream space.
        aStream nextPut:$!!.
        aStream cr
    ]
!

fileOutOn:aStream
    "file out all methods onto aStream"

    |collectionOfCategories|

    aStream nextPutAll:(Smalltalk timeStamp).
    aStream nextPut:$!. 
    aStream cr.
    aStream cr.
    self fileOutDefinitionOn:aStream.
    aStream nextPut:$!!. 
    aStream cr.
    aStream cr.
    self class instanceVariableString isBlank ifFalse:[
        self fileOutClassInstVarDefinitionOn:aStream.
        aStream nextPut:$!!. 
        aStream cr.
        aStream cr
    ].

    comment notNil ifTrue:[
        aStream nextPutAll:name.
        aStream nextPutAll:' comment:'.
        aStream nextPutAll:(comment storeString).
        aStream nextPut:$!!.
        aStream cr.
        aStream cr
    ].
    collectionOfCategories := self class categories.
    collectionOfCategories notNil ifTrue:[
        collectionOfCategories do:[:aCategory |
            self class fileOutCategory:aCategory on:aStream.
            aStream cr
        ]
    ].
    collectionOfCategories := self categories.
    collectionOfCategories notNil ifTrue:[
        collectionOfCategories do:[:aCategory |
            self fileOutCategory:aCategory on:aStream.
            aStream cr
        ]
    ].
    (self class implements:#initialize) ifTrue:[
        aStream nextPutAll:(name , ' initialize').
        aStream nextPut:$!!. 
        aStream cr
    ]
!

fileOutCategory:aCategory
    "create a file 'class-category.st' consisting of all methods in aCategory"

    |aStream fileName|

    fileName := name , '-' , aCategory , '.st'.
    aStream := FileStream newFileNamed:fileName.
    self fileOutCategory:aCategory on:aStream.
    aStream close
!

fileOutMethod:aMethod
    "create a file 'class-method.st' consisting of the method, aMethod"

    |aStream fileName selector|

    selector := self selectorForMethod:aMethod.
    selector notNil ifTrue:[
        fileName := name , '-' , selector, '.st'.
        aStream := FileStream newFileNamed:fileName.
        self fileOutMethod:aMethod on:aStream.
        aStream close
    ]
!

fileOut
    "create a file 'class.st' consisting of all methods in myself"

    |aStream fileName|

    fileName := (Smalltalk fileNameForClass:self name) , '.st'.
    aStream := FileStream newFileNamed:fileName.
    aStream isNil ifTrue:[
        ^ self error:('cannot create source file:', fileName)
    ].
    self fileOutOn:aStream.
    aStream close
!

fileOutIn:aFileDirectory
    "create a file 'class.st' consisting of all methods in self in
     directory aFileDirectory"

    |aStream fileName|

    fileName := (Smalltalk fileNameForClass:self) , '.st'.
    aStream := FileStream newFileNamed:fileName
                                    in:aFileDirectory.
    aStream isNil ifTrue:[
        ^ self error:('cannot create source file:', fileName)
    ].
    self fileOutOn:aStream.
    aStream close
!

binaryFileOutMethodsOn:aStream
    "binary file out all methods onto aStream"

    |temporaryMethod index|

    methods notNil ifTrue:[
        aStream nextPut:$!!.
        self printClassNameOn:aStream.
        aStream nextPutAll:' binaryMethods'.
        aStream nextPut:$!!.
        aStream cr.
        index := 1.
        methods do:[:aMethod |
            (selectors at:index) storeOn:aStream.
            aStream nextPut:$!!.

            aMethod byteCode isNil ifTrue:[
                temporaryMethod := Compiler compile:(aMethod source)
                                           forClass:self
                                         inCategory:(aMethod category)
                                          notifying:nil
                                            install:false.
                temporaryMethod binaryFileOutOn:aStream
            ] ifFalse:[
                aMethod binaryFileOutOn:aStream
            ].
            aStream cr.
            index := index + 1
        ].
        aStream nextPut:$!!.
        aStream cr
    ]
!

binaryFileOutOn:aStream
    "file out all methods onto aStream"

    aStream nextPut:$'.
    aStream nextPutAll:('From Smalltalk/X, Version:'
                        , (Smalltalk version)
                        , ' on ').
    aStream nextPutAll:(Date today printString , ' at ' , Time now printString).
    aStream nextPut:$'.
    aStream nextPut:$!!.
    aStream cr.
    self fileOutDefinitionOn:aStream.
    aStream nextPut:$!!. 
    aStream cr.
    comment notNil ifTrue:[
        aStream nextPutAll:name.
        aStream nextPutAll:' comment:'.
        aStream nextPutAll:(comment storeString).
        aStream nextPut:$!!.
        aStream cr
    ].
    self class binaryFileOutMethodsOn:aStream.
    self binaryFileOutMethodsOn:aStream.
    (self class implements:#initialize) ifTrue:[
        aStream nextPutAll:(name , ' initialize').
        aStream nextPut:$!!. 
        aStream cr
    ]
!

binaryFileOut
    "create a file 'class.sb' consisting of all methods in myself"

    |aStream fileName|

    fileName := (Smalltalk fileNameForClass:self name) , '.sb'.
    aStream := FileStream newFileNamed:fileName.
    aStream isNil ifTrue:[
        ^ self error:('cannot create class file:', fileName)
    ].
    self binaryFileOutOn:aStream.
    aStream close
! !

!Class methodsFor:'printOut'!

printOutDefinitionOn:aPrintStream
    "print out my definition"

    aPrintStream nextPutAll:'class                '.
    aPrintStream bold.
    aPrintStream nextPutAll:name.
    aPrintStream normal.
    aPrintStream cr. 

    aPrintStream nextPutAll:'superclass           '.
    superclass isNil ifTrue:[
        aPrintStream nextPutAll:'Object'
    ] ifFalse:[
        aPrintStream nextPutAll:(superclass name)
    ].
    aPrintStream cr. 

    aPrintStream nextPutAll:'instance Variables   '.
    self printInstVarNamesOn:aPrintStream indent:21.
    aPrintStream cr. 

    aPrintStream nextPutAll:'class Variables      '.
    self printClassVarNamesOn:aPrintStream indent:21.
    aPrintStream cr.

    category notNil ifTrue:[
        aPrintStream nextPutAll:'category             '.
        aPrintStream nextPutAll:(category printString).
        aPrintStream cr
    ].

    comment notNil ifTrue:[
        aPrintStream cr.
        aPrintStream nextPutAll:'comment:'.
        aPrintStream cr.
        aPrintStream italic.
        aPrintStream nextPutAll:comment.
        aPrintStream normal.
        aPrintStream cr
    ]
!

printOutSourceProtocol:aString on:aPrintStream
    "given the source in aString, print the methods message specification
     and any method comments - without source; used to generate documentation
     pages"

    |text line nQuote index|

    text := aString asText.
    (text size < 1) ifTrue:[^self].
    aPrintStream bold.
    aPrintStream nextPutAll:(text at:1).
    aPrintStream cr.
    (text size >= 2) ifTrue:[
        aPrintStream italic.
        line := (text at:2).
        nQuote := line occurrencesOf:(Character doubleQuote).
        (nQuote == 2) ifTrue:[
            aPrintStream nextPutAll:line.
            aPrintStream cr
        ] ifFalse:[
            (nQuote == 1) ifTrue:[
                aPrintStream nextPutAll:line.
                aPrintStream cr.
                index := 3.
                line := text at:index.
                nQuote := line occurrencesOf:(Character doubleQuote).
                [nQuote ~~ 1] whileTrue:[
                    aPrintStream nextPutAll:line.
                    aPrintStream cr.
                    index := index + 1.
                    line := text at:index.
                    nQuote := line occurrencesOf:(Character doubleQuote)
                ].
                aPrintStream nextPutAll:(text at:index).
                aPrintStream cr
             ]
         ]
    ].
    aPrintStream normal
!

printOutSource:aString on:aPrintStream
    "print out a source-string; the message-specification is printed bold,
     comments are printed italic"

    |text textIndex textSize line lineIndex lineSize inComment aCharacter|
    text := aString asText.
    aPrintStream bold.
    aPrintStream nextPutAll:(text at:1).
    aPrintStream normal.
    aPrintStream cr.
    inComment := false.
    textSize := text size.
    textIndex := 2.
    [textIndex <= textSize] whileTrue:[
        line := text at:textIndex.
        ((line occurrencesOf:Character doubleQuote) == 0) ifTrue:[
            aPrintStream nextPutAll:line
        ] ifFalse:[
            lineSize := line size.
            lineIndex := 1.
            [lineIndex <= lineSize] whileTrue:[
                aCharacter := line at:lineIndex.
                (aCharacter == Character doubleQuote) ifTrue:[
                    inComment ifTrue:[
                        aPrintStream normal.
                        aPrintStream nextPut:aCharacter.
                        inComment := false
                    ] ifFalse:[
                        aPrintStream nextPut:aCharacter.
                        aPrintStream italic.
                        inComment := true
                    ]
                ] ifFalse:[
                    aPrintStream nextPut:aCharacter
                ].
                lineIndex := lineIndex + 1
            ]
        ].
        aPrintStream cr.
        textIndex := textIndex + 1
    ]
!
    
printOutCategory:aCategory on:aPrintStream
    "print out all methods in aCategory on aPrintStream should be a PrintStream"

    |any|
    methods notNil ifTrue:[
        any := false.
        methods do:[:aMethod |
            (aCategory = aMethod category) ifTrue:[
                any := true
            ]
        ].
        any ifTrue:[
             aPrintStream italic.
             aPrintStream nextPutAll:aCategory.
             aPrintStream normal.
             aPrintStream cr.
             aPrintStream cr.
             methods do:[:aMethod |
                 (aCategory = aMethod category) ifTrue:[
                     self printOutSource:(aMethod source) on:aPrintStream.
                     aPrintStream cr.
                     aPrintStream cr
                 ]
             ].
             aPrintStream cr
         ]
    ]
!

printOutOn:aPrintStream
    "print out all methods on aPrintStream which should be a printStream"

    |collectionOfCategories|
    self printOutDefinitionOn:aPrintStream.
    aPrintStream cr.
    collectionOfCategories := self class categories.
    collectionOfCategories notNil ifTrue:[
        aPrintStream nextPutAll:'class protocol'.
        aPrintStream cr. aPrintStream cr.
        collectionOfCategories do:[:aCategory |
            self class printOutCategory:aCategory on:aPrintStream
        ]
    ].
    collectionOfCategories := self categories.
    collectionOfCategories notNil ifTrue:[
        aPrintStream nextPutAll:'instance protocol'.
        aPrintStream cr. aPrintStream cr.
        collectionOfCategories do:[:aCategory |
            self printOutCategory:aCategory on:aPrintStream
        ]
    ]
!

printOutCategoryProtocol:aCategory on:aPrintStream
    |any|
    methods notNil ifTrue:[
        any := false.
        methods do:[:aMethod |
            (aCategory = aMethod category) ifTrue:[
                any := true
            ]
        ].
        any ifTrue:[
            aPrintStream italic.
            aPrintStream nextPutAll:aCategory.
            aPrintStream normal.
            aPrintStream cr.
            aPrintStream cr.
            methods do:[:aMethod |
                (aCategory = aMethod category) ifTrue:[
                    self printOutSourceProtocol:(aMethod source) 
                                             on:aPrintStream.
                    aPrintStream cr.
                    aPrintStream cr
                ]
            ].
            aPrintStream cr
        ]
    ]
!

printOutProtocolOn:aPrintStream
    |collectionOfCategories|
    self printOutDefinitionOn:aPrintStream.
    aPrintStream cr.
    collectionOfCategories := self class categories.
    collectionOfCategories notNil ifTrue:[
        aPrintStream nextPutAll:'class protocol'.
        aPrintStream cr. aPrintStream cr.
        collectionOfCategories do:[:aCategory |
            self class printOutCategoryProtocol:aCategory on:aPrintStream
        ]
    ].
    collectionOfCategories := self categories.
    collectionOfCategories notNil ifTrue:[
        aPrintStream nextPutAll:'instance protocol'.
        aPrintStream cr. aPrintStream cr.
        collectionOfCategories do:[:aCategory |
            self printOutCategoryProtocol:aCategory on:aPrintStream
        ]
    ]
! !

!Class methodsFor: 'binary storage'!

addGlobalsTo: globalDictionary manager: manager
"
    classPool == nil ifFalse: [
        classPool associationsDo: [:assoc|
            globalDictionary at: assoc put: self
        ]
    ]
"
!

storeBinaryDefinitionOf: anAssociation on: stream manager: manager
    | string |

    string := self name, ' classPool at: ', anAssociation key storeString.
    stream nextNumber: 2 put: string size.
    string do: [:char| stream nextPut: char asciiValue]
! !