'From Squeak3.4 of 1 March 2003 [latest update: #5170] on 28 March 2003 at 3:11:22 pm'! "Change Set: KCP-0011- Date: 28 March 2003 Author: stephane ducasse, alexandre bergel, and nathanael schaerli Changes all the references to Smalltalk by self environment in the class Behavior"! !Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName _ self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName _ obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! ! !Behavior methodsFor: 'accessing' stamp: 'sd 3/28/2003 15:07'! confirmRemovalOf: aSelector "Determine if it is okay to remove the given selector. Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed." | count aMenu answer caption allCalls | allCalls _ self environment allCallsOn: aSelector. (count _ allCalls size) == 0 ifTrue: [^ 1]. "no senders -- let the removal happen without warning" count == 1 ifTrue: [ (allCalls first actualClass == self and: [allCalls first methodSymbol == aSelector]) ifTrue: [^ 1] ]. "only sender is itself" aMenu _ PopUpMenu labels: 'Remove it Remove, then browse senders Don''t remove, but show me those senders Forget it -- do nothing -- sorry I asked'. caption _ 'This message has ', count printString, ' sender'. count > 1 ifTrue: [caption _ caption copyWith: $s]. answer _ aMenu startUpWithCaption: caption. answer == 3 ifTrue: [ Smalltalk browseMessageList: allCalls name: 'Senders of ', aSelector autoSelect: aSelector keywords first ]. answer == 0 ifTrue: [answer _ 3]. "If user didn't answer, treat it as cancel" ^ answer min: 3! ! !Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07'! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(self environment compactClassesArray includes: self) or:[(self environment specialObjectsArray includes: self) or:[self isKindOf: self]]! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'sd 3/28/2003 15:07'! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" self environment signalLowSpace. ^ self basicNew "retry if user proceeds" ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." self environment signalLowSpace. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames _ SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 3/28/2003 15:06'! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" ^ self environment allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 3/28/2003 15:07'! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b | byte _ b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:05'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. self withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel == #DoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:05'! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." | aSet special byte cls | aSet _ Set new. cls _ self theNonMetaClass. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. cls withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. cls class withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. ^aSet! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:06'! browseAllAccessesTo: instVarName "Collection browseAllAccessesTo: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [ self withAllSubAndSuperclassesDo: [:class | (class whichSelectorsAccess: instVarName) do: [:sel | sel == #DoIt ifFalse: [ coll add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ]. ^ self environment browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:07'! browseAllCallsOn: aSymbol "Create and schedule a Message Set browser for all the methods that call on aSymbol." | key label | label _ (aSymbol isKindOf: LookupKey) ifTrue: ['Users of ' , (key _ aSymbol key)] ifFalse: ['Senders of ' , (key _ aSymbol)]. ^ self environment browseMessageList: (self allCallsOn: aSymbol) name: label autoSelect: key "Number browseAllCallsOn: #/."! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:07'! browseAllStoresInto: instVarName "Collection browseAllStoresInto: 'contents'." "Create and schedule a Message Set browser for all the receiver's methods or any methods of a subclass that refer to the instance variable name." | coll | coll _ OrderedCollection new. Cursor wait showWhile: [ self withAllSubAndSuperclassesDo: [:class | (class whichSelectorsStoreInto: instVarName) do: [:sel | sel == #DoIt ifFalse: [ coll add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ]. ^ self environment browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index _ cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeUncompact | cct index | cct _ self environment compactClassesArray. (index _ self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format _ format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! !