--- a/Autoload.st Thu Nov 23 03:13:03 1995 +0100
+++ b/Autoload.st Thu Nov 23 11:46:35 1995 +0100
@@ -10,11 +10,11 @@
hereby transferred.
"
-Object subclass:#Autoload
- instanceVariableNames:''
- classVariableNames:'LazyLoading AutoloadFailedSignal LoadedClasses'
- poolDictionaries:''
- category:'Kernel-Classes'
+nil subclass:#Autoload
+ instanceVariableNames:''
+ classVariableNames:'LazyLoading AutoloadFailedSignal LoadedClasses'
+ poolDictionaries:''
+ category:'Kernel-Classes'
!
!Autoload class methodsFor:'documentation'!
@@ -31,10 +31,6 @@
other person. No title to or ownership of the software is
hereby transferred.
"
-!
-
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.29 1995-11-11 14:26:46 cg Exp $'
!
documentation
@@ -60,6 +56,10 @@
AutoloadFailedSignal <Signal> signal raised if an autoloaded
classes source is not available.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Autoload.st,v 1.30 1995-11-23 10:44:41 cg Exp $'
! !
!Autoload class methodsFor:'initialization'!
@@ -83,51 +83,8 @@
^ AutoloadFailedSignal
! !
-!Autoload class methodsFor:'queries'!
-
-isBehavior
- "return true if the recevier is some kind of class.
- Autoloaded classes are definitely; therefore return true."
-
- ^ true
-!
-
-isLoaded
- "return true, if the class has been loaded; redefined in Autoload;
- see comment there. this allows testing for a class been already loaded."
-
- ^ (self == Autoload)
-!
-
-wasAutoloaded:aClass
- ^ LoadedClasses notNil and:[LoadedClasses includes:aClass]
-! !
-
-!Autoload class methodsFor:'lazy compilation'!
-
-compileLazy
- "return the lazy loading flag - if on, fileIn is much faster,
- but pauses are to be expected later, since methods are compiled
- when first executed."
-
- ^ LazyLoading
-!
-
-compileLazy:aBoolean
- "turn on/off lazy loading - if on, fileIn is much faster,
- but pauses are to be expected later, since methods are compiled
- when first executed.
- If you like it, add a line to your startup file."
-
- LazyLoading := aBoolean
-! !
-
!Autoload class methodsFor:'adding/removing autoloaded classes'!
-removeClass:aClass
- LoadedClasses remove:aClass ifAbsent:[]
-!
-
addClass:aClassName
self addClass:aClassName inCategory:'autoloaded-Classes'
@@ -150,6 +107,87 @@
"
Autoload addClass:'Clock' inCategory:'autoloaded-Demos'
"
+!
+
+removeClass:aClass
+ LoadedClasses remove:aClass ifAbsent:[]
+! !
+
+!Autoload class methodsFor:'fileout'!
+
+fileOutDefinitionOn:aStream
+ "print an expression to define myself on aStream.
+ Since autoloaded classes dont know their real definition, simply
+ output some comment string making things clear in the browser."
+
+ |myName fileName nm|
+
+ (self == Autoload) ifTrue:[^ super fileOutDefinitionOn:aStream].
+
+ myName := self name.
+ aStream nextPutAll:'"' ; nextPutAll:'Notice from Autoload:'; cr; cr;
+ spaces:4; nextPutAll:myName , ' is not yet loaded.'; cr; cr.
+ aStream nextPutAll:'to load, execute: '.
+ aStream cr; cr; spaces:4; nextPutAll:myName , ' autoload'; cr.
+
+ "
+ the following is simply informative ...
+ actually, its a hack & kludge - there ought to be a method for this
+ in Smalltalk
+ (knowing the details of loading here is no good coding style)
+ "
+ fileName := Smalltalk fileNameForClass:myName.
+ (ObjectFileLoader notNil and:[Smalltalk loadBinaries]) ifTrue:[
+ (nm := Smalltalk libraryFileNameOfClass:myName) notNil ifTrue:[
+ nm := nm , ' (a classLibrary, possibly including more classes)'
+ ] ifFalse:[
+ nm := Smalltalk getBinaryFileName:(fileName , '.so').
+ nm isNil ifTrue:[
+ nm := Smalltalk getBinaryFileName:(fileName , '.o')
+ ].
+ nm notNil ifTrue:[
+ nm := nm , ' (a classBinary)'
+ ]
+ ].
+ ].
+ nm isNil ifTrue:[
+ nm := Smalltalk getFileInFileName:(fileName , '.st').
+ nm isNil ifTrue:[
+ nm := Smalltalk getSourceFileName:(fileName , '.st').
+ ].
+ ].
+ nm notNil ifTrue:[
+ aStream cr; nextPutAll:'When accessed, ' , myName , ' will automatically be loaded'; cr.
+ aStream nextPutAll:'from: '; cr; spaces:4; nextPutAll:nm.
+ nm asFilename isSymbolicLink ifTrue:[
+ aStream cr; cr.
+ aStream nextPutAll:'which is a link to: '; cr; spaces:4;
+ nextPutAll:(nm asFilename linkInfo at:#path).
+ ]
+ ] ifFalse:[
+ aStream cr; nextPutAll:'there is currently no file to load ' , myName , ' from.'.
+ aStream cr; nextPutAll:'When accessed, an error will be reported.'.
+ ].
+ aStream cr; nextPutAll:'"'.
+! !
+
+!Autoload class methodsFor:'lazy compilation'!
+
+compileLazy
+ "return the lazy loading flag - if on, fileIn is much faster,
+ but pauses are to be expected later, since methods are compiled
+ when first executed."
+
+ ^ LazyLoading
+!
+
+compileLazy:aBoolean
+ "turn on/off lazy loading - if on, fileIn is much faster,
+ but pauses are to be expected later, since methods are compiled
+ when first executed.
+ If you like it, add a line to your startup file."
+
+ LazyLoading := aBoolean
! !
!Autoload class methodsFor:'loading'!
@@ -214,6 +252,26 @@
!Autoload class methodsFor:'message catching'!
+basicNew
+ "catch basicNew"
+
+ ^ self doesNotUnderstand:(Message selector:#basicNew)
+!
+
+basicNew:arg
+ "catch basicNew:"
+
+ ^ self doesNotUnderstand:(Message selector:#basicNew: with:arg)
+!
+
+comment
+ "return the classes comment.
+ Autoloaded classes have no comment; but I myself have one"
+
+ (self == Autoload) ifTrue:[^ super comment].
+ ^ 'not yet loaded'
+!
+
doesNotUnderstand:aMessage
"cought a message; load class and retry"
@@ -235,24 +293,12 @@
^ self doesNotUnderstand:(Message selector:#new)
!
-basicNew
- "catch basicNew"
-
- ^ self doesNotUnderstand:(Message selector:#basicNew)
-!
-
new:arg
"catch new:"
^ self doesNotUnderstand:(Message selector:#new: with:arg)
!
-basicNew:arg
- "catch basicNew:"
-
- ^ self doesNotUnderstand:(Message selector:#basicNew: with:arg)
-!
-
subclass:a1 instanceVariableNames:a2 classVariableNames:a3 poolDictionaries:a4 category:a5
"catch subclass creation - this forces missing superclasses to be
loaded first"
@@ -275,70 +321,26 @@
^ newClass perform:sel withArguments:args
].
^ nil
-!
-
-comment
- "return the classes comment.
- Autoloaded classes have no comment; but I myself have one"
-
- (self == Autoload) ifTrue:[^ super comment].
- ^ 'not yet loaded'
! !
-!Autoload class methodsFor:'fileout'!
-
-fileOutDefinitionOn:aStream
- "print an expression to define myself on aStream.
- Since autoloaded classes dont know their real definition, simply
- output some comment string making things clear in the browser."
+!Autoload class methodsFor:'queries'!
- |myName fileName nm|
-
- (self == Autoload) ifTrue:[^ super fileOutDefinitionOn:aStream].
+isBehavior
+ "return true if the recevier is some kind of class.
+ Autoloaded classes are definitely; therefore return true."
- myName := self name.
- aStream nextPutAll:'"' ; nextPutAll:'Notice from Autoload:'; cr; cr;
- spaces:4; nextPutAll:myName , ' is not yet loaded.'; cr; cr.
- aStream nextPutAll:'to load, execute: '.
- aStream cr; cr; spaces:4; nextPutAll:myName , ' autoload'; cr.
+ ^ true
+!
- "
- the following is simply informative ...
- actually, its a hack & kludge - there ought to be a method for this
- in Smalltalk
- (knowing the details of loading here is no good coding style)
- "
- fileName := Smalltalk fileNameForClass:myName.
- (ObjectFileLoader notNil and:[Smalltalk loadBinaries]) ifTrue:[
- (nm := Smalltalk libraryFileNameOfClass:myName) notNil ifTrue:[
- nm := nm , ' (a classLibrary, possibly including more classes)'
- ] ifFalse:[
- nm := Smalltalk getBinaryFileName:(fileName , '.so').
- nm isNil ifTrue:[
- nm := Smalltalk getBinaryFileName:(fileName , '.o')
- ].
- nm notNil ifTrue:[
- nm := nm , ' (a classBinary)'
- ]
- ].
- ].
- nm isNil ifTrue:[
- nm := Smalltalk getFileInFileName:(fileName , '.st').
- nm isNil ifTrue:[
- nm := Smalltalk getSourceFileName:(fileName , '.st').
- ].
- ].
- nm notNil ifTrue:[
- aStream cr; nextPutAll:'When accessed, ' , myName , ' will automatically be loaded'; cr.
- aStream nextPutAll:'from: '; cr; spaces:4; nextPutAll:nm.
- nm asFilename isSymbolicLink ifTrue:[
- aStream cr; cr.
- aStream nextPutAll:'which is a link to: '; cr; spaces:4;
- nextPutAll:(nm asFilename linkInfo at:#path).
- ]
- ] ifFalse:[
- aStream cr; nextPutAll:'there is currently no file to load ' , myName , ' from.'.
- aStream cr; nextPutAll:'When accessed, an error will be reported.'.
- ].
- aStream cr; nextPutAll:'"'.
+isLoaded
+ "return true, if the class has been loaded; redefined in Autoload;
+ see comment there. this allows testing for a class been already loaded."
+
+ ^ (self == Autoload)
+!
+
+wasAutoloaded:aClass
+ ^ LoadedClasses notNil and:[LoadedClasses includes:aClass]
! !
+
+Autoload initialize!
--- a/Behavior.st Thu Nov 23 03:13:03 1995 +0100
+++ b/Behavior.st Thu Nov 23 11:46:35 1995 +0100
@@ -11,11 +11,11 @@
"
Object subclass:#Behavior
- instanceVariableNames:'superclass flags selectorArray methodArray
- otherSuperclasses instSize'
- classVariableNames:'SubclassInfo'
- poolDictionaries:''
- category:'Kernel-Classes'
+ instanceVariableNames:'superclass flags selectorArray methodArray otherSuperclasses
+ instSize'
+ classVariableNames:'SubclassInfo'
+ poolDictionaries:''
+ category:'Kernel-Classes'
!
!Behavior class methodsFor:'documentation'!
@@ -34,10 +34,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.52 1995-11-11 14:26:59 cg Exp $'
-!
-
documentation
"
Every class in the system inherits from Behavior (via Class, ClassDescription);
@@ -90,6 +86,10 @@
"
!
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Behavior.st,v 1.53 1995-11-23 10:45:04 cg Exp $'
+!
+
virtualMachineRelationship
"
NOTICE:
@@ -256,14 +256,6 @@
"
! !
-!Behavior class methodsFor:'queries'!
-
-isBuiltInClass
- "this class is known by the run-time-system"
-
- ^ true
-! !
-
!Behavior class methodsFor:'creating new classes'!
new
@@ -299,8 +291,263 @@
"
! !
+!Behavior class methodsFor:'flag bit constants'!
+
+flagBehavior
+ "return the flag code which marks Behavior-like instances.
+ You have to check this single bit in the flag value when
+ checking for behaviors."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(BEHAVIOR_INSTS) );
+%}
+
+ "consistency check:
+ all class-entries must be behaviors;
+ all behaviors must be flagged so (in its class's flags)
+ (otherwise, VM will bark)
+ all non-behaviors may not be flagged
+
+ |bit|
+ bit := Class flagBehavior.
+
+ ObjectMemory allObjectsDo:[:o|
+ o isBehavior ifTrue:[
+ (o class flags bitTest:bit) ifFalse:[
+ self halt
+ ].
+ ] ifFalse:[
+ (o class flags bitTest:bit) ifTrue:[
+ self halt
+ ].
+ ].
+ o class isBehavior ifFalse:[
+ self halt
+ ] ifTrue:[
+ (o class class flags bitTest:bit) ifFalse:[
+ self halt
+ ]
+ ]
+ ]
+ "
+!
+
+flagBlock
+ "return the flag code which marks Block-like instances.
+ You have to check this single bit in the flag value when
+ checking for blocks."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(BLOCK_INSTS) );
+%}
+!
+
+flagBlockContext
+ "return the flag code which marks BlockContext-like instances.
+ You have to check this single bit in the flag value when
+ checking for blockContexts."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(BCONTEXT_INSTS) );
+%}
+!
+
+flagBytes
+ "return the flag code for byte-valued indexed instances.
+ You have to mask the flag value with indexMask when comparing
+ it with flagBytes."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(BYTEARRAY) );
+%}
+ "
+ Behavior flagBytes
+ "
+!
+
+flagContext
+ "return the flag code which marks Context-like instances.
+ You have to check this single bit in the flag value when
+ checking for contexts."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(CONTEXT_INSTS) );
+%}
+!
+
+flagDoubles
+ "return the flag code for double-valued indexed instances (i.e. 8-byte reals).
+ You have to mask the flag value with indexMask when comparing
+ it with flagDoubles."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(DOUBLEARRAY) );
+%}
+ "
+ Behavior flagDoubles
+ "
+!
+
+flagFloat
+ "return the flag code which marks Float-like instances.
+ You have to check this single bit in the flag value when
+ checking for floats."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(FLOAT_INSTS) );
+%}
+!
+
+flagFloats
+ "return the flag code for float-valued indexed instances (i.e. 4-byte reals).
+ You have to mask the flag value with indexMask when comparing
+ it with flagFloats."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(FLOATARRAY) );
+%}
+ "
+ Behavior flagFloats
+ "
+!
+
+flagLongs
+ "return the flag code for long-valued indexed instances (i.e. 4-byte).
+ You have to mask the flag value with indexMask when comparing
+ it with flagLongs."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(LONGARRAY) );
+%}
+ "
+ Behavior flagLongs
+ "
+!
+
+flagMethod
+ "return the flag code which marks Method-like instances.
+ You have to check this single bit in the flag value when
+ checking for methods."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(METHOD_INSTS) );
+%}
+!
+
+flagNonObjectInst
+ "return the flag code which marks instances which have a
+ non-object instance variable (in slot 1).
+ (these are ignored by the garbage collector)"
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(NONOBJECT_INSTS) );
+%}
+!
+
+flagNotIndexed
+ "return the flag code for non-indexed instances.
+ You have to mask the flag value with indexMask when comparing
+ it with flagNotIndexed."
+
+ ^ 0
+!
+
+flagPointers
+ "return the flag code for pointer indexed instances (i.e. Array of object).
+ You have to mask the flag value with indexMask when comparing
+ it with flagPointers."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(POINTERARRAY) );
+%}
+ "
+ Behavior flagPointers
+ "
+!
+
+flagSymbol
+ "return the flag code which marks Symbol-like instances.
+ You have to check this single bit in the flag value when
+ checking for symbols."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(SYMBOL_INSTS) );
+%}
+!
+
+flagWeakPointers
+ "return the flag code for weak pointer indexed instances (i.e. WeakArray).
+ You have to mask the flag value with indexMask when comparing
+ it with flagWeakPointers."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(WKPOINTERARRAY) );
+%}
+!
+
+flagWords
+ "return the flag code for word-valued indexed instances (i.e. 2-byte).
+ You have to mask the flag value with indexMask when comparing
+ it with flagWords."
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(WORDARRAY) );
+%}
+ "
+ Behavior flagWords
+ "
+!
+
+maskIndexType
+ "return a mask to extract all index-type bits"
+
+%{ /* NOCONTEXT */
+ /* this is defined as a primitive to get defines from stc.h */
+
+ RETURN ( _MKSMALLINT(ARRAYMASK) );
+%}
+! !
+
!Behavior class methodsFor:'private '!
+flushSubclassInfo
+ SubclassInfo := nil.
+
+ "
+ Class flushSubclassInfo
+ "
+!
+
subclassInfo
|d|
@@ -327,18 +574,722 @@
"
Class subclassInfo
"
+! !
+
+!Behavior class methodsFor:'queries'!
+
+isBuiltInClass
+ "this class is known by the run-time-system"
+
+ ^ true
+! !
+
+!Behavior methodsFor:'accessing'!
+
+addSelector:newSelector withLazyMethod:newMethod
+ "add the method given by 2nd argument under the selector given by
+ 1st argument to the methodDictionary. Since it does not flush
+ any caches, this is only allowed for lazy methods."
+
+ newMethod isLazyMethod ifFalse:[
+ self error:'operation only allowed for lazy methods'.
+ ^ false
+ ].
+ "/ oops: we must flush, if this method already exists ...
+ (selectorArray includes:newSelector) ifTrue:[
+ ObjectMemory flushCaches
+ ].
+ (self primAddSelector:newSelector withMethod:newMethod) ifTrue:[
+ self changed:#methodDictionary with:newSelector.
+ ^ true
+ ].
+ ^ false
!
-flushSubclassInfo
+addSelector:newSelector withMethod:newMethod
+ "add the method given by 2nd argument under the selector given by
+ 1st argument to the methodDictionary. Flush all caches."
+
+ |nargs|
+
+ (self primAddSelector:newSelector withMethod:newMethod) ifFalse:[^ false].
+ self changed:#methodDictionary with:newSelector.
+
+ "
+ if I have no subclasses, all we have to flush is cached
+ data for myself ... (actually, in any case all that needs
+ to be flushed is info for myself and all of my subclasses)
+ "
+"
+ problem: this is slower; since looking for all subclasses is (currently)
+ a bit slow :-(
+ We need the hasSubclasses-info bit in Behavior; now
+
+ self withAllSubclassesDo:[:aClass |
+ ObjectMemory flushInlineCachesFor:aClass withArgs:nargs.
+ ObjectMemory flushMethodCacheFor:aClass
+ ].
+"
+
+ "
+ actually, we would do better with less flushing ...
+ "
+ nargs := newSelector numArgs.
+
+ ObjectMemory flushMethodCache.
+ ObjectMemory flushInlineCachesWithArgs:nargs.
+
+ ^ true
+!
+
+addSuperclass:aClass
+ "EXPERIMENTAL MI support: add aClass to the set of classes, from which instances
+ inherit protocol."
+
+ "first, check if the class is abstract -
+ allows abstract mixins are allowed in the current implementation"
+
+ aClass instSize == 0 ifFalse:[
+ self error:'only abstract mixins allowed'.
+ ^ self
+ ].
+ otherSuperclasses isNil ifTrue:[
+ otherSuperclasses := Array with:aClass
+ ] ifFalse:[
+ otherSuperclasses := otherSuperclasses copyWith:aClass
+ ].
SubclassInfo := nil.
+ ObjectMemory flushCaches
+!
+
+category
+ "return the category of the class.
+ Returning nil here, since Behavior does not define a category
+ (only ClassDescriptions do)."
+
+ ^ nil
+
+ "
+ Point category
+ Behavior new category
+ "
+!
+
+displayString
+ "although behaviors have no name, we return something
+ useful here - there are many places (inspectors) where
+ a classes name is asked for.
+ Implementing this message here allows instances of anonymous classes
+ to show a reasonable name."
+
+ ^ 'someBehavior'
+!
+
+flags
+ "return the receivers flag bits"
+
+ ^ flags
+!
+
+implicit_methodDict
+ "ST-80 compatibility.
+ This allows subclasses to assume there is an instance variable
+ named methodDict."
+
+ ^ self methodDictionary
+!
+
+implicit_methodDict:aDictionary
+ "ST-80 compatibility.
+ This allows subclasses to assume there is an instance variable
+ named methodDict."
+
+ ^ self error:'not allowed to set the methodDictionary'
+!
+
+instSize
+ "return the number of instance variables of the receiver.
+ This includes all superclass instance variables."
+
+ ^ instSize
+!
+
+methodArray
+ "return the receivers method array.
+ Notice: this is not compatible with ST-80."
+
+ ^ methodArray
+!
+
+methodDictionary
+ "return the receivers method dictionary.
+ Since no dictionary is actually present, create one for ST-80 compatibility."
+
+ |dict n "{ Class: SmallInteger }"|
+
+ dict := IdentityDictionary new.
+ n := selectorArray size.
+ 1 to:n do:[:index |
+ dict at:(selectorArray at:index) put:(methodArray at:index)
+ ].
+ ^ dict
+!
+
+name
+ "although behaviors have no name, we return something
+ useful here - there are many places (inspectors) where
+ a classes name is asked for.
+ Implementing this message here allows anonymous classes
+ and instances of them to be inspected."
+
+ ^ 'someBehavior'
+!
+
+removeSelector:aSelector
+ "remove the selector, aSelector and its associated method
+ from the methodDictionary"
+
+ |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
+
+ index := selectorArray identityIndexOf:aSelector startingAt:1.
+ (index == 0) ifTrue:[^ false].
+
+ newSelectorArray := selectorArray copyWithoutIndex:index.
+ newMethodArray := methodArray copyWithoutIndex:index.
+ oldSelectorArray := selectorArray.
+ oldMethodArray := methodArray.
+ selectorArray := newSelectorArray.
+ methodArray := newMethodArray.
+"
+ [
+ |nargs|
+ nargs := aSelector numArgs.
+ ObjectMemory flushMethodCache.
+ ObjectMemory flushInlineCachesWithArgs:nargs.
+ ] value
+"
+ "
+ actually, we would do better with less flushing ...
+ "
+ ObjectMemory flushCaches.
+ ^ true
+!
+
+removeSuperclass:aClass
+ "EXPERIMENTAL MI support: remove aClass from the set of classes, from which instances
+ inherit protocol."
+
+ otherSuperclasses notNil ifTrue:[
+ otherSuperclasses := otherSuperclasses copyWithout:aClass.
+ otherSuperclasses isEmpty ifTrue:[
+ otherSuperclasses := nil
+ ].
+ SubclassInfo := nil.
+ ObjectMemory flushCaches
+ ].
+!
+
+selectorArray
+ "return the receivers selector array.
+ Notice: this is not compatible with ST-80."
+
+ ^ selectorArray
+!
+
+selectors
+ "return the receivers selector array as an orderedCollection.
+ Notice: this may not be compatible with ST-80.
+ (should we return a Set ?)"
+
+ ^ selectorArray asOrderedCollection
+!
+
+selectors:newSelectors methods:newMethods
+ "set both selector array and method array of the receiver,
+ and flush caches"
+
+ ObjectMemory flushCaches.
+ selectorArray := newSelectors.
+ methodArray := newMethods
+!
+
+superclass
+ "return the receivers superclass"
+
+ ^ superclass
+!
+
+superclass:aClass
+ "set the superclass - this actually creates a new class,
+ recompiling all methods for the new one. The receiving class stays
+ around anonymous to allow existing instances some life.
+ This may change in the future (adjusting existing instances)"
+
+ SubclassInfo := nil.
+
+ "must flush caches since lookup chain changes"
+ ObjectMemory flushCaches.
+
+"
+ superclass := aClass
+"
+ "for correct recompilation, just create a new class ..."
+
+ aClass subclass:(self name)
+ instanceVariableNames:(self instanceVariableString)
+ classVariableNames:(self classVariableString)
+ poolDictionaries:''
+ category:self category
+! !
+
+!Behavior methodsFor:'autoload check'!
+
+autoload
+ "force autoloading - do nothing here;
+ redefined in Autoload; see comment there"
+
+ ^ self
+!
+
+isLoaded
+ "return true, if the class has been loaded;
+ redefined in Autoload; see comment there"
+
+ ^ true
+! !
+
+!Behavior methodsFor:'binary storage'!
+
+binaryDefinitionFrom:stream manager:manager
+ "sent during a binary read by the input manager.
+ Read the definition on an empty instance (of my class) from stream.
+ All pointer instances are left nil, while all bits are read in here.
+ return the new object."
+
+ |obj t
+ basicSize "{ Class: SmallInteger }" |
+
+ self isPointers ifTrue: [
+ "/
+ "/ inst size not needed - if you uncomment the line below,
+ "/ also uncomment the corresponding line in
+ "/ Object>>storeBinaryDefinitionOn:manager:
+ "/
+ "/ stream next. "skip instSize"
+ self isVariable ifTrue: [
+ ^ self basicNew:(stream nextNumber:3)
+ ].
+ ^ self basicNew
+ ].
"
- Class flushSubclassInfo
+ an object with bit-valued instance variables.
+ These are read here.
+ "
+ basicSize := stream nextNumber:4.
+ obj := self basicNew:basicSize.
+
+ self isBytes ifTrue: [
+ stream nextBytes:basicSize into:obj
+ ] ifFalse: [
+ self isWords ifTrue: [
+ 1 to:basicSize do:[:i |
+ obj basicAt:i put:(stream nextNumber:2)
+ ]
+ ] ifFalse:[
+ self isLongs ifTrue: [
+ 1 to:basicSize do:[:i |
+ obj basicAt:i put:(stream nextNumber:4)
+ ]
+ ] ifFalse:[
+ self isFloats ifTrue: [
+ "could do it in one big read on machines which use IEEE floats ..."
+ t := Float basicNew.
+ 1 to:basicSize do:[:i |
+ Float readBinaryIEEESingleFrom:stream into:t.
+ obj basicAt:i put: t
+ ]
+ ] ifFalse:[
+ self isDoubles ifTrue: [
+ "could do it in one big read on machines which use IEEE doubles ..."
+ t := Float basicNew.
+ 1 to:basicSize do:[:i |
+ Float readBinaryIEEEDoubleFrom:stream into:t.
+ obj basicAt:i put: t
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^obj
+!
+
+canCloneFrom:anObject
+ "return true, if this class can clone an obsolete object as retrieved
+ by a binary load. Subclasses which do not want to have obsolete objects
+ be converted, should redefine this method to return false.
+ (However, conversion is never done silently in a binary load; you
+ have to have a handler for the binaryload errors and for the conversion
+ request signal.)"
+
+ ^ true
+!
+
+cloneFrom:aPrototype
+ "return an instance of myself with variables initialized from
+ a prototype. This is used when instances of obsolete classes are
+ binary loaded and a conversion is done on the obsolete object.
+ UserClasses may redefine this for better conversions."
+
+ |newInst indexed myInfo otherInfo varIndexAssoc|
+
+ indexed := false.
+ aPrototype class isVariable ifTrue:[
+ self isVariable ifTrue:[
+ indexed := true.
+ ].
+ "otherwise, these are lost ..."
+ ].
+ indexed ifTrue:[
+ newInst := self basicNew:aPrototype basicSize
+ ] ifFalse:[
+ newInst := self basicNew
+ ].
+
+ myInfo := self instanceVariableOffsets.
+ otherInfo := aPrototype class instanceVariableOffsets.
+ myInfo keysAndValuesDo:[:name :index |
+ varIndexAssoc := otherInfo at:name ifAbsent:[].
+ varIndexAssoc notNil ifTrue:[
+ newInst instVarAt:index put:(aPrototype instVarAt:(varIndexAssoc value))
+ ]
+ ].
+ indexed ifTrue:[
+ 1 to:aPrototype basicSize do:[:index |
+ newInst basicAt:index put:(aPrototype basicAt:index)
+ ].
+ ].
+ ^ newInst
+
+ "
+ Class withoutUpdatingChangesDo:[
+ Point subclass:#Point3D
+ instanceVariableNames:'z'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'testing'.
+ (Point3D cloneFrom:1@2) inspect.
+ ]
+ "
+
+ "
+ Class withoutUpdatingChangesDo:[
+ Point variableSubclass:#Point3D
+ instanceVariableNames:'z'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'testing'.
+ (Point3D cloneFrom:#(1 2 3)) inspect.
+ ]
+ "
+
+ "
+ |someObject|
+
+ Class withoutUpdatingChangesDo:[
+ Object subclass:#TestClass1
+ instanceVariableNames:'foo bar'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'testing'.
+ someObject := TestClass1 new.
+ someObject instVarAt:1 put:'foo'; instVarAt:2 put:'bar'.
+ Object subclass:#TestClass2
+ instanceVariableNames:'bar foo'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'testing'.
+ (TestClass2 cloneFrom:someObject) inspect.
+ ]
+ "
+!
+
+readBinaryFrom:aStream
+ "read an objects binary representation from the argument,
+ aStream and return it.
+ The read object must be a kind of myself, otherwise an error is raised.
+ To get any object, use 'Object readBinaryFrom:...',
+ To get any number, use 'Number readBinaryFrom:...' and so on.
+ This is the reverse operation to 'storeBinaryOn:'. "
+
+ ^ self readBinaryFrom:aStream onError:[self error:('expected ' , self name)]
+
+ "
+ |s|
+ s := WriteStream on:(ByteArray new).
+ #(1 2 3 4) storeBinaryOn:s.
+ Object readBinaryFrom:(ReadStream on:s contents)
+ "
+ "
+ |s|
+ s := 'testFile' asFilename writeStream binary.
+ #(1 2 3 4) storeBinaryOn:s.
+ 'hello world' storeBinaryOn:s.
+ s close.
+
+ s := 'testFile' asFilename readStream binary.
+ Transcript showCr:(Object readBinaryFrom:s).
+ Transcript showCr:(Object readBinaryFrom:s).
+ s close.
+ "
+!
+
+readBinaryFrom:aStream onError:exceptionBlock
+ "read an objects binary representation from the argument,
+ aStream and return it.
+ The read object must be a kind of myself, otherwise the value of
+ the exceptionBlock is returned.
+ To get any object, use 'Object readBinaryFrom:...',
+ To get any number, use 'Number readBinaryFrom:...' and so on.
+ This is the reverse operation to 'storeBinaryOn:'. "
+
+ |newObject|
+
+ newObject := (BinaryInputManager new:1024) readFrom:aStream.
+ (newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
+ ^ newObject
+
+ "
+ |s|
+ s := WriteStream on:(ByteArray new).
+ #(1 2 3 4) storeBinaryOn:s.
+ Object readBinaryFrom:(ReadStream on:s contents) onError:['oops']
+ "
+ "
+ |s|
+ s := WriteStream on:(ByteArray new).
+ #[1 2 3 4] storeBinaryOn:s.
+ Array readBinaryFrom:(ReadStream on:s contents) onError:['oops']
+ "
+!
+
+storeBinaryDefinitionOn: stream manager: manager
+ "binary store of a classes definition.
+ Classes will store the name only and restore by looking for
+ that name in the Smalltalk dictionary."
+
+ | myName |
+
+ myName := self name.
+ stream nextNumber:4 put:self signature.
+ stream nextNumber:2 put:0.
+ stream nextNumber:2 put:myName size.
+ myName do:[:c|
+ stream nextPut:c asciiValue
+ ]
+
+ "
+ |s|
+ s := WriteStream on:ByteArray new.
+ #(1 2 3 4) storeBinaryOn:s.
+ Object readBinaryFrom:(ReadStream on:s contents)
+
+ |s|
+ s := WriteStream on:ByteArray new.
+ Rectangle storeBinaryOn:s.
+ Object readBinaryFrom:(ReadStream on:s contents)
+ "
+! !
+
+!Behavior methodsFor:'compiler interface'!
+
+compiler
+ "return the compiler to use for this class.
+ OBSOLETE: This is the old ST/X interface, kept for migration.
+ Dont use it - it will vanish."
+
+ ^ self compilerClass
+!
+
+compilerClass
+ "return the compiler to use for this class -
+ this can be redefined in special classes, to get classes with
+ Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
+
+ ^ Compiler
+!
+
+evaluatorClass
+ "return the compiler to use for expression evaluation for this class -
+ this can be redefined in special classes, to get classes with
+ Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
+
+ ^ Compiler
+! !
+
+!Behavior methodsFor:'copying'!
+
+deepCopy
+ "return a deep copy of the receiver
+ - return the receiver here - time will show if this is ok"
+
+ ^ self
+!
+
+deepCopyUsing:aDictionary
+ "return a deep copy of the receiver
+ - return the receiver here - time will show if this is ok"
+
+ ^ self
+!
+
+simpleDeepCopy
+ "return a deep copy of the receiver
+ - return the receiver here - time will show if this is ok"
+
+ ^ self
+! !
+
+!Behavior methodsFor:'enumerating'!
+
+allDerivedInstancesDo:aBlock
+ "evaluate aBlock for all of my instances and all instances of subclasses.
+ This method is going to be removed for protocol compatibility with
+ other STs; use allSubInstancesDo:"
+
+ self obsoleteMethodWarning:'please use #allSubInstancesDo:'.
+ self allSubInstancesDo:aBlock
+
+ "
+ StandardSystemView allDerivedInstancesDo:[:v | Transcript showCr:(v name)]
+ "
+!
+
+allInstancesDo:aBlock
+ "evaluate aBlock for all of my instances"
+
+"/ ObjectMemory allObjectsDo:[:anObject |
+"/ (anObject class == self) ifTrue:[
+"/ aBlock value:anObject
+"/ ]
+"/ ]
+
+ ObjectMemory allInstancesOf:self do:[:anObject |
+ aBlock value:anObject
+ ]
+
+ "
+ StandardSystemView allInstancesDo:[:v | Transcript showCr:(v name)]
+ "
+!
+
+allSubInstancesDo:aBlock
+ "evaluate aBlock for all of my instances and all instances of subclasses"
+
+ ObjectMemory allObjectsDo:[:anObject |
+ (anObject isKindOf:self) ifTrue:[
+ aBlock value:anObject
+ ]
+ ]
+
+ "
+ StandardSystemView allSubInstancesDo:[:v | Transcript showCr:(v name)]
+ "
+!
+
+allSubclassesDo:aBlock
+ "evaluate aBlock for all of my subclasses.
+ There is no specific order, in which the entries are enumerated.
+ This will only enumerate globally known classes - for anonymous
+ behaviors, you have to walk over all instances of Behavior."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ (aClass isSubclassOf:self) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+
+ "
+ Collection allSubclassesDo:[:c | Transcript showCr:(c name)]
+ "
+!
+
+allSubclassesInOrderDo:aBlock
+ "evaluate aBlock for all of my subclasses.
+ Higher level subclasses will be enumerated before the deeper ones,
+ so the order in which aBlock gets called is ok to fileOut classes in
+ correct order for later fileIn.
+ This will only enumerate globally known classes - for anonymous
+ behaviors, you have to walk over all instances of Behavior"
+
+ self subclassesDo:[:aClass |
+ aBlock value:aClass.
+ aClass allSubclassesInOrderDo:aBlock
+ ]
+
+ "
+ Collection allSubclassesInOrderDo:[:c | Transcript showCr:(c name)]
+ "
+!
+
+allSuperclassesDo:aBlock
+ "evaluate aBlock for all of my superclasses"
+
+ |theClass|
+
+ theClass := superclass.
+ [theClass notNil] whileTrue:[
+ aBlock value:theClass.
+ theClass := theClass superclass
+ ]
+
+ "
+ String allSuperclassesDo:[:c | Transcript showCr:(c name)]
+ "
+!
+
+subclassesDo:aBlock
+ "evaluate the argument, aBlock for all immediate subclasses.
+ This will only enumerate globally known classes - for anonymous
+ behaviors, you have to walk over all instances of Behavior."
+
+ |coll|
+
+ SubclassInfo isNil ifTrue:[
+ Behavior subclassInfo
+ ].
+ SubclassInfo notNil ifTrue:[
+ coll := SubclassInfo at:self ifAbsent:nil.
+ coll notNil ifTrue:[
+ coll do:aBlock.
+ ].
+ ^ self
+ ].
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ (aClass superclass == self) ifTrue:[
+ aBlock value:aClass
+ ]
+ ]
+
+ "
+ Collection subclassesDo:[:c | Transcript showCr:(c name)]
"
! !
!Behavior methodsFor:'initialization'!
+deinitialize
+ "deinitialize is sent to a class before it is physically unloaded.
+ This is only done with classes which have been loaded in from a binary
+ file. Classes may release any primitive memory or other stuff which is
+ not visible to smalltalk (for example, release internal memory).
+ The default action here is to do nothing."
+
+ ^ self
+!
+
initialize
"initialize is sent to a class either during startup,
(for all statically compiled-in classes) or after a class
@@ -367,96 +1318,10 @@
The default action here is to do nothing."
^ self
-!
-
-deinitialize
- "deinitialize is sent to a class before it is physically unloaded.
- This is only done with classes which have been loaded in from a binary
- file. Classes may release any primitive memory or other stuff which is
- not visible to smalltalk (for example, release internal memory).
- The default action here is to do nothing."
-
- ^ self
-! !
-
-!Behavior methodsFor:'copying'!
-
-deepCopy
- "return a deep copy of the receiver
- - return the receiver here - time will show if this is ok"
-
- ^ self
-!
-
-deepCopyUsing:aDictionary
- "return a deep copy of the receiver
- - return the receiver here - time will show if this is ok"
-
- ^ self
-!
-
-simpleDeepCopy
- "return a deep copy of the receiver
- - return the receiver here - time will show if this is ok"
-
- ^ self
! !
!Behavior methodsFor:'instance creation'!
-uninitializedNew
- "create an instance of myself with uninitialized contents.
- For all classes except ByteArray, this is the same as #basicNew."
-
- ^ self basicNew
-!
-
-uninitializedNew:anInteger
- "create an instance of myself with uninitialized contents.
- For all classes except ByteArray, this is the same as #basicNew:."
-
- ^ self basicNew:anInteger
-!
-
-niceBasicNew:anInteger
- "same as basicNew:anInteger, but tries to avoid long pauses
- due to garbage collection. This method checks to see if
- allocation is possible without a pause, and does a background
- incremental garbage collect first if there is not enough memory
- available at the moment for fast allocation.
- This is useful in low-priority background processes which like to
- avoid disturbing any higher priority foreground process while allocating
- big amounts of memory. Of course, using this method only makes
- sense for big or huge objects (say > 200k).
-
- EXPERIMENTAL: this is a non-standard interface and should only
- be used for special applications. There is no guarantee, that this
- method will be available in future ST/X releases."
-
- |size|
-
- size := self sizeOfInst:anInteger.
- (ObjectMemory checkForFastNew:size) ifFalse:[
- "
- incrementally collect garbage
- "
- ObjectMemory incrementalGC.
- ].
- ^ self basicNew:anInteger
-!
-
-new
- "return an instance of myself without indexed variables"
-
- ^ self basicNew
-!
-
-new:anInteger
- "return an instance of myself with anInteger indexed variables"
-
- ^ self basicNew:anInteger
-!
-
basicNew
"return an instance of myself without indexed variables.
If the receiver-class has indexed instvars, the new object will have
@@ -1011,6 +1876,45 @@
^ ObjectMemory allocationFailureSignal raise.
!
+new
+ "return an instance of myself without indexed variables"
+
+ ^ self basicNew
+!
+
+new:anInteger
+ "return an instance of myself with anInteger indexed variables"
+
+ ^ self basicNew:anInteger
+!
+
+niceBasicNew:anInteger
+ "same as basicNew:anInteger, but tries to avoid long pauses
+ due to garbage collection. This method checks to see if
+ allocation is possible without a pause, and does a background
+ incremental garbage collect first if there is not enough memory
+ available at the moment for fast allocation.
+ This is useful in low-priority background processes which like to
+ avoid disturbing any higher priority foreground process while allocating
+ big amounts of memory. Of course, using this method only makes
+ sense for big or huge objects (say > 200k).
+
+ EXPERIMENTAL: this is a non-standard interface and should only
+ be used for special applications. There is no guarantee, that this
+ method will be available in future ST/X releases."
+
+ |size|
+
+ size := self sizeOfInst:anInteger.
+ (ObjectMemory checkForFastNew:size) ifFalse:[
+ "
+ incrementally collect garbage
+ "
+ ObjectMemory incrementalGC.
+ ].
+ ^ self basicNew:anInteger
+!
+
readFrom:aStream
"read an objects printed representation from the argument, aStream
and return it.
@@ -1107,543 +2011,734 @@
Point readFromString:'0'
Point readFromString:'0' onError:[0@0]
"
+!
+
+uninitializedNew
+ "create an instance of myself with uninitialized contents.
+ For all classes except ByteArray, this is the same as #basicNew."
+
+ ^ self basicNew
+!
+
+uninitializedNew:anInteger
+ "create an instance of myself with uninitialized contents.
+ For all classes except ByteArray, this is the same as #basicNew:."
+
+ ^ self basicNew:anInteger
! !
-!Behavior methodsFor:'autoload check'!
-
-isLoaded
- "return true, if the class has been loaded;
- redefined in Autoload; see comment there"
+!Behavior methodsFor:'private accessing'!
+
+flags:aNumber
+ "set the flags.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here;
+ Do NOT use it."
+
+ flags := aNumber
+!
+
+instSize:aNumber
+ "set the instance size.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here;
+ Do NOT use it."
+
+ instSize := aNumber
+!
+
+primAddSelector:newSelector withMethod:newMethod
+ "add the method given by 2nd argument under the selector given by
+ the 1st argument to the methodDictionary.
+ Does NOT flush any caches, does NOT write a change record.
+
+ Do not use this in normal situations, strange behavior will be
+ the consequence.
+ I.e. executing obsolete methods, since the old method will still
+ be executed out of the caches."
+
+ |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
+
+ (newSelector isMemberOf:Symbol) ifFalse:[
+ self error:'invalid selector'.
+ ^ false
+ ].
+ newMethod isNil ifTrue:[
+ self error:'invalid method'.
+ ^ false
+ ].
+
+ index := selectorArray identityIndexOf:newSelector startingAt:1.
+ (index == 0) ifTrue:[
+ "
+ a new selector
+ "
+ newSelectorArray := selectorArray copyWith:newSelector.
+ newMethodArray := methodArray copyWith:newMethod.
+ "
+ keep a reference so they wont go away ...
+ mhmh: this is no longer needed - try without
+ "
+ oldSelectorArray := selectorArray.
+ oldMethodArray := methodArray.
+ selectorArray := newSelectorArray.
+ methodArray := newMethodArray
+ ] ifFalse:[
+ methodArray at:index put:newMethod
+ ].
+ ^ true
+!
+
+setMethodArray:anArray
+ "set the method array of the receiver.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here.
+ NOT for general use."
+
+ methodArray := anArray
+!
+
+setMethodDictionary:aDictionary
+ "set the receivers method dictionary.
+ Since no dictionary is actually used, decompose into selector- and
+ method arrays and set those. For ST-80 compatibility.
+ NOT for general use."
+
+ |n newSelectorArray newMethodArray idx|
+
+ n := aDictionary size.
+ newSelectorArray := Array basicNew:n.
+ newMethodArray := Array basicNew:n.
+ idx := 1.
+ aDictionary keysAndValuesDo:[:sel :method |
+ newSelectorArray at:idx put:sel.
+ newMethodArray at:idx put:method.
+ idx := idx + 1
+ ].
+ selectorArray := newSelectorArray.
+ methodArray := newMethodArray
+!
+
+setOtherSuperclasses:anArrayOfClasses
+ "EXPERIMENTAL: set the other superclasses of the receiver.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here;
+ Do NOT use it."
+
+ SubclassInfo := nil.
+ otherSuperclasses := anArrayOfClasses
+!
+
+setSelectorArray:anArray
+ "set the selector array of the receiver.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here.
+ NOT for general use."
+
+ selectorArray := anArray
+!
+
+setSelectors:sels methods:m
+ "set some inst vars.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here;
+ Do NOT use it."
+
+ selectorArray := sels.
+ methodArray := m.
+!
+
+setSuperclass:aClass
+ "set the superclass of the receiver.
+ this method is for special uses only - there will be no recompilation
+ and no change record written here. Also, if the receiver class has
+ already been in use, future operation of the system is not guaranteed to
+ be correct, since no caches are flushed.
+ Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
+
+ SubclassInfo := nil.
+ superclass := aClass
+!
+
+setSuperclass:sup selectors:sels methods:m instSize:i flags:f
+ "set some inst vars.
+ this method is for special uses only - there will be no recompilation
+ and no change record is written here. Also, if the receiver class has
+ already been in use, future operation of the system is not guaranteed to
+ be correct, since no caches are flushed.
+ Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
+
+ SubclassInfo := nil.
+ superclass := sup.
+ selectorArray := sels.
+ methodArray := m.
+ instSize := i.
+ flags := f
+! !
+
+!Behavior methodsFor:'queries'!
+
+allClassVarNames
+ "return a collection of all the class variable name-strings
+ this includes all superclass-class variables.
+ Since Behavior has no idea of classvar-names, return an empty collection
+ here. Redefined in ClassDescription."
+
+ ^ #()
+!
+
+allDerivedInstances
+ "return a collection of all instances of myself and
+ instances of all subclasses of myself.
+ This method is going to be removed for protocol compatibility with
+ other STs; use allSubInstances"
+
+ self obsoleteMethodWarning:'please use #allSubInstances'.
+ ^ self allSubInstances
+!
+
+allInstVarNames
+ "return a collection of all the instance variable name-strings
+ this includes all superclass-instance variables.
+ Since Behavior has no idea of instvar-names, return an empty collection
+ here. Redefined in ClassDescription."
+
+ ^ #()
+!
+
+allInstances
+ "return a collection of all my instances"
+
+ "Read the documentation on why there seem to be no
+ instances of SmallInteger and UndefinedObject"
+
+ |coll|
+
+ coll := OrderedCollection new:100.
+ self allInstancesDo:[:anObject |
+ coll add:anObject
+ ].
+ ^ coll
+
+ "
+ ScrollBar allInstances
+ "
+!
+
+allSubInstances
+ "return a collection of all instances of myself and
+ instances of all subclasses of myself."
+
+ |coll|
+
+ coll := OrderedCollection new:100.
+ self allSubInstancesDo:[:anObject |
+ (anObject isKindOf:self) ifTrue:[
+ coll add:anObject
+ ]
+ ].
+ ^ coll
+
+ "
+ View allSubInstances
+ "
+!
+
+allSubclasses
+ "return a collection of all subclasses (direct AND indirect) of
+ the receiver. There will be no specific order, in which entries
+ are returned."
+
+ |newColl|
+
+ newColl := OrderedCollection new.
+ self allSubclassesDo:[:aClass |
+ newColl add:aClass
+ ].
+ ^ newColl
+
+ "
+ Collection allSubclasses
+ "
+!
+
+allSubclassesInOrder
+ "return a collection of all subclasses (direct AND indirect) of
+ the receiver. Higher level subclasses will come before lower ones."
+
+ |newColl|
+
+ newColl := OrderedCollection new.
+ self allSubclassesInOrderDo:[:aClass |
+ newColl add:aClass
+ ].
+ ^ newColl
+
+ "
+ Collection allSubclassesInOrder
+ "
+!
+
+allSuperclasses
+ "return a collection of the receivers accumulated superclasses"
+
+ |aCollection theSuperClass|
+
+ theSuperClass := superclass.
+ theSuperClass notNil ifTrue:[
+ aCollection := OrderedCollection new.
+ [theSuperClass notNil] whileTrue:[
+ aCollection add:theSuperClass.
+ theSuperClass := theSuperClass superclass
+ ]
+ ].
+ ^ aCollection
+
+ "
+ String allSuperclasses
+ "
+!
+
+cachedLookupMethodFor:aSelector
+ "return the method, which would be executed if aSelector was sent to
+ an instance of the receiver. I.e. the selector arrays of the receiver
+ and all of its superclasses are searched for aSelector.
+ Return the method, or nil if instances do not understand aSelector.
+ This interface provides exactly the same information as #lookupMethodFor:,
+ but uses the lookup-cache in the VM for faster search.
+ However, keep in mind, that doing a lookup through the cache also adds new
+ entries and can thus slow down the system by polluting the cache with
+ irrelevant entries. (do NOT loop over all objects calling this method).
+ Does NOT (currently) handle MI"
+
+%{ /* NOCONTEXT */
+ extern OBJ __lookup();
+
+ RETURN ( __lookup(self, aSelector, SENDER) );
+%}
+
+ "
+ String cachedLookupMethodFor:#=
+ String cachedLookupMethodFor:#asOrderedCollection
+ "
+!
+
+canBeSubclassed
+ "return true, if its allowed to create subclasses of the receiver.
+ This method is redefined in SmallInteger and UndefinedObject, since
+ instances are detected by their pointer-fields, i.e. they do not have
+ a class entry (you dont have to understand this :-)"
^ true
!
-autoload
- "force autoloading - do nothing here;
- redefined in Autoload; see comment there"
-
- ^ self
-! !
-
-!Behavior methodsFor:'snapshots'!
-
-preSnapshot
- "sent by ObjectMemory, before a snapshot is written.
- Nothing done here."
+canUnderstand:aSelector
+ "return true, if the receiver or one of its superclasses implements aSelector.
+ (i.e. true if my instances understand aSelector)"
+
+ ^ (self lookupMethodFor:aSelector) notNil
+
+ "
+ True canUnderstand:#ifTrue:
+ True canUnderstand:#==
+ True canUnderstand:#do:
+ "
!
-postSnapshot
- "sent by ObjectMemory, after a snapshot has been written.
- Nothing done here."
-! !
-
-!Behavior class methodsFor:'flag bit constants'!
-
-flagNotIndexed
- "return the flag code for non-indexed instances.
- You have to mask the flag value with indexMask when comparing
- it with flagNotIndexed."
-
- ^ 0
-!
-
-flagBytes
- "return the flag code for byte-valued indexed instances.
- You have to mask the flag value with indexMask when comparing
- it with flagBytes."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(BYTEARRAY) );
-%}
+compiledMethodAt:aSelector
+ "return the method for given selector aSelector or nil.
+ Only methods in the receiver - not in the superclass chain are tested."
+
+ |index|
+
+ selectorArray isNil ifTrue:[
+ ('oops: nil selectorArray in ' , self name) errorPrintNL.
+ ^ nil
+ ].
+
+ index := selectorArray identityIndexOf:aSelector startingAt:1.
+ (index == 0) ifTrue:[^ nil].
+ ^ methodArray at:index
+
"
- Behavior flagBytes
- "
-!
-
-flagWords
- "return the flag code for word-valued indexed instances (i.e. 2-byte).
- You have to mask the flag value with indexMask when comparing
- it with flagWords."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(WORDARRAY) );
-%}
- "
- Behavior flagWords
+ Object compiledMethodAt:#==
+ (Object compiledMethodAt:#==) category
"
-!
-
-flagLongs
- "return the flag code for long-valued indexed instances (i.e. 4-byte).
- You have to mask the flag value with indexMask when comparing
- it with flagLongs."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(LONGARRAY) );
-%}
- "
- Behavior flagLongs
+!
+
+containsMethod:aMethod
+ "Return true, if the argument, aMethod is a method of myself"
+
+ methodArray isNil ifTrue:[^ false]. "degenerated class"
+ ^ (methodArray identityIndexOf:aMethod startingAt:1) ~~ 0
+!
+
+derivedInstanceCount
+ "return the number of instances of myself and of subclasses"
+
+ |count|
+
+ count := 0.
+ ObjectMemory allObjectsDo:[:anObject |
+ (anObject isKindOf:self) ifTrue:[
+ count := count + 1
+ ]
+ ].
+ ^ count
+
"
-!
-
-flagFloats
- "return the flag code for float-valued indexed instances (i.e. 4-byte reals).
- You have to mask the flag value with indexMask when comparing
- it with flagFloats."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(FLOATARRAY) );
-%}
- "
- Behavior flagFloats
+ View derivedInstanceCount
+ SequenceableCollection derivedInstanceCount
"
-!
-
-flagDoubles
- "return the flag code for double-valued indexed instances (i.e. 8-byte reals).
- You have to mask the flag value with indexMask when comparing
- it with flagDoubles."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(DOUBLEARRAY) );
-%}
- "
- Behavior flagDoubles
+!
+
+hasInstances
+ "return true, if there are any instances of myself"
+
+ "Read the documentation on why there seem to be no
+ instances of SmallInteger and UndefinedObject"
+
+"/ ObjectMemory allObjectsDo:[:anObject |
+"/ (anObject class == self) ifTrue:[
+"/ ^ true
+"/ ]
+"/ ].
+ ObjectMemory allInstancesOf:self do:[:anObject |
+ ^ true
+ ].
+ ^ false
+
"
-!
-
-flagPointers
- "return the flag code for pointer indexed instances (i.e. Array of object).
- You have to mask the flag value with indexMask when comparing
- it with flagPointers."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(POINTERARRAY) );
-%}
+ Object hasInstances
+ SequenceableCollection hasInstances
+ Float hasInstances
+ SmallInteger hasInstances
"
- Behavior flagPointers
+!
+
+hasMethods
+ "return true, if there are any (local) methods in this class"
+
+ ^ (methodArray size ~~ 0)
+
"
-!
-
-flagWeakPointers
- "return the flag code for weak pointer indexed instances (i.e. WeakArray).
- You have to mask the flag value with indexMask when comparing
- it with flagWeakPointers."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(WKPOINTERARRAY) );
-%}
-!
-
-maskIndexType
- "return a mask to extract all index-type bits"
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(ARRAYMASK) );
-%}
-!
-
-flagBehavior
- "return the flag code which marks Behavior-like instances.
- You have to check this single bit in the flag value when
- checking for behaviors."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(BEHAVIOR_INSTS) );
-%}
-
- "consistency check:
- all class-entries must be behaviors;
- all behaviors must be flagged so (in its class's flags)
- (otherwise, VM will bark)
- all non-behaviors may not be flagged
-
- |bit|
- bit := Class flagBehavior.
-
- ObjectMemory allObjectsDo:[:o|
- o isBehavior ifTrue:[
- (o class flags bitTest:bit) ifFalse:[
- self halt
- ].
- ] ifFalse:[
- (o class flags bitTest:bit) ifTrue:[
- self halt
- ].
- ].
- o class isBehavior ifFalse:[
- self halt
- ] ifTrue:[
- (o class class flags bitTest:bit) ifFalse:[
- self halt
- ]
- ]
- ]
+ True hasMethods
+ True class hasMethods
+ "
+!
+
+hasMultipleSuperclasses
+ "Return true, if this class inherits from other classes
+ (beside its primary superclass).
+ This method is a preparation for a future multiple inheritance extension
+ - currently it is not supported by the VM"
+
+ ^ otherSuperclasses notNil
+!
+
+implements:aSelector
+ "return true, if the receiver implements aSelector.
+ (i.e. implemented in THIS class - NOT in a superclass).
+ Dont use this method to check if someone responds to a message -
+ use #canUnderstand: on the class or #respondsTo: on the instance
+ to do this."
+
+ ^ (selectorArray identityIndexOf:aSelector startingAt:1) ~~ 0
+
+ "
+ True implements:#ifTrue:
+ True implements:#==
+ "
+!
+
+includesSelector:aSelector
+ "for ST-80 compatibility"
+
+ ^ self implements:aSelector
+!
+
+inheritsFrom:aClass
+ "return true, if the receiver inherits methods from aClass"
+
+ ^ self isSubclassOf:aClass
+
+ "
+ True inheritsFrom:Object
+ LinkedList inheritsFrom:Array
"
-!
-
-flagBlock
- "return the flag code which marks Block-like instances.
- You have to check this single bit in the flag value when
- checking for blocks."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(BLOCK_INSTS) );
-%}
-!
-
-flagMethod
- "return the flag code which marks Method-like instances.
- You have to check this single bit in the flag value when
- checking for methods."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(METHOD_INSTS) );
-%}
-!
-
-flagNonObjectInst
- "return the flag code which marks instances which have a
- non-object instance variable (in slot 1).
- (these are ignored by the garbage collector)"
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(NONOBJECT_INSTS) );
-%}
!
-flagContext
- "return the flag code which marks Context-like instances.
- You have to check this single bit in the flag value when
- checking for contexts."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(CONTEXT_INSTS) );
-%}
-!
-
-flagBlockContext
- "return the flag code which marks BlockContext-like instances.
- You have to check this single bit in the flag value when
- checking for blockContexts."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(BCONTEXT_INSTS) );
-%}
-!
-
-flagFloat
- "return the flag code which marks Float-like instances.
- You have to check this single bit in the flag value when
- checking for floats."
-
-%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(FLOAT_INSTS) );
-%}
-!
-
-flagSymbol
- "return the flag code which marks Symbol-like instances.
- You have to check this single bit in the flag value when
- checking for symbols."
+instanceCount
+ "return the number of instances of myself."
+
+ "Read the documentation on why there seem to be no
+ instances of SmallInteger and UndefinedObject"
+
+ |count|
+
+ count := 0.
+"/ ObjectMemory allObjectsDo:[:anObject |
+"/ (anObject class == self) ifTrue:[
+"/ count := count + 1
+"/ ]
+"/ ].
+ ObjectMemory allInstancesOf:self do:[:anObject |
+ count := count + 1
+ ].
+ ^ count
+
+ "
+ View instanceCount
+ Object instanceCount
+ Float instanceCount
+ SequenceableCollection instanceCount
+ SmallInteger instanceCount .... mhmh - hear, hear
+ "
+!
+
+isBehavior
+ "return true, if the receiver is describing another objects behavior,
+ i.e. is a class. Defined to avoid the need to use isKindOf:"
+
+ ^ true
+
+ "
+ True isBehavior
+ true isBehavior
+ "
+!
+
+isBits
+ "return true, if instances have indexed byte or short instance variables.
+ Ignore long, float and double arrays, since ST-80 code using isBits are probably
+ not prepared to handle them correctly."
%{ /* NOCONTEXT */
- /* this is defined as a primitive to get defines from stc.h */
-
- RETURN ( _MKSMALLINT(SYMBOL_INSTS) );
+
+ REGISTER int flags;
+
+ RETURN ( (((flags = (_intVal(_INST(flags)) & ARRAYMASK)) == BYTEARRAY)
+ || (flags == WORDARRAY)) ? true : false );
+%}
+!
+
+isBytes
+ "return true, if instances have indexed byte instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagBytes
+ "
+%{ /* NOCONTEXT */
+
+ RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == BYTEARRAY) ? true : false );
%}
-! !
-
-!Behavior methodsFor:'accessing'!
-
-name
- "although behaviors have no name, we return something
- useful here - there are many places (inspectors) where
- a classes name is asked for.
- Implementing this message here allows anonymous classes
- and instances of them to be inspected."
-
- ^ 'someBehavior'
+!
+
+isDoubles
+ "return true, if instances have indexed double instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagDoubles
+ "
+%{ /* NOCONTEXT */
+
+ RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == DOUBLEARRAY) ? true : false );
+%}
+!
+
+isFixed
+ "return true, if instances do not have indexed instance variables"
+
+ "this could also be defined as:
+ ^ self isVariable not
+ "
+
+%{ /* NOCONTEXT */
+
+ RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? false : true );
+%}
+!
+
+isFloats
+ "return true, if instances have indexed float instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagFloats
+ "
+%{ /* NOCONTEXT */
+
+ RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == FLOATARRAY) ? true : false );
+%}
!
-displayString
- "although behaviors have no name, we return something
- useful here - there are many places (inspectors) where
- a classes name is asked for.
- Implementing this message here allows instances of anonymous classes
- to show a reasonable name."
-
- ^ 'someBehavior'
+isLongs
+ "return true, if instances have indexed long instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagLongs
+ "
+%{ /* NOCONTEXT */
+
+ RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == LONGARRAY) ? true : false );
+%}
!
-category
- "return the category of the class.
- Returning nil here, since Behavior does not define a category
- (only ClassDescriptions do)."
-
- ^ nil
+isPointers
+ "return true, if instances have pointer instance variables
+ i.e. are either non-indexed or have indexed pointer variables"
+
+ "QUESTION: should we ignore WeakPointers ?"
+
+%{ /* NOCONTEXT */
+
+ REGISTER int flags;
+
+ flags = _intVal(_INST(flags)) & ARRAYMASK;
+ switch (flags) {
+ default:
+ /* normal objects */
+ RETURN ( true );
+
+ case BYTEARRAY:
+ case WORDARRAY:
+ case LONGARRAY:
+ case FLOATARRAY:
+ case DOUBLEARRAY:
+ RETURN (false );
+
+ case WKPOINTERARRAY:
+ /* what about those ? */
+ RETURN (true );
+ }
+%}
+!
+
+isSubclassOf:aClass
+ "return true, if I am a subclass of the argument, aClass"
+
+ |theClass|
+
+ theClass := superclass.
+ [theClass notNil] whileTrue:[
+ (theClass == aClass) ifTrue:[^ true].
+%{
+ if (__isBehaviorLike(theClass)) {
+ theClass = __ClassInstPtr(theClass)->c_superclass;
+ } else {
+ theClass = nil;
+ }
+%}.
+"/ theClass := theClass superclass.
+ ].
+ ^ false
"
- Point category
- Behavior new category
+ String isSubclassOf:Collection
+ LinkedList isSubclassOf:Array
+ 1 isSubclassOf:Number <- will fail since 1 is no class
+ "
+!
+
+isVariable
+ "return true, if instances have indexed instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) ~~ 0
+ "
+
+%{ /* NOCONTEXT */
+
+ RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? true : false );
+%}
+!
+
+isWords
+ "return true, if instances have indexed short instance variables"
+
+ "this could also be defined as:
+ ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagWords
+ "
+%{ /* NOCONTEXT */
+
+ RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == WORDARRAY) ? true : false );
+%}
+!
+
+lookupMethodFor:aSelector
+ "return the method, which would be executed if aSelector was sent to
+ an instance of the receiver. I.e. the selector arrays of the receiver
+ and all of its superclasses are searched for aSelector.
+ Return the method, or nil if instances do not understand aSelector.
+ EXPERIMENTAL: take care of multiple superclasses."
+
+ |m cls|
+
+ cls := self.
+ [cls notNil] whileTrue:[
+ m := cls compiledMethodAt:aSelector.
+ m notNil ifTrue:[^ m].
+ cls hasMultipleSuperclasses ifTrue:[
+ cls superclasses do:[:aSuperClass |
+ m := aSuperClass lookupMethodFor:aSelector.
+ m notNil ifTrue:[^ m].
+ ].
+ ^ nil
+ ] ifFalse:[
+ cls := cls superclass
+ ]
+ ].
+ ^ nil
+!
+
+selectorAtMethod:aMethod
+ "Return the selector for given method aMethod."
+
+ ^ self selectorAtMethod:aMethod ifAbsent:[nil]
+
+ "
+ |m|
+
+ m := Object compiledMethodAt:#copy.
+ Fraction selectorAtMethod:m.
+ "
+ "
+ |m|
+
+ m := Object compiledMethodAt:#copy.
+ Object selectorAtMethod:m.
"
!
-superclass
- "return the receivers superclass"
-
- ^ superclass
-!
-
-selectorArray
- "return the receivers selector array.
- Notice: this is not compatible with ST-80."
-
- ^ selectorArray
-!
-
-selectors
- "return the receivers selector array as an orderedCollection.
- Notice: this may not be compatible with ST-80.
- (should we return a Set ?)"
-
- ^ selectorArray asOrderedCollection
-!
-
-methodArray
- "return the receivers method array.
- Notice: this is not compatible with ST-80."
-
- ^ methodArray
-!
-
-methodDictionary
- "return the receivers method dictionary.
- Since no dictionary is actually present, create one for ST-80 compatibility."
-
- |dict n "{ Class: SmallInteger }"|
-
- dict := IdentityDictionary new.
- n := selectorArray size.
- 1 to:n do:[:index |
- dict at:(selectorArray at:index) put:(methodArray at:index)
- ].
- ^ dict
-!
-
-implicit_methodDict
- "ST-80 compatibility.
- This allows subclasses to assume there is an instance variable
- named methodDict."
-
- ^ self methodDictionary
-!
-
-implicit_methodDict:aDictionary
- "ST-80 compatibility.
- This allows subclasses to assume there is an instance variable
- named methodDict."
-
- ^ self error:'not allowed to set the methodDictionary'
-!
-
-instSize
- "return the number of instance variables of the receiver.
- This includes all superclass instance variables."
-
- ^ instSize
-!
-
-flags
- "return the receivers flag bits"
-
- ^ flags
-!
-
-superclass:aClass
- "set the superclass - this actually creates a new class,
- recompiling all methods for the new one. The receiving class stays
- around anonymous to allow existing instances some life.
- This may change in the future (adjusting existing instances)"
-
- SubclassInfo := nil.
-
- "must flush caches since lookup chain changes"
- ObjectMemory flushCaches.
-
-"
- superclass := aClass
-"
- "for correct recompilation, just create a new class ..."
-
- aClass subclass:(self name)
- instanceVariableNames:(self instanceVariableString)
- classVariableNames:(self classVariableString)
- poolDictionaries:''
- category:self category
-!
-
-addSuperclass:aClass
- "EXPERIMENTAL MI support: add aClass to the set of classes, from which instances
- inherit protocol."
-
- "first, check if the class is abstract -
- allows abstract mixins are allowed in the current implementation"
-
- aClass instSize == 0 ifFalse:[
- self error:'only abstract mixins allowed'.
- ^ self
- ].
- otherSuperclasses isNil ifTrue:[
- otherSuperclasses := Array with:aClass
- ] ifFalse:[
- otherSuperclasses := otherSuperclasses copyWith:aClass
- ].
- SubclassInfo := nil.
- ObjectMemory flushCaches
-!
-
-removeSuperclass:aClass
- "EXPERIMENTAL MI support: remove aClass from the set of classes, from which instances
- inherit protocol."
-
- otherSuperclasses notNil ifTrue:[
- otherSuperclasses := otherSuperclasses copyWithout:aClass.
- otherSuperclasses isEmpty ifTrue:[
- otherSuperclasses := nil
- ].
- SubclassInfo := nil.
- ObjectMemory flushCaches
- ].
-!
-
-selectors:newSelectors methods:newMethods
- "set both selector array and method array of the receiver,
- and flush caches"
-
- ObjectMemory flushCaches.
- selectorArray := newSelectors.
- methodArray := newMethods
-!
-
-addSelector:newSelector withMethod:newMethod
- "add the method given by 2nd argument under the selector given by
- 1st argument to the methodDictionary. Flush all caches."
-
- |nargs|
-
- (self primAddSelector:newSelector withMethod:newMethod) ifFalse:[^ false].
- self changed:#methodDictionary with:newSelector.
+selectorAtMethod:aMethod ifAbsent:failBlock
+ "return the selector for given method aMethod
+ or the value of failBlock, if not found."
+
+ |index|
+
+ index := methodArray identityIndexOf:aMethod startingAt:1.
+ (index == 0) ifTrue:[^ failBlock value].
+ ^ selectorArray at:index
"
- if I have no subclasses, all we have to flush is cached
- data for myself ... (actually, in any case all that needs
- to be flushed is info for myself and all of my subclasses)
+ |m|
+
+ m := Object compiledMethodAt:#copy.
+ Object selectorAtMethod:m ifAbsent:['oops'].
+ "
"
-"
- problem: this is slower; since looking for all subclasses is (currently)
- a bit slow :-(
- We need the hasSubclasses-info bit in Behavior; now
-
- self withAllSubclassesDo:[:aClass |
- ObjectMemory flushInlineCachesFor:aClass withArgs:nargs.
- ObjectMemory flushMethodCacheFor:aClass
- ].
-"
-
+ |m|
+
+ m := Object compiledMethodAt:#copy.
+ Fraction selectorAtMethod:m ifAbsent:['oops'].
"
- actually, we would do better with less flushing ...
- "
- nargs := newSelector numArgs.
-
- ObjectMemory flushMethodCache.
- ObjectMemory flushInlineCachesWithArgs:nargs.
-
- ^ true
!
-addSelector:newSelector withLazyMethod:newMethod
- "add the method given by 2nd argument under the selector given by
- 1st argument to the methodDictionary. Since it does not flush
- any caches, this is only allowed for lazy methods."
-
- newMethod isLazyMethod ifFalse:[
- self error:'operation only allowed for lazy methods'.
- ^ false
- ].
- "/ oops: we must flush, if this method already exists ...
- (selectorArray includes:newSelector) ifTrue:[
- ObjectMemory flushCaches
- ].
- (self primAddSelector:newSelector withMethod:newMethod) ifTrue:[
- self changed:#methodDictionary with:newSelector.
- ^ true
- ].
- ^ false
+selectorIndex:aSelector
+ "return the index in the arrays for given selector aSelector"
+
+ ^ selectorArray identityIndexOf:aSelector startingAt:1
!
-removeSelector:aSelector
- "remove the selector, aSelector and its associated method
- from the methodDictionary"
-
- |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
-
- index := selectorArray identityIndexOf:aSelector startingAt:1.
- (index == 0) ifTrue:[^ false].
-
- newSelectorArray := selectorArray copyWithoutIndex:index.
- newMethodArray := methodArray copyWithoutIndex:index.
- oldSelectorArray := selectorArray.
- oldMethodArray := methodArray.
- selectorArray := newSelectorArray.
- methodArray := newMethodArray.
-"
- [
- |nargs|
- nargs := aSelector numArgs.
- ObjectMemory flushMethodCache.
- ObjectMemory flushInlineCachesWithArgs:nargs.
- ] value
-"
- "
- actually, we would do better with less flushing ...
- "
- ObjectMemory flushCaches.
- ^ true
-! !
-
-!Behavior methodsFor:'queries'!
-
sizeOfInst:n
"return the number of bytes required for an instance of
myself with n indexed instance variables. The argument n
@@ -1697,220 +2792,20 @@
%}
!
-isVariable
- "return true, if instances have indexed instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) ~~ 0
- "
-
-%{ /* NOCONTEXT */
-
- RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? true : false );
-%}
-!
-
-isFixed
- "return true, if instances do not have indexed instance variables"
-
- "this could also be defined as:
- ^ self isVariable not
- "
-
-%{ /* NOCONTEXT */
-
- RETURN ( (_intVal(_INST(flags)) & ARRAYMASK) ? false : true );
-%}
-!
-
-isBits
- "return true, if instances have indexed byte or short instance variables.
- Ignore long, float and double arrays, since ST-80 code using isBits are probably
- not prepared to handle them correctly."
-
-%{ /* NOCONTEXT */
-
- REGISTER int flags;
-
- RETURN ( (((flags = (_intVal(_INST(flags)) & ARRAYMASK)) == BYTEARRAY)
- || (flags == WORDARRAY)) ? true : false );
-%}
-!
-
-isBytes
- "return true, if instances have indexed byte instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagBytes
- "
-%{ /* NOCONTEXT */
-
- RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == BYTEARRAY) ? true : false );
-%}
-!
-
-isWords
- "return true, if instances have indexed short instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagWords
- "
-%{ /* NOCONTEXT */
-
- RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == WORDARRAY) ? true : false );
-%}
-!
-
-isLongs
- "return true, if instances have indexed long instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagLongs
- "
-%{ /* NOCONTEXT */
-
- RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == LONGARRAY) ? true : false );
-%}
-!
-
-isFloats
- "return true, if instances have indexed float instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagFloats
- "
-%{ /* NOCONTEXT */
-
- RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == FLOATARRAY) ? true : false );
-%}
-!
-
-isDoubles
- "return true, if instances have indexed double instance variables"
-
- "this could also be defined as:
- ^ (flags bitAnd:(Behavior maskIndexType)) == Behavior flagDoubles
- "
-%{ /* NOCONTEXT */
-
- RETURN ( ((_intVal(_INST(flags)) & ARRAYMASK) == DOUBLEARRAY) ? true : false );
-%}
-!
-
-isPointers
- "return true, if instances have pointer instance variables
- i.e. are either non-indexed or have indexed pointer variables"
-
- "QUESTION: should we ignore WeakPointers ?"
-
-%{ /* NOCONTEXT */
-
- REGISTER int flags;
-
- flags = _intVal(_INST(flags)) & ARRAYMASK;
- switch (flags) {
- default:
- /* normal objects */
- RETURN ( true );
-
- case BYTEARRAY:
- case WORDARRAY:
- case LONGARRAY:
- case FLOATARRAY:
- case DOUBLEARRAY:
- RETURN (false );
-
- case WKPOINTERARRAY:
- /* what about those ? */
- RETURN (true );
- }
-%}
-!
-
-isBehavior
- "return true, if the receiver is describing another objects behavior,
- i.e. is a class. Defined to avoid the need to use isKindOf:"
-
- ^ true
+sourceCodeAt:aSelector
+ "return the methods source for given selector aSelector or nil.
+ Only methods in the receiver - not in the superclass chain are tested."
+
+ |method|
+
+ method := self compiledMethodAt:aSelector.
+ method isNil ifTrue:[^ nil].
+ ^ method source
"
- True isBehavior
- true isBehavior
- "
-!
-
-canBeSubclassed
- "return true, if its allowed to create subclasses of the receiver.
- This method is redefined in SmallInteger and UndefinedObject, since
- instances are detected by their pointer-fields, i.e. they do not have
- a class entry (you dont have to understand this :-)"
-
- ^ true
-!
-
-hasMultipleSuperclasses
- "Return true, if this class inherits from other classes
- (beside its primary superclass).
- This method is a preparation for a future multiple inheritance extension
- - currently it is not supported by the VM"
-
- ^ otherSuperclasses notNil
-!
-
-superclasses
- "return a collection of the receivers immediate superclasses.
- This method is a preparation for a future multiple inheritance extension
- - currently it is not supported by the VM"
-
- |a|
-
- a := Array with:superclass.
- otherSuperclasses notNil ifTrue:[
- ^ a , otherSuperclasses
- ].
- ^ a
-
- "
- String superclasses
- "
-!
-
-allSuperclasses
- "return a collection of the receivers accumulated superclasses"
-
- |aCollection theSuperClass|
-
- theSuperClass := superclass.
- theSuperClass notNil ifTrue:[
- aCollection := OrderedCollection new.
- [theSuperClass notNil] whileTrue:[
- aCollection add:theSuperClass.
- theSuperClass := theSuperClass superclass
- ]
- ].
- ^ aCollection
-
- "
- String allSuperclasses
- "
-!
-
-withAllSuperclasses
- "return a collection containing the receiver and all
- of the receivers accumulated superclasses"
-
- |aCollection theSuperClass|
-
- aCollection := OrderedCollection with:self.
- theSuperClass := superclass.
- [theSuperClass notNil] whileTrue:[
- aCollection add:theSuperClass.
- theSuperClass := theSuperClass superclass
- ].
- ^ aCollection
-
- "
- String withAllSuperclasses
+ True sourceCodeAt:#ifTrue:
+ Object sourceCodeAt:#==
+ Behavior sourceCodeAt:#sourceCodeAt:
"
!
@@ -1935,357 +2830,21 @@
"
!
-allSubclasses
- "return a collection of all subclasses (direct AND indirect) of
- the receiver. There will be no specific order, in which entries
- are returned."
-
- |newColl|
-
- newColl := OrderedCollection new.
- self allSubclassesDo:[:aClass |
- newColl add:aClass
- ].
- ^ newColl
-
- "
- Collection allSubclasses
- "
-!
-
-allSubclassesInOrder
- "return a collection of all subclasses (direct AND indirect) of
- the receiver. Higher level subclasses will come before lower ones."
-
- |newColl|
-
- newColl := OrderedCollection new.
- self allSubclassesInOrderDo:[:aClass |
- newColl add:aClass
- ].
- ^ newColl
-
- "
- Collection allSubclassesInOrder
- "
-!
-
-withAllSubclasses
- "return a collection containing the receiver and
- all subclasses (direct AND indirect) of the receiver"
-
- |newColl|
-
- newColl := OrderedCollection with:self.
- self allSubclassesDo:[:aClass |
- newColl add:aClass
- ].
- ^ newColl
-
- "
- Collection withAllSubclasses
- "
-!
-
-isSubclassOf:aClass
- "return true, if I am a subclass of the argument, aClass"
-
- |theClass|
-
- theClass := superclass.
- [theClass notNil] whileTrue:[
- (theClass == aClass) ifTrue:[^ true].
-%{
- if (__isBehaviorLike(theClass)) {
- theClass = __ClassInstPtr(theClass)->c_superclass;
- } else {
- theClass = nil;
- }
-%}.
-"/ theClass := theClass superclass.
+superclasses
+ "return a collection of the receivers immediate superclasses.
+ This method is a preparation for a future multiple inheritance extension
+ - currently it is not supported by the VM"
+
+ |a|
+
+ a := Array with:superclass.
+ otherSuperclasses notNil ifTrue:[
+ ^ a , otherSuperclasses
].
- ^ false
-
- "
- String isSubclassOf:Collection
- LinkedList isSubclassOf:Array
- 1 isSubclassOf:Number <- will fail since 1 is no class
- "
-!
-
-allInstVarNames
- "return a collection of all the instance variable name-strings
- this includes all superclass-instance variables.
- Since Behavior has no idea of instvar-names, return an empty collection
- here. Redefined in ClassDescription."
-
- ^ #()
-!
-
-allClassVarNames
- "return a collection of all the class variable name-strings
- this includes all superclass-class variables.
- Since Behavior has no idea of classvar-names, return an empty collection
- here. Redefined in ClassDescription."
-
- ^ #()
-!
-
-allInstances
- "return a collection of all my instances"
-
- "Read the documentation on why there seem to be no
- instances of SmallInteger and UndefinedObject"
-
- |coll|
-
- coll := OrderedCollection new:100.
- self allInstancesDo:[:anObject |
- coll add:anObject
- ].
- ^ coll
-
- "
- ScrollBar allInstances
- "
-!
-
-allSubInstances
- "return a collection of all instances of myself and
- instances of all subclasses of myself."
-
- |coll|
-
- coll := OrderedCollection new:100.
- self allSubInstancesDo:[:anObject |
- (anObject isKindOf:self) ifTrue:[
- coll add:anObject
- ]
- ].
- ^ coll
-
- "
- View allSubInstances
- "
-!
-
-allDerivedInstances
- "return a collection of all instances of myself and
- instances of all subclasses of myself.
- This method is going to be removed for protocol compatibility with
- other STs; use allSubInstances"
-
- self obsoleteMethodWarning:'please use #allSubInstances'.
- ^ self allSubInstances
-!
-
-hasInstances
- "return true, if there are any instances of myself"
-
- "Read the documentation on why there seem to be no
- instances of SmallInteger and UndefinedObject"
-
-"/ ObjectMemory allObjectsDo:[:anObject |
-"/ (anObject class == self) ifTrue:[
-"/ ^ true
-"/ ]
-"/ ].
- ObjectMemory allInstancesOf:self do:[:anObject |
- ^ true
- ].
- ^ false
+ ^ a
"
- Object hasInstances
- SequenceableCollection hasInstances
- Float hasInstances
- SmallInteger hasInstances
- "
-!
-
-instanceCount
- "return the number of instances of myself."
-
- "Read the documentation on why there seem to be no
- instances of SmallInteger and UndefinedObject"
-
- |count|
-
- count := 0.
-"/ ObjectMemory allObjectsDo:[:anObject |
-"/ (anObject class == self) ifTrue:[
-"/ count := count + 1
-"/ ]
-"/ ].
- ObjectMemory allInstancesOf:self do:[:anObject |
- count := count + 1
- ].
- ^ count
-
- "
- View instanceCount
- Object instanceCount
- Float instanceCount
- SequenceableCollection instanceCount
- SmallInteger instanceCount .... mhmh - hear, hear
- "
-!
-
-derivedInstanceCount
- "return the number of instances of myself and of subclasses"
-
- |count|
-
- count := 0.
- ObjectMemory allObjectsDo:[:anObject |
- (anObject isKindOf:self) ifTrue:[
- count := count + 1
- ]
- ].
- ^ count
-
- "
- View derivedInstanceCount
- SequenceableCollection derivedInstanceCount
- "
-!
-
-selectorIndex:aSelector
- "return the index in the arrays for given selector aSelector"
-
- ^ selectorArray identityIndexOf:aSelector startingAt:1
-!
-
-includesSelector:aSelector
- "for ST-80 compatibility"
-
- ^ self implements:aSelector
-!
-
-compiledMethodAt:aSelector
- "return the method for given selector aSelector or nil.
- Only methods in the receiver - not in the superclass chain are tested."
-
- |index|
-
- selectorArray isNil ifTrue:[
- ('oops: nil selectorArray in ' , self name) errorPrintNL.
- ^ nil
- ].
-
- index := selectorArray identityIndexOf:aSelector startingAt:1.
- (index == 0) ifTrue:[^ nil].
- ^ methodArray at:index
-
- "
- Object compiledMethodAt:#==
- (Object compiledMethodAt:#==) category
- "
-!
-
-sourceCodeAt:aSelector
- "return the methods source for given selector aSelector or nil.
- Only methods in the receiver - not in the superclass chain are tested."
-
- |method|
-
- method := self compiledMethodAt:aSelector.
- method isNil ifTrue:[^ nil].
- ^ method source
-
- "
- True sourceCodeAt:#ifTrue:
- Object sourceCodeAt:#==
- Behavior sourceCodeAt:#sourceCodeAt:
- "
-!
-
-lookupMethodFor:aSelector
- "return the method, which would be executed if aSelector was sent to
- an instance of the receiver. I.e. the selector arrays of the receiver
- and all of its superclasses are searched for aSelector.
- Return the method, or nil if instances do not understand aSelector.
- EXPERIMENTAL: take care of multiple superclasses."
-
- |m cls|
-
- cls := self.
- [cls notNil] whileTrue:[
- m := cls compiledMethodAt:aSelector.
- m notNil ifTrue:[^ m].
- cls hasMultipleSuperclasses ifTrue:[
- cls superclasses do:[:aSuperClass |
- m := aSuperClass lookupMethodFor:aSelector.
- m notNil ifTrue:[^ m].
- ].
- ^ nil
- ] ifFalse:[
- cls := cls superclass
- ]
- ].
- ^ nil
-!
-
-cachedLookupMethodFor:aSelector
- "return the method, which would be executed if aSelector was sent to
- an instance of the receiver. I.e. the selector arrays of the receiver
- and all of its superclasses are searched for aSelector.
- Return the method, or nil if instances do not understand aSelector.
- This interface provides exactly the same information as #lookupMethodFor:,
- but uses the lookup-cache in the VM for faster search.
- However, keep in mind, that doing a lookup through the cache also adds new
- entries and can thus slow down the system by polluting the cache with
- irrelevant entries. (do NOT loop over all objects calling this method).
- Does NOT (currently) handle MI"
-
-%{ /* NOCONTEXT */
- extern OBJ __lookup();
-
- RETURN ( __lookup(self, aSelector, SENDER) );
-%}
-
- "
- String cachedLookupMethodFor:#=
- String cachedLookupMethodFor:#asOrderedCollection
- "
-!
-
-hasMethods
- "return true, if there are any (local) methods in this class"
-
- ^ (methodArray size ~~ 0)
-
- "
- True hasMethods
- True class hasMethods
- "
-!
-
-implements:aSelector
- "return true, if the receiver implements aSelector.
- (i.e. implemented in THIS class - NOT in a superclass).
- Dont use this method to check if someone responds to a message -
- use #canUnderstand: on the class or #respondsTo: on the instance
- to do this."
-
- ^ (selectorArray identityIndexOf:aSelector startingAt:1) ~~ 0
-
- "
- True implements:#ifTrue:
- True implements:#==
- "
-!
-
-canUnderstand:aSelector
- "return true, if the receiver or one of its superclasses implements aSelector.
- (i.e. true if my instances understand aSelector)"
-
- ^ (self lookupMethodFor:aSelector) notNil
-
- "
- True canUnderstand:#ifTrue:
- True canUnderstand:#==
- True canUnderstand:#do:
+ String superclasses
"
!
@@ -2326,609 +2885,51 @@
"
!
-inheritsFrom:aClass
- "return true, if the receiver inherits methods from aClass"
-
- ^ self isSubclassOf:aClass
-
- "
- True inheritsFrom:Object
- LinkedList inheritsFrom:Array
- "
-!
-
-selectorAtMethod:aMethod ifAbsent:failBlock
- "return the selector for given method aMethod
- or the value of failBlock, if not found."
-
- |index|
-
- index := methodArray identityIndexOf:aMethod startingAt:1.
- (index == 0) ifTrue:[^ failBlock value].
- ^ selectorArray at:index
-
- "
- |m|
-
- m := Object compiledMethodAt:#copy.
- Object selectorAtMethod:m ifAbsent:['oops'].
- "
- "
- |m|
-
- m := Object compiledMethodAt:#copy.
- Fraction selectorAtMethod:m ifAbsent:['oops'].
- "
-!
-
-selectorAtMethod:aMethod
- "Return the selector for given method aMethod."
-
- ^ self selectorAtMethod:aMethod ifAbsent:[nil]
+withAllSubclasses
+ "return a collection containing the receiver and
+ all subclasses (direct AND indirect) of the receiver"
+
+ |newColl|
+
+ newColl := OrderedCollection with:self.
+ self allSubclassesDo:[:aClass |
+ newColl add:aClass
+ ].
+ ^ newColl
"
- |m|
-
- m := Object compiledMethodAt:#copy.
- Fraction selectorAtMethod:m.
- "
- "
- |m|
-
- m := Object compiledMethodAt:#copy.
- Object selectorAtMethod:m.
- "
-!
-
-containsMethod:aMethod
- "Return true, if the argument, aMethod is a method of myself"
-
- methodArray isNil ifTrue:[^ false]. "degenerated class"
- ^ (methodArray identityIndexOf:aMethod startingAt:1) ~~ 0
-! !
-
-!Behavior methodsFor:'private accessing'!
-
-setSuperclass:sup selectors:sels methods:m instSize:i flags:f
- "set some inst vars.
- this method is for special uses only - there will be no recompilation
- and no change record is written here. Also, if the receiver class has
- already been in use, future operation of the system is not guaranteed to
- be correct, since no caches are flushed.
- Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
-
- SubclassInfo := nil.
- superclass := sup.
- selectorArray := sels.
- methodArray := m.
- instSize := i.
- flags := f
-!
-
-setSuperclass:aClass
- "set the superclass of the receiver.
- this method is for special uses only - there will be no recompilation
- and no change record written here. Also, if the receiver class has
- already been in use, future operation of the system is not guaranteed to
- be correct, since no caches are flushed.
- Therefore: do NOT use it; use Behavior>>superclass: (or flush the caches, at least)"
-
- SubclassInfo := nil.
- superclass := aClass
-!
-
-setOtherSuperclasses:anArrayOfClasses
- "EXPERIMENTAL: set the other superclasses of the receiver.
- this method is for special uses only - there will be no recompilation
- and no change record written here;
- Do NOT use it."
-
- SubclassInfo := nil.
- otherSuperclasses := anArrayOfClasses
-!
-
-instSize:aNumber
- "set the instance size.
- this method is for special uses only - there will be no recompilation
- and no change record written here;
- Do NOT use it."
-
- instSize := aNumber
-!
-
-flags:aNumber
- "set the flags.
- this method is for special uses only - there will be no recompilation
- and no change record written here;
- Do NOT use it."
-
- flags := aNumber
-!
-
-setSelectors:sels methods:m
- "set some inst vars.
- this method is for special uses only - there will be no recompilation
- and no change record written here;
- Do NOT use it."
-
- selectorArray := sels.
- methodArray := m.
-!
-
-setSelectorArray:anArray
- "set the selector array of the receiver.
- this method is for special uses only - there will be no recompilation
- and no change record written here.
- NOT for general use."
-
- selectorArray := anArray
-!
-
-setMethodArray:anArray
- "set the method array of the receiver.
- this method is for special uses only - there will be no recompilation
- and no change record written here.
- NOT for general use."
-
- methodArray := anArray
-!
-
-setMethodDictionary:aDictionary
- "set the receivers method dictionary.
- Since no dictionary is actually used, decompose into selector- and
- method arrays and set those. For ST-80 compatibility.
- NOT for general use."
-
- |n newSelectorArray newMethodArray idx|
-
- n := aDictionary size.
- newSelectorArray := Array basicNew:n.
- newMethodArray := Array basicNew:n.
- idx := 1.
- aDictionary keysAndValuesDo:[:sel :method |
- newSelectorArray at:idx put:sel.
- newMethodArray at:idx put:method.
- idx := idx + 1
- ].
- selectorArray := newSelectorArray.
- methodArray := newMethodArray
-!
-
-primAddSelector:newSelector withMethod:newMethod
- "add the method given by 2nd argument under the selector given by
- the 1st argument to the methodDictionary.
- Does NOT flush any caches, does NOT write a change record.
-
- Do not use this in normal situations, strange behavior will be
- the consequence.
- I.e. executing obsolete methods, since the old method will still
- be executed out of the caches."
-
- |index oldSelectorArray oldMethodArray newSelectorArray newMethodArray|
-
- (newSelector isMemberOf:Symbol) ifFalse:[
- self error:'invalid selector'.
- ^ false
- ].
- newMethod isNil ifTrue:[
- self error:'invalid method'.
- ^ false
- ].
-
- index := selectorArray identityIndexOf:newSelector startingAt:1.
- (index == 0) ifTrue:[
- "
- a new selector
- "
- newSelectorArray := selectorArray copyWith:newSelector.
- newMethodArray := methodArray copyWith:newMethod.
- "
- keep a reference so they wont go away ...
- mhmh: this is no longer needed - try without
- "
- oldSelectorArray := selectorArray.
- oldMethodArray := methodArray.
- selectorArray := newSelectorArray.
- methodArray := newMethodArray
- ] ifFalse:[
- methodArray at:index put:newMethod
- ].
- ^ true
-! !
-
-!Behavior methodsFor:'compiler interface'!
-
-compiler
- "return the compiler to use for this class.
- OBSOLETE: This is the old ST/X interface, kept for migration.
- Dont use it - it will vanish."
-
- ^ self compilerClass
-!
-
-compilerClass
- "return the compiler to use for this class -
- this can be redefined in special classes, to get classes with
- Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
-
- ^ Compiler
-!
-
-evaluatorClass
- "return the compiler to use for expression evaluation for this class -
- this can be redefined in special classes, to get classes with
- Lisp, Prolog, ASN1, Basic :-) or whatever syntax."
-
- ^ Compiler
-! !
-
-!Behavior methodsFor:'enumerating'!
-
-allInstancesDo:aBlock
- "evaluate aBlock for all of my instances"
-
-"/ ObjectMemory allObjectsDo:[:anObject |
-"/ (anObject class == self) ifTrue:[
-"/ aBlock value:anObject
-"/ ]
-"/ ]
-
- ObjectMemory allInstancesOf:self do:[:anObject |
- aBlock value:anObject
- ]
-
- "
- StandardSystemView allInstancesDo:[:v | Transcript showCr:(v name)]
- "
-!
-
-allDerivedInstancesDo:aBlock
- "evaluate aBlock for all of my instances and all instances of subclasses.
- This method is going to be removed for protocol compatibility with
- other STs; use allSubInstancesDo:"
-
- self obsoleteMethodWarning:'please use #allSubInstancesDo:'.
- self allSubInstancesDo:aBlock
-
- "
- StandardSystemView allDerivedInstancesDo:[:v | Transcript showCr:(v name)]
- "
-!
-
-allSubInstancesDo:aBlock
- "evaluate aBlock for all of my instances and all instances of subclasses"
-
- ObjectMemory allObjectsDo:[:anObject |
- (anObject isKindOf:self) ifTrue:[
- aBlock value:anObject
- ]
- ]
-
- "
- StandardSystemView allSubInstancesDo:[:v | Transcript showCr:(v name)]
+ Collection withAllSubclasses
"
!
-subclassesDo:aBlock
- "evaluate the argument, aBlock for all immediate subclasses.
- This will only enumerate globally known classes - for anonymous
- behaviors, you have to walk over all instances of Behavior."
-
- |coll|
-
- SubclassInfo isNil ifTrue:[
- Behavior subclassInfo
- ].
- SubclassInfo notNil ifTrue:[
- coll := SubclassInfo at:self ifAbsent:nil.
- coll notNil ifTrue:[
- coll do:aBlock.
- ].
- ^ self
+withAllSuperclasses
+ "return a collection containing the receiver and all
+ of the receivers accumulated superclasses"
+
+ |aCollection theSuperClass|
+
+ aCollection := OrderedCollection with:self.
+ theSuperClass := superclass.
+ [theSuperClass notNil] whileTrue:[
+ aCollection add:theSuperClass.
+ theSuperClass := theSuperClass superclass
].
-
- Smalltalk allBehaviorsDo:[:aClass |
- (aClass superclass == self) ifTrue:[
- aBlock value:aClass
- ]
- ]
-
- "
- Collection subclassesDo:[:c | Transcript showCr:(c name)]
- "
-!
-
-allSubclassesDo:aBlock
- "evaluate aBlock for all of my subclasses.
- There is no specific order, in which the entries are enumerated.
- This will only enumerate globally known classes - for anonymous
- behaviors, you have to walk over all instances of Behavior."
-
- Smalltalk allBehaviorsDo:[:aClass |
- (aClass isSubclassOf:self) ifTrue:[
- aBlock value:aClass
- ]
- ]
-
- "
- Collection allSubclassesDo:[:c | Transcript showCr:(c name)]
- "
-!
-
-allSubclassesInOrderDo:aBlock
- "evaluate aBlock for all of my subclasses.
- Higher level subclasses will be enumerated before the deeper ones,
- so the order in which aBlock gets called is ok to fileOut classes in
- correct order for later fileIn.
- This will only enumerate globally known classes - for anonymous
- behaviors, you have to walk over all instances of Behavior"
-
- self subclassesDo:[:aClass |
- aBlock value:aClass.
- aClass allSubclassesInOrderDo:aBlock
- ]
-
- "
- Collection allSubclassesInOrderDo:[:c | Transcript showCr:(c name)]
- "
-!
-
-allSuperclassesDo:aBlock
- "evaluate aBlock for all of my superclasses"
-
- |theClass|
-
- theClass := superclass.
- [theClass notNil] whileTrue:[
- aBlock value:theClass.
- theClass := theClass superclass
- ]
-
- "
- String allSuperclassesDo:[:c | Transcript showCr:(c name)]
- "
-! !
-
-!Behavior methodsFor:'binary storage'!
-
-storeBinaryDefinitionOn: stream manager: manager
- "binary store of a classes definition.
- Classes will store the name only and restore by looking for
- that name in the Smalltalk dictionary."
-
- | myName |
-
- myName := self name.
- stream nextNumber:4 put:self signature.
- stream nextNumber:2 put:0.
- stream nextNumber:2 put:myName size.
- myName do:[:c|
- stream nextPut:c asciiValue
- ]
-
- "
- |s|
- s := WriteStream on:ByteArray new.
- #(1 2 3 4) storeBinaryOn:s.
- Object readBinaryFrom:(ReadStream on:s contents)
-
- |s|
- s := WriteStream on:ByteArray new.
- Rectangle storeBinaryOn:s.
- Object readBinaryFrom:(ReadStream on:s contents)
- "
-!
-
-readBinaryFrom:aStream
- "read an objects binary representation from the argument,
- aStream and return it.
- The read object must be a kind of myself, otherwise an error is raised.
- To get any object, use 'Object readBinaryFrom:...',
- To get any number, use 'Number readBinaryFrom:...' and so on.
- This is the reverse operation to 'storeBinaryOn:'. "
-
- ^ self readBinaryFrom:aStream onError:[self error:('expected ' , self name)]
-
- "
- |s|
- s := WriteStream on:(ByteArray new).
- #(1 2 3 4) storeBinaryOn:s.
- Object readBinaryFrom:(ReadStream on:s contents)
- "
- "
- |s|
- s := 'testFile' asFilename writeStream binary.
- #(1 2 3 4) storeBinaryOn:s.
- 'hello world' storeBinaryOn:s.
- s close.
-
- s := 'testFile' asFilename readStream binary.
- Transcript showCr:(Object readBinaryFrom:s).
- Transcript showCr:(Object readBinaryFrom:s).
- s close.
- "
-!
-
-readBinaryFrom:aStream onError:exceptionBlock
- "read an objects binary representation from the argument,
- aStream and return it.
- The read object must be a kind of myself, otherwise the value of
- the exceptionBlock is returned.
- To get any object, use 'Object readBinaryFrom:...',
- To get any number, use 'Number readBinaryFrom:...' and so on.
- This is the reverse operation to 'storeBinaryOn:'. "
-
- |newObject|
-
- newObject := (BinaryInputManager new:1024) readFrom:aStream.
- (newObject isKindOf:self) ifFalse:[^ exceptionBlock value].
- ^ newObject
+ ^ aCollection
"
- |s|
- s := WriteStream on:(ByteArray new).
- #(1 2 3 4) storeBinaryOn:s.
- Object readBinaryFrom:(ReadStream on:s contents) onError:['oops']
- "
- "
- |s|
- s := WriteStream on:(ByteArray new).
- #[1 2 3 4] storeBinaryOn:s.
- Array readBinaryFrom:(ReadStream on:s contents) onError:['oops']
- "
-!
-
-binaryDefinitionFrom:stream manager:manager
- "sent during a binary read by the input manager.
- Read the definition on an empty instance (of my class) from stream.
- All pointer instances are left nil, while all bits are read in here.
- return the new object."
-
- |obj t
- basicSize "{ Class: SmallInteger }" |
-
- self isPointers ifTrue: [
- "/
- "/ inst size not needed - if you uncomment the line below,
- "/ also uncomment the corresponding line in
- "/ Object>>storeBinaryDefinitionOn:manager:
- "/
- "/ stream next. "skip instSize"
- self isVariable ifTrue: [
- ^ self basicNew:(stream nextNumber:3)
- ].
- ^ self basicNew
- ].
-
- "
- an object with bit-valued instance variables.
- These are read here.
- "
- basicSize := stream nextNumber:4.
- obj := self basicNew:basicSize.
-
- self isBytes ifTrue: [
- stream nextBytes:basicSize into:obj
- ] ifFalse: [
- self isWords ifTrue: [
- 1 to:basicSize do:[:i |
- obj basicAt:i put:(stream nextNumber:2)
- ]
- ] ifFalse:[
- self isLongs ifTrue: [
- 1 to:basicSize do:[:i |
- obj basicAt:i put:(stream nextNumber:4)
- ]
- ] ifFalse:[
- self isFloats ifTrue: [
- "could do it in one big read on machines which use IEEE floats ..."
- t := Float basicNew.
- 1 to:basicSize do:[:i |
- Float readBinaryIEEESingleFrom:stream into:t.
- obj basicAt:i put: t
- ]
- ] ifFalse:[
- self isDoubles ifTrue: [
- "could do it in one big read on machines which use IEEE doubles ..."
- t := Float basicNew.
- 1 to:basicSize do:[:i |
- Float readBinaryIEEEDoubleFrom:stream into:t.
- obj basicAt:i put: t
- ]
- ]
- ]
- ]
- ]
- ].
- ^obj
-!
-
-canCloneFrom:anObject
- "return true, if this class can clone an obsolete object as retrieved
- by a binary load. Subclasses which do not want to have obsolete objects
- be converted, should redefine this method to return false.
- (However, conversion is never done silently in a binary load; you
- have to have a handler for the binaryload errors and for the conversion
- request signal.)"
-
- ^ true
-!
-
-cloneFrom:aPrototype
- "return an instance of myself with variables initialized from
- a prototype. This is used when instances of obsolete classes are
- binary loaded and a conversion is done on the obsolete object.
- UserClasses may redefine this for better conversions."
-
- |newInst indexed myInfo otherInfo varIndexAssoc|
-
- indexed := false.
- aPrototype class isVariable ifTrue:[
- self isVariable ifTrue:[
- indexed := true.
- ].
- "otherwise, these are lost ..."
- ].
- indexed ifTrue:[
- newInst := self basicNew:aPrototype basicSize
- ] ifFalse:[
- newInst := self basicNew
- ].
-
- myInfo := self instanceVariableOffsets.
- otherInfo := aPrototype class instanceVariableOffsets.
- myInfo keysAndValuesDo:[:name :index |
- varIndexAssoc := otherInfo at:name ifAbsent:[].
- varIndexAssoc notNil ifTrue:[
- newInst instVarAt:index put:(aPrototype instVarAt:(varIndexAssoc value))
- ]
- ].
- indexed ifTrue:[
- 1 to:aPrototype basicSize do:[:index |
- newInst basicAt:index put:(aPrototype basicAt:index)
- ].
- ].
- ^ newInst
-
- "
- Class withoutUpdatingChangesDo:[
- Point subclass:#Point3D
- instanceVariableNames:'z'
- classVariableNames:''
- poolDictionaries:''
- category:'testing'.
- (Point3D cloneFrom:1@2) inspect.
- ]
- "
-
- "
- Class withoutUpdatingChangesDo:[
- Point variableSubclass:#Point3D
- instanceVariableNames:'z'
- classVariableNames:''
- poolDictionaries:''
- category:'testing'.
- (Point3D cloneFrom:#(1 2 3)) inspect.
- ]
- "
-
- "
- |someObject|
-
- Class withoutUpdatingChangesDo:[
- Object subclass:#TestClass1
- instanceVariableNames:'foo bar'
- classVariableNames:''
- poolDictionaries:''
- category:'testing'.
- someObject := TestClass1 new.
- someObject instVarAt:1 put:'foo'; instVarAt:2 put:'bar'.
- Object subclass:#TestClass2
- instanceVariableNames:'bar foo'
- classVariableNames:''
- poolDictionaries:''
- category:'testing'.
- (TestClass2 cloneFrom:someObject) inspect.
- ]
+ String withAllSuperclasses
"
! !
+
+!Behavior methodsFor:'snapshots'!
+
+postSnapshot
+ "sent by ObjectMemory, after a snapshot has been written.
+ Nothing done here."
+!
+
+preSnapshot
+ "sent by ObjectMemory, before a snapshot is written.
+ Nothing done here."
+! !
+
--- a/Class.st Thu Nov 23 03:13:03 1995 +0100
+++ b/Class.st Thu Nov 23 11:46:35 1995 +0100
@@ -12,10 +12,10 @@
ClassDescription subclass:#Class
instanceVariableNames:'classvars comment subclasses classFilename package revision
- history'
+ history'
classVariableNames:'UpdatingChanges LockChangesFile FileOutErrorSignal
- CatchMethodRedefinitions MethodRedefinitionSignal
- UpdateChangeFileQuerySignal'
+ CatchMethodRedefinitions MethodRedefinitionSignal
+ UpdateChangeFileQuerySignal'
poolDictionaries:''
category:'Kernel-Classes'
!
@@ -106,7 +106,7 @@
!
version
-^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.80 1995-11-23 00:26:55 cg Exp $'! !
+^ '$Header: /cvs/stx/stx/libbasic/Class.st,v 1.81 1995-11-23 10:45:55 cg Exp $'! !
!Class class methodsFor:'initialization'!
@@ -164,64 +164,6 @@
! !
-!Class class methodsFor:'helpers'!
-
-revisionInfoFromString:aString
- "return a dictionary filled with revision info.
- This extracts the relevant info from aString."
-
- |words info nm|
-
- info := IdentityDictionary new.
- words := aString asCollectionOfWords.
-
- "/
- "/ supported formats:
- "/
- "/ $-Header: pathName rev date time user state $
- "/ $-Revision: rev $
- "/ $-Id: fileName rev date time user state $
- "/
-
- ((words at:1) = '$Header:') ifTrue:[
- nm := words at:2.
- info at:#repositoryPathName put:nm.
- (nm endsWith:',v') ifTrue:[
- nm := nm copyWithoutLast:2
- ].
- info at:#fileName put:nm asFilename baseName.
- info at:#revision put:(words at:3).
- info at:#date put:(words at:4).
- info at:#time put:(words at:5).
- info at:#user put:(words at:6).
- info at:#state put:(words at:7).
- ^ info
- ].
- ((words at:1) = '$Revision:') ifTrue:[
- info at:#revision put:(words at:2).
- ^ info
- ].
- ((words at:1) = '$Id:') ifTrue:[
- info at:#fileName put:(words at:2).
- info at:#revision put:(words at:3).
- info at:#date put:(words at:4).
- info at:#time put:(words at:5).
- info at:#user put:(words at:6).
- info at:#state put:(words at:7).
- ^ info
- ].
-
- "/
- "/ mhmh - maybe its some other source code system
- "/
- SourceCodeManager notNil ifTrue:[
- ^ SourceCodeManager revisionInfoFromString:aString
- ].
- ^ nil
-
- "Created: 15.11.1995 / 14:58:35 / cg"
-! !
-
!Class class methodsFor:'accessing - flags'!
catchMethodRedefinitions
@@ -310,6 +252,64 @@
classes do:aBlock
! !
+!Class class methodsFor:'helpers'!
+
+revisionInfoFromString:aString
+ "return a dictionary filled with revision info.
+ This extracts the relevant info from aString."
+
+ |words info nm|
+
+ info := IdentityDictionary new.
+ words := aString asCollectionOfWords.
+
+ "/
+ "/ supported formats:
+ "/
+ "/ $-Header: pathName rev date time user state $
+ "/ $-Revision: rev $
+ "/ $-Id: fileName rev date time user state $
+ "/
+
+ ((words at:1) = '$Header:') ifTrue:[
+ nm := words at:2.
+ info at:#repositoryPathName put:nm.
+ (nm endsWith:',v') ifTrue:[
+ nm := nm copyWithoutLast:2
+ ].
+ info at:#fileName put:nm asFilename baseName.
+ info at:#revision put:(words at:3).
+ info at:#date put:(words at:4).
+ info at:#time put:(words at:5).
+ info at:#user put:(words at:6).
+ info at:#state put:(words at:7).
+ ^ info
+ ].
+ ((words at:1) = '$Revision:') ifTrue:[
+ info at:#revision put:(words at:2).
+ ^ info
+ ].
+ ((words at:1) = '$Id:') ifTrue:[
+ info at:#fileName put:(words at:2).
+ info at:#revision put:(words at:3).
+ info at:#date put:(words at:4).
+ info at:#time put:(words at:5).
+ info at:#user put:(words at:6).
+ info at:#state put:(words at:7).
+ ^ info
+ ].
+
+ "/
+ "/ mhmh - maybe its some other source code system
+ "/
+ SourceCodeManager notNil ifTrue:[
+ ^ SourceCodeManager revisionInfoFromString:aString
+ ].
+ ^ nil
+
+ "Created: 15.11.1995 / 14:58:35 / cg"
+! !
+
!Class methodsFor:'ST/V subclass creation'!
subclass:t instanceVariableNames:f classVariableNames:d poolDictionaries:s
@@ -1237,6 +1237,14 @@
]
!
+addChangeRecordForClassCheckIn:aClass
+ "append a class-was-checkedIn-record to the changes file"
+
+ self addInfoRecord:('checkin ' , aClass name)
+
+ "Created: 18.11.1995 / 17:04:58 / cg"
+!
+
addChangeRecordForClassComment:aClass
"add a class-comment-record to the changes file"
@@ -1256,14 +1264,6 @@
self addInfoRecord:('fileOut ' , aClass name)
!
-addChangeRecordForClassCheckIn:aClass
- "append a class-was-checkedIn-record to the changes file"
-
- self addInfoRecord:('checkin ' , aClass name)
-
- "Created: 18.11.1995 / 17:04:58 / cg"
-!
-
addChangeRecordForClassInstvars:aClass
"add a class-instvars-record to the changes file"
@@ -1472,6 +1472,17 @@
self addInfoRecord:('snapshot ' , aFileName) to:aStream
!
+addChangeTimeStampTo:aStream
+ "a timestamp - prepended to any change, except infoRecords"
+
+ |info|
+
+ info := 'timestamp ' , OperatingSystem getLoginName , '@' , OperatingSystem getHostName.
+ self addInfoRecord:info to:aStream. aStream cr.
+
+ "Created: 18.11.1995 / 15:41:01 / cg"
+!
+
addInfoRecord:aMessage
"add an info-record (snapshot, class fileOut etc.) to the changes file"
@@ -1490,17 +1501,6 @@
aStream nextPutChunkSeparator.
!
-addChangeTimeStampTo:aStream
- "a timestamp - prepended to any change, except infoRecords"
-
- |info|
-
- info := 'timestamp ' , OperatingSystem getLoginName , '@' , OperatingSystem getHostName.
- self addInfoRecord:info to:aStream. aStream cr.
-
- "Created: 18.11.1995 / 15:41:01 / cg"
-!
-
changesStream
"return a Stream for the writing changes file - or nil if no update is wanted"
@@ -1565,6 +1565,26 @@
].
!
+writingChangeDo:aBlock
+ "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"
+!
+
+writingChangePerform:aSelector with:anArgument
+ self writingChangeWithTimeStamp:true perform:aSelector with:anArgument
+
+ "Created: 28.10.1995 / 16:50:48 / cg"
+ "Modified: 18.11.1995 / 15:44:53 / cg"
+!
+
writingChangeWithTimeStamp:doStampIt do:aBlock
"common helper to write a change record.
Opens the changefile and executes aBlock passing the stream
@@ -1591,32 +1611,12 @@
"Created: 18.11.1995 / 15:36:02 / cg"
!
-writingChangeDo:aBlock
- "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"
-!
-
writingChangeWithTimeStamp:stampIt perform:aSelector with:anArgument
self writingChangeWithTimeStamp:stampIt do:[:stream |
self perform:aSelector with:anArgument with:stream.
]
"Created: 18.11.1995 / 15:44:28 / cg"
-!
-
-writingChangePerform:aSelector with:anArgument
- self writingChangeWithTimeStamp:true perform:aSelector with:anArgument
-
- "Created: 28.10.1995 / 16:50:48 / cg"
- "Modified: 18.11.1995 / 15:44:53 / cg"
! !
!Class methodsFor:'compiling'!
@@ -2795,21 +2795,6 @@
"Modified: 15.11.1995 / 14:59:34 / cg"
!
-revisionStringFromSource:aMethodSourceString
- "extract a revision string from a methods source string"
-
- |lines idx val|
-
- lines := aMethodSourceString asCollectionOfLines.
- idx := lines findFirst:[:l |
- l withoutSpaces startsWith:'$Header'
- ].
- idx == 0 ifTrue:[^ nil].
- ^ lines at:idx.
-
- "Created: 15.11.1995 / 15:01:19 / cg"
-!
-
revisionString
"return my revision string; that one is extracted from the
classes #version method. Either this is a method returning that string,
@@ -2849,6 +2834,21 @@
"Modified: 15.11.1995 / 15:01:54 / cg"
!
+revisionStringFromSource:aMethodSourceString
+ "extract a revision string from a methods source string"
+
+ |lines idx val|
+
+ lines := aMethodSourceString asCollectionOfLines.
+ idx := lines findFirst:[:l |
+ l withoutSpaces startsWith:'$Header'
+ ].
+ idx == 0 ifTrue:[^ nil].
+ ^ lines at:idx.
+
+ "Created: 15.11.1995 / 15:01:19 / cg"
+!
+
setPrimitiveSpecsAt:index to:aString
"set a primitiveSpecification component to aString"