SystemOrganization addCategory: #'Shingle-Core'!
SystemOrganization addCategory: #'Shingle-Copies'!
SystemOrganization addCategory: #'Shingle-Changes'!

TestCase subclass: #SGCopyTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Copies'!

!SGCopyTest methodsFor: 'running' stamp: 'lr 2/16/2007 14:24'!
tearDown
	Smalltalk at: #SGMock ifPresent: [ :class | class removeFromSystem ]! !

!SGCopyTest methodsFor: 'testing' stamp: 'lr 2/16/2007 14:25'!
testClass
	| class snapshot1 snapshot2 snapshot3 |
	class := Object subclass: #SGMock
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: self class category.

	snapshot1 := class snapshotCopy.
	self assert: (class isIdenticalToSnapshot: snapshot1).
	
	class addInstVarName: 'foo'.
	snapshot2 := class snapshotCopy.
	self assert: (class isIdenticalToSnapshot: snapshot2).
	
	class compile: 'foo ^ foo'.
	snapshot3 := class snapshotCopy.
	self assert: (class isIdenticalToSnapshot: snapshot3).

	snapshot1 restore: class.
	self assert: class instVarNames isEmpty.
	self assert: class methodDict isEmpty.
	
	snapshot2 restore: class.
	self assert: class instVarNames = #('foo').
	self assert: class methodDict isEmpty.
	
	snapshot3 restore: class.
	self assert: class instVarNames = #('foo').
	self assert: class methodDict notEmpty! !

!SGCopyTest methodsFor: 'testing-szenarios' stamp: 'lr 2/23/2007 12:02'!
testClassSzenario1
	| class object snapshot1 snapshot2 snapshot3 |
	class := Object subclass: #SGMock
		instanceVariableNames: 'counter'
		classVariableNames: ''
		poolDictionaries: ''
		category: self class category.
	class compile: 'initialize counter := 0'.
	class compile: 'value ^ counter'.
	class compile: 'increase counter := counter + 1'.
	class compile: 'decrease counter := counter - 1'.
	object := class new.
	snapshot1 := SGSnapshot new.
	snapshot1 register: class.
	snapshot1 register: object.
	self assert: object value = 0.
	
	object increase; increase.
	self assert: object value = 2.
	snapshot2 := snapshot1 snapshot.
	
	class removeInstVarName:  'counter'.
	self assert: object value = nil.
	snapshot3 := snapshot2 snapshot.
	
	snapshot2 restore.
	self assert: object value = 2.
	
	snapshot1 restore.
	self assert: object value = 0! !

!SGCopyTest methodsFor: 'testing-szenarios' stamp: 'lr 2/16/2007 16:07'!
testClassSzenario2
	| class object snapshot |
	class := Object subclass: #SGMock
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: self class category.
	object := class new.
	snapshot := SGSnapshot new.
	snapshot register: class.
	snapshot register: object.
	
	self
		should: [
			snapshot transaction: [
				class addInstVarName: 'counter'. 
				class compile: 'initialize counter := 0'.
				class compile: 'value ^ counter'.
				class compile: 'increase counter := counter + 1'.
				class compile: 'decrease counter := counter - 1'.
				object initialize; increase; increase.
				class addInstVarName: 'counter' ] ]
		raise: Error.
	self assert: object value = object.
	self deny: (object respondsTo: #increase).
	self deny: (object respondsTo: #decrease).
	
	self
		shouldnt: [
			snapshot transaction: [
				class addInstVarName: 'counter'. 
				class compile: 'initialize counter := 0'.
				class compile: 'value ^ counter'.
				class compile: 'increase counter := counter + 1'.
				class compile: 'decrease counter := counter - 1'.
				object initialize; increase; increase ] ]
		raise: Error.
	self assert: object value = 2.
	self assert: (object respondsTo: #increase).
	self assert: (object respondsTo: #decrease).! !

!SGCopyTest methodsFor: 'testing' stamp: 'lr 2/16/2007 14:21'!
testIndexed
	| a1 s1 a2 |
	a1 := #( 1 2 3 ) copy.
	s1 := a1 snapshotCopy.
	self assert: (a1 isIdenticalToSnapshot: s1).
	
	a2 := #( 3 2 1 ) copy.
	self deny: (a2 isIdenticalToSnapshot: s1).
	a2 restoreFromSnapshot: s1.
	self assert: (a2 isIdenticalToSnapshot: s1).
	
	self assert: a1 = a2! !

!SGCopyTest methodsFor: 'testing' stamp: 'lr 2/16/2007 14:19'!
testNamed
	| p1 s1 p2 |
	p1 := 1 @ 2.
	s1 := p1 snapshotCopy.
	self assert: (p1 isIdenticalToSnapshot: s1).
	
	p2 := Point new.
	self deny: (p2 isIdenticalToSnapshot: s1).
	p2 restoreFromSnapshot: s1.
	self assert: (p2 isIdenticalToSnapshot: s1).
	
	self assert: p1 = p2! !

TestCase subclass: #SGTestSnapshot
	instanceVariableNames: 'value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!SGTestSnapshot methodsFor: 'testing' stamp: 'lr 2/23/2007 12:02'!
testAncestors
	| object step0 step1 step21 step22 |
	step0 := SGSnapshot new.
	step0 register: (object := ValueHolder new).

	object contents: 1.
	step1 := step0 snapshot.
	
	step1 restore.
	object contents: 21.
	step21 := step1 snapshot.
	
	step1 restore.
	object contents: 22.
	step22 := step1 snapshot.
	
	self assert: (step21 ancestors includes: step1).
	self assert: (step21 allAncestors includes: step0).
	self assert: (step21 allAncestors includes: step1).
	
	self assert: (step22 ancestors includes: step1).
	self assert: (step22 allAncestors includes: step0).
	self assert: (step22 allAncestors includes: step1)
! !

!SGTestSnapshot methodsFor: 'testing' stamp: 'lr 2/23/2007 12:02'!
testArray
	| array step0 step1 step2 |
	step0 := SGSnapshot new.
	step0 register: (array := Array new: 1).
	
	array at: 1 put: 1.
	step1 := step0 snapshot.
	array at: 1 put: 2.
	step2 := step1 snapshot.
	
	step0 restore.
	self assert: array first isNil.
	step1 restore.
	self assert: array first = 1.
	step2 restore.
	self assert: array first = 2! !

!SGTestSnapshot methodsFor: 'testing-merging' stamp: 'lr 2/23/2007 12:02'!
testMergeConflict
	| object step0 step11 step12 step21 step22 |
	step0 := SGSnapshot new.
	step0
		register: (object := Array new: 2);
		register: (object at: 1 put: ValueHolder new);
		register: (object at: 2 put: ValueHolder new);
		update.

	step0 restore.
	object first contents: 1.
	step11 := step0 snapshot.
	
	step0 restore.
	object first contents: 2.
	object second contents: 3.
	step12 := step0 snapshot.
	
	self 
		should: [ step11 merge: step12 ]
		raise: Error.
	self 
		should: [ step12 merge: step11 ]
		raise: Error.

	step21 := step11 merge: step12 resolver: [ :a :b |
		self assert: a contents = 1; assert: b contents = 2.
		ValueHolder new contents: 4 ].
	step21 restore.
  	self assert: object first contents = 4.
	self assert: object second contents = 3.
	
	step22 := step12 merge: step11 resolver: [ :a :b |
		self assert: a contents = 2; assert: b contents = 1.
		ValueHolder new contents: 5 ].
	step22 restore.
  	self assert: object first contents = 5.
	self assert: object second contents = 3! !

!SGTestSnapshot methodsFor: 'testing-merging' stamp: 'lr 2/23/2007 12:01'!
testMergeSimple
	| object step0 step11 step12 step21 step22 |
	step0 := SGSnapshot new.
	step0
		register: (object := Array new: 2);
		register: (object at: 1 put: ValueHolder new);
		register: (object at: 2 put: ValueHolder new);
		update.

	step0 restore.
	object first contents: 1.
	step11 := step0 snapshot.
	
	step0 restore.
	object second contents: 2.
	step12 := step0 snapshot.
	
	step21 := step11 merge: step12.
	step21 restore.
  	self assert: object first contents = 1.
	self assert: object second contents = 2.
	
	step22 := step12 merge: step11.
	step22 restore.
  	self assert: object first contents = 1.
	self assert: object second contents = 2! !

!SGTestSnapshot methodsFor: 'testing' stamp: 'lr 2/23/2007 12:01'!
testObject
	| object step0 step1 step2 |
	step0 := SGSnapshot new.
	step0 register: (object := ValueHolder new).

	object contents: 1.
	step1 := step0 snapshot.
	object contents: 2.
	step2 := step1 snapshot.
	
	step0 restore.
	self assert: object contents isNil.
	step1 restore.
	self assert: object contents = 1.
	step2 restore.
	self assert: object contents = 2! !

!SGTestSnapshot methodsFor: 'testing' stamp: 'lr 2/23/2007 15:16'!
testRegistry
	| object registry |
	object := ValueHolder new.
	registry := SGRegistry new.
	registry register: object.
		
	" snapshot "
	object contents: 1.
	registry snapshot.
	object contents: 2.
	registry snapshot.

	" restore "
	self assert: object contents = 2.
	registry previous.
	self assert: object contents = 1.
	registry previous! !

!SGTestSnapshot methodsFor: 'testing' stamp: 'lr 2/9/2007 17:47'!
testTransaction
	| object step0 |
	step0 := SGSnapshot new.
	step0 register: (object := ValueHolder new).
	step0 transaction: [ object contents: 1 ].
	
	self assert: object contents = 1.
	self
		should: [ step0 transaction: [ object contents: 2. 1 / 0 ] ]
		raise: ZeroDivide.
	self assert: object contents = 1! !

Object subclass: #LESlice
	instanceVariableNames: 'objects'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!LESlice methodsFor: 'initialization' stamp: 'lr 2/25/2007 10:51'!
initialize
	super initialize.
	objects := OrderedCollection new! !

!LESlice methodsFor: 'accessing' stamp: 'lr 2/25/2007 10:51'!
objects
	^ objects! !

!LESlice methodsFor: 'registration' stamp: 'lr 2/25/2007 10:50'!
register: anObject
	objects add: anObject! !

!LESlice methodsFor: 'public' stamp: 'lr 2/25/2007 10:53'!
snapshot
	^ LESlice on: self objects! !

Object subclass: #LESnapshot
	instanceVariableNames: 'contents'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!LESnapshot class methodsFor: 'instance-creation' stamp: 'lr 2/25/2007 10:54'!
on: aCollection
	^ self new initializeOn: aCollection! !

!LESnapshot methodsFor: 'accessing' stamp: 'lr 2/25/2007 11:01'!
contents
	^ contents! !

!LESnapshot methodsFor: 'initialization' stamp: 'lr 2/25/2007 11:01'!
initialize
	super initialize.
	contents := IdentityDictionary new! !

!LESnapshot methodsFor: 'initialization' stamp: 'lr 2/25/2007 10:55'!
initializeOn: aCollection
	aCollection do: [ :each | objects at: each put: each snapshotCopy ]! !

Object subclass: #LEVersion
	instanceVariableNames: 'ancestors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

LEVersion subclass: #LEClassVersion
	instanceVariableNames: 'name environment type category superclass varNames classVarNames methods classMethods'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!LEClassVersion methodsFor: 'testing' stamp: 'lr 2/25/2007 12:02'!
isIdenticalTo: anObject
	^ name = anObject name
		and: [ environment = anObject environment
		and: [ type = anObject typeOfClass
		and: [ category = anObject category
		and: [ superclass = anObject superclass
		and: [ varNames = anObject instVarNames
		and: [ classVarNames = anObject class instVarNames
		and: [ methods = anObject methodDict 
		and: [ classMethods = anObject class methodDict ] ] ] ] ] ] ] ]! !

!LEClassVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:59'!
restore: anObject
	anObject methodDict: methods.
	anObject class methodDict: classMethods.
	ClassBuilder beSilentDuring: [
		ClassBuilder new
			class: anObject
			name: name
			inEnvironment: environment
			subclassOf: superclass
			type: type
			instanceVariableNames: varNames
			classVariableNames: classVarNames
			category: category ]! !

!LEClassVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:59'!
snapshot: anObject
	name := anObject name.
	environment := anObject environment.
	type := anObject typeOfClass.
	category := anObject category.
	superclass := anObject superclass.
	varNames := anObject instVarNames.
	classVarNames := anObject class instVarNames.
	methods := anObject methodDict copy.
	classMethods := anObject class methodDict copy! !

LEVersion subclass: #LEObjectVersion
	instanceVariableNames: 'named indexed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!LEObjectVersion methodsFor: 'testing' stamp: 'lr 2/25/2007 12:04'!
isIdenticalTo: anObject
	| index |
	index := named size.
	[ index > 0 ] whileTrue: [
		(named at: index) == (anObject instVarAt: index)
			ifFalse: [ ^ false ].
		index := index - 1 ].
	index := indexed size.
	[ index > 0 ] whileTrue: [
		(indexed at: index) == (anObject basicAt: index)
			ifFalse: [ ^ false ].
		index := index - 1 ].
	^ true! !

!LEObjectVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:58'!
restore: anObject
	| index |
	index := named size.
	[ index > 0 ] whileTrue: [
		anObject instVarAt: index put: (named at: index).
		index := index - 1 ].
	index := indexed size.
	[ index > 0 ] whileTrue: [
		anObject basicAt: index put: (indexed at: index).
		index := index - 1 ]! !

!LEObjectVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:56'!
snapshot: anObject
	| index |
	named := Array new: (index := anObject class instSize).
	[ index > 0 ] whileTrue: [
		named at: index put: (anObject instVarAt: index).
		index := index - 1 ].
	indexed := Array new: (index := anObject basicSize).
	[ index > 0 ] whileTrue: [
		indexed at: index put: (anObject basicAt: index).
		index := index - 1 ]! !

!LEVersion class methodsFor: 'initialization' stamp: 'lr 2/25/2007 11:26'!
initialize
	(Object classVarNames includes: #VersionedInstances)
		ifFalse: [ Object addClassVarName: #VersionedInstances ]! !

!LEVersion class methodsFor: 'instance-creation' stamp: 'lr 2/25/2007 12:01'!
on: anObject
	| ancestor |
	ancestor := anObject versionedInstances 
		at: anObject ifAbsent: [ nil ].
	^ self on: anObject ancestors: (ancestor 
		ifNotNil: [ Array with: ancestor ]
		ifNil: [ #() ])! !

!LEVersion class methodsFor: 'instance-creation' stamp: 'lr 2/25/2007 12:01'!
on: anObject ancestors: anArray
	^ self new
		setAncestors: anArray;
		snapshot: anObject;
		yourself! !

!LEVersion class methodsFor: 'initialization' stamp: 'lr 2/25/2007 11:26'!
unload
	(Object classVarNames includes: #VersionedInstances)
		ifTrue: [ Object removeClassVarName: #VersionedInstances ]! !

!LEVersion methodsFor: 'accessing' stamp: 'lr 2/25/2007 11:42'!
ancestors
	^ ancestors! !

!LEVersion methodsFor: 'ancestry' stamp: 'lr 2/25/2007 11:44'!
ancestry
	^ Array streamContents: [ :stream | 
		self ancestoryDo: [ :each |
			stream nextPut: each ] ]! !

!LEVersion methodsFor: 'ancestry' stamp: 'lr 2/25/2007 11:45'!
ancestryDo: aBlock
	| seen todo next |
	seen := Set with: self.
	todo := OrderedCollection withAll: ancestors.
	[ todo isEmpty ] whileFalse: [
		next := todo removeFirst.
		next ancestors do: [ :each |
			(seen includes: each) ifFalse: [
				aBlock value: each.
				seen add: each.
				todo add: each ] ] ]! !

!LEVersion methodsFor: 'testing' stamp: 'lr 2/25/2007 12:02'!
isIdenticalTo: anObject
	self subclassResponsibility! !

!LEVersion methodsFor: 'querying' stamp: 'lr 2/25/2007 11:10'!
precedes: aVersion
	^ aVersion ancestry includes: self! !

!LEVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:56'!
restore: anObject
	self subclassResponsibility! !

!LEVersion methodsFor: 'initialization' stamp: 'lr 2/25/2007 12:00'!
setAncestors: anArray
	ancestors := anArray! !

!LEVersion methodsFor: 'public' stamp: 'lr 2/25/2007 11:56'!
snapshot: anObject
	self subclassResponsibility! !

!LEVersion methodsFor: 'querying' stamp: 'lr 2/25/2007 11:09'!
succeeds: aVersion
	^ aVersion precedes: self! !

!Object class methodsFor: '*shingle' stamp: 'lr 2/25/2007 11:37'!
versionedInstances
	^ VersionedInstances ifNil: [ VersionedInstances := WeakKeyDictionary new ]! !

!Object methodsFor: '*shingle' stamp: 'lr 2/16/2007 14:03'!
isIdenticalToSnapshot: aCopy
	^ aCopy isIdenticalTo: self! !

!Object methodsFor: '*shingle' stamp: 'lr 2/12/2007 09:57'!
restoreFromSnapshot: aCopy
	aCopy restore: self! !

!Object methodsFor: '*shingle' stamp: 'lr 2/12/2007 09:56'!
snapshotCopy
	^ SGObjectCopy from: self! !

Object subclass: #SGChange
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Changes'!

!SGChange methodsFor: 'public' stamp: 'lr 2/19/2007 08:40'!
apply
	self subclassResponsibility! !

!SGChange methodsFor: 'public' stamp: 'lr 2/19/2007 08:53'!
conflictsWith: aChange
	self subclassResponsibility! !

SGChange subclass: #SGVariableChange
	instanceVariableNames: 'receiver index value'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Changes'!

SGVariableChange subclass: #SGIndexedChange
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Changes'!

!SGIndexedChange methodsFor: 'public' stamp: 'lr 2/19/2007 08:41'!
apply
	receiver basicAt: index put: value! !

SGVariableChange subclass: #SGNamedChange
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Changes'!

!SGNamedChange methodsFor: 'public' stamp: 'lr 2/19/2007 08:42'!
apply
	receiver instVarAt: index put: value! !

!SGVariableChange methodsFor: 'comparing' stamp: 'lr 2/19/2007 08:50'!
= anObject
	^ self species = anObject species
		and: [ self receiver == anObject receiver
		and: [ self index == anObject index
		and: [ self value == anObject value ] ] ]! !

!SGVariableChange methodsFor: 'public' stamp: 'lr 2/19/2007 08:53'!
conflictsWith: aChange
	^ self species = aChange species! !

!SGVariableChange methodsFor: 'accessing' stamp: 'lr 2/19/2007 08:50'!
index
	^ index! !

!SGVariableChange methodsFor: 'accessing' stamp: 'lr 2/19/2007 08:50'!
receiver
	^ receiver! !

!SGVariableChange methodsFor: 'accessing' stamp: 'lr 2/19/2007 08:50'!
value
	^ value! !

Object subclass: #SGCopy
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Copies'!

SGCopy subclass: #SGClassCopy
	instanceVariableNames: 'name environment type category superclass varNames classVarNames methods classMethods'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Copies'!

!SGClassCopy class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 10:20'!
from: aClass
	^ self basicNew snapshot: aClass! !

!SGClassCopy methodsFor: 'testing' stamp: 'lr 2/16/2007 14:05'!
isIdenticalTo: aClass
	^ name = aClass name
		and: [ environment = aClass environment
		and: [ type = aClass typeOfClass
		and: [ category = aClass category
		and: [ superclass = aClass superclass
		and: [ varNames = aClass instVarNames
		and: [ classVarNames = aClass class instVarNames
		and: [ methods = aClass methodDict 
		and: [ classMethods = aClass class methodDict ] ] ] ] ] ] ] ]! !

!SGClassCopy methodsFor: 'accessing' stamp: 'lr 2/16/2007 11:22'!
priority
	^ -10! !

!SGClassCopy methodsFor: 'public' stamp: 'lr 2/12/2007 16:53'!
restore: aClass
	aClass methodDict: methods.
	aClass class methodDict: classMethods.
	ClassBuilder beSilentDuring: [
		ClassBuilder new
			class: aClass
			name: name
			inEnvironment: environment
			subclassOf: superclass
			type: type
			instanceVariableNames: varNames
			classVariableNames: classVarNames
			category: category ]! !

!SGClassCopy methodsFor: 'public' stamp: 'lr 2/12/2007 16:53'!
snapshot: aClass
	name := aClass name.
	environment := aClass environment.
	type := aClass typeOfClass.
	category := aClass category.
	superclass := aClass superclass.
	varNames := aClass instVarNames.
	classVarNames := aClass class instVarNames.
	methods := aClass methodDict copy.
	classMethods := aClass class methodDict copy! !

!SGCopy class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 09:28'!
from: anObject
	"Intern the state of anObject."
	
	self subclassResponsibility! !

!SGCopy methodsFor: 'testing' stamp: 'lr 2/16/2007 14:03'!
isIdenticalTo: anObject
	^ false! !

!SGCopy methodsFor: 'accessing' stamp: 'lr 2/23/2007 14:04'!
priority
	^ 0! !

!SGCopy methodsFor: 'public' stamp: 'lr 2/12/2007 08:36'!
restore: anObject
	"Restore the interned state to anObject."
	
	self subclassResponsibility! !

!SGCopy methodsFor: 'public' stamp: 'lr 2/12/2007 10:21'!
snapshot: anObject
	"Intern the state of anObject."
	
	self subclassResponsibility! !

SGCopy variableSubclass: #SGObjectCopy
	instanceVariableNames: 'namedSize'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Copies'!

!SGObjectCopy commentStamp: 'lr 2/12/2007 09:22' prior: 0!
I intern the state of a Squeak object with named and indexed variables in space efficient manner. I am independent of the original object, so even if its class is gone I do not loose any information. 

My internal structure is as follows:

	| name_1 | name_2 | ... | name_n 
	| var_1 | var_2 | ... | var_n 
	| indexed_1 | indexed_2 | ... | indexed_m
	
where n is the number of named variables and m is the number of indexed variables.!

!SGObjectCopy class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 09:54'!
from: anObject
	^ (self basicNew: 2 * anObject class instSize + anObject basicSize) snapshot: anObject! !

!SGObjectCopy methodsFor: 'querying' stamp: 'lr 2/12/2007 09:27'!
indexedAt: anInteger ifAbsent: aBlock
	"Answer the value of an indexed variable."
	
	| index |
	index := 2 * namedSize + anInteger.
	^ (0 < anInteger and: [ index <= self basicSize ])
		ifTrue: [ self basicAt: index ]
		ifFalse: [ aBlock value ]! !

!SGObjectCopy methodsFor: 'accessing' stamp: 'lr 2/12/2007 09:17'!
indexedSize
	^ self basicSize - (2 * self namedSize)! !

!SGObjectCopy methodsFor: 'testing' stamp: 'lr 2/16/2007 14:17'!
isIdenticalTo: anObject
	| index names |
	index := self namedSize.
	names := anObject class allInstVarNames.
	index = names size 
		ifFalse: [ ^ false ].
	[ index > 0 ] whileTrue: [
		(names at: index) = (self basicAt: index)
			ifFalse: [ ^ false ].
		(anObject instVarAt: index) == (self basicAt: namedSize + index)
			ifFalse: [ ^ false ].
		index := index - 1 ].
	index := self indexedSize.
	index = anObject basicSize
		ifFalse: [ ^ false ].
	[ index > 0 ] whileTrue: [
		(anObject basicAt: index) == (self basicAt: 2 * namedSize + index)
			ifFalse: [ ^ false ].
		index := index - 1 ].
	^ true! !

!SGObjectCopy methodsFor: 'querying' stamp: 'lr 2/12/2007 09:24'!
namedAt: aString ifAbsent: aBlock
	"Answer the value of a named variable."
	
	| index |
	index := namedSize.
	[ index > 0 ] whileTrue: [
		(self basicAt: index) = aString
			ifTrue: [ ^ self basicAt: namedSize + index ].
		index := index - 1 ].
	^ aBlock value! !

!SGObjectCopy methodsFor: 'accessing' stamp: 'lr 2/12/2007 09:12'!
namedSize
	^ namedSize! !

!SGObjectCopy methodsFor: 'public' stamp: 'lr 2/19/2007 08:30'!
restore: anObject
	| names index |
	names := anObject class allInstVarNames.
	index := names size.
	[ index > 0 ] whileTrue: [
		anObject
			instVarAt: index
			put: (self
				namedAt: (names at: index)
				ifAbsent: [ nil ]).
		index := index - 1 ].
	index := anObject basicSize.
	[ index > 0 ] whileTrue: [
		anObject
			basicAt: index
			put: (self
				indexedAt: index
				ifAbsent: [ nil ]).
		index := index - 1 ]! !

!SGObjectCopy methodsFor: 'public' stamp: 'lr 2/19/2007 08:30'!
snapshot: anObject
	| names index |
	names := anObject class allInstVarNames.
	namedSize := index := names size.
	[ index > 0 ] whileTrue: [
		self
			basicAt: index
			put: (names at: index).
		self
			basicAt: index + namedSize
			put: (anObject instVarAt: index).
		index := index - 1 ].
	index := anObject basicSize.
	[ index > 0 ] whileTrue: [
		self
			basicAt: 2 * namedSize + index
			put: (anObject basicAt: index).
		index := index - 1 ]! !

Object subclass: #SGRegistry
	instanceVariableNames: 'current'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!SGRegistry methodsFor: 'accessing' stamp: 'lr 2/23/2007 13:54'!
current
	^ current! !

!SGRegistry methodsFor: 'initialize' stamp: 'lr 2/23/2007 13:54'!
initialize
	super initialize.
	current := SGSnapshot new! !

!SGRegistry methodsFor: 'actions' stamp: 'lr 2/23/2007 14:00'!
previous
	^ current := current ancestor restore! !

!SGRegistry methodsFor: 'registration' stamp: 'lr 2/23/2007 12:05'!
register: anObject
	current register: anObject! !

!SGRegistry methodsFor: 'actions' stamp: 'lr 2/23/2007 14:01'!
snapshot
	^ current := current snapshot! !

Object subclass: #SGSnapshot
	instanceVariableNames: 'objects ancestors'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!SGSnapshot methodsFor: 'ancestors' stamp: 'lr 2/5/2007 10:22'!
addAncestor: aSnapshot
	ancestors := ancestors copyWith: aSnapshot! !

!SGSnapshot methodsFor: 'ancestors' stamp: 'lr 2/5/2007 11:02'!
allAncestors
	^ Array streamContents: [ :stream | 
		self allAncestorsDo: [ :each |
			stream nextPut: each ] ]! !

!SGSnapshot methodsFor: 'ancestors' stamp: 'lr 2/5/2007 10:22'!
allAncestorsDo: aBlock
	| seen todo next |
	seen := Set with: self.
	todo := OrderedCollection with: self.
	[ todo isEmpty ] whileFalse: [
		next := todo removeFirst.
		next ancestors do: [ :each |
			(seen includes: each) ifFalse: [
				aBlock value: each.
				seen add: each.
				todo add: each ] ] ]! !

!SGSnapshot methodsFor: 'ancestors' stamp: 'lr 2/23/2007 12:00'!
ancestor
	self ancestors size = 1
		ifFalse: [ self error: self printString , ' has ' , self ancestors size printString , ' ancestors' ].
	^ self ancestors first! !

!SGSnapshot methodsFor: 'accessing' stamp: 'lr 2/5/2007 09:55'!
ancestors
	^ ancestors! !

!SGSnapshot methodsFor: 'enumerating' stamp: 'lr 2/16/2007 14:29'!
at: anObject ifAbsent: aBlock
	self objectsAndCopiesDo: [ :object :copy |
		anObject == object
			ifTrue: [ ^ copy ] ].
	^ aBlock value! !

!SGSnapshot methodsFor: 'ancestors' stamp: 'lr 2/5/2007 12:12'!
commonAncestorsWith: aSnapshot
	^ self allAncestors intersection: aSnapshot allAncestors! !

!SGSnapshot methodsFor: 'enumerating' stamp: 'lr 2/16/2007 13:59'!
indexObjectsAndCopiesDo: aBlock
	1 to: objects size by: 2 do: [ :index |
		aBlock
			value: index
			value: (objects at: index) 
			value: (objects at: index + 1) ]! !

!SGSnapshot methodsFor: 'initialization' stamp: 'lr 2/16/2007 14:00'!
initialize
	super initialize.
	objects := ancestors := #()! !

!SGSnapshot methodsFor: 'public' stamp: 'lr 2/19/2007 09:06'!
merge: aSnapshot
	^ self merge: aSnapshot resolver: [ :a :b | self error: 'Merge conflict' ]! !

!SGSnapshot methodsFor: 'public' stamp: 'lr 2/16/2007 14:48'!
merge: aSnapshot resolver: aBlock
	| result ancestor common other |
	result := self class new
		addAncestor: self;
		addAncestor: aSnapshot;
		yourself.
	ancestor := self commonAncestorsWith: aSnapshot.
	ancestor := ancestors isEmpty
		ifTrue: [ self class new ]
		ifFalse: [ ancestors first ].
	self objectsAndCopiesDo: [ :object :copy |
		common := ancestor at: object ifAbsent: [ nil ].
		other := aSnapshot at: object ifAbsent: [ nil ].
		(copy == common
			ifTrue: [ result register: object with: other ]
			ifFalse: [
				other == common
					ifTrue: [ result register: object with: copy ] ]) ].
	aSnapshot objectsAndCopiesDo: [ :object :copy |
		common := ancestor at: object ifAbsent: [ nil ].
		other := self at: object ifAbsent: [ nil ].
		result register: object with: (copy == common
			ifTrue: [ other ]
			ifFalse: [
				other == common
					ifTrue: [ copy ]
					ifFalse: [ 
						(aBlock 
							value: (object shallowCopy
								restoreFromSnapshot: other)
							value: (object shallowCopy
								restoreFromSnapshot: copy))
									snapshotCopy ] ]) ].
	^ result! !

!SGSnapshot methodsFor: 'accessing' stamp: 'lr 2/5/2007 09:55'!
objects
	^ objects! !

!SGSnapshot methodsFor: 'enumerating' stamp: 'lr 2/16/2007 13:57'!
objectsAndCopiesDo: aBlock
	1 to: objects size by: 2 do: [ :index |
		aBlock 
			value: (objects at: index) 
			value: (objects at: index + 1) ]! !

!SGSnapshot methodsFor: 'copying' stamp: 'lr 2/16/2007 13:48'!
postCopy
	super postCopy.
	objects := objects copy.
	ancestors := #()! !

!SGSnapshot methodsFor: 'printing' stamp: 'lr 2/5/2007 12:17'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' <'; print: self identityHash; nextPutAll: '>'! !

!SGSnapshot methodsFor: 'public' stamp: 'lr 2/23/2007 11:58'!
register: anObject
	self register: anObject with: anObject snapshotCopy! !

!SGSnapshot methodsFor: 'public' stamp: 'lr 2/16/2007 14:30'!
register: anObject with: aCopy
	| pair |
	pair := Array with: anObject with: aCopy.
	objects := aCopy priority < 0 ifTrue: [ pair , objects ] ifFalse: [ objects , pair ]! !

!SGSnapshot methodsFor: 'actions' stamp: 'lr 2/23/2007 12:01'!
restore
	"Activate the receiving snapshot."
	
	self objectsAndCopiesDo: [ :object :copy | 
		object restoreFromSnapshot: copy ]! !

!SGSnapshot methodsFor: 'actions' stamp: 'lr 2/9/2007 17:15'!
snapshot
	"Answer a new snapshot intering the current state of all registered objects."
	
	^ self copy
		addAncestor: self;
		update! !

!SGSnapshot methodsFor: 'utilities' stamp: 'lr 2/23/2007 12:01'!
transaction: aBlock
	| snapshot |
	snapshot := self snapshot.
	aBlock ifCurtailed: [ snapshot restore ]! !

!SGSnapshot methodsFor: 'actions' stamp: 'lr 2/16/2007 14:00'!
update
	"Updates the current snapshot from the real objects."
	
	self indexObjectsAndCopiesDo: [ :index :object :copy |
		(object isIdenticalToSnapshot: copy)
			ifFalse: [ objects basicAt: index + 1 put: object snapshotCopy ] ]! !

!Class methodsFor: '*shingle' stamp: 'lr 2/12/2007 16:44'!
snapshotCopy
	^ SGClassCopy from: self! !

!ClassBuilder methodsFor: '*shingle' stamp: 'lr 2/12/2007 16:54'!
class: aClass name: aNameString inEnvironment: anEnvironment subclassOf: aSuperClass type: aTypeSymbol instanceVariableNames: anInstVarString classVariableNames: aClassVarString category: aCategoryString
	| instVars oldClass copyOfOldClass needNew newClass force newCategory organization |
	instVars := Scanner new scanFieldNames: anInstVarString.
	oldClass := aClass.
	oldClass isBehavior ifTrue: [
		copyOfOldClass := oldClass copy.
		copyOfOldClass superclass addSubclass: copyOfOldClass ].
	[	needNew := self needsSubclassOf: aSuperClass type: aTypeSymbol instanceVariables: instVars from: oldClass.
		needNew ifNil: [ ^ nil ].
		needNew 
			ifFalse: [ newClass := oldClass ]
			ifTrue: [
				newClass := self 
					newSubclassOf: aSuperClass 
					type: aTypeSymbol 
					instanceVariables: instVars
					from: oldClass.
				newClass ifNil: [ ^ nil ].
				newClass setName: aNameString ].
		force := newClass declare: aClassVarString.
		newCategory := aCategoryString asSymbol.
		organization := anEnvironment ifNotNil: [ anEnvironment organization ].
		organization classify: newClass name under: newCategory.
		newClass environment: anEnvironment.
		newClass := self recompile: force from: oldClass to: newClass mutate: false.
		(anEnvironment at: newClass name ifAbsent: [ nil ]) == newClass ifFalse: [
			[ environ at: newClass name put: newClass ]
				on: AttemptToWriteReadOnlyGlobal
				do: [ :ex | ex resume: true ].
			Smalltalk flushClassNameCache ].
		newClass doneCompiling ] 
	ensure: [
		copyOfOldClass ifNotNil: [ copyOfOldClass superclass removeSubclass: copyOfOldClass ].
		Behavior flushObsoleteSubclasses ].
	^ newClass! !

!ValueHolder methodsFor: '*shingle-snapshot' stamp: 'lr 2/5/2007 14:44'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' print: '; print: self contents! !
LEVersion initialize!