--- a/ClassDescr.st Mon May 26 17:39:16 1997 +0200
+++ b/ClassDescr.st Tue May 27 10:36:04 1997 +0200
@@ -10,9 +10,16 @@
hereby transferred.
"
+'From Smalltalk/X, Version:3.1.5 on 3-apr-1997 at 19:19:00' !
+
Behavior subclass:#ClassDescription
- instanceVariableNames:'name category instvars primitiveSpec signature'
- classVariableNames:''
+ instanceVariableNames:'instvars'
+ classVariableNames:'UpdatingChanges LockChangesFile FileOutErrorSignal
+ CatchMethodRedefinitions MethodRedefinitionSignal
+ UpdateChangeFileQuerySignal TryLocalSourceFirst
+ ChangeFileAccessLock NameSpaceQuerySignal PackageQuerySignal
+ UsedNameSpaceQuerySignal CreateNameSpaceQuerySignal
+ FileOutNameSpaceQuerySignal'
poolDictionaries:''
category:'Kernel-Classes'
!
@@ -35,46 +42,211 @@
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.
+ ClassDescription conceptually adds some descriptive information to the basic
+ Behavior class. It is an abstract class used as a common superclass
+ for Metaclass and Class.
+ Subclasses must define the #name, #category and #comment methods.
[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.
+
+ [Class variables:]
+
+ UpdatingChanges <Boolean> true if the changes-file shall be updated
+ (except during startup and when filing in, this flag
+ is usually true)
+
+ UpdateChangeFileQuerySignal used as an upQuery from the change management.
+ Whenever a changeRecord is to be written,
+ this signal is raised and a handler (if present)
+ is supposed to return true or false.
+ If unhandled, the value of the global
+ UpdatingChanges is returned for backward
+ compatibility (which means that the old
+ mechanism is used if no query-handler
+ is present).
+
+ LockChangesFile <Boolean> if true, the change file is locked for updates.
+ Required when multiple users operate on a common
+ change file.
+ This is an experimental new feature, being evaluated.
+
+ FileOutErrorSignal raised when an error occurs during fileOut
+
+ CatchMethodRedefinitions if true, classes protect themself
+ MethodRedefinitionSignal (by raising MethodRedefinitionSignal)
+ from redefining any existing methods,
+ which are defined in another package.
+ (i.e. a signal will be raised, if you
+ fileIn something which redefines an
+ existing method and the packages do not
+ match).
+ The default is (currently) true.
+
+ TryLocalSourceFirst If true, local source files are tried
+ first BEFORE the sourceCodeManager is
+ consulted. If false, the sourceCodeManager
+ is asked first.
+ Should be turned on, if you run an image from
+ local sources which have not yet been checked in.
+
+ NameSpaceQuerySignal used as an upQuery to ask for a namespace into
+ which new classes are to be installed.
+
+ PackageQuerySignal used as an upQuery to ask for a packageSymbol with
+ which new classes/methods are to be marked.
+
+ CreateNameSpaceQuerySignal used as an upQuery to ask if unknown namespaces
+ should be silently created (without asking the user)
+
[author:]
Claus Gittinger
[see also:]
- Behavior Class Metaclass
+ 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:'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 avoid putting too much junk into the changes-file."
+
+ UpdatingChanges := true.
+ LockChangesFile := false.
+ CatchMethodRedefinitions := true.
+ TryLocalSourceFirst := false.
+
+ FileOutErrorSignal isNil ifTrue:[
+ FileOutErrorSignal := ErrorSignal newSignalMayProceed:false.
+ FileOutErrorSignal nameClass:self message:#fileOutErrorSignal.
+ FileOutErrorSignal notifierString:'error during fileOut'.
+
+ MethodRedefinitionSignal := ErrorSignal newSignalMayProceed:true.
+ MethodRedefinitionSignal nameClass:self message:#methodRedefinitionSignal.
+ MethodRedefinitionSignal notifierString:'attempt to redefine method from different package'.
+
+ UpdateChangeFileQuerySignal := QuerySignal new.
+ UpdateChangeFileQuerySignal nameClass:self message:#updateChangeFileQuerySignal.
+ UpdateChangeFileQuerySignal notifierString:'asking if changeFile update is wanted'.
+ UpdateChangeFileQuerySignal handlerBlock:[:ex | ex proceedWith:UpdatingChanges].
+
+ NameSpaceQuerySignal := QuerySignal new.
+ NameSpaceQuerySignal nameClass:self message:#nameSpaceQuerySignal.
+ NameSpaceQuerySignal notifierString:'asking for nameSpace'.
+ NameSpaceQuerySignal handlerBlock:[:ex | ex proceedWith:Smalltalk defaultNameSpace].
+
+ UsedNameSpaceQuerySignal := QuerySignal new.
+ UsedNameSpaceQuerySignal nameClass:self message:#usedNameSpaceQuerySignal.
+ UsedNameSpaceQuerySignal notifierString:'asking for used nameSpaced'.
+
+ CreateNameSpaceQuerySignal := QuerySignal new.
+ CreateNameSpaceQuerySignal nameClass:self message:#createNameSpaceQuerySignal.
+ CreateNameSpaceQuerySignal notifierString:'asking for nameSpace creation'.
+ CreateNameSpaceQuerySignal defaultAnswer:false.
+
+ PackageQuerySignal := QuerySignal new.
+ PackageQuerySignal nameClass:self message:#packageQuerySignal.
+ PackageQuerySignal notifierString:'asking for package'.
+ PackageQuerySignal handlerBlock:[:ex | ex proceedWith:(Project isNil
+ ifTrue:[
+ 'no package'
+ ] ifFalse:[
+ Project currentPackageName
+ ])].
+
+ FileOutNameSpaceQuerySignal := QuerySignal new.
+ FileOutNameSpaceQuerySignal defaultAnswer:false.
+
+ ChangeFileAccessLock := Semaphore forMutualExclusion name:'ChangeFileAccessLock'.
+ ]
+
+ "Modified: 3.1.1997 / 15:16:05 / cg"
+ "Created: 2.4.1997 / 17:27:40 / stefan"
+! !
+
+!ClassDescription class methodsFor:'Signal constants'!
+
+createNameSpaceQuerySignal
+ "return the signal used as an upQuery if a new nameSpace should be
+ silently created without user confirmation.
+ Only used when installing autoloaded classes"
+
+ ^ CreateNameSpaceQuerySignal
+
+ "Created: 2.4.1997 / 17:27:54 / stefan"
+!
+
+fileOutErrorSignal
+ "return the signal raised when an error occurs while fileing out.
+ This is signalled to allow browsers some user feed back in case
+ a fileout fails (for example due to disk-full errors)"
+
+ ^ FileOutErrorSignal
+
+ "Created: 2.4.1997 / 17:28:03 / stefan"
+!
+
+fileOutNameSpaceQuerySignal
+ "return the signal used as an upQuery wether the current
+ namespace should be prepended on fileOut."
+
+ ^ FileOutNameSpaceQuerySignal
+
+ "
+ Transcript showCR:Class fileOutNameSpaceQuerySignal raise
+ "
+
+ "Modified: 5.11.1996 / 20:08:38 / cg"
+ "Created: 2.4.1997 / 17:28:41 / stefan"
+! !
+
+!ClassDescription class methodsFor:'enumeration '!
+
+allClassesInCategory:aCategory do:aBlock
+ "evaluate aBlock for all classes in aCategory;
+ no specific order is defined."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = aCategory) ifTrue:[
+ aBlock value:aClass
+ ]
+ ].
+ ]
+
+ "
+ Class allClassesInCategory:'Kernel-Classes'
+ do:[:class |Transcript showCR:class name]
+ "
+
+ "Created: 1.4.1997 / 23:45:09 / stefan"
+!
+
+allClassesInCategory:aCategory inOrderDo:aBlock
+ "evaluate aBlock for all classes in aCategory;
+ superclasses come first - then subclasses."
+
+ |classes|
+
+ classes := OrderedCollection new.
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass isMeta ifFalse:[
+ (aClass category = aCategory) ifTrue:[
+ classes add:aClass
+ ]
+ ]
+ ].
+ classes topologicalSort:[:a :b | b isSubclassOf:a].
+ classes do:aBlock
+
+ "Created: 1.4.1997 / 23:45:15 / stefan"
! !
!ClassDescription class methodsFor:'queries'!
@@ -92,30 +264,15 @@
!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"
+ ^ self subclassResponsibility
+
+ "Created: 2.4.1997 / 00:51:04 / stefan"
!
-category:aStringOrSymbol
- "set the category of the class to be the argument, aStringOrSymbol"
-
- aStringOrSymbol isNil ifTrue:[
- category := aStringOrSymbol
- ] ifFalse:[
- category := aStringOrSymbol asSymbol
- ]
+comment
+ ^ self subclassResponsibility
+
+ "Created: 2.4.1997 / 00:51:11 / stefan"
!
instVarAtOffset:index
@@ -175,10 +332,9 @@
!
name
- "return the name of the class. In the current implementation,
- this returns a string, but will be changed to Symbol soon."
-
- ^ name
+ ^ self subclassResponsibility
+
+ "Created: 2.4.1997 / 00:50:56 / stefan"
!
organization
@@ -188,8 +344,897 @@
^ ClassOrganizer for:self
! !
+!ClassDescription methodsFor:'adding/removing'!
+
+basicAddSelector:newSelector withMethod:newMethod
+ "add the method given by 2nd argument under the selector given by
+ 1st argument to the methodDictionary.
+ This does NOT append a change record to the changes file and tell
+ dependents. Also, no methodHistory is kept or redefinition is checked."
+
+ super addSelector:newSelector withMethod:newMethod
+
+ "Created: 2.4.1997 / 01:01:08 / stefan"
+!
+
+removeSelector:aSelector
+ "remove the selector, aSelector and its associated method
+ from the methodDictionary.
+ Append a change record to the changes file and tell dependents."
+
+ (super removeSelector:aSelector) ifTrue:[
+ self addChangeRecordForRemoveSelector:aSelector.
+ "/
+ "/ also notify a change of mySelf;
+ "/
+ self changed:#methodDictionary with:aSelector.
+
+ "/
+ "/ also notify a change of Smalltalk;
+ "/ this allows a dependent of Smalltalk to watch all class
+ "/ changes (no need for observing all classes)
+ "/ - this allows for watchers to find out if its a new method or a method-change
+ "/
+ Smalltalk changed:#methodInClassRemoved with:(Array with:self with:aSelector).
+ ]
+
+ "Modified: 8.1.1997 / 23:03:49 / cg"
+ "Created: 2.4.1997 / 00:59:29 / stefan"
+! !
+
+!ClassDescription methodsFor:'c function interfacing'!
+
+cInterfaceFunction:selector calling:cFunctionNameString args:argTypeArray returning:returnType
+ "{ Pragma: +optSpace }"
+
+ "create an interface to an existing (i.e. already linked in) c function.
+ The function can be called by sending selector to the receiver class.
+ The c-function has the name cFunctionNameString, and expects parameters as specified in
+ argTypeArray. The functions return value has a type as specified by returnType.
+ WARNING:
+ this interface is EXPERIMENTAL - it may change or even be removed."
+
+ StubGenerator isNil ifTrue:[
+ ^ self error:'this system does not support dynamic C Interface functions'.
+ ].
+
+ StubGenerator
+ createStubFor:selector
+ calling:cFunctionNameString
+ args:argTypeArray
+ returning:returnType
+ in:self
+
+ "
+ Object subclass:#CInterface
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Examples'.
+
+ CInterface cInterfaceFunction:#printfOn:format:withFloat:
+ calling:'fprintf'
+ args:#(ExternalStream String Float)
+ returning:#SmallInteger.
+
+ CInterface printfOn:Stdout format:'this is a float: %g' withFloat:(Float pi). Stdout cr
+ "
+
+ "Modified: 5.1.1997 / 19:58:22 / cg"
+ "Created: 2.4.1997 / 00:57:40 / stefan"
+! !
+
+!ClassDescription methodsFor:'changes management'!
+
+addChangeRecordForMethod:aMethod
+ "{ Pragma: +optSpace }"
+
+ "add a method-change-record to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangePerform:#addChangeRecordForMethod:to: with:aMethod.
+ "this test allows a smalltalk without Projects/ChangeSets"
+ Project notNil ifTrue:[
+ Project addMethodChange:aMethod in:self
+ ]
+ ]
+
+ "Modified: 20.1.1997 / 12:36:02 / cg"
+ "Created: 2.4.1997 / 01:02:16 / stefan"
+!
+
+addChangeRecordForMethodCategory:aMethod category:aString
+ "{ Pragma: +optSpace }"
+
+ "add a methodCategory-change-record to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangeDo:[:aStream |
+ self addChangeRecordForMethodCategory:aMethod category:aString to:aStream.
+ ].
+
+ "this test allows a smalltalk without Projects/ChangeSets"
+ Project notNil ifTrue:[
+ Project addMethodCategoryChange:aMethod category:aString in:self
+ ]
+ ]
+
+ "Modified: 20.1.1997 / 12:36:05 / cg"
+ "Modified: 2.4.1997 / 17:30:20 / stefan"
+!
+
+addChangeRecordForMethodPrivacy:aMethod
+ "{ Pragma: +optSpace }"
+
+ "add a method-privacy-change-record to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangePerform:#addChangeRecordForMethodPrivacy:to: with:aMethod.
+ "this test allows a smalltalk without Projects/ChangeSets"
+ Project notNil ifTrue:[
+ Project addMethodPrivacyChange:aMethod in:self
+ ]
+ ]
+
+ "Modified: 27.8.1995 / 22:47:32 / claus"
+ "Modified: 20.1.1997 / 12:36:08 / cg"
+ "Created: 2.4.1997 / 17:30:33 / stefan"
+!
+
+addChangeRecordForRemoveSelector:aSelector
+ "{ Pragma: +optSpace }"
+
+ "add a method-remove-record to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangePerform:#addChangeRecordForRemoveSelector:to: with:aSelector.
+ ]
+
+ "Modified: 24.1.1997 / 19:10:48 / cg"
+ "Created: 2.4.1997 / 17:30:47 / stefan"
+!
+
+addChangeRecordForRenameCategory:oldCategory to:newCategory
+ "{ Pragma: +optSpace }"
+
+ "add a category-rename record to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangeDo:[:aStream |
+ self addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream.
+ ]
+ ]
+
+ "Modified: 24.1.1997 / 19:10:57 / cg"
+ "Created: 2.4.1997 / 17:31:03 / stefan"
+!
+
+addChangeTimeStampTo:aStream
+ "{ Pragma: +optSpace }"
+
+ "a timestamp - prepended to any change, except infoRecords"
+
+ |info|
+
+ info := 'timestamp ' , OperatingSystem getLoginName , '@' , OperatingSystem getHostName.
+ self addInfoRecord:info to:aStream. aStream cr.
+
+ "Modified: 22.3.1997 / 17:14:10 / cg"
+ "Created: 3.4.1997 / 19:18:27 / stefan"
+!
+
+addInfoRecord:aMessage
+ "{ Pragma: +optSpace }"
+
+ "add an info-record (snapshot, class fileOut etc.) to the changes file"
+
+ UpdateChangeFileQuerySignal raise ifTrue:[
+ self writingChangeWithTimeStamp:false
+ perform:#addInfoRecord:to:
+ with:aMessage.
+ ]
+
+ "Modified: 24.1.1997 / 19:13:14 / cg"
+ "Created: 2.4.1997 / 17:34:18 / stefan"
+!
+
+changesStream
+ "return a Stream for the writing changes file.
+ This returns a regular stream or a locked stream - according to
+ the LockChangesFile settings
+ (recommended if multiple images operate on a common changes file)"
+
+ |streamType aStream fileName|
+
+ fileName := ObjectMemory nameForChanges.
+
+ LockChangesFile ifTrue:[
+ streamType := LockedFileStream.
+ ] ifFalse:[
+ streamType := FileStream.
+ ].
+ aStream := streamType oldFileNamed:fileName.
+ aStream isNil ifTrue:[
+ aStream := streamType newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ self warn:'cannot create/update the changes file'.
+ ^ nil
+ ]
+ ].
+ aStream setToEnd.
+ ^ aStream
+
+ "Modified: 24.1.1997 / 19:14:27 / cg"
+ "Created: 2.4.1997 / 17:34:13 / stefan"
+!
+
+withoutUpdatingChangesDo:aBlock
+ "turn off change file update while evaluating aBlock."
+
+ UpdateChangeFileQuerySignal
+ answer:false
+ do:[
+ aBlock value
+ ].
+
+ "Modified: 17.1.1997 / 20:48:05 / cg"
+ "Created: 2.4.1997 / 17:34:35 / stefan"
+! !
+
+!ClassDescription methodsFor:'compiling'!
+
+compile:code
+ "compile code, aString for this class;
+ if successful update the method dictionary.
+ Returns the new method or nil (on failure)."
+
+ ^ self compilerClass
+ compile:code
+ forClass:self
+
+ "Modified: 13.12.1995 / 10:56:00 / cg"
+ "Created: 1.4.1997 / 23:43:51 / stefan"
+!
+
+compile:code classified:category
+ "compile code, aString for this class;
+ if successful update the method dictionary.
+ The method is classified under category.
+ Returns the new method or nil (on failure)."
+
+ ^ self compile:code classified:category logged:true
+
+ "Modified: 20.4.1996 / 12:30:51 / cg"
+ "Created: 1.4.1997 / 23:43:57 / stefan"
+!
+
+compile:code classified:category logged:logged
+ "compile code, aString for this class;
+ if successful update the method dictionary.
+ The method is classified under category.
+ If logged is true, a changeRecord is written.
+ Returns the new method or nil (on failure)."
+
+ logged ifFalse:[
+ self withoutUpdatingChangesDo:[
+ ^ self compilerClass
+ compile:code
+ forClass:self
+ inCategory:category
+ ]
+ ] ifTrue:[
+ ^ self compilerClass
+ compile:code
+ forClass:self
+ inCategory:category
+ ].
+
+ "Modified: 13.12.1995 / 11:02:34 / cg"
+ "Created: 1.4.1997 / 23:44:02 / stefan"
+!
+
+compile:code notifying:requestor
+ "compile code, aString for this class; on any error, notify
+ requestor, anObject with the error reason.
+ Returns the new method or nil (on failure)."
+
+ ^ self compilerClass
+ compile:code
+ forClass:self
+ notifying:requestor
+
+ "Modified: 13.12.1995 / 11:02:40 / cg"
+ "Created: 1.4.1997 / 23:43:43 / stefan"
+!
+
+recompile
+ "{ Pragma: +optSpace }"
+
+ "recompile all methods
+ used when a class changes instances and therefore all methods
+ have to be recompiled"
+
+ self methodDictionary keys do:[:aSelector |
+ self recompile:aSelector
+ ]
+
+ "Modified: 12.6.1996 / 11:51:15 / stefan"
+ "Modified: 5.1.1997 / 19:56:23 / cg"
+ "Created: 1.4.1997 / 23:43:38 / stefan"
+!
+
+recompile:aSelector
+ "{ Pragma: +optSpace }"
+
+ "recompile the method associated with the argument, aSelector;
+ used when a superclass changes instances and we have to recompile
+ subclasses"
+
+ |cat code|
+
+ Class withoutUpdatingChangesDo:[
+ MethodRedefinitionSignal ignoreIn:[
+ cat := (self compiledMethodAt:aSelector) category.
+ code := self sourceCodeAt:aSelector.
+ self compilerClass compile:code forClass:self inCategory:cat
+ ]
+ ]
+
+ "Modified: 5.1.1997 / 19:56:54 / cg"
+ "Created: 1.4.1997 / 23:43:34 / stefan"
+!
+
+recompileAll
+ "{ Pragma: +optSpace }"
+
+ "recompile this class and all subclasses"
+
+ |classes|
+
+ classes := self subclasses.
+ self recompile.
+ classes do:[:aClass |
+ aClass recompileAll
+ ]
+
+ "Modified: 5.1.1997 / 19:56:29 / cg"
+ "Created: 1.4.1997 / 23:44:15 / stefan"
+!
+
+recompileForSpeed:aSelector
+ "{ Pragma: +optSpace }"
+
+ "recompile the method associated with the argument, aSelector;
+ for highest speed (i.e. using the stc compiler, if supported by
+ the architecture)."
+
+ |cat code prev savedMethod|
+
+ Class withoutUpdatingChangesDo:[
+ MethodRedefinitionSignal ignoreIn:[
+ savedMethod := self compiledMethodAt:aSelector.
+ cat := savedMethod category.
+ code := self sourceCodeAt:aSelector.
+
+ prev := Compiler stcCompilation:#always.
+ [
+ self compilerClass compile:code forClass:self inCategory:cat
+ ] valueNowOrOnUnwindDo:[
+ Compiler stcCompilation:prev.
+
+ (self compiledMethodAt:aSelector) isNil ifTrue:[
+ self primAddSelector:aSelector withMethod:savedMethod
+ ]
+ ]
+ ]
+ ]
+
+ "Modified: 5.1.1997 / 19:55:33 / cg"
+ "Created: 1.4.1997 / 23:44:32 / stefan"
+!
+
+recompileInvalidatedMethods
+ "{ Pragma: +optSpace }"
+
+ "recompile all invalidated methods"
+
+ self methodDictionary keysAndValuesDo:[:aSelector :aMethod |
+ |trap trapCode trapByteCode|
+
+ trap := aMethod trapMethodForNumArgs:aMethod numArgs.
+ trapCode := trap code.
+ trapByteCode := trap byteCode.
+
+ (aMethod code = trapCode
+ or:[aMethod byteCode == trapByteCode]) ifTrue:[
+ self recompile:aSelector
+ ]
+ ]
+
+ "Modified: 12.6.1996 / 11:52:09 / stefan"
+ "Modified: 5.1.1997 / 19:56:59 / cg"
+ "Created: 1.4.1997 / 23:44:37 / stefan"
+!
+
+recompileMethodsAccessingAny:setOfNames
+ "{ Pragma: +optSpace }"
+
+ "recompile all methods accessing a variable from setOfNames"
+
+ self recompileMethodsAccessingAny:setOfNames orSuper:false
+
+ "Modified: 5.1.1997 / 19:57:05 / cg"
+ "Created: 1.4.1997 / 23:44:41 / stefan"
+!
+
+recompileMethodsAccessingAny:setOfNames orSuper:superBoolean
+ "{ Pragma: +optSpace }"
+
+ "recompile all methods accessing a variable from setOfNames,
+ or super (if superBoolean is true)"
+
+ |p|
+
+ self methodDictionary keys do:[:aSelector |
+ |m mustCompile lits source|
+
+ m := self compiledMethodAt:aSelector.
+ mustCompile := nil.
+
+ source := m source.
+
+ "/ avoid parsing, if possible
+ superBoolean ifFalse:[
+ setOfNames size == 1 ifTrue:[
+ (source findString:(setOfNames first)) == 0 ifTrue:[
+ mustCompile := false.
+ ]
+ ]
+ ].
+
+ mustCompile isNil ifTrue:[
+ p := Parser parseMethod:(m source) in:self.
+ (p isNil
+ or:[(p usedVars notNil and:[p usedVars includesAny:setOfNames])
+ or:[superBoolean and:[p usesSuper]]]) ifTrue:[
+ mustCompile := true
+ ]
+ ].
+
+ mustCompile == true ifTrue:[
+ self recompile:aSelector
+ ]
+ ]
+
+ "Modified: 12.6.1996 / 11:52:35 / stefan"
+ "Modified: 9.1.1997 / 02:07:40 / cg"
+ "Created: 1.4.1997 / 23:44:46 / stefan"
+!
+
+recompileMethodsAccessingGlobal:aGlobalKey
+ "{ Pragma: +optSpace }"
+
+ "recompile all methods accessing the global variable aGlobalKey"
+
+ self methodDictionary keys do:[:aSelector |
+ |m lits|
+
+ m := self compiledMethodAt:aSelector.
+ "/ can look at the methods literalArray ..
+ m isWrapped ifTrue:[
+ m := m originalMethod
+ ].
+ lits := m literals.
+ lits notNil ifTrue:[
+ (lits includes:aGlobalKey) ifTrue:[
+ self recompile:aSelector
+ ]
+ ]
+ ]
+
+ "Modified: 12.6.1996 / 11:52:35 / stefan"
+ "Modified: 29.1.1997 / 23:51:11 / cg"
+ "Created: 1.4.1997 / 23:44:53 / stefan"
+! !
+
+!ClassDescription methodsFor:'fileIn interface'!
+
+ignoredMethodsFor:aCategory
+ "this is a speciality of ST/X - it allows quick commenting of methods
+ from a source-file by replacing the 'methodsFor:' by 'ignoredMethodsFor:'.
+ Returns a ClassCategoryReader to read in and skip methods."
+
+ ^ (self methodsFor:aCategory) ignoredProtocol
+
+ "Modified: 10.2.1996 / 12:53:25 / cg"
+ "Created: 1.4.1997 / 13:58:46 / stefan"
+!
+
+methods
+ "this method allows fileIn of ST/V methods -
+ return a ClassCategoryReader to read in and compile methods for me.
+ Since ST/V does not support method categories, the loaded methods are
+ categorized as 'ST/V methods'."
+
+ ^ ClassCategoryReader class:self category:'ST/V methods'
+
+ "Modified: 10.2.1996 / 12:44:21 / cg"
+ "Created: 1.4.1997 / 13:58:52 / stefan"
+!
+
+methodsFor:aCategory
+ "return a ClassCategoryReader to read in and compile methods for me."
+
+ ^ ClassCategoryReader class:self category:aCategory
+
+ "Modified: 10.2.1996 / 12:44:43 / cg"
+ "Created: 1.4.1997 / 13:57:37 / stefan"
+!
+
+methodsForUndefined:categoryString
+ "ST-80 compatibility.
+ I dont yet know what this does - it was encountered by some tester.
+ For now, simply forward it."
+
+ ^ self methodsFor:categoryString
+
+ "Created: 1.4.1997 / 13:59:14 / stefan"
+!
+
+privateMethodsFor:aCategory
+ "this method allows fileIn of ENVY and ST/X private methods.
+
+ The following methods are only allowed to be executed if sent from a method
+ within the current class. Subclass sends or out-of-class sends will raise
+ a privatMethodError exception."
+
+ ^ (self methodsFor:aCategory) privateProtocol
+
+ "Modified: 10.2.1996 / 12:48:44 / cg"
+ "Created: 1.4.1997 / 14:01:07 / stefan"
+!
+
+protectedMethodsFor:aCategory
+ "this method allows fileIn of ENVY and ST/X protected methods.
+
+ The following methods are only allowed to be executed if sent from a method
+ within the current class or a subclass. Out-of-class sends will raise
+ a privatMethodError exception."
+
+ ^ (self methodsFor:aCategory) protectedProtocol
+
+ "Modified: 10.2.1996 / 12:49:18 / cg"
+ "Created: 1.4.1997 / 13:59:32 / stefan"
+!
+
+publicMethodsFor:aCategory
+ "this method allows fileIn of ENVY methods
+ The publicMethods keyword is for documentation only; my default, methods
+ are public anyway (for backward compatibility)."
+
+ ^ self methodsFor:aCategory
+
+ "Modified: 10.2.1996 / 12:50:11 / cg"
+ "Created: 1.4.1997 / 13:59:39 / stefan"
+! !
+
+!ClassDescription methodsFor:'fileOut'!
+
+fileOutCategory:aCategory
+ "create a file 'class-category.st' consisting of all methods in aCategory.
+ If the current project is not nil, create the file in the projects
+ directory."
+
+ |aStream fileName|
+
+ fileName := self name , '-' , aCategory , '.st'.
+ fileName replaceAll:(Character space) by:$_.
+
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
+ ].
+ self fileOutCategory:aCategory on:aStream.
+ aStream close
+
+ "Modified: 1.4.1997 / 16:00:24 / stefan"
+ "Created: 1.4.1997 / 16:04:18 / stefan"
+!
+
+fileOutCategory:aCategory except:skippedMethods only:savedMethods on:aStream
+ "file out all methods belonging to aCategory, aString onto aStream.
+ If skippedMethods is nonNil, those are not saved.
+ If savedMethods is nonNil, only those are saved.
+ If both are nil, all are saved. See version-method handling in
+ fileOut for what this is needed."
+
+ |dict source sortedSelectors first privacy interestingMethods cat|
+
+ dict := self methodDictionary.
+ dict notNil ifTrue:[
+ interestingMethods := OrderedCollection new.
+ dict do:[:aMethod |
+ |wanted|
+
+ (aCategory = aMethod category) ifTrue:[
+ skippedMethods notNil ifTrue:[
+ wanted := (skippedMethods includesIdentical:aMethod) not
+ ] ifFalse:[
+ savedMethods notNil ifTrue:[
+ wanted := (savedMethods includesIdentical:aMethod).
+ ] ifFalse:[
+ wanted := true
+ ]
+ ].
+ wanted ifTrue:[interestingMethods add:aMethod].
+ ]
+ ].
+ interestingMethods notEmpty ifTrue:[
+ first := true.
+ privacy := nil.
+
+ "/
+ "/ sort by selector
+ "/
+ sortedSelectors := interestingMethods collect:[:m | self selectorAtMethod:m].
+ sortedSelectors sortWith:interestingMethods.
+
+ interestingMethods do:[:aMethod |
+ first ifFalse:[
+ privacy ~~ aMethod privacy ifTrue:[
+ first := true.
+ aStream space.
+ aStream nextPutChunkSeparator.
+ ].
+ aStream cr; cr
+ ].
+
+ privacy := aMethod privacy.
+
+ first ifTrue:[
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+ privacy ~~ #public ifTrue:[
+ aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+ ] ifFalse:[
+ aStream nextPutAll:' methodsFor:'.
+ ].
+ cat := aCategory.
+ cat isNil ifTrue:[ cat := '' ].
+ aStream nextPutAll:aCategory asString storeString.
+ aStream nextPutChunkSeparator; cr; cr.
+ first := false.
+ ].
+ source := aMethod source.
+ source isNil ifTrue:[
+ FileOutErrorSignal
+ raiseRequestWith:self
+ errorString:'no source for method: ', (aMethod displayString)
+ ] ifFalse:[
+ aStream nextChunkPut:source.
+ ].
+ ].
+ aStream space.
+ aStream nextPutChunkSeparator.
+ aStream cr
+ ]
+ ]
+
+ "Modified: 28.8.1995 / 14:30:41 / claus"
+ "Modified: 12.6.1996 / 11:37:33 / stefan"
+ "Modified: 15.11.1996 / 11:32:21 / cg"
+ "Created: 1.4.1997 / 16:04:33 / stefan"
+!
+
+fileOutCategory:aCategory on:aStream
+ "file out all methods belonging to aCategory, aString onto aStream"
+
+ self fileOutCategory:aCategory except:nil only:nil on:aStream
+
+ "Created: 1.4.1997 / 16:04:44 / stefan"
+!
+
+fileOutMethod:aMethod
+ "create a file 'class-method.st' consisting of the method, aMethod.
+ If the current project is not nil, create the file in the projects
+ directory."
+
+ |aStream fileName selector|
+
+ selector := self selectorAtMethod:aMethod.
+ selector notNil ifTrue:[
+ fileName := self name , '-' , selector, '.st'.
+ fileName replaceAll:$: by:$_.
+ "
+ this test allows a smalltalk to be built without Projects/ChangeSets
+ "
+ Project notNil ifTrue:[
+ fileName := Project currentProjectDirectory , fileName.
+ ].
+
+ "
+ if file exists, save original in a .sav file
+ "
+ fileName asFilename exists ifTrue:[
+ fileName asFilename copyTo:(fileName , '.sav')
+ ].
+ aStream := FileStream newFileNamed:fileName.
+ aStream isNil ifTrue:[
+ ^ FileOutErrorSignal
+ raiseRequestWith:fileName
+ errorString:('cannot create file:', fileName)
+ ].
+ self fileOutMethod:aMethod on:aStream.
+ aStream close
+ ]
+
+ "Modified: 1.4.1997 / 16:00:57 / stefan"
+ "Created: 2.4.1997 / 00:24:28 / stefan"
+!
+
+fileOutMethod:aMethod on:aStream
+ "file out the method, aMethod onto aStream"
+
+ |dict cat source privacy|
+
+ dict := self methodDictionary.
+ dict notNil ifTrue:[
+ aStream nextPutChunkSeparator.
+ self printClassNameOn:aStream.
+
+ (privacy := aMethod privacy) ~~ #public ifTrue:[
+ aStream space; nextPutAll:privacy; nextPutAll:'MethodsFor:'.
+ ] ifFalse:[
+ aStream nextPutAll:' methodsFor:'.
+ ].
+ cat := aMethod category.
+ cat isNil ifTrue:[
+ cat := ''
+ ].
+ aStream nextPutAll:cat asString storeString.
+ aStream nextPutChunkSeparator; cr; cr.
+ source := aMethod source.
+ source isNil ifTrue:[
+ FileOutErrorSignal
+ raiseRequestWith:self
+ errorString:('no source for method: ' ,
+ self name , '>>' ,
+ (self selectorAtMethod:aMethod))
+ ] ifFalse:[
+ aStream nextChunkPut:source.
+ ].
+ aStream space.
+ aStream nextPutChunkSeparator.
+ aStream cr
+ ]
+
+ "Modified: 27.8.1995 / 01:23:19 / claus"
+ "Modified: 12.6.1996 / 11:44:41 / stefan"
+ "Modified: 15.11.1996 / 11:32:43 / cg"
+ "Created: 2.4.1997 / 00:24:33 / stefan"
+! !
+
!ClassDescription methodsFor:'printOut'!
+nameWithoutNameSpacePrefix
+ "helper for fileOut and others - return my names printString,
+ without any nameSpace prefix (but with owningClasses prefix)"
+
+ |nm owner|
+
+ nm := self nameWithoutPrefix.
+ (owner := self owningClass) isNil ifTrue:[
+ ^ nm
+ ].
+
+ ^ (owner nameWithoutNameSpacePrefix , '::' , nm)
+
+ "a public class:
+ Array name
+ Array nameWithoutPrefix
+ Array nameWithoutNameSpacePrefix
+ "
+
+ "a private class:
+ Method::MethodWhoInfo name
+ Method::MethodWhoInfo nameWithoutPrefix
+ Method::MethodWhoInfo nameWithoutNameSpacePrefix
+ "
+
+ "a namespace class:
+ CodingExamples::TopClass name
+ CodingExamples::TopClass nameWithoutPrefix
+ CodingExamples::TopClass nameWithoutNameSpacePrefix
+ "
+
+ "a private class in a namespace class:
+ CodingExamples::TopClass::SubClass name
+ CodingExamples::TopClass::SubClass nameWithoutPrefix
+ CodingExamples::TopClass::SubClass nameWithoutNameSpacePrefix
+ "
+
+ "Modified: 5.1.1997 / 18:22:57 / cg"
+ "Created: 1.4.1997 / 16:20:13 / stefan"
+!
+
+nameWithoutPrefix
+ "helper for fileOut and others - return my names printString,
+ without any owningClass or nameSpace prefix"
+
+ |nm idx|
+
+ nm := self name.
+ idx := nm lastIndexOf:$:.
+ idx == 0 ifTrue:[
+ ^ nm
+ ].
+ ^ nm copyFrom:idx+1.
+
+ "a public class:
+ Array name
+ Array nameWithoutPrefix
+ Array nameWithoutNameSpacePrefix
+ "
+
+ "a private class:
+ Method::MethodWhoInfo name
+ Method::MethodWhoInfo nameWithoutPrefix
+ Method::MethodWhoInfo nameWithoutNameSpacePrefix
+ "
+
+ "a namespace class:
+ CodingExamples::TopClass name
+ CodingExamples::TopClass nameWithoutPrefix
+ CodingExamples::TopClass nameWithoutNameSpacePrefix
+ "
+
+ "a private class in a namespace class:
+ CodingExamples::TopClass::SubClass name
+ CodingExamples::TopClass::SubClass nameWithoutPrefix
+ CodingExamples::TopClass::SubClass nameWithoutNameSpacePrefix
+ "
+
+ "Modified: 5.1.1997 / 18:23:14 / cg"
+ "Created: 1.4.1997 / 16:20:34 / stefan"
+!
+
+printClassNameOn:aStream
+ "helper for fileOut - print my name.
+ Private classes always print their owning-class as nameSpace
+ prefix; non-private ones print without, except if the
+ FileOutNameSpaceQuery returns true. The last feature is used
+ with changefile updates - here, the full name is wanted."
+
+ |nm|
+
+ Class fileOutNameSpaceQuerySignal raise == false ifTrue:[
+ nm := self nameWithoutNameSpacePrefix
+ ] ifFalse:[
+ nm := self name.
+ ].
+
+ aStream nextPutAll:nm.
+
+ "Modified: 3.1.1997 / 20:41:26 / cg"
+ "Created: 1.4.1997 / 16:06:57 / stefan"
+ "Modified: 1.4.1997 / 16:19:22 / stefan"
+!
+
printHierarchyAnswerIndentOn:aStream
"print my class hierarchy on aStream - return indent
recursively calls itself to print superclass and use returned indent
@@ -286,15 +1331,17 @@
displayString
"return a string for display in inspectors"
- |nm more|
-
- (category = 'obsolete'
- or:[category = '* obsolete *']) ifTrue:[
+ |nm more cat|
+
+ cat := self category.
+
+ (cat = 'obsolete'
+ or:[cat = '* obsolete *']) ifTrue:[
"add obsolete - to make life easier ..."
more := ' (obsolete)'
].
- (category = 'removed'
- or:[category = '* removed *']) ifTrue:[
+ (cat = 'removed'
+ or:[cat = '* removed *']) ifTrue:[
"add removed - to make life easier ..."
more := ' (removed)'
].
@@ -309,6 +1356,7 @@
^ nm , more
"Modified: 15.10.1996 / 20:01:30 / cg"
+ "Modified: 1.4.1997 / 15:49:13 / stefan"
!
isObsolete
@@ -316,115 +1364,353 @@
(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 *']]]
+ |cat|
+
+ cat := self category.
+
+ ^ cat = 'obsolete'
+ or:[cat = 'removed'
+ or:[cat = '* removed *'
+ or:[cat = '* obsolete *']]]
"Modified: 10.9.1996 / 14:02:07 / cg"
-! !
-
-!ClassDescription methodsFor:'renaming'!
-
-renameTo:newName
- "change the name of the class. Warning: this does not write a change record."
-
- |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"
+ "Modified: 1.4.1997 / 15:49:49 / stefan"
! !
-!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
+!ClassDescription methodsFor:'private changes management'!
+
+addChangeRecordForMethod:aMethod to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append a method-change-record to aStream"
+
+ self fileOutMethod:aMethod on:aStream.
+
+ "Created: 2.4.1997 / 17:31:46 / stefan"
+!
+
+addChangeRecordForMethodCategory:aMethod category:newCategory to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append a methodCategory-change-record to aStream"
+
+ |selector|
+
+ selector := aMethod selector.
+ selector notNil ifTrue:[
+ aStream nextPutAll:'('.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
+ aStream nextPutAll:(') category:' , newCategory storeString).
+ aStream nextPutChunkSeparator.
+ ]
+
+ "Created: 2.4.1997 / 17:31:56 / stefan"
+!
+
+addChangeRecordForMethodPrivacy:aMethod to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append a method-privacy-change-record to aStream"
+
+ |selector|
+
+ selector := aMethod selector.
+ selector notNil ifTrue:[
+ aStream nextPutAll:'('.
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' compiledMethodAt:' , selector storeString).
+ aStream nextPutAll:(') privacy:' , aMethod privacy storeString).
+ aStream nextPutChunkSeparator.
+ ]
+
+ "Modified: 27.8.1995 / 22:59:56 / claus"
+ "Created: 2.4.1997 / 17:32:04 / stefan"
+!
+
+addChangeRecordForRemoveSelector:aSelector to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append a method-remove-record to aStream"
+
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' removeSelector:' , aSelector asSymbol storeString).
+ aStream nextPutChunkSeparator.
+
+ "Modified: 1.7.1996 / 21:27:55 / cg"
+ "Created: 2.4.1997 / 17:32:31 / stefan"
+!
+
+addChangeRecordForRenameCategory:oldCategory to:newCategory to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append a category-rename record to aStream"
+
+ self printClassNameOn:aStream.
+ aStream nextPutAll:(' renameCategory:' , oldCategory storeString).
+ aStream nextPutAll:(' to:' , newCategory storeString).
+ aStream nextPutChunkSeparator.
+
+ "Created: 2.4.1997 / 17:32:44 / stefan"
+!
+
+addInfoRecord:aMessage to:aStream
+ "{ Pragma: +optSpace }"
+
+ "append an info-record (snapshot, class fileOut etc.) to aStream"
+
+ aStream nextPutAll:('''---- ' , aMessage , ' ',
+ Date today printString , ' ' ,
+ Time now printString ,
+ ' ----''').
+ aStream nextPutChunkSeparator.
+
+ "Created: 2.4.1997 / 17:33:42 / stefan"
+!
+
+writingChangeDo:aBlock
+ "{ Pragma: +optSpace }"
+
+ "common helper to write a change record.
+ Opens the changefile and executes aBlock passing the stream
+ as argument. WriteErrors are cought and will lead to a warning.
+ The changefile is not kept open, to force the change to go to disk
+ as soon as possible - thus, in case of a crash, no changes should
+ be lost due to buffering."
+
+ self writingChangeWithTimeStamp:true do:aBlock
+
+ "Modified: 18.11.1995 / 15:43:36 / cg"
+ "Created: 2.4.1997 / 17:32:57 / stefan"
+!
+
+writingChangePerform:aSelector with:anArgument
+ "{ Pragma: +optSpace }"
+
+ self writingChangeWithTimeStamp:true perform:aSelector with:anArgument
+
+ "Modified: 18.11.1995 / 15:44:53 / cg"
+ "Created: 2.4.1997 / 17:33:03 / stefan"
!
-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.
- "
+writingChangeWithTimeStamp:doStampIt do:aBlock
+ "{ Pragma: +optSpace }"
+
+ "common helper to write a change record.
+ Opens the changefile and executes aBlock passing the stream
+ as argument. WriteErrors are cought and will lead to a warning.
+ The changefile is not kept open, to force the change to go to disk
+ as soon as possible - thus, in case of a crash, no changes should
+ be lost due to buffering.
+ Access to the change file is serialized via the accessLock;
+ this prevents the changefile to be corrupted when multiple users
+ accept in the browser in a multi-display (or timesliced) configuration"
+
+ ChangeFileAccessLock critical:[
+ |aStream|
+
+ FileOutNameSpaceQuerySignal answer:true
+ do:[
+ aStream := self changesStream.
+ aStream notNil ifTrue:[
+ [
+ FileStream writeErrorSignal handle:[:ex |
+ self warn:('could not update the changes-file\\' , ex errorString) withCRs.
+ ex return
+ ] do:[
+ doStampIt ifTrue:[
+ self addChangeTimeStampTo:aStream
+ ].
+ aBlock value:aStream.
+ aStream cr.
+ ].
+ ] valueNowOrOnUnwindDo:[
+ aStream close
+ ]
+ ]
+ ]
+ ]
+
+ "Modified: 22.3.1997 / 17:12:40 / cg"
+ "Created: 2.4.1997 / 17:33:09 / stefan"
+!
+
+writingChangeWithTimeStamp:stampIt perform:aSelector with:anArgument
+ "{ Pragma: +optSpace }"
+
+ self writingChangeWithTimeStamp:stampIt do:[:stream |
+ self perform:aSelector with:anArgument with:stream.
+ ]
+
+ "Created: 2.4.1997 / 17:33:16 / stefan"
+! !
+
+!ClassDescription methodsFor:'private helpers'!
+
+addAllCategoriesTo:aCollection
+ "helper - add categories and all superclasses categories
+ to the argument, aCollection"
+
+ (superclass notNil) ifTrue:[
+ superclass addAllCategoriesTo:aCollection
+ ].
+ self addCategoriesTo:aCollection
+
+ "Created: 1.4.1997 / 23:52:27 / stefan"
!
-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
+addCategoriesTo:aCollection
+ "helper - add categories to the argument, aCollection"
+
+ self methodDictionary do:[:aMethod |
+ |cat|
+
+ cat := aMethod category.
+ (aCollection includes:cat) ifFalse:[
+ aCollection add:cat
+ ]
+ ]
+
+ "Modified: 12.6.1996 / 11:46:24 / stefan"
+ "Created: 1.4.1997 / 23:52:38 / stefan"
+! !
+
+!ClassDescription methodsFor:'protocol printOut'!
+
+printOutCategoryProtocol:aCategory on:aPrintStream
+ "{ Pragma: +optSpace }"
+
+ |dict any|
+
+ dict := self methodDictionary.
+ dict notNil ifTrue:[
+ any := false.
+ dict do:[:aMethod |
+ (aCategory = aMethod category) ifTrue:[
+ any := true
+ ]
+ ].
+ any ifTrue:[
+ aPrintStream italic.
+ aPrintStream nextPutAll:aCategory.
+ aPrintStream normal.
+ aPrintStream cr; cr.
+ dict do:[:aMethod |
+ (aCategory = aMethod category) ifTrue:[
+ self printOutMethodProtocol:aMethod on:aPrintStream.
+ aPrintStream cr; cr
+ ]
+ ].
+ aPrintStream cr
+ ]
+ ]
+
+ "Modified: 20.4.1996 / 18:20:26 / cg"
+ "Modified: 12.6.1996 / 11:48:46 / stefan"
+ "Created: 2.4.1997 / 01:10:40 / stefan"
+!
+
+printOutMethodProtocol:aMethod on:aPrintStream
+ "{ Pragma: +optSpace }"
+
+ "given the source in aString, print the methods message specification
+ and any method comments - without source; used to generate documentation
+ pages"
+
+ |text comment|
+
+ text := aMethod source asStringCollection.
+ (text size < 1) ifTrue:[^self].
+ aPrintStream bold.
+ aPrintStream nextPutLine:(text at:1).
+ (text size >= 2) ifTrue:[
+ (comment := aMethod comment) notNil ifTrue:[
+ aPrintStream italic.
+ aPrintStream spaces:((text at:2) indexOfNonSeparatorStartingAt:1).
+ aPrintStream nextPutLine:aMethod comment.
+ ]
+ ].
+ aPrintStream normal
"
- Class instSizeFromSignature:Point signature.
- Class instSizeFromSignature:Association signature.
- Class instSizeFromSignature:Dictionary signature.
+ Float printOutProtocolOn:Stdout
"
-!
-
-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)
+
+ "Modified: 9.11.1996 / 00:13:54 / cg"
+ "Created: 2.4.1997 / 01:11:00 / stefan"
+! !
+
+!ClassDescription methodsFor:'queries'!
+
+allCategories
+ "Return a collection of all method-categories known in class
+ and all superclasses. This does NOT include the metaclass categories.
+ The returned collection is not sorted by any order."
+
+ |coll|
+
+ coll := OrderedCollection new.
+ self addAllCategoriesTo:coll.
+ ^ coll
"
- Class instTypeFromSignature:Object signature.
- Class instTypeFromSignature:Array signature.
- Class instTypeFromSignature:String signature.
- Class instTypeFromSignature:OrderedCollection signature.
+ Point categories
+ Point allCategories
+
+ Point class categories
+ Point class allCategories
"
+
+ "Modified: 21.3.1996 / 16:28:57 / cg"
+ "Created: 1.4.1997 / 15:57:41 / stefan"
!
-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.
+categories
+ "Return a collection of all method-categories known in the receiver class.
+ This does NOT include the metaclasses categories or the superclass categories.
+ The returned collection is not sorted by any order."
+
+ |newList cat|
+
+ newList := OrderedCollection new.
+ self methodDictionary do:[:aMethod |
+ cat := aMethod category.
+ newList indexOf:cat ifAbsent:[newList add:cat]
].
- value := value + (nameKey bitShift:14).
- signature := value.
- ^ value
+ ^ newList
"
- Array signature
- ByteArray signature
- View signature
+ Point categories
+ Point class categories
"
+
+ "Modified: 16.4.1996 / 18:06:11 / cg"
+ "Modified: 12.6.1996 / 11:25:59 / stefan"
+ "Created: 1.4.1997 / 15:57:18 / stefan"
+!
+
+whichClassDefinesInstVar:aVariableName
+ "return the class which defines the instance variable
+ named aVariableName. This method should not be used for
+ repeated searches (i.e. in the compiler/parser), since it creates
+ many throw away intermediate objects."
+
+ |cls|
+
+ cls := self.
+ [cls notNil] whileTrue:[
+ (cls instVarNames includes:aVariableName) ifTrue:[ ^ cls].
+ cls := cls superclass
+ ].
+ ^ nil
+
+ "
+ StandardSystemView whichClassDefinesInstVar:'label'
+ StandardSystemView whichClassDefinesInstVar:'paint'
+ StandardSystemView whichClassDefinesInstVar:'foo'
+ "
+
+ "Created: 2.4.1997 / 01:12:27 / stefan"
! !
!ClassDescription methodsFor:'special accessing'!
@@ -435,14 +1721,6 @@
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'!
@@ -1106,5 +2384,6 @@
!ClassDescription class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.44 1997-04-07 17:33:25 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ClassDescr.st,v 1.45 1997-05-27 08:35:58 stefan Exp $'
! !
+ClassDescription initialize!