'From Squeak3.7 of ''4 September 2004'' [latest update: #5989] on 9 April 2005 at 12:29:41 pm'!
"Change Set:		Prototypes
Date:			3 April 2005
Author:			Russell Allen

This is an implementation of prototype objects.

It replaces a previous implementation by Hans-Martin Mosner, which I extended (in an ugly way) to handle delegation of behaviour.  Hans-Martin's code is still available.

Filing in this changeset and running Prototype>>newPrototype will return a prototype object, that is an object without a class.

This object will understand the following basic messages:

	parent/parent:				set and retrieve the parent of the object
	addSlot:/removeSlot:			add and remove a data slot
	addMethod:/removeMethod:	add and remove a method
	clone						return a new prototype, same as the old prototype
							
Single inheritance is preserved through the parent slot.   At the moment, the prototypes must inherit (eventually) from Behavior otherwise they blow up.

The code works by creating an object which is its own class.  You can test this on a prototype:

|p|
p _ Prototype newPrototype.
p == p class

should evaluate to true.

A simple clone of a prototype creates a lightweight prototype (essentially an instance) to save memory space.  Changing anything (ie adding a slot etc) will result in the conversion to a heavyweight prototype.

At the moment, I think an image full of prototypes would be larger and slower; but I think that this penalty can be reduced (perhaps to nil).

Prototype objects can be inspected and altered in the inspector, debugging should work.

"!

ProtoObject subclass: #Prototype
	instanceVariableNames: 'superclass methodDict format'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
Inspector subclass: #PrototypeInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!PrototypeInspector commentStamp: '<historical>' 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.!

TestCase subclass: #PrototypeTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes-Tests'!

!Behavior methodsFor: 'accessing' stamp: 'rca 11/14/2003 12:09'!
format: aFormat
	"Used by the Prototyping code"

	format _ aFormat! !



!Prototype methodsFor: 'compiling' stamp: 'rca 11/16/2003 01:51'!
compile: aString

	^self
		compile: aString
		withMarker: 0! !

!Prototype methodsFor: 'compiling' stamp: 'rca 11/16/2003 01:54'!
compile: code withMarker: anInteger
	"Simplified version for prototypes"
	| methodNode selector method |

	methodNode _ Compiler 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].
	methodDict at: selector put: method.

	^selector! !

!Prototype methodsFor: 'compiling' stamp: 'rca 4/8/2005 20:03'!
compileSlot: aString index: slotIndex

	"This is to cope with both normal and lightweight(instance) prototypes" 

	self
		compile: aString, ' 
			(self class == self) "We are not a lightweight clone"
				ifTrue: [^ inst',  slotIndex asString, ']
				ifFalse: [^ inst', (slotIndex - 3) asString, ']'
		withMarker: 250.	

	self
		compile: aString, ': value 
			(self class == self) "We are not a lightweight clone"
				ifTrue: [inst',  slotIndex asString, ' _ value]
				ifFalse: [inst', (slotIndex - 3) asString, ' _ value]'
		withMarker: 251.

	! !

!Prototype methodsFor: 'private' stamp: 'rca 4/5/2005 20:19'!
basicParent

	^ superclass! !

!Prototype methodsFor: 'private' stamp: 'rca 4/5/2005 20:02'!
basicParent: aParent

	superclass _ aParent! !

!Prototype methodsFor: 'private' stamp: 'rca 4/4/2005 22:25'!
cloneFull
	"The deepCopy is so we don't share state with our clone"
	| c |
	c _ self newPrototypeSize: self slotSize.
	self deepCopyAllStateFrom: self to: c.
	^ c! !

!Prototype methodsFor: 'private' stamp: 'rca 11/16/2003 00:53'!
copyBasicStateFrom: a to: b

	1 to: 3 do: [:i | b instVarAt: i put: (a instVarAt: i)].
! !

!Prototype methodsFor: 'private' stamp: 'rca 11/16/2003 01:12'!
copyExtraStateFrom: a to: b

	a slotSize > 0 ifTrue: [
		4 to: a slotSize do: [:i | b instVarAt: i put: (a instVarAt: i)]].
! !

!Prototype methodsFor: 'private' stamp: 'rca 11/16/2003 01:21'!
deepCopyAllStateFrom: a to: b

	1 to: a instSize do: [:i | b instVarAt: i put: (a instVarAt: i) veryDeepCopy].
! !

!Prototype methodsFor: 'private' stamp: 'rca 11/16/2003 01:25'!
format: aFormat

	format _ aFormat! !

!Prototype methodsFor: 'private' stamp: 'rca 4/5/2005 19:48'!
makeStandAlone
	"Makes sure that we are a full prototype, so that we can make changes to slots, methods etc"
	| tmp |
	
	"Do we have lightweight prototypes with us as class?"
	self allInstances do: [:e |
		e == self "As we are an instance of ourself"
			ifFalse: [e makeStandAlone]].
	
	"Are we real?"
	self == self class ifTrue: [^ self].
	
	"OK, make us real"
	tmp _ self class cloneFull.
	self becomeForward: tmp.

	^ self
	! !

!Prototype methodsFor: 'private' stamp: 'rca 11/16/2003 01:20'!
methodDict: aMethodDict

	methodDict _ aMethodDict! !

!Prototype methodsFor: 'private' stamp: 'rca 4/4/2005 22:33'!
newPrototypeSize: n
	| dis ins ert |
	(dis _ self class new)
		basicParent: self; "Superclass"
		methodDict: MethodDictionary new;
		format: (ClassBuilder new
				computeFormat: #normal
				instSize: n + 3
				forSuper: nil
				ccIndex: 0).

	self copyBasicStateFrom: dis to: (ins _ dis new).
	self copyBasicStateFrom: ins to: (ert _ ins new).

	"Make us child"
	ert basicParent: self.

	"Abracadabra"
	ins becomeForward: ert.

	^ ert! !

!Prototype methodsFor: 'printing' stamp: 'rca 11/16/2003 01:42'!
printOn: aStream

	aStream nextPutAll: self name! !

!Prototype methodsFor: 'inspecting' stamp: 'rca 11/16/2003 01:41'!
defaultLabelForInspector

	^self name! !

!Prototype methodsFor: 'inspecting' stamp: 'rca 4/2/2005 21:06'!
inspectorClass

	^ PrototypeInspector! !

!Prototype methodsFor: 'access' stamp: 'rca 4/4/2005 22:23'!
addMethod: code
	
	self makeStandAlone.
	self compile: code! !

!Prototype methodsFor: 'access' stamp: 'rca 11/16/2003 01:39'!
addSlot: name

	^ self addSlot: name withValue: nil

! !

!Prototype methodsFor: 'access' stamp: 'rca 4/4/2005 22:24'!
addSlot: name withValue: anObject

	| c |
	self makeStandAlone.

	c _ self newPrototypeSize: self slotSize + 1.
	self copyExtraStateFrom: self to: c.
	c methodDict: methodDict.
	c parent: self parent.
	c compileSlot: name index: self instSize + 1.
	c instVarAt: self instSize + 1 put: anObject.
	self becomeForward: c.

! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:23'!
basicMethodNames
	"Don't show methods which are merely access methods for slots"

	^ (methodDict keys select: [:each | 
		((methodDict at: each) last ~= 250) &
		((methodDict at: each) last ~= 251) &
		((methodDict at: each) last ~= 252)
		]) asSortedCollection! !

!Prototype methodsFor: 'access' stamp: 'rca 4/8/2005 20:11'!
clone
	"Makes a lightweight copy that will be changed to full if necessary"
	| c |

	"New instance"
	c _  self class new.
	
	"Copy slots"
	self slotNames do: [:s |
		c perform: (s, ':') asSymbol with: (self perform: s)].
	
	^ c! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:23'!
methodNames
	"Don't show methods which are merely access methods for slots"

	^ self class basicMethodNames! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:23'!
methodSize

	^ self class methodDict size! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:24'!
methodSourceAt: aSymbol

	^ self class sourceCodeAt: aSymbol! !

!Prototype methodsFor: 'access' stamp: 'rca 4/2/2005 21:28'!
name

	^'a Prototype Object'! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:20'!
parent

	^ self class basicParent! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:02'!
parent: aParent

	(aParent isKindOf: Behavior)
		ifTrue: [self makeStandAlone.
				superclass _ aParent]
		ifFalse: [self error: 'Prototypes must inherit from Behavior']! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:24'!
parentNames

	^ {self parent}! !

!Prototype methodsFor: 'access' stamp: 'rca 4/4/2005 22:24'!
removeMethod: key

	self makeStandAlone.
	methodDict removeKey: key asSymbol ifAbsent: []! !

!Prototype methodsFor: 'access' stamp: 'rca 4/4/2005 22:24'!
removeSlot: name

	| c |	
		
	self makeStandAlone.

	c _ self newPrototypeSize: self slotSize - 1.
	self copyExtraStateFrom: self to: c.
	c methodDict: methodDict.
	c parent: self parent.
	c removeMethod: name, ':'.
	c removeMethod: name.
	self becomeForward: c.

! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:25'!
slotNames

	^ (self class methodDict keys select: [:each | (self class methodDict at: each) last = 250]) asSortedCollection! !

!Prototype methodsFor: 'access' stamp: 'rca 4/5/2005 20:24'!
slotSize

	^ self class instSize - 3! !

!Prototype methodsFor: 'primatives' stamp: 'rca 11/15/2003 21:13'!
becomeForward: otherObject 
	"Primitive. All variables in the entire system that used to point
	to the receiver now point to the argument.
	Fails if either argument is a SmallInteger."

	(Array with: self)
		elementsForwardIdentityTo:
			(Array with: otherObject)! !

!Prototype methodsFor: 'primatives' stamp: 'rca 11/15/2003 21:13'!
instVarAt: index 
	"Primitive. Answer a fixed variable in an object. The numbering of the 
	variables corresponds to the named instance variables. Fail if the index 
	is not an Integer or is not the index of a fixed variable. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 73>
	"Access beyond fixed variables."
	^self basicAt: index - self class instSize		! !

!Prototype methodsFor: 'primatives' stamp: 'rca 11/15/2003 21:13'!
instVarAt: anInteger put: anObject 
	"Primitive. Store a value into a fixed variable in the receiver. The 
	numbering of the variables corresponds to the named instance variables. 
	Fail if the index is not an Integer or is not the index of a fixed variable. 
	Answer the value stored as the result. Using this message violates the 
	principle that each object has sovereign control over the storing of 
	values into its instance variables. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 74>
	"Access beyond fixed fields"
	^self basicAt: anInteger - self class instSize put: anObject! !

!Prototype methodsFor: 'primatives' stamp: 'rca 11/15/2003 21:17'!
new
	"Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."

	<primitive: 70>  "This method runs primitively if successful"
	^ self basicNew  "Exceptional conditions will be handled in basicNew"
! !

!Prototype methodsFor: 'behavior' stamp: 'rca 11/16/2003 01:25'!
format

	^ format! !

!Prototype methodsFor: 'behavior' stamp: 'rca 11/16/2003 01:32'!
instSize
	"Answer the number of named instance variables
	(as opposed to indexed variables) of the receiver."

	self flag: #instSizeChange.  "Smalltalk browseAllCallsOn: #instSizeChange"
"
	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
	When we revise the image format, it should become...
	^ ((format bitShift: -1) bitAnd: 16rFF) - 1
	Note also that every other method in this category will require
	2 bits more of right shift after the change.
"
	^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! !

!Prototype methodsFor: 'behavior' stamp: 'rca 11/16/2003 01:20'!
methodDict

	^ methodDict! !

!Prototype methodsFor: 'misc' stamp: 'rca 4/3/2005 15:43'!
classPool
	"Needed so that DoIt works"
	^ Dictionary new! !

!Prototype methodsFor: 'misc' stamp: 'rca 4/3/2005 15:44'!
sharedPools
	"Needed so that DoIt works"
	^ Dictionary new! !


!Prototype class methodsFor: 'as yet unclassified' stamp: 'rca 4/5/2005 20:21'!
loadInitialBehaviorFor: prototype

	"Get enough behavior to allow us to become alone...
	(add ProtoObject for minimal good behavior if we want to be able to become parentless.)
	
	The new object needs to be able to respond both to 
	normal object messages and messages for an objects 
	class (as p class == p). 
	
	We also import the specialised behavior for prototypes."
	
	{Prototype} do: [:c |
		c methodDict associationsDo: [:association |
			(prototype instVarAt: 2) at: association key put: association value veryDeepCopy]].

	^ prototype
! !

!Prototype class methodsFor: 'as yet unclassified' stamp: 'rca 4/5/2005 20:21'!
newPrototype
	| parent child |

	"Create parent..."
	(parent _ Behavior new)
		methodDictionary: MethodDictionary new;
		superclass: Behavior;
		format: (ClassBuilder new
				computeFormat: #normal
				instSize: 0
				forSuper: Behavior
				ccIndex: 0).

	"Create child in the image of parent"
	child _ parent new.
	1 to: 3 do: [:i | child instVarAt: i put: (parent instVarAt: i)].

	"Merge to become something new..."
	parent becomeForward: child.

	"Get enough behavior to allow us to bootstrap"
	self loadInitialBehaviorFor: child.

	"For stability purposes make initial prototype a child of Behavior"
	child parent: Behavior.

	^ child! !


!PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 4/3/2005 15:39'!
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]].
	
	(((object parentNames includes: slotName) | (self parentHeading = slotName))
		and: [Smalltalk hasClassNamed: aString asString])
		ifTrue: [object parent: (Smalltalk classNamed: aString asString).
				self changed: #fieldList.
				^ true].
		
	^false! !

!PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 4/3/2005 15:40'!
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) | (self parentHeading = slotName) | (object parentNames includes: slotName)! !

!PrototypeInspector methodsFor: 'as yet unclassified' stamp: 'rca 4/5/2005 22:10'!
fieldList

	^OrderedCollection new
		add: 'self';
		add: self parentHeading;
		add: object parent name;
		add: self slotsHeading;
		addAll: object slotNames;
		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 4/3/2005 15:03'!
parentHeading

	^'--- parent ---' 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 4/5/2005 22:11'!
selection
	| slotName |

	selectionIndex = 0 ifTrue: [^nil].
	selectionIndex = 1 ifTrue: [^object].
	slotName _ self selectedSlotName.
	
	slotName = self parentHeading
		ifTrue: [^ 'Enter the name of a class to change parent (Objects can only have one parent)'].
		
	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 parent name = slotName)
		ifTrue: [^slotName].

	^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)! !


!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/5/2005 22:25'!
testCreation
	"Test that we can create a classless object"
	| p |
	p _ Prototype newPrototype.
	
	self assert: (p class == p).! !

!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/8/2005 19:25'!
testInherit
	"Test that we can inherit"
	| p i |
	p _ Prototype newPrototype.
	p addMethod: 'hh ^ 123'.
	
	i _ p clone.
	self shouldnt: [i hh] raise: Error.
	self assert: (i hh == 123).
	
	i removeMethod: 'hh'.
	self should: [i hh] raise: Error.
	self shouldnt: [p hh] raise: Error.
! !

!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/8/2005 19:22'!
testMethod
	"Test that we can add and remove methods"
	| p |
	p _ Prototype newPrototype.
	self should: [p hh] raise: Error.
	p addMethod: 'hh ^ 123'.
	self shouldnt: [p hh] raise: Error.
	self assert: (p hh == 123).
	p removeMethod: 'hh'.
	self should: [p hh] raise: Error.! !

!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/8/2005 19:28'!
testParent
	"Test inheritance by parent"
	| p i |
	p _ Prototype newPrototype.
	p addMethod: 'hh ^ 123'.
	
	i _ p clone.
	self assert: (i parent == p parent).
	i removeMethod: 'hh'.
	self should: [i hh] raise: Error.
	self shouldnt: [p hh] raise: Error.

	i parent: p.
	self shouldnt: [i hh] raise: Error.
	! !

!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/8/2005 19:21'!
testSlot
	"Test that we can add and remove slots"
	| p |
	p _ Prototype newPrototype.
	self should: [p hh] raise: Error.
	p addSlot: 'hh'.
	self shouldnt: [p hh] raise: Error.
	self assert: ((p hh: 123) hh == 123).
	p removeSlot: 'hh'.
	self should: [p hh] raise: Error.! !

!PrototypeTests methodsFor: 'as yet unclassified' stamp: 'rca 4/8/2005 19:39'!
testSlotClone
	"Test cloning and slots"
	| p i |
	p _ Prototype newPrototype.
	p addSlot: 'hh' withValue: 123.
	
	i _ p clone.
	self assert: (i hh = 123).

	i hh: 1234.
	self assert: (i hh = 1234).
	self assert: (p hh = 123).
! !