"

 COPYRIGHT (c) 1993 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.

"

Behavior subclass:#ClassDescription

	instanceVariableNames:'name category instvars primitiveSpec signature'

	classVariableNames:''

	poolDictionaries:''

	category:'Kernel-Classes'

!

!ClassDescription class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1993 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.

"

!

documentation

"

    this class has been added for ST-80 compatibility only.

    All class stuff used to be in Behavior and Class - but, to be

    able to file in some PD code, it became nescessary to add C'Description

    in between it.

    ClassDescription adds some descriptive information to the basic

    Behavior class.

    [Instance variables:]

        name            <Symbol>            the classes name

        category        <String | Symbol>   the classes category

        instvars        <String>            the names of the instance variables

        primitiveSpec   <Array | nil>       describes primitiveIncludes, primitiveFunctions etc.

        signature       <SmallInteger>      the classes signature (used to detect obsolete

                                            or changed classes with binaryStorage)

                                            This is filled in lazy - i.e. upon the first signature query.

    [author:]

        Claus Gittinger

    [see also:]

	Behavior Class Metaclass

"

! !

!ClassDescription class methodsFor:'instance creation'!

new

    "creates and returns a new class.

     Redefined to give the new class at least some name info"

    |newClass|

    newClass := super new.

    newClass setName:('some' , self name).

    ^ newClass

! !

!ClassDescription class methodsFor:'queries'!

isBuiltInClass

    "return true if this class is known by the run-time-system.

     Here, true is returned for myself, false for subclasses."

    ^ self == ClassDescription class or:[self == ClassDescription]

    "Created: 15.4.1996 / 17:16:59 / cg"

    "Modified: 23.4.1996 / 15:56:54 / cg"

! !

!ClassDescription methodsFor:'accessing'!

category

    "return the category of the class. 

     The returned value may be a string or symbol."

    |owner|

    (owner := self owningClass) notNil ifTrue:[^ owner category].

    ^ category

    "

     Point category                

     Dictionary category           

    "

    "Modified: 15.10.1996 / 21:20:01 / cg"

!

category:aStringOrSymbol

    "set the category of the class to be the argument, aStringOrSymbol"

    aStringOrSymbol isNil ifTrue:[

	category := aStringOrSymbol

    ] ifFalse:[

	category := aStringOrSymbol asSymbol

    ]

!

instVarAtOffset:index

    "return the name of the instance variable at index"

    ^ self allInstanceVariableNames at:index

!

instVarNames

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

    instvars isNil ifTrue:[

	^ OrderedCollection new

    ].

    ^ instvars asCollectionOfWords

    "

     Point instVarNames  

    "

!

instVarOffsetOf:aVariableName

    "return the index (as used in instVarAt:/instVarAt:put:) of a named instance

     variable. The returned number is 1..instSize for valid variable names, nil for

     illegal names."

    ^ self allInstVarNames indexOf:aVariableName ifAbsent:nil

!

instanceVariableOffsets

    "returns a dictionary containing the instance variable index

     for each instVar name"

    |dict index|

    index := 0. dict := Dictionary new.

    self allInstVarNames do:[:nm | index := index + 1. dict at:nm put:index].

    ^ dict

    "

     Point instanceVariableOffsets 

     GraphicsContext instanceVariableOffsets 

    "

!

instanceVariableString

    "return a string of the instance variable names"

    instvars isNil ifTrue:[^ ''].

    ^ instvars

    "

     Point instanceVariableString   

    "

!

name

    "return the name of the class. In the current implementation,

     this returns a string, but will be changed to Symbol soon."

    ^ name

!

organization

    "for ST80 compatibility; 

     read the documentation in ClassOrganizer for more info."

    ^ ClassOrganizer for:self

! !

!ClassDescription methodsFor:'printing & storing'!

displayString

    "return a string for display in inspectors"

    |nm more|

    (category = 'obsolete'

    or:[category = '* obsolete *']) ifTrue:[

        "add obsolete - to make life easier ..."

        more := ' (obsolete)'

    ].

    (category = 'removed'

    or:[category = '* removed *']) ifTrue:[

        "add removed - to make life easier ..."

        more := ' (removed)'

    ].

    self isPrivate ifTrue:[

        nm := self nameWithoutPrefix.

        more := ' (private in ' , self owningClass name , ')'.

    ] ifFalse:[

        nm := self name.

    ].

    more isNil ifTrue:[^ nm].

    ^ nm , more

    "Modified: 15.10.1996 / 20:01:30 / cg"

!

isObsolete 

    "return true, if the receiver is obsolete 

     (i.e. has been replaced by a different class or was removed, 

      but is still referenced by instanced)"

    ^ category = 'obsolete' 

      or:[category = 'removed'

      or:[category = '* removed *'

      or:[category = '* obsolete *']]]

    "Modified: 10.9.1996 / 14:02:07 / cg"

! !

!ClassDescription methodsFor:'renaming'!

renameTo:newName

    "change the name of the class"

    |oldSym newSym|

    oldSym := name asSymbol.

    newSym := newName asSymbol.

    self setName:newSym.

    Smalltalk at:oldSym put:nil.

    Smalltalk removeKey:oldSym.             "26.jun 93"

    Smalltalk at:newSym put:self.

    "Modified: 18.7.1996 / 11:26:46 / cg"

! !

!ClassDescription methodsFor:'signature checking'!

classinstSizeFromSignature:aSignature

    "for checking class compatibility: return some number based on 

     the classinstSize from a signature key (not always the real classinstsize)."

    ^ (aSignature bitShift:-7) bitAnd:7

!

instNameKeyFromSignature:aSignature

    "for checking class compatibility: return a number based on the

     names and order of the instance variables from a signature key."

    ^ (aSignature bitShift:-14) bitAnd:16rFFFF

    "

     Point instNameKeyFromSignature:Point signature.             

     Association instNameKeyFromSignature:Association signature.  

    "

!

instSizeFromSignature:aSignature

    "for checking class compatibility: return the some number based on

     the instSize from a signature key (not always the real instSize)."

    ^ aSignature bitAnd:16r7F

    "

     Class instSizeFromSignature:Point signature.     

     Class instSizeFromSignature:Association signature.   

     Class instSizeFromSignature:Dictionary signature.    

    "

!

instTypeFromSignature:aSignature

    "for checking class compatibility: return some number based on

     the instType (i.e. variableBytes/Pointers etc.) from a signature key."

    ^ (aSignature bitShift:-10) bitAnd:(Class maskIndexType)

    "

     Class instTypeFromSignature:Object signature.               

     Class instTypeFromSignature:Array signature.                

     Class instTypeFromSignature:String signature.               

     Class instTypeFromSignature:OrderedCollection signature.    

    "

!

signature

    "return a signature number - this number is useful for a quick

     check for changed classes, and is done in the binary-object loader, 

     and the dynamic class loader.

     Do NOT change the algorithm here - others may depend on it.

     Also, the algorithm may change - so never interpret the returned value

     (if at all, use the access #XXXFromSignature: methods)"

    |value   "{ Class: SmallInteger }"

     nameKey "{ Class: SmallInteger }" |

    signature notNil ifTrue:[^ signature].

    value := self flags bitAnd:(Class maskIndexType).

    value := (value bitShift:3) + ((self class instSize - Class instSize) bitAnd:7).

    value := (value bitShift:7) + (self instSize bitAnd:16r7F).

    nameKey := 0.

    self allInstVarNames do:[:name |

	nameKey := nameKey bitShift:1.

	(nameKey bitAnd:16r10000) ~~ 0 ifTrue:[

	    nameKey := nameKey bitXor:1.

	    nameKey := nameKey bitAnd:16rFFFF.

	].

	nameKey := (nameKey + (name at:1) asciiValue) bitAnd:16rFFFF.

    ].

    value := value + (nameKey bitShift:14).

    signature := value.

    ^ value

    "

     Array signature

     ByteArray signature

     View signature

    "

! !

!ClassDescription methodsFor:'special accessing'!

setInstanceVariableString:aString

    "set the classes instvarnames string - no recompilation

     or updates are done and no changeList records are written.

     This is NOT for general use."

    instvars := aString.

!

setName:aString

    "set the classes name - be careful, it will be still

     in the Smalltalk dictionary - under another key.

     This is NOT for general use - see renameTo:"

    name := aString

! !

!ClassDescription methodsFor:'subclass creation'!

subclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool 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:nameSymbol  

            inEnvironment:(Class nameSpaceQuerySignal raise)

            subclassOf:self

            instanceVariableNames:instVarNameString

            variable:false

            words:true

            pointers:true

            classVariableNames:classVarString

            poolDictionaries:pool

            category:cat

            comment:nil

            changed:true 

    ].

!

subclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool category:cat inEnvironment:aNameSpace

    "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 ifTrue:[

        Class nameSpaceQuerySignal handle:[:ex |

            ex proceedWith:aNameSpace

        ] do:[

            ^ self

                subclass:nameSymbol 

                instanceVariableNames:instVarNameString 

                classVariableNames:classVarString 

                poolDictionaries:pool 

                category:cat 

        ].

    ].

    ^ self class

        name:nameSymbol  

        inEnvironment:aNameSpace

        subclassOf:self

        instanceVariableNames:instVarNameString

        variable:false

        words:true

        pointers:true

        classVariableNames:classVarString

        poolDictionaries:pool

        category:cat

        comment:nil

        changed:true

    "Created: 8.2.1997 / 19:41:44 / cg"

    "Modified: 8.2.1997 / 20:03:52 / cg"

!

variableByteSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool 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:nameSymbol

        inEnvironment:(Class nameSpaceQuerySignal raise)

        subclassOf:self

        instanceVariableNames:instVarNameString

        variable:true

        words:false

        pointers:false

        classVariableNames:classVarString

        poolDictionaries:pool

        category:cat

        comment:nil

        changed:true

    "Created: 12.10.1996 / 19:18:18 / cg"

    "Modified: 6.11.1996 / 22:48:18 / cg"

!

variableDoubleSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool 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:nameSymbol

        inEnvironment:(Class nameSpaceQuerySignal raise)

        subclassOf:self

        instanceVariableNames:instVarNameString

        variable:#double 

        words:false

        pointers:false

        classVariableNames:classVarString

        poolDictionaries:pool

        category:cat

        comment:nil

        changed:true

    "Created: 12.10.1996 / 19:18:21 / cg"

    "Modified: 6.11.1996 / 22:48:22 / cg"

!

variableFloatSubclass:nameSymbol instanceVariableNames:instVarNameString classVariableNames:classVarString poolDictionaries:pool 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:nameSymbol