"====================================================================== | | Behavior Method Definitions | | $Revision: 1.7.5$ | $Date: 2000/05/28 16:56:52$ | $Author: pb$ | ======================================================================" "====================================================================== | | Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc. | Written by Steve Byrne. | | This file is part of the GNU Smalltalk class library. | | The GNU Smalltalk class library is free software; you can redistribute it | and/or modify it under the terms of the GNU Lesser General Public License | as published by the Free Software Foundation; either version 2.1, or (at | your option) any later version. | | The GNU Smalltalk class library is distributed in the hope that it will be | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser | General Public License for more details. | | You should have received a copy of the GNU Lesser General Public License | along with the GNU Smalltalk class library; see the file COPYING.LESSER. | If not, write to the Free Software Foundation, 59 Temple Place - Suite | 330, Boston, MA 02111-1307, USA. | ======================================================================" Object subclass: #Behavior instanceVariableNames: 'superClass subClasses methodDictionary instanceSpec instanceVariables' classVariableNames: '' poolDictionaries: '' category: 'Language-Implementation' ! Behavior comment: 'I am the parent class of all "class" type methods. My instances know about the subclass/superclass relationships between classes, contain the description that instances are created from, and hold the method dictionary that''s associated with each class. I provide methods for compiling methods, modifying the class inheritance hierarchy, examining the method dictionary, and iterating over the class hierarchy.' ! !Behavior class methodsFor: 'C interface'! defineCFunc: cFuncNameString withSelectorArgs: selectorAndArgs forClass: aClass returning: returnTypeSymbol args: argsArray "Lookup the part on the C interface in this manual -- it is too complex to describe it here ;-) Anyway this is private and kept for backward com- patibility. You should use defineCFunc:withSelectorArgs:returning:args: which also checks if the function is present in the DLD libraries." | code gensym descriptor | "This is pretty complex. What I want to provide is a very efficient way of calling a C function. I create a descriptor object that holds the relevant information regarding the C function. I then compile the method that's to be invoked to call the C function. This method uses the primitive #255 to perform the actual call-out. To let the primitive know which descriptor to use, I arrange for the first and only method literal of the compiled method to be an association that contains as its value the C function descriptor object. I add new associations to the global shared pool 'CFunctionDescs', and reference the newly generated key in the text of the compiled method." gensym := ('CFunction' , CFunctionGensym printString) asSymbol. descriptor := self makeDescriptorFor: cFuncNameString returning: returnTypeSymbol withArgs: argsArray. descriptor isValid ifFalse: [ ('C function ', cFuncNameString, ' not defined') printNl ]. CFunctionDescs at: gensym put: descriptor. CFunctionGensym := CFunctionGensym + 1. code := ('%1 "C call-out to %2. Do not modify!" ^%3') bindWith: selectorAndArgs with: cFuncNameString with: gensym asString. ^aClass compile: code ! ! !Behavior methodsFor: 'instance variables'! addInstVarName: aString "Add the given instance variable to instance of the receiver" instanceVariables := instanceVariables copyWith: aString. instanceSpec := instanceSpec + 4096. "Highly implementation specific" self updateInstanceVars: instanceVariables variable: self isVariable words: self isWords pointers: self isPointers ! removeInstVarName: aString "Remove the given instance variable from the receiver and recompile all of the receiver's subclasses" instanceVariables := instanceVariables copyWithout: aString. instanceSpec := instanceSpec - 4096. "Highly implementation specific" self asClass compileAll; compileAllSubclasses. self asMetaclass compileAll; compileAllSubclasses. self updateInstanceVars: instanceVariables variable: self isVariable words: self isWords pointers: self isPointers ! ! !Behavior methodsFor: 'creating method dictionary'! createGetMethod: what default: value "Create a method accessing the variable `what', with a default value of `value', using lazy initialization" ^self compile: ('%1 "Answer the receiver''s %1. Its default value is %2" %1 isNil ifTrue: [ %1 := %2 ]. ^%1' bindWith: what with: value) ! createGetMethod: what "Create a method accessing the variable `what'." ^self compile: ('%1 "Answer the receiver''s %1" ^%1' bindWith: what) ! createSetMethod: what "Create a method which sets the variable `what'." | parameter | parameter := (what = 'value') ifTrue: [ 'theValue' ] ifFalse: [ 'value' ]. ^self compile: ('%1: %2 "Set the receiver''s %1 to %2" %1 := %2' bindWith: what with: parameter) ! defineCFunc: cFuncNameString withSelectorArgs: selectorAndArgs returning: returnTypeSymbol args: argsArray "Lookup the C interface in the manual. Too complex to describe it here ;-)" ^Behavior defineCFunc: cFuncNameString withSelectorArgs: selectorAndArgs forClass: self returning: returnTypeSymbol args: argsArray ! methodDictionary "Answer the receiver's method dictionary. Don't modify the method dictionary unless you exactly know what you're doing" ^methodDictionary ! methodDictionary: aDictionary "Set the receiver's method dictionary to aDictionary" | newDictionary | newDictionary := aDictionary collect: [ :each | each withNewMethodClass: self ]. aDictionary become: newDictionary. Behavior flushCache. methodDictionary := aDictionary. ! addSelector: selector withMethod: compiledMethod "Add the given compiledMethod to the method dictionary, giving it the passed selector. Answer compiledMethod" methodDictionary isNil ifTrue: [ methodDictionary := MethodDictionary new ]. ^methodDictionary at: selector put: (compiledMethod withNewMethodClass: self selector: selector). ! removeSelector: selector "Remove the given selector from the method dictionary, answer the CompiledMethod attached to that selector" ^self removeSelector: selector ifAbsent: [ self error: 'selector not found' ] ! removeSelector: selector ifAbsent: aBlock "Remove the given selector from the method dictionary, answer the CompiledMethod attached to that selector. If the selector cannot be found, answer the result of evaluating aBlock." methodDictionary isNil ifTrue: [ ^aBlock value ]. (methodDictionary includesKey: selector) ifFalse: [ ^aBlock value ]. ^methodDictionary removeKey: selector ifAbsent: [ self error: 'huh?!?' ] ! compile: code "Compile method source. If there are parsing errors, answer nil. Else, return a CompiledMethod result of compilation" (code isKindOf: PositionableStream) ifTrue: [ ^self compileString: code contents ]. (code isMemberOf: String) ifFalse: [ ^self compileString: code asString ]. ^self compileString: code ! compile: code ifError: block "Compile method source. If there are parsing errors, invoke exception block, 'block' passing file name, line number and error. description. Return a CompiledMethod result of compilation" (code isKindOf: PositionableStream) ifTrue: [ ^self compileString: code contents ifError: block ]. (code isMemberOf: String) ifFalse: [ ^self compileString: code asString ifError: block ]. ^self compileString: code ifError: block. ! compile: code notifying: requestor "Compile method source. If there are parsing errors, send #error: to the requestor object, else return a CompiledMethod result of compilation" | method | method := self compile: code. method isNil ifTrue: [ ^requestor error: 'Compilation failed' ]. ^method ! compileAllSubclasses: aNotifier "Recompile all selector of all subclasses. Notify aNotifier by sen- ding #error: messages if something goes wrong." self allSubclassesDo: [ :subclass | subclass compileAll: aNotifier ] ! compileAllSubclasses "Recompile all selector of all subclasses. Notify aNotifier by sen- ding #error: messages if something goes wrong." self allSubclassesDo: [ :subclass | subclass compileAll ] ! recompile: selector "Recompile the given selector, answer nil if something goes wrong or the new CompiledMethod if everything's ok." Transcript nextPutAll: 'Recompiling selector: '; print: selector asSymbol; nl. ^self compile: (self sourceCodeAt: selector) classified: (self compiledMethodAt: selector) methodCategory. ! recompile: selector notifying: aNotifier "Recompile the given selector. If there are parsing errors, send #error: to the aNotifier object, else return a CompiledMethod result of compilation" Transcript nextPutAll: 'Recompiling selector: '; print: selector asSymbol; nl. ^self compile: (self sourceCodeAt: selector) classified: ((self compiledMethodAt: selector) methodCategory) notifying: aNotifier. ! decompile: selector "Decompile the bytecodes for the given selector." | method source | method := self compiledMethodAt: selector. source := method methodSourceString. source isNil ifTrue: [ Decompiler decompile: selector in: self ] ifFalse: [ ^source ] ! edit: selector "Open Emacs to edit the method with the passed selector, then compile it" | method sourceFile sourcePos | method := self compiledMethodAt: selector. sourceFile := method methodSourceFile. sourceFile isNil ifTrue: [ ^self error: 'decompiler can''t edit methods without source' ]. sourcePos := method methodSourcePos. Smalltalk system: 'emacs -l st -smalltalk ', sourceFile, ' ', sourcePos printString " Possible Windows code follows: "" method := self >> selector. sourceFile := method methodSourceCode asString. sourcePos := sourceFile size. (sourceFile at: sourcePos) = $! ifTrue: [ sourcePos := sourcePos - 1 ]. (FileStream open: 'st.tmp' mode: FileStream write) nextPutAll: (sourceFile copyFrom: 1 to: sourcePos); close. Smalltalk system: 'notepad st.tmp'. sourceFile := FileStream open: 'st.tmp' mode: FileStream read. self compile: sourceFile contents. sourceFile close. (self >> selector) methodCategory: method methodCategory. Smalltalk system: 'del st.tmp' " ! compileAll "Recompile all selectors in the receiver. Ignore errors." Transcript nextPutAll: 'Recompiling class: '; print: self; nl. methodDictionary notNil ifTrue: [ methodDictionary keysDo: [ :selector | self recompile: selector ] ] ! compileAll: aNotifier "Recompile all selectors in the receiver. Notify aNotifier by sen- ding #error: messages if something goes wrong." Transcript nextPutAll: 'Recompiling class: '; print: self; nl. methodDictionary notNil ifTrue: [ methodDictionary keysDo: [ :selector | self recompile: selector notifying: aNotifier] ] ! ! !Behavior methodsFor: 'evaluating'! evalString: aString to: anObject "Answer the stack top at the end of the evaluation of the code in aString. The code is executed as part of anObject" | s result next method | s := ReadStream on: aString. [ next := self extractEvalChunk: s. method := anObject class compileString: 'Doit ^ [ ', next, ' ] value ' ifError: [ :fname :line :error | nil ]. method isNil | (next allSatisfy: [ :each | each = Character space ]) ifFalse: [ [ result := anObject Doit ] valueWithUnwind ]. s atEnd ] whileFalse. "anObject class removeSelector: #Doit." ^result ! evalString: aString to: anObject ifError: aBlock "Answer the stack top at the end of the evaluation of the code in aString. If aString cannot be parsed, evaluate aBlock (see compileString:ifError:). The code is executed as part of anObject" | s result next method | s := ReadStream on: aString. [ next := self extractEvalChunk: s. method := anObject class compileString: 'Doit ^ [ ', next, ' ] value ' ifError: [:fname :lineNo :errorString | aBlock value: fname value: lineNo - 1 value: errorString. nil ]. method isNil | (next allSatisfy: [ :each | each = Character space ]) ifFalse: [ [ result := anObject Doit ] valueWithUnwind ]. s atEnd ] whileFalse. "anObject class removeSelector: #Doit." ^result ! evaluate: code "Evaluate Smalltalk expression in 'code' and return result." (code isKindOf: PositionableStream) ifTrue: [ ^self evalString: code contents to: nil ]. (code isMemberOf: String) ifFalse: [ ^self evalString: code asString to: nil ]. ^self evalString: code to: nil ! evaluate: code ifError: block "Evaluate 'code'. If a parsing error is detected, invoke 'block'" (code isKindOf: PositionableStream) ifTrue: [ ^self evalString: code contentsto: nil ifError: block ]. (code isMemberOf: String) ifFalse: [ ^self evalString: code asString to: nil ifError: block ]. ^self evalString: code to: nil ifError: block. ! evaluate: code to: anObject ifError: block "Evaluate Smalltalk expression as part of anObject's method definition. This method is used to support Inspector expression evaluation. If a parsing error is encountered, invoke error block, 'block'" (code isKindOf: PositionableStream) ifTrue: [ ^self evalString: code contents to: anObject ifError: block ]. (code isMemberOf: String) ifFalse: [ ^self evalString: code asString to: anObject ifError: block ]. ^self evalString: code to: anObject ifError: block. ! evaluate: code to: anObject "Evaluate Smalltalk expression as part of anObject's method definition" (code isKindOf: PositionableStream) ifTrue: [ ^self evalString: code contents to: anObject ]. (code isMemberOf: String) ifFalse: [ ^self evalString: code asString to: anObject ]. ^self evalString: code to: anObject. ! evaluate: code notifying: requestor "Evaluate Smalltalk expression in 'code'. If a parsing error is encountered, invoke error block, 'block'" | method aStream | ^self evaluate: code ifError: [:fname :lineNo :errorString | requestor error: ('line ', lineNo printString, ': ' , errorString) ]. ! ! !Behavior methodsFor: 'creating a class hierarchy'! superclass: aClass "Set the receiver's superclass." superClass := aClass. instanceSpec isNil ifTrue: [ instanceSpec := aClass isNil ifTrue: [ 0 ] ifFalse: [ aClass instanceSpec ] ]. ! addSubclass: aClass "Add aClass asone of the receiver's subclasses." subClasses isNil ifTrue: [ subClasses := Array new: 0 ] ifFalse: [ "remove old class if any" subClasses := subClasses copyWithout: aClass ]. subClasses := subClasses copyWith: aClass ! removeSubclass: aClass "Remove aClass from the list of the receiver's subclasses" subClasses := subClasses copyWithout: aClass ! ! !Behavior methodsFor: 'accessing the methodDictionary'! selectors "Answer a Set of the receiver's selectors" methodDictionary isNil ifTrue: [ ^Set new ] ifFalse: [ ^methodDictionary keys ] ! allSelectors "Answer a Set of all the selectors understood by the receiver" | aSet | aSet := self selectors. self allSuperclassesDo: [ :superclass | aSet addAll: superclass selectors ]. ^aSet ! compiledMethodAt: selector "Return the compiled method associated with selector, from the local method dictionary. Error if not found." methodDictionary isNil ifTrue: [ self error: 'key not found' ]. ^methodDictionary at: selector ! >> selector "Return the compiled method associated with selector, from the local method dictionary. Error if not found." methodDictionary isNil ifTrue: [ self error: 'key not found' ]. ^methodDictionary at: selector ! selectorAt: method "Return selector for the given compiledMethod" ^methodDictionary keyAtValue: method. ! sourceCodeAt: selector "Answer source code (if available) for the given compiledMethod" | source | source := (self compiledMethodAt: selector) methodSourceCode. source isNil ifTrue: [ '" *** SOURCE CODE NOT AVAILABLE *** "' copy ]. ^source asString ! sourceMethodAt: selector "This is too dependent on the original implementation" self shouldNotImplement ! ! !Behavior methodsFor: 'accessing instances and variables'! allInstances "Returns a set of all instances of the receiver" | result weakResult anInstance | result := WriteStream on: (Array new: 100). anInstance := self someInstance. [ anInstance notNil ] whileTrue: [ result nextPut: anInstance. anInstance := anInstance nextInstance ]. result := result contents. weakResult := WeakArray new: result size. 1 to: result size do: [ :i | weakResult at: i put: (result at: i) ]. ^weakResult ! instanceCount "Return a count of all the instances of the receiver" | count anInstance | count := 0. anInstance := self someInstance. [ anInstance notNil ] whileTrue: [ count := count + 1. anInstance := anInstance nextInstance ]. ^count ! instVarNames "Answer an Array containing the instance variables defined by the receiver" | superVars | instanceVariables isNil ifTrue: [ ^#() ]. superClass isNil ifTrue: [ ^instanceVariables copy ] ifFalse: [ superVars := superClass allInstVarNames. ^instanceVariables copyFrom: superVars size+1 to: instanceVariables size ] ! subclassInstVarNames "Answer the names of the instance variables the receiver inherited from its superclass" | superVars | instanceVariables isNil ifTrue: [ ^#() ]. superClass isNil ifTrue: [ ^#() ]. ^superClass allInstVarNames. ! allInstVarNames "Answer the names of every instance variables the receiver contained in the receiver's instances" ^instanceVariables isNil ifTrue: [#()] ifFalse: [instanceVariables]. ! classVarNames "Answer all the class variables for instances of the receiver" ^self superclass isNil ifTrue: [ #() ] ifFalse: [ self superclass classVarNames ] ! allClassVarNames "Return all the class variables understood by the receiver" | result | result := WriteStream with: self classVarNames. self allSuperclassesDo: [ :each | result nextPutAll: each classVarNames ]. ^result contents ! classPool "Answer the class pool dictionary. Since Behavior does not support classes with class variables, we answer an empty one; adding variables to it results in an error." ^Dictionary new makeReadOnly: true; yourself ! sharedPools "Return the names of the shared pools defined by the class" ^self superclass isNil ifTrue: [ #() ] ifFalse: [ self superclass sharedPools ] ! allSharedPools "Return the names of the shared pools defined by the class and any of its superclasses" | result | result := self sharedPools asSet. self environment withAllSuperspacesDo: [ :each | result add: each name asSymbol ]. self allSuperclassesDo: [ :each | result addAll: each sharedPools ]. ^result asArray ! ! !Behavior methodsFor: 'accessing class hierarchy'! subclasses "Answer the direct subclasses of the receiver in a Set" subClasses isNil ifTrue: [ ^Set new ] ifFalse: [ ^subClasses asSet ] ! allSubclasses "Answer the direct and indirect subclasses of the receiver in a Set" | aSet | aSet := Set new. self allSubclassesDo: [ :subclass | aSet add: subclass ]. ^aSet ! withAllSubclasses "Answer a Set containing the receiver together with its direct and indirect subclasses" | aSet | aSet := Set with: self. aSet addAll: (self allSubclasses). ^aSet ! superclass "Answer the receiver's superclass (if any, otherwise answer nil)" ^superClass ! withAllSuperclasses "Answer the receiver and all of its superclasses in a collection" | supers | supers := OrderedCollection with: self. self allSuperclassesDo: [ :superclass | supers addLast: superclass ]. ^supers ! allSuperclasses "Answer all the receiver's superclasses in a collection" | supers | supers := OrderedCollection new. self allSuperclassesDo: [ :superclass | supers addLast: superclass ]. ^supers ! ! !Behavior methodsFor: 'testing the method dictionary'! whichSelectorsReferToByteCode: aByteCode "Return the collection of selectors in the class which reference the byte code, aByteCode" | s method specialSelector | s := Set new. methodDictionary isNil ifTrue: [ ^s ]. methodDictionary associationsDo: [ :assoc | method := assoc value. ((1 to: method numBytecodes) detect: [ :i | aByteCode = (method bytecodeAt: i)] ifNone: [0]) > 0 ifTrue: [ s add: assoc key ]. ]. ^s ! hasMethods "Return whether the receiver has any methods defined" ^methodDictionary notNil and: [ methodDictionary size ~= 0 ] ! includesSelector: selector "Returns true if the local method dictionary contains the given selector" ^methodDictionary notNil and: [ methodDictionary includesKey: selector ] ! canUnderstand: selector "Returns true if the instances of the receiver understand the given selector" (self includesSelector: selector) ifTrue: [ ^true ]. self allSuperclassesDo: [ :superclass | (superclass includesSelector: selector) ifTrue: [ ^true ] ]. ^false ! whichClassIncludesSelector: selector "Answer which class in the receiver's hierarchy contains the implementation of selector used by instances of the class (nil if none does)" self withAllSuperclassesDo: [ :superclass | (superclass includesSelector: selector) ifTrue: [ ^superclass ] ]. ^nil ! whichSelectorsAccess: instVarName "Answer a Set of selectors which access the given instance variable" | md index | index := self allInstVarNames indexOf: instVarName ifAbsent: [ ^Set new ]. " ### should it raise an error?" md := self methodDictionary. md isNil ifTrue: [ ^Set new ]. ^(md select: [ :each | each accesses: index - 1 ]) keys ! whichSelectorsReferTo: anObject "Returns a Set of selectors that refer to anObject" | md | md := self methodDictionary. md isNil ifTrue: [ ^Set new ]. ^(md select: [ :each | each refersTo: anObject ]) keys ! scopeHas: name ifTrue: aBlock "If methods understood by the receiver's instances have access to a symbol named 'name', evaluate aBlock" | nameSym | nameSym := name asSymbol. (self allInstVarNames includes: nameSym) ifTrue: [ ^aBlock value ]. (self allClassVarNames includes: nameSym) ifTrue: [ ^aBlock value ]. (self environment includesKey: nameSym) ifTrue: [ ^aBlock value ] self allSharedPools do: [ :dictName | ((self environment at: dictName asSymbol) includesKey: nameSym) ifTrue: [ ^aBlock value ] ] ! ! !Behavior methodsFor: 'testing the form of the instances'! isPointers "Answer whether the instance variables of the receiver's instances are objects" ^(self instanceSpec bitAt: 4) ~= 0 ! isIdentity "Answer whether x = y implies x == y for instances of the receiver" ^false ! isImmediate "Answer whether, if x is an instance of the receiver, x copy == x" ^false ! isBits "Answer whether the instance variables of the receiver's instances are bytes or words" ^self isPointers not ! isBytes "Answer whether the instance variables of the receiver's instances are bytes" ^self isPointers not & self isWords not ! isWords "Answer whether the instance variables of the receiver's instances are words" ^(self instanceSpec bitAt: 3) ~= 0 ! isFixed "Answer whether the receiver's instances have no indexed instance variables" ^self isVariable not ! isVariable "Answer whether the receiver's instances have indexed instance variables" ^(self instanceSpec bitAt: 2) ~= 0 ! instSize "Answer how many fixed instance variables are reserved to each of the receiver's instances" ^self instanceSpec bitShift: -12 ! ! !Behavior methodsFor: 'testing the class hierarchy'! inheritsFrom: aClass "Returns true if aClass is a superclass of the receiver" | sc | sc := self. [ sc := sc superclass. sc isNil ] whileFalse: [ sc == aClass ifTrue: [ ^true ] ]. ^false ! kindOfSubclass "Return a string indicating the type of class the receiver is" self isVariable ifFalse: [ ^'subclass: ' ]. self isBytes ifTrue: [ ^'variableByteSubclass: ' ]. ^self isPointers ifTrue: [ 'variableSubclass: ' ] ifFalse: [ 'variableWordSubclass: ' ] ! ! !Behavior methodsFor: 'enumerating'! allSubclassesDo: aBlock "Invokes aBlock for all subclasses, both direct and indirect." subClasses notNil ifTrue: [ subClasses do: [ :class | aBlock value: class. class allSubclassesDo: aBlock ] ] ! allSuperclassesDo: aBlock "Invokes aBlock for all superclasses, both direct and indirect." | class superclass | class := self. [ superclass := class superclass. class := superclass. superclass notNil ] whileTrue: [ aBlock value: superclass ] ! withAllSubclassesDo: aBlock "Invokes aBlock for the receiver and all subclasses, both direct and indirect." aBlock value: self. subClasses notNil ifTrue: [ subClasses do: [ :subclass | aBlock value: subclass. subclass allSubclassesDo: aBlock ] ] ! withAllSuperclassesDo: aBlock "Invokes aBlock for the receiver and all superclasses, both direct and indirect." | class | class := self. [ aBlock value: class. class := class superclass. class notNil ] whileTrue ! allInstancesDo: aBlock "Invokes aBlock for all instances of the receiver" self allInstances do: [ :each | each isNil ifFalse: [ aBlock value: each ] ] ! allSubinstancesDo: aBlock "Invokes aBlock for all instances of each of the receiver's subclasses." self allSubclassesDo: [ :subclass | subclass allInstancesDo: aBlock ] ! selectSubclasses: aBlock "Return a Set of subclasses of the receiver satisfying aBlock." | aSet | aSet := Set new. self allSubclassesDo: [ :subclass | (aBlock value: subclass) ifTrue: [ aSet add: subclass ] ]. ^aSet ! selectSuperclasses: aBlock "Return a Set of superclasses of the receiver satisfying aBlock." | aSet | aSet := Set new. self allSuperclassesDo: [ :superclass | (aBlock value: superclass) ifTrue: [ aSet add: superclass ] ]. ^aSet ! subclassesDo: aBlock "Invokes aBlock for all direct subclasses." subClasses notNil ifTrue: [ subClasses do: [ :subclass | aBlock value: subclass ] ] ! ! !Behavior methodsFor: 'compilation (alternative)'! methods "Don't use this, it's only present to file in from Smalltalk/V" ^self methodsFor: 'no category' ! methodsFor "Don't use this, it's only present to file in from Dolphin Smalltalk" ^self methodsFor: 'no category' ! methodsFor: category ifFeatures: features "Start compiling methods in the receiver if this implementation of Smalltalk has the given features, else skip the section" ^self methodsFor: category ifTrue: (Smalltalk hasFeatures: features) ! methodsFor: category stamp: notUsed "Don't use this, it's only present to file in from Squeak" ^self methodsFor: category ! privateMethods "Don't use this, it's only present to file in from IBM Smalltalk" ^self methodsFor: 'private' ! publicMethods "Don't use this, it's only present to file in from IBM Smalltalk" ^self methodsFor: 'public' ! ! !Behavior methodsFor: 'support for lightweight classes'! article "Answer an article (`a' or `an') which is ok for the receiver's name" ^self superclass article ! asClass "Answer the first superclass that is a full-fledged Class object" ^self superclass asClass ! environment "Answer the namespace that this class belongs to - the same as the superclass, since Behavior does not support namespaces yet." ^self superclass environment ! nameIn: aNamespace "Answer the class name when the class is referenced from aNamespace - a dummy one, since Behavior does not support names." ^'' ! name "Answer the class name; this prints to the name of the superclass enclosed in braces. This class name is used, for example, to print the receiver." ^'{%1}' bindWith: self asClass name ! ! !Behavior methodsFor: 'private'! extractEvalChunk: aStream "Private - Extract the code in the next evaluation chunk (i.e. the code until the next bang which is outside string literals or comments)" | code ch | code := WriteStream on: (String new: 100). [ aStream atEnd ] whileFalse: [ ch := aStream next. ch = $! ifTrue: [ ^code contents ]. code nextPut: ch. ch = $" ifTrue: [ code nextPutAll: (aStream upTo: ch); nextPut: ch ]. ch = $' ifTrue: [ [ code nextPutAll: (aStream upTo: ch); nextPut: $'. aStream atEnd not and: [ aStream peekFor: ch ] ] whileTrue: [ code nextPut: ch. ] ]. ]. ^code contents ! instanceSpec ^instanceSpec ! setInstanceSpec: variableBoolean words: wordsBoolean pointers: pointersBoolean instVars: anIntegerSize "hasFinalize is cleared by this method -- should it be? " instanceSpec := 0. pointersBoolean ifTrue: [ instanceSpec := instanceSpec bitOr: ( 1 bitShift: 3 ) ]. wordsBoolean ifTrue: [ instanceSpec := instanceSpec bitOr: ( 1 bitShift: 2 ) ]. variableBoolean ifTrue: [ instanceSpec := instanceSpec bitOr: ( 1 bitShift: 1 ) ]. instanceSpec := instanceSpec bitOr: (anIntegerSize bitShift: 12). ! sharedPoolDictionaries "Return the shared pools (not the names!) defined by the class" ^self superclass sharedPoolDictionaries ! setInstanceVariables: instVariableArray instanceVariables := instVariableArray ! updateInstanceVars: variableArray variable: variableBoolean words: wordBoolean pointers: pointerBoolean "Update instance variables and instance spec of the class and all its subclasses" | instVarMap startOfInstanceVars endOfInstanceVars newInstanceVars oldInstVars map oldClass instances | startOfInstanceVars := self superclass instSize + 1. endOfInstanceVars := self instSize. newInstanceVars := variableArray copyFrom: startOfInstanceVars to: variableArray size. oldInstVars := self allInstVarNames. instVarMap := Array new: newInstanceVars size. startOfInstanceVars to: endOfInstanceVars do: [ :i | map := newInstanceVars indexOf: (oldInstVars at: i). map > 0 ifTrue: [instVarMap at: map put: i] ]. "Fix up all subclasses." self allSubclassesDo: [ :sc || iv | oldClass := Behavior new. oldClass superclass: sc. instances := sc allInstances. instances do: [ :each | each changeClassTo: oldClass ]. iv := sc allInstVarNames copyReplaceFrom: startOfInstanceVars to: endOfInstanceVars with: newInstanceVars. sc setInstanceVariables: iv. sc setInstanceSpec: sc isVariable words: sc isWords pointers: sc isPointers instVars: sc allInstVarNames size. "Mutate all instances of the class to conform to new memory model of the class." instances do: [ :each | each mutate: instVarMap startAt: startOfInstanceVars newClass: sc ] ]. "Now update this class' instance vars " oldClass := Behavior new. oldClass superclass: self. instances := self allInstances. instances do: [ :each | each changeClassTo: oldClass ]. self setInstanceVariables: variableArray. self setInstanceSpec: variableBoolean words: wordBoolean pointers: pointerBoolean instVars: variableArray size. instances do: [ :each | each mutate: instVarMap startAt: startOfInstanceVars newClass: self ]. ! !