SystemOrganization addCategory: #'Shingle-Core'!
SystemOrganization addCategory: #'Shingle-Tests'!

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

!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-Tests'!

!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 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: #SLSlice
	instanceVariableNames: 'objects'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

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

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

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

!SLSlice methodsFor: 'public' stamp: 'lr 2/25/2007 13:08'!
snapshot
	^ SLSlice on: self objects! !

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

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

!SLSnapshot methodsFor: 'initialization' stamp: 'lr 2/25/2007 12:40'!
initialize
	super initialize.
	contents := OrderedCollection new! !

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

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

!SLClassVersion 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 ] ] ] ] ] ] ] ]! !

!SLClassVersion 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 ]! !

!SLClassVersion 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! !

SLVersion subclass: #SLObjectVersion
	instanceVariableNames: 'named indexed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Shingle-Core'!

!SLObjectVersion 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! !

!SLObjectVersion 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 ]! !

!SLObjectVersion 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 ]! !

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

!SLVersion 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: [ #() ])! !

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

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

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

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

!SLVersion 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 ] ] ]! !

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

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

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

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

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

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

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

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

!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! !
SLVersion initialize!