SystemOrganization addCategory: #'Shingle-Core'! SystemOrganization addCategory: #'Shingle-Test'! TestCase subclass: #SGMergeTest instanceVariableNames: 'object1 object2 object3 slice' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Test'! !SGMergeTest methodsFor: 'running' stamp: 'lr 2/26/2007 12:46'! setUp object1 := Array new: 2. object1 at: 1 put: (object2 := ValueHolder new). object1 at: 2 put: (object3 := ValueHolder new). slice := SGSlice new. slice register: object1; register: object2; register: object3! ! !SGMergeTest methodsFor: 'testing' stamp: 'lr 2/26/2007 13:18'! testConflict | start version1 version2 | start := slice snapshot. slice restore: start. object2 contents: 2. version1 := slice snapshot. slice restore: start. object2 contents: 3. object3 contents: 4. version2 := slice snapshot. self should: [ slice merge: version1 with: version2 ] raise: Error. slice merge: version1 with: version2 onConflict: [ :a :b | self assert: a contents = 2; assert: b contents = 3. ValueHolder new contents: 5 ]. self assert: object2 contents = 5. self assert: object3 contents = 4! ! !SGMergeTest methodsFor: 'testing' stamp: 'lr 2/26/2007 13:14'! testSimple | start version1 version2 | start := slice snapshot. slice restore: start. object2 contents: 2. version1 := slice snapshot. slice restore: start. object3 contents: 3. version2 := slice snapshot. self shouldnt: [ slice merge: version1 with: version2 ] raise: Error. slice merge: version1 with: version2. self assert: object2 contents = 2. self assert: object3 contents = 3! ! TestCase subclass: #SGSliceTest instanceVariableNames: 'slice' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Test'! !SGSliceTest methodsFor: 'running' stamp: 'lr 2/26/2007 12:00'! setUp slice := SGSlice new! ! !SGSliceTest methodsFor: 'running' stamp: 'lr 2/26/2007 12:38'! tearDown Smalltalk at: #SGMock ifPresent: [ :class | class removeFromSystem ]! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:21'! testActive self assert: slice active notNil! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:38'! testClasses | class instance | class := Object subclass: #SGMock instanceVariableNames: 'count' classVariableNames: '' poolDictionaries: '' category: self class category. class compile: 'count ^ count'. class compile: 'initialize count := 0'. instance := class new. slice register: class; register: instance. self assert: instance count = 0. slice snapshot. class removeInstVarName: 'count'. self assert: instance count = nil. slice restore: slice active. self assert: instance count = 0! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:08'! testOrder slice register: 'Hello'; register: String. self assert: slice objects asArray first = String. self assert: slice objects asArray second = 'Hello'! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:15'! testPrevious | object | object := ValueHolder new contents: 0. slice register: object. slice snapshot. object contents: 1. slice snapshot. object contents: 2. slice snapshot. self assert: object contents = 2. slice previous. self assert: object contents = 1. slice previous. self assert: object contents = 0! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:03'! testRegister self assert: slice objects isEmpty. slice register: 'Hello World'. self deny: slice objects isEmpty! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:21'! testRestore | object | object := ValueHolder new contents: 0. slice register: object. slice snapshot. object contents: 1. slice restore: slice active. self assert: object contents = 0! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 13:22'! testSimple | object | object := ValueHolder new. slice register: object. " snapshot " slice snapshot. object contents: 1. slice snapshot. object contents: 2. slice snapshot. " restore " self assert: object contents = 2. slice previous. self assert: object contents = 1. slice previous. self assert: object contents isNil! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 13:41'! testTransaction | object | object := ValueHolder new. slice register: object. slice transaction: [ object contents: 1 ]. self assert: object contents = 1. self should: [ slice transaction: [ object contents: 2. 1 / 0 ] ] raise: ZeroDivide. self assert: object contents = 1! ! !SGSliceTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:05'! testUnique slice register: 1; register: 1. self assert: slice objects size = 1. slice register: 1 @ 2; register: 1 @ 2. self assert: slice objects size = 3! ! TestCase subclass: #SGVersionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Test'! !SGVersionTest methodsFor: 'running' stamp: 'lr 2/16/2007 14:24'! tearDown Smalltalk at: #SGMock ifPresent: [ :class | class removeFromSystem ]! ! !SGVersionTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:30'! testClass | class snapshot1 snapshot2 snapshot3 | class := Object subclass: #SGMock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self class category. snapshot1 := class versionClass from: class. self assert: (snapshot1 isIdenticalTo: class). class addInstVarName: 'foo'. snapshot2 := class versionClass from: class. self assert: (snapshot2 isIdenticalTo: class). class compile: 'foo ^ foo'. snapshot3 := class versionClass from: class. self assert: (snapshot3 isIdenticalTo: class). 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! ! !SGVersionTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:29'! testIndexed | a1 s1 a2 | a1 := #( 1 2 3 ) copy. s1 := a1 versionClass from: a1. self assert: (s1 isIdenticalTo: a1). a2 := #( 3 2 1 ) copy. self deny: (s1 isIdenticalTo: a2). s1 restore: a2. self assert: (s1 isIdenticalTo: a2). self assert: a1 = a2! ! !SGVersionTest methodsFor: 'testing' stamp: 'lr 2/26/2007 12:28'! testNamed | p1 s1 p2 | p1 := 1 @ 2. s1 := p1 versionClass from: p1. self assert: (s1 isIdenticalTo: p1). p2 := Point new. self deny: (s1 isIdenticalTo: p2). s1 restore: p2. self assert: (s1 isIdenticalTo: p2). self assert: p1 = p2! ! !Object methodsFor: '*shingle' stamp: 'lr 2/26/2007 11:51'! versionClass ^ SGObjectVersion! ! Object subclass: #SGSlice instanceVariableNames: 'objects active' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Core'! !SGSlice methodsFor: 'accessing' stamp: 'lr 2/26/2007 12:17'! active ^ active! ! !SGSlice methodsFor: 'initialize' stamp: 'lr 2/26/2007 12:23'! initialize super initialize. objects := SortedCollection sortBlock: [ :a :b | a versionClass priority < b versionClass priority ]. active := SGSnapshot new! ! !SGSlice methodsFor: 'merging' stamp: 'lr 2/26/2007 12:48'! merge: aFirst with: aSecond ^ self merge: aFirst with: aSecond onConflict: [ :a :b | self error: 'Merge conflict' ]! ! !SGSlice methodsFor: 'merging' stamp: 'lr 2/26/2007 13:13'! merge: aFirst with: aSecond onConflict: aBlock ^ self restore: (aFirst merge: aSecond onConflict: aBlock)! ! !SGSlice methodsFor: 'accessing' stamp: 'lr 2/26/2007 12:02'! objects ^ objects! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 12:26'! previous "Restore the previously active snapshot." ^ self restore: self active ancestor! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 12:04'! register: anObject (objects identityIncludes: anObject) ifFalse: [ objects add: anObject ]! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 12:22'! restore "Restore the active snapshot." ^ self restore: self active! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 12:25'! restore: aSnapshot "Restore aSnapshot and make it the active one." ^ active := aSnapshot restore: self objects! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 12:25'! snapshot "Create a new snapshot and make it active." ^ active := SGSnapshot new addAncestor: self active; snapshot: self objects; yourself! ! !SGSlice methodsFor: 'actions' stamp: 'lr 2/26/2007 13:42'! transaction: aBlock "Evaluate aBlock within a transaction of the receiver, create a new transaction to be able to restore the original content if necessary." | snapshot | snapshot := self snapshot. ^ aBlock ifCurtailed: [ self restore: 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: 'ancestors' stamp: 'lr 2/5/2007 12:12'! commonAncestorsWith: aSnapshot ^ self allAncestors intersection: aSnapshot allAncestors! ! !SGSnapshot methodsFor: 'initialization' stamp: 'lr 2/26/2007 11:55'! initialize super initialize. objects := IdentityDictionary new. ancestors := #()! ! !SGSnapshot methodsFor: 'public' stamp: 'lr 2/26/2007 13:14'! merge: aSnapshot onConflict: aBlock | result ancestor common other merged first second | result := self class new addAncestor: self; addAncestor: aSnapshot; yourself. ancestor := self commonAncestorsWith: aSnapshot. ancestor := ancestors isEmpty ifTrue: [ self class new ] ifFalse: [ ancestors first ]. self objects keysAndValuesDo: [ :object :copy | common := ancestor objects at: object ifAbsent: [ nil ]. other := aSnapshot objects at: object ifAbsent: [ nil ]. (copy = common ifTrue: [ result objects at: object put: other ] ifFalse: [ other = common ifTrue: [ result objects at: object put: copy ] ]) ]. aSnapshot objects keysAndValuesDo: [ :object :copy | common := ancestor objects at: object ifAbsent: [ nil ]. other := self objects at: object ifAbsent: [ nil ]. result objects at: object put: (copy = common ifTrue: [ other ] ifFalse: [ other = common ifTrue: [ copy ] ifFalse: [ other restore: (first := object shallowCopy). copy restore: (second := object shallowCopy). merged := aBlock value: first value: second. merged versionClass from: merged ] ]) ]. ^ result! ! !SGSnapshot methodsFor: 'accessing' stamp: 'lr 2/5/2007 09:55'! objects ^ objects! ! !SGSnapshot methodsFor: 'printing' stamp: 'lr 2/5/2007 12:17'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' <'; print: self identityHash; nextPutAll: '>'! ! !SGSnapshot methodsFor: 'actions' stamp: 'lr 2/26/2007 11:59'! restore: aCollection "Activate the receiving snapshot." aCollection do: [ :each | objects at: each ifPresent: [ :value | value restore: each ] ]! ! !SGSnapshot methodsFor: 'actions' stamp: 'lr 2/26/2007 11:58'! snapshot: aCollection "Answer a new snapshot intering the current state of all registered objects." aCollection do: [ :each | objects at: each put: (each versionClass from: each) ]! ! Object subclass: #SGVersion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Core'! SGVersion subclass: #SGClassVersion instanceVariableNames: 'name environment type category superclass varNames classVarNames methods classMethods' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Core'! !SGClassVersion class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 10:20'! from: aClass ^ self basicNew snapshot: aClass! ! !SGClassVersion class methodsFor: 'accessing' stamp: 'lr 2/26/2007 11:53'! priority ^ -10! ! !SGClassVersion methodsFor: 'testing' stamp: 'lr 2/26/2007 13:04'! = aVersion ^ name = aVersion name and: [ environment = aVersion environment and: [ type = aVersion typeOfClass and: [ category = aVersion category and: [ superclass = aVersion superclass and: [ varNames = aVersion instVarNames and: [ classVarNames = aVersion class instVarNames and: [ methods = aVersion methodDict and: [ classMethods = aVersion class methodDict ] ] ] ] ] ] ] ]! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:07'! category ^ category! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:07'! classMethods ^ classMethods! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! classVarNames ^ classVarNames! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! environment ^ environment! ! !SGClassVersion 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 ] ] ] ] ] ] ] ]! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! methods ^ methods! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:07'! name ^ name! ! !SGClassVersion 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 ]! ! !SGClassVersion 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! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! superclass ^ superclass! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! type ^ type ! ! !SGClassVersion methodsFor: 'accessing' stamp: 'lr 2/26/2007 13:08'! varNames ^ varNames! ! SGVersion variableSubclass: #SGObjectVersion instanceVariableNames: 'namedSize' classVariableNames: '' poolDictionaries: '' category: 'Shingle-Core'! !SGObjectVersion 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.! !SGObjectVersion class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 09:54'! from: anObject ^ (self basicNew: 2 * anObject class instSize + anObject basicSize) snapshot: anObject! ! !SGObjectVersion methodsFor: 'testing' stamp: 'lr 2/26/2007 13:07'! = anObject | index | ^ self species = anObject species and: [ self namedSize = anObject namedSize and: [ self indexedSize = anObject indexedSize and: [ index := self basicSize. [ 0 < index ] whileTrue: [ (self basicAt: index) == (anObject basicAt: index) ifFalse: [ ^ false ]. index := index - 1 ]. true ] ] ]! ! !SGObjectVersion 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 ]! ! !SGObjectVersion methodsFor: 'accessing' stamp: 'lr 2/12/2007 09:17'! indexedSize ^ self basicSize - (2 * self namedSize)! ! !SGObjectVersion 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! ! !SGObjectVersion 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! ! !SGObjectVersion methodsFor: 'accessing' stamp: 'lr 2/12/2007 09:12'! namedSize ^ namedSize! ! !SGObjectVersion 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 ]! ! !SGObjectVersion 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 ]! ! !SGVersion class methodsFor: 'instance-creation' stamp: 'lr 2/12/2007 09:28'! from: anObject "Intern the state of anObject." self subclassResponsibility! ! !SGVersion class methodsFor: 'accessing' stamp: 'lr 2/26/2007 11:53'! priority ^ 0! ! !SGVersion methodsFor: 'testing' stamp: 'lr 2/16/2007 14:03'! isIdenticalTo: anObject ^ false! ! !SGVersion methodsFor: 'public' stamp: 'lr 2/12/2007 08:36'! restore: anObject "Restore the interned state to anObject." self subclassResponsibility! ! !SGVersion methodsFor: 'public' stamp: 'lr 2/12/2007 10:21'! snapshot: anObject "Intern the state of anObject." self subclassResponsibility! ! !Class methodsFor: '*shingle' stamp: 'lr 2/26/2007 11:52'! versionClass ^ SGClassVersion! ! !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! !