'From Squeak2.9alpha of 13 June 2000 [latest update: #2426] on 24 July 2000 at 10:27:24 am'! Behavior subclass: #PrototypeBehavior instanceVariableNames: 'shared ' classVariableNames: '' poolDictionaries: '' category: 'System-Prototypes'! !PrototypeBehavior commentStamp: 'rca 6/23/2000 22:38' prior: 0! PrototypeBehavior implements the behavior of PrototypeObjects. A PrototypeBehavior has simplified methods for creating and removing methods and slot accessors. For good storage economy, PrototypeBehaviors are shared between structurally similar PrototypeObjects. When a PrototypeObject is cloned, its class is set to shared. When a PrototypeObject changes structure (by adding/removing slots or methods) it checks to see whether its class is shared. If it is, a new PrototypeBehavior is created for this now structurally different object. This new PrototypeBehavior is owned, so further structural changes don't create new PrototypeBehaviors. Implementation detail: Methods stored in PrototypeBehaviors are specially marked to note whether they are slot accessors or normal methods. The marking mechanism has a slight chance of colliding with the temp name storage mechanism if a lot of temp names are used. Normal methods are stored with temp names, but their source is not recorded in the changes file as there would not be a named class to associate it with.! Inspector subclass: #PrototypeInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Prototypes'! !PrototypeInspector commentStamp: '' prior: 0! This special inspector serves as a user interface for PrototypeObjects. It displays slots and methods in an intuitive way. Note that it does not work very well in the Morphic environment.! Object subclass: #PrototypeObject instanceVariableNames: 'slots delegates ' classVariableNames: '' poolDictionaries: '' category: 'System-Prototypes'! !PrototypeObject commentStamp: '' prior: 0! PrototypeObjects are objects with instance-specific behavior and structure. You can add and remove slots at any time with the messages PrototypeObject addSlot: PrototypeObject addSlot:withValue: PrototypeObject removeSlot: Added slots are accessible with standard getter/setter messages. Methods can be added and removed with PrototypeObject addMethod: PrototypeObject removeMethod: PrototypeObjects have a class which is an instance of PrototypeBehavior. Look there for the internals of behavior sharing. An example structure of PrototypeObjects: execute PrototypeObject exampleFamily.! PrototypeObject class instanceVariableNames: ''! !PrototypeBehavior methodsFor: 'instance creation' stamp: 'hmm 10/21/1998 21:24'! basicNew: anInteger self error: 'disallowed'! ! !PrototypeBehavior methodsFor: 'instance creation' stamp: 'hmm 10/22/1998 08:24'! new self error: 'disallowed'! ! !PrototypeBehavior methodsFor: 'instance creation' stamp: 'hmm 10/21/1998 21:24'! new: anInteger self error: 'disallowed'! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:22'! beOwned shared _ false! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:21'! beShared shared _ true! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/21/1998 21:38'! classPool ^superclass classPool! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:22'! cloneForModifiedObject ^self copy beOwned! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'rca 7/23/2000 18:23'! delegateNames ^(self selectors select: [:each | (self compiledMethodAt: each) last = 252]) asSortedCollection! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'rca 7/23/2000 22:09'! fromSuperclass: aSuperclass format _ aSuperclass format. superclass _ aSuperclass. methodDict _ MethodDictionary new! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:21'! isShared ^shared == true! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:41'! methodNames ^(self selectors select: [:each | (self compiledMethodAt: each) last < 250]) asSortedCollection! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/21/1998 21:38'! sharedPools ^superclass sharedPools! ! !PrototypeBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:41'! slotNames ^(self selectors select: [:each | (self compiledMethodAt: each) last = 250]) asSortedCollection! ! !PrototypeBehavior methodsFor: 'compiling' stamp: 'rca 7/23/2000 22:09'! compile: aString ^self compile: aString withMarker: 0! ! !PrototypeBehavior methodsFor: 'compiling' stamp: 'rca 7/23/2000 22:09'! compile: code withMarker: anInteger "Simplified version for prototypes" | methodNode selector method | methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [:error | self error: error]. selector _ methodNode selector. methodNode encoder requestor: nil. "Why was this not preserved?" method _ methodNode generate: (#(0 0 0) copyWith: anInteger). anInteger = 0 ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. self addSelector: selector withMethod: method. ^selector! ! !PrototypeBehavior methodsFor: 'compiling' stamp: 'rca 7/23/2000 18:23'! compileDelegate: aString index: delegateIndex self compile: aString, '^delegates at:', delegateIndex printString withMarker: 252. self compile: aString, ':obj ^delegates at:', delegateIndex printString, ' put:obj' withMarker: 253. ! ! !PrototypeBehavior methodsFor: 'compiling' stamp: 'rca 7/23/2000 18:22'! compileSlot: aString index: slotIndex self compile: aString, '^slots at:', slotIndex printString withMarker: 250. self compile: aString, ':obj ^slots at:', slotIndex printString, ' put:obj' withMarker: 251. ! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 19:02'! accept: aString | slotName selector result | slotName _ self selectedSlotName. ((object methodNames includes: slotName) or: [slotName = self methodsHeading]) ifTrue: [ selector _ object addMethod: aString. selector = slotName ifFalse: [ self changed: #fieldList. self toggleIndex: (self fieldList indexOf: selector)]. ^true]. ((object slotNames includes: slotName) or: [slotName = self slotsHeading]) ifTrue: [ result _ self doItReceiver class evaluatorClass new evaluate: (ReadStream on: aString) in: self doItContext to: self doItReceiver notifying: nil "fix this" ifFail: [^ false]. result == #failedDoit ifFalse: [contents _ result printString. self replaceSelectionValue: result. "may put contents back" self changed: #contents. ^ true]]. ^false! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 19:03'! contentsForSlotName: slotName slotName = 'self' ifTrue: [^object printString]. slotName = self slotsHeading ifTrue: [^'Enter slot value to create a new slot']. slotName = self delegatesHeading ifTrue: [^'List of delegates to this object']. slotName = self methodsHeading ifTrue: [^'method "New method in Smalltalk syntax. Remember to access slots via message sends!!"' asText makeSelectorBoldIn: object class]. (object methodNames includes: slotName) ifTrue: [^(object methodSourceAt: slotName) asText makeSelectorBoldIn: object class]. ^(object perform: slotName) printString! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:43'! contentsIsString "Hacked so contents empty when deselected and = long printString when item 2" | slotName | selectionIndex = 0 ifTrue: [^true]. slotName _ self selectedSlotName. ^ (object methodNames includes: slotName) | (self methodsHeading = slotName) | (self slotsHeading = slotName)! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:20'! delegatesHeading ^'--- delegates ---' asText allBold! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:19'! fieldList ^OrderedCollection new add: 'self'; add: self slotsHeading; addAll: object slotNames; add: self delegatesHeading; addAll: object delegateNames; add: self methodsHeading; addAll: object methodNames; yourself! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:59'! fieldListMenu: aMenu ^ aMenu labels: 'inspect inspect references clone remove slot/method update ' lines: #(3 4) selections: #(inspectSelection objectReferencesToSelection inspectClone removeSlot updateFieldList). ! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 09:31'! inspectClone ^self selection clone inspect! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:09'! methodsHeading ^'--- methods ---' asText allBold! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:59'! removeSlot | slotName | slotName _ self selectedSlotName. (object slotNames includes: slotName) ifTrue: [object removeSlot: slotName] ifFalse: [(object methodNames includes: slotName) ifTrue: [object removeMethod: slotName]]. selectionIndex _ 0. self changed: #fieldList! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 19:00'! replaceSelectionValue: anObject | slotName | slotName _ self selectedSlotName. (object slotNames includes: slotName) ifTrue: [object perform: (slotName, ':') asSymbol with: anObject] ifFalse: [ slotName _ FillInTheBlank request: 'Name of slot to store into (empty to ignore)?'. slotName isEmpty ifFalse: [ object addSlot: slotName withValue: anObject. self changed: #fieldList. self toggleIndex: (self fieldList indexOf: slotName asSymbol)]]! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 20:11'! selectedSlotName selectionIndex = 0 ifTrue: [^nil]. ^self fieldList atPin: selectionIndex! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 19:05'! selection | slotName | selectionIndex = 0 ifTrue: [^nil]. selectionIndex = 1 ifTrue: [^object]. slotName _ self selectedSlotName. slotName = self slotsHeading ifTrue: [^'Enter slot value to create a new slot']. slotName = self delegatesHeading ifTrue: [^'List of delegates to this object']. slotName = self methodsHeading ifTrue: [^'method "New method in Smalltalk syntax. Remember to access slots via message sends!!"' asText makeSelectorBoldIn: object class]. (object methodNames includes: slotName) ifTrue: [^(object methodSourceAt: slotName) asText makeSelectorBoldIn: object class]. ^object perform: slotName! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:09'! slotsHeading ^'--- slots ---' asText allBold! ! !PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 7/23/2000 18:47'! updateFieldList | slotName | slotName _ self selectedSlotName. selectionIndex _ 0. self changed: #fieldList. self toggleIndex: (self fieldList indexOf: slotName)! ! !PrototypeObject methodsFor: 'delegation' stamp: 'rca 7/23/2000 17:16'! addDelegate: aString withValue: anObject "Add a new slot with the given value. New clones of this object will also have that slot" delegates _ delegates copyWith: anObject. self ownClass compileDelegate: aString index: delegates size! ! !PrototypeObject methodsFor: 'delegation' stamp: 'rca 7/23/2000 17:50'! removeDelegate: aString "The storage for the slot is not actually removed. This is left as an exercise for the reader" | setter getter | setter _ (aString, ':') asSymbol. getter _ aString asSymbol. self perform: setter with: nil. self ownClass removeSelector: setter; removeSelector: getter. ! ! !PrototypeObject methodsFor: 'private' stamp: 'rca 7/23/2000 17:22'! delegates: anArray delegates _ anArray! ! !PrototypeObject methodsFor: 'private' stamp: 'rca 7/23/2000 21:14'! doesNotUnderstand: aMessage | method result selector | selector _ aMessage selector. delegates do: [:each | each ifNotNil: [(method _ each getCompiledMethod: selector) ifNotNil: [method last = 250 | (method last = 251) ifTrue: [^ each perform: selector withArguments: aMessage arguments] ifFalse: [self class addSelector: selector withMethod: method. result _ self perform: selector withArguments: aMessage arguments. self class removeSelector: selector. ^ result]]]]. ^ super doesNotUnderstand: aMessage! ! !PrototypeObject methodsFor: 'private' stamp: 'rca 7/23/2000 21:37'! getCompiledMethod: aSelector | temp | ^self class compiledMethodAt: aSelector ifAbsent: [ delegates do: [:each | (temp _ each getCompiledMethod: aSelector) ifNotNil: [^temp]]. ^ nil]! ! !PrototypeObject methodsFor: 'private' stamp: 'rca 7/23/2000 17:25'! ownClass | newClass | self class isShared ifTrue: [ newClass _ self class cloneForModifiedObject. self become: (newClass basicNew slots: slots; delegates: delegates)]. ^self class! ! !PrototypeObject methodsFor: 'private' stamp: 'rca 7/23/2000 17:21'! privatePostClone slots _ slots clone. delegates _ delegates clone! ! !PrototypeObject methodsFor: 'private' stamp: 'hmm 10/21/1998 21:23'! slots: anArray slots _ anArray! ! !PrototypeObject methodsFor: 'slot adding/removing' stamp: 'rca 7/23/2000 22:07'! addMethod: aString "Add a new method to the receiver, or overwrite a method of the same name. Returns the selector of the new method" ^self ownClass compile: aString! ! !PrototypeObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/21/1998 21:20'! addSlot: aString ^self addSlot: aString withValue: nil! ! !PrototypeObject methodsFor: 'slot adding/removing' stamp: 'rca 7/23/2000 22:07'! addSlot: aString withValue: anObject "Add a new slot with the given value. New clones of this object will also have that slot" slots _ slots copyWith: anObject. self ownClass compileSlot: aString index: slots size! ! !PrototypeObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/22/1998 10:11'! removeMethod: aSymbol self ownClass removeSelector: aSymbol! ! !PrototypeObject methodsFor: 'slot adding/removing' stamp: 'rca 7/23/2000 22:08'! removeSlot: aString "The storage for the slot is not actually removed. This is left as an exercise for the reader" | setter getter | setter _ (aString, ':') asSymbol. getter _ aString asSymbol. self perform: setter with: nil. self ownClass removeSelector: setter; removeSelector: getter! ! !PrototypeObject methodsFor: 'accessing' stamp: 'rca 7/23/2000 18:24'! delegateNames ^self class delegateNames! ! !PrototypeObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:40'! methodNames ^self class methodNames! ! !PrototypeObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:42'! methodSourceAt: aSymbol ^self class sourceCodeAt: aSymbol! ! !PrototypeObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 09:32'! name ^'a Protoype Object'! ! !PrototypeObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:40'! slotNames ^self class slotNames! ! !PrototypeObject methodsFor: 'inspecting' stamp: 'hmm 10/22/1998 09:33'! defaultLabelForInspector ^self name! ! !PrototypeObject methodsFor: 'inspecting' stamp: 'rca 7/23/2000 22:08'! inspect "Create and schedule an Inspector in which the user can examine the receiver's variables." PrototypeInspector openOn: self withEvalPane: true! ! !PrototypeObject methodsFor: 'cloning' stamp: 'rca 7/23/2000 22:08'! clone self class beShared. ^super clone privatePostClone; postClone; yourself! ! !PrototypeObject methodsFor: 'cloning' stamp: 'hmm 10/22/1998 08:19'! postClone "instances can define something else"! ! !PrototypeObject methodsFor: 'printing' stamp: 'hmm 10/22/1998 20:22'! printOn: aStream aStream nextPutAll: self name! ! !PrototypeObject class methodsFor: 'instance creation' stamp: 'rca 7/23/2000 17:26'! new "Objects are instantiated with no slots" ^self newPrototypeBehavior basicNew slots: #(); delegates: #()! ! !PrototypeObject class methodsFor: 'instance creation' stamp: 'hmm 10/22/1998 08:23'! newPrototypeBehavior "Create a new PrototypeBehavior for a cloned object" ^PrototypeBehavior new fromSuperclass: self! ! !PrototypeObject class methodsFor: 'examples' stamp: 'hmm 10/22/1998 20:40'! exampleFamily "PrototypeObject exampleFamily" | person child parent dad mom son daughter jimmy patty | person _ self new. person addSlot: 'name'. parent _ person clone. parent addSlot: 'children'. dad _ parent clone. dad name: 'Daddy'. mom _ parent clone. mom name: 'Mommy'. dad addSlot: 'wife' withValue: mom. mom addSlot: 'husband' withValue: dad. child _ person clone. child addSlot: 'dad' withValue: dad. child addSlot: 'mom' withValue: mom. child addMethod: 'childSpec ^''child'''. child addMethod: 'printOn: aStream aStream nextPutAll: self name; nextPutAll: '', '', self childSpec, '' of '', self dad name; nextPutAll: '' and '', self mom name'. son _ child clone. son addMethod: 'childSpec ^''son'''. daughter _ child clone. daughter addMethod: 'childSpec ^''daughter'''. jimmy _ son clone. jimmy name: 'Jimmy'. patty _ daughter clone. patty name: 'Patty'. dad children: (OrderedCollection with: jimmy with: patty). mom children: dad children copy. dad inspect! ! PrototypeObject removeSelector: #addDelegate:! PrototypeObject removeSelector: #addDelegate:called:!