Behavior subclass: #ProtoBehavior
	instanceVariableNames: 'shared '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Prototypes'!
!ProtoBehavior commentStamp: 'hmm 10/22/1998 21:02' prior: 0!
ProtoBehavior implements the behavior of ProtoObjects. A ProtoBehavior has simplified methods for creating and removing methods and slot accessors.
For good storage economy, ProtoBehaviors are shared between structurally similar ProtoObjects. When a ProtoObject is cloned, its class is set to shared.
When a ProtoObject changes structure (by adding/removing slots or methods) it checks to see whether its class is shared. If it is, a new ProtoBehavior is created for this now structurally different object. This new ProtoBehavior is owned, so further structural changes don't create new ProtoBehaviors.

Implementation detail: Methods stored in ProtoBehaviors 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.!
]style[(41 11 241 6 234 5 480)f1,f1LProtoObject Comment;,f1,f1b,f1,f1b,f1!


!ProtoBehavior methodsFor: 'instance creation' stamp: 'hmm 10/21/1998 21:24'!
basicNew: anInteger
	self error: 'disallowed'! !

!ProtoBehavior methodsFor: 'instance creation' stamp: 'hmm 10/22/1998 08:24'!
new
	self error: 'disallowed'! !

!ProtoBehavior methodsFor: 'instance creation' stamp: 'hmm 10/21/1998 21:24'!
new: anInteger
	self error: 'disallowed'! !


!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:22'!
beOwned
	shared _ false! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:21'!
beShared
	shared _ true! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/21/1998 21:38'!
classPool
	^superclass classPool! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:22'!
cloneForModifiedObject
	^self copy beOwned! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/21/1998 21:35'!
fromSuperclass: aSuperclass
	format _ aSuperclass format.
	superclass _ aSuperclass.
	methodDict _ MethodDictionary new! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:21'!
isShared
	^shared == true! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:41'!
methodNames
	^(self selectors select: [:each | (self compiledMethodAt: each) last < 250]) asSortedCollection! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/21/1998 21:38'!
sharedPools
	^superclass sharedPools! !

!ProtoBehavior methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:41'!
slotNames
	^(self selectors select: [:each | (self compiledMethodAt: each) last = 250]) asSortedCollection! !


!ProtoBehavior methodsFor: 'compiling' stamp: 'hmm 10/22/1998 08:59'!
compile: aString
	^self
		compile: aString
		withMarker: 0! !

!ProtoBehavior methodsFor: 'compiling' stamp: 'hmm 10/22/1998 08:59'!
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! !

!ProtoBehavior methodsFor: 'compiling' stamp: 'hmm 10/22/1998 08:30'!
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.
	! !


Inspector subclass: #ProtoInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Prototypes'!
!ProtoInspector commentStamp: 'hmm 10/22/1998 20:58' prior: 0!
This special inspector serves as a user interface for ProtoObjects. It displays slots and methods in an intuitive way. Note that it does not work very well in the Morphic environment.!
]style[(54 11 118)f1,f1LProtoObject Comment;,f1!


!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 09:28'!
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! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 20:04'!
contentsForSlotName: slotName
	slotName = 'self' ifTrue: [^object printString].
	slotName = self slotsHeading
		ifTrue: [^'Enter slot value to create a new slot'].
	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! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 19:55'!
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)! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 09:10'!
fieldList
	^OrderedCollection new
		add: 'self';
		add: self slotsHeading;
		addAll: object slotNames;
		add: self methodsHeading;
		addAll: object methodNames;
		yourself! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 20:20'!
fieldListMenu: aMenu

	^ aMenu labels: 'inspect
inspect references
clone
remove slot/method
update
'
	lines: #(3 4)
	selections: #(inspectSelection objectReferencesToSelection inspectClone  removeSlot updateFieldList).
! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 09:31'!
inspectClone
	^self selection clone inspect! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:09'!
methodsHeading
	^'--- methods ---' asText allBold! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:28'!
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! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 09:19'!
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)]]! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 20:11'!
selectedSlotName
	selectionIndex = 0 ifTrue: [^nil].
	^self fieldList atPin: selectionIndex! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 20:14'!
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 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! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:09'!
slotsHeading
	^'--- slots ---' asText allBold! !

!ProtoInspector methodsFor: 'as yet unclassified' stamp: 'hmm 10/22/1998 10:42'!
updateFieldList
	| slotName |
	slotName _ self selectedSlotName.
	selectionIndex _ 0.
	self changed: #fieldList.
	self toggleIndex: (self fieldList indexOf: slotName)! !


Object subclass: #ProtoObject
	instanceVariableNames: 'slots '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Prototypes'!
!ProtoObject commentStamp: '<historical>' prior: 0!
ProtoObjects are objects with instance-specific behavior and structure. You can add and remove slots at any time with the messages
	ProtoObject addSlot:
	ProtoObject addSlot:withValue:
	ProtoObject removeSlot:
Added slots are accessible with standard getter/setter messages.
Methods can be added and removed with
	ProtoObject addMethod:
	ProtoObject removeMethod:
ProtoObjects have a class which is an instance of ProtoBehavior. Look there for the internals of behavior sharing.

An example structure of ProtoObjects: execute ProtoObject exampleFamily.!
]style[(132 20 2 30 2 23 105 22 2 25 51 13 99 25 1)f1,f1LProtoObject addSlot:;,f1,f1LProtoObject addSlot:withValue:;,f1,f1LProtoObject removeSlot:;,f1,f1LProtoObject addMethod:;,f1,f1LProtoObject removeMethod:;,f1,f1LProtoBehavior Comment;,f1,f1dProtoObject exampleFamily;;,f1!


!ProtoObject methodsFor: 'private' stamp: 'hmm 10/22/1998 08:35'!
ownClass
	| newClass |
	self class isShared ifTrue: [
		newClass _ self class cloneForModifiedObject.
		self become: (newClass basicNew slots: slots)].
	^self class! !

!ProtoObject methodsFor: 'private' stamp: 'hmm 10/22/1998 08:18'!
privatePostClone
	slots _ slots clone! !

!ProtoObject methodsFor: 'private' stamp: 'hmm 10/21/1998 21:23'!
slots: anArray
	slots _ anArray! !


!ProtoObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/22/1998 08:59'!
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! !

!ProtoObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/21/1998 21:20'!
addSlot: aString
	^self addSlot: aString withValue: nil! !

!ProtoObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/22/1998 08:25'!
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! !

!ProtoObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/22/1998 10:11'!
removeMethod: aSymbol
	self ownClass removeSelector: aSymbol! !

!ProtoObject methodsFor: 'slot adding/removing' stamp: 'hmm 10/22/1998 10:13'!
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! !


!ProtoObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:40'!
methodNames
	^self class methodNames! !

!ProtoObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:42'!
methodSourceAt: aSymbol
	^self class sourceCodeAt: aSymbol! !

!ProtoObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 09:32'!
name
	^'a Protoype Object'! !

!ProtoObject methodsFor: 'accessing' stamp: 'hmm 10/22/1998 08:40'!
slotNames
	^self class slotNames! !


!ProtoObject methodsFor: 'inspecting' stamp: 'hmm 10/22/1998 09:33'!
defaultLabelForInspector
	^self name! !

!ProtoObject methodsFor: 'inspecting' stamp: 'hmm 10/21/1998 22:06'!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."

	ProtoInspector openOn: self withEvalPane: true! !


!ProtoObject methodsFor: 'cloning' stamp: 'hmm 10/22/1998 08:34'!
clone
	self class beShared.
	^super clone
		privatePostClone;
		postClone;
		yourself! !

!ProtoObject methodsFor: 'cloning' stamp: 'hmm 10/22/1998 08:19'!
postClone
	"instances can define something else"! !


!ProtoObject methodsFor: 'printing' stamp: 'hmm 10/22/1998 20:22'!
printOn: aStream
	aStream nextPutAll: self name! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtoObject class
	instanceVariableNames: ''!

!ProtoObject class methodsFor: 'instance creation' stamp: 'hmm 10/22/1998 08:24'!
new
	"Objects are instantiated with no slots"
	^self newProtoBehavior basicNew slots: #()! !

!ProtoObject class methodsFor: 'instance creation' stamp: 'hmm 10/22/1998 08:23'!
newProtoBehavior
	"Create a new ProtoBehavior for a cloned object"
	^ProtoBehavior new fromSuperclass: self! !


!ProtoObject class methodsFor: 'examples' stamp: 'hmm 10/22/1998 20:40'!
exampleFamily
	"ProtoObject 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! !