"

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

"

"{ Package: 'stx:libbasic' }"

ClassDescription subclass:#Class

	instanceVariableNames:'name category classvars comment subclasses classFilename package

		revision environment signature attributes'

	classVariableNames:'DefaultCategoryForSTV DefaultCategoryForVAGE

		DefaultCategoryForDolphin'

	poolDictionaries:''

	category:'Kernel-Classes'

!

Object subclass:#ClassAttributes

	instanceVariableNames:'primitiveDefinitions primitiveVariables primitiveFunctions

		sharedPools'

	classVariableNames:''

	poolDictionaries:''

	privateIn:Class

!

Object subclass:#SimulatedClassPool

	instanceVariableNames:'class'

	classVariableNames:''

	poolDictionaries:''

	privateIn:Class

!

Association subclass:#SimulatedVariableBinding

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	privateIn:Class::SimulatedClassPool

!

!Class class methodsFor:'documentation'!

copyright

"

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

"

    Class adds more functionality to classes; minimum stuff has already

    been defined in Behavior and ClassDescription; this adds naming, categories etc.

    [Instance variables:]

        name            <Symbol>        the classes name

        category        <Symbol>        the classes category

        classvars       <String>        the names of the class variables

                        | <Collection of words>

        comment         <String>        the classes comment; either a string,

                                        a number specifying the offset in classFilename, or nil

        subclasses      <Collection>    cached collection of subclasses

                                        (currently unused - but will be soon)

        classFilename   <String>        the file (or nil) where the classes

                                        sources are found

        package         <Symbol>        the package, in which the class was defined

                                        (inserted by compilers)

        revision        <String>        revision string - inserted by stc

        environment     <Symbol | nil>  cached environment (i.e. Smalltalk or a namespace)

        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.

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

                                        also a place to add additional attributes,

                                        without a need to recompile all classes.

    WARNING: layout known by compiler and runtime system

    [author:]

        Claus Gittinger

    [see also:]

        Behavior ClassDescription Metaclass

"

! !

!Class class methodsFor:'accessing-flags'!

tryLocalSourceFirst

    ^ TryLocalSourceFirst

    "Created: 24.1.1996 / 19:55:35 / cg"

!

tryLocalSourceFirst:aBoolean

    TryLocalSourceFirst := aBoolean

    "Created: 24.1.1996 / 19:55:35 / cg"

!

updateChanges:aBoolean

    "turn on/off changes management. Return the prior value of the flag.

     This value is used as a default fallback - a querySignal handler may still

     decide to return something else."

    |prev|

    prev := UpdatingChanges.

    UpdatingChanges := aBoolean.

    ^ prev

!

updatingChanges

    "return true if changes are recorded.

     The value returned here is the default fallback - a querySignal handler may still

     decide to return something else."

    ^ UpdatingChanges

! !

!Class class methodsFor:'helpers'!

revisionInfoFromString:aString

    "{ Pragma: +optSpace }"

    "return a dictionary filled with revision info.

     This extracts the relevant info from aString, asking

     the sourceCode manager (if there is one)"

    |mgr|

    "/

    "/ mhmh - ask the default manager

    "/

    (mgr := SourceCodeManager) isNil ifTrue:[

        "/

        "/ fallBack - assume CVS header

        "/

        mgr := CVSSourceCodeManager

    ].

    "/

    "/ care for standAlone apps which have no CVS (libbasic3) included

    "/

    mgr isNil ifTrue:[

        AbstractSourceCodeManager notNil ifTrue:[

            ^ AbstractSourceCodeManager revisionInfoFromRCSString:aString

        ].

        ^ nil

    ].

    ^ mgr revisionInfoFromString:aString.

!

revisionStringFromSource:aMethodSourceString

    "{ Pragma: +optSpace }"

    "extract a revision string from a methods source string"

    |lines line|

    lines := aMethodSourceString asCollectionOfLines.

    lines do:[:l |

        |i|

        i := l indexOfSubCollection:'$Header: '.

        i ~~ 0 ifTrue:[

            line := l copyFrom:i.

            i := line lastIndexOf:$$.

            i > 1 ifTrue:[

                line := line copyTo:i.

            ].

            ^ line

        ]

    ].

    ^ nil

    "Created: 15.10.1996 / 18:57:57 / cg"

    "Modified: 16.10.1996 / 16:54:40 / cg"

! !

!Class class methodsFor:'misc'!

template:aCategoryString

    "return a class-definition template"

    ^ 'NameOfSuperclass subclass:#NameOfClass

    instanceVariableNames:''instVarName1 instVarName2''

    classVariableNames:''classVarName1 classVarName2''

    poolDictionaries:''''

    category:''' , aCategoryString , ''''

    "Created: / 19.6.1998 / 02:09:06 / cg"

! !

!Class class methodsFor:'private'!

flushSubclassInfo

    "throw away (forget) the cached subclass information, as created

     by #subclassInfo.

     This is private protocol"

    SubclassInfo := nil.

    "

     Class flushSubclassInfo

    "

    "Modified: 22.1.1997 / 18:39:36 / cg"

!

subclassInfo

    "build & return a dictionary, containing the set of subclass

     for each class. This information is kept until explicitely flushed

     by #flushSubclassInfo.

     This cache is used internally, for enumerators like #allSubclasses

     or #allSubclassesDo:, to avoid repeated recursive walks over the class

     hierarchy.

     This is private protocol."

    |d|

    SubclassInfo notNil ifTrue:[^ SubclassInfo].

    d := IdentityDictionary new.

    Smalltalk allClassesDo:[:aClass |

        |superCls setToAddSubclass|

        superCls := aClass superclass.

        superCls notNil ifTrue:[

            setToAddSubclass := d at:superCls ifAbsent:nil.

            setToAddSubclass isNil ifTrue:[

                d at:superCls put:(Set with:aClass).

            ] ifFalse:[

                setToAddSubclass add:aClass

            ]

        ]

    ].

    SubclassInfo := d.

    ^ d

    "

     Class subclassInfo

    "

    "Modified: 22.1.1997 / 18:44:59 / cg"

! !

!Class 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 == Class class or:[self == Class]

    "Created: 15.4.1996 / 17:17:13 / cg"

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

! !

!Class methodsFor:'Compatibility-Dolphin'!

defaultCategoryForDolphinClasses

    ^ DefaultCategoryForDolphin ? 'Dolphin classes'.

!

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

    "{ Pragma: +optSpace }"

    "this method allows fileIn of Dolphin classes "

    ^ self subclass:t

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForDolphinClasses)

           classInstanceVariableNames:classInstanceVariableNames

    "Modified: / 15.6.1998 / 21:31:34 / cg"

    "Modified: / 18.3.1999 / 18:16:11 / stefan"

!

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

    "{ Pragma: +optSpace }"

    "this method allows fileIn of Dolphin classes "

    ^ self variableSubclass:t

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForDolphinClasses)

           classInstanceVariableNames:classInstanceVariableNames

    "Modified: / 15.6.1998 / 21:31:34 / cg"

    "Modified: / 18.3.1999 / 18:16:11 / stefan"

! !

!Class methodsFor:'Compatibility-ST/V and V''Age'!

defaultCategoryForSTVorVAGEClasses

    |cat app|

    DefaultApplicationQuerySignal isHandled ifTrue:[

        app := DefaultApplicationQuerySignal query.

        app notNil ifTrue:[

            cat := 'Applications-' , app name.

        ] ifFalse:[

            cat := DefaultCategoryForVAGE ? 'V''Age classes'.

        ].

    ] ifFalse:[

        cat := DefaultCategoryForSTV ? 'ST/V classes'.

    ].

    ^ cat

!

subclass:nm classInstanceVariableNames:cIV instanceVariableNames:iV classVariableNames:cV poolDictionaries:p

    "{ Pragma: +optSpace }"

    "this method allows fileIn of V'Age classes"

    ^ self 

           subclass:nm

           instanceVariableNames:iV

           classVariableNames:cV

           poolDictionaries:p

           category:(self defaultCategoryForSTVorVAGEClasses)

           classInstanceVariableNames:cIV

!

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

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age classes

     (which seem to have no category)"

    ^ self 

           subclass:t

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:34 / cg"

    "Modified: / 18.3.1999 / 18:16:11 / stefan"

!

variableByteSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable byte classes

     (which seem to have no category and no instvars)"

    ^ self variableByteSubclass:t

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:38 / cg"

    "Modified: / 18.3.1999 / 18:16:21 / stefan"

!

variableLongSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable long (32bit integers) classes

     (which seem to have no category and no instvars)"

    ^ self variableLongSubclass:t

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

!

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

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable pointer classes

     (which seem to have no category)"

    ^ self variableSubclass:t

           instanceVariableNames:f

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

    "Modified: / 15.6.1998 / 21:31:41 / cg"

    "Modified: / 18.3.1999 / 18:16:33 / stefan"

!

variableWordSubclass:t classVariableNames:d poolDictionaries:s

    "{ Pragma: +optSpace }"

    "this method allows fileIn of ST/V and V'Age variable word (16bit integers) classes

     (which seem to have no category and no instvars)"

    ^ self variableWordSubclass:t

           instanceVariableNames:''

           classVariableNames:d

           poolDictionaries:s

           category:(self defaultCategoryForSTVorVAGEClasses)

! !

!Class methodsFor:'Compatibility-ST80'!

fileOutSourceOn:aStream

    self fileOutOn:aStream withTimeStamp:false

    "Created: 20.6.1997 / 17:18:14 / cg"

    "Modified: 20.6.1997 / 17:18:26 / cg"

!

rename:newName

    "same as renameTo: - for ST80 compatibility"

    ^ Smalltalk renameClass:self to:newName.

"/    ^ self renameTo:newName

    "Created: / 18.6.1998 / 22:08:45 / cg"

! !

!Class methodsFor:'accessing'!

addChangeRecordForClass:aClass andNotifyChangeOf:aspect

    "writes a change record and notifies dependents."

    |namespace|

    self addChangeRecordForClass:aClass.

    aClass changed:#definition.

    namespace := aClass nameSpace.

    namespace changed:#classDefinition with:aClass.

    namespace ~~ Smalltalk ifTrue:[

        Smalltalk changed:#classDefinition with:aClass.

    ].

    namespace changed:aspect with:aClass.

    namespace ~~ Smalltalk ifTrue:[

        Smalltalk changed:aspect with:aClass.

    ].

!

addClassVarName:aString

    "add a class variable if not already there and initialize it with nil.

     Also writes a change record and notifies dependents."

    (self classVarNames includes:aString) ifFalse:[

        self classVariableString:(self classVariableString , ' ' , aString).

        Class withoutUpdatingChangesDo:[

            self withAllSubclasses do:[:cls|

                cls recompileMethodsAccessingAnyClassvarOrGlobal:

                                        (Array with:aString asSymbol)

            ].

        ].

        self addChangeRecordForClass:self andNotifyChangeOf:#classVariables.

    ]

    "Created: / 29.10.1995 / 19:40:51 / cg"

    "Modified: / 23.1.1998 / 15:46:23 / stefan"

!

allPrivateClasses