SystemOrganization addCategory: #'Transactional-Model'! SystemOrganization addCategory: #'Transactional-Tests'! SystemOrganization addCategory: #'Transactional-Errors'! Notification subclass: #ACCurrentTransaction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !ACCurrentTransaction class methodsFor: 'evaluating' stamp: 'lr 5/4/2007 17:46'! use: aTransaction during: aBlock ^ aBlock on: self do: [ :n | n resume: aTransaction ]! ! !ContextPart methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:58'! canHandleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) or: [self nextHandlerContext canHandleSignal: exception]. ! ! !ContextPart methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:57'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | val | (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. self tempAt: 3 put: false. "disable self while executing handle block" val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}] ensure: [self tempAt: 3 put: true]. self return: val. "return from self if not otherwise directed in handle block" ! ! !BlockContext methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:09'! atomic ^ ACTransaction within: self! ! !BlockContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:47'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^home at: index! ! !BlockContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:47'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^home at: index put: value! ! !CompiledMethod methodsFor: '*transactional' stamp: 'lr 5/6/2007 11:38'! atomicMethod ^ self properties at: #atomicMethod ifAbsentPut: [ self newAtomicMethod ]! ! !CompiledMethod methodsFor: '*transactional' stamp: 'lr 5/6/2007 11:53'! flushAtomic ^ self properties removeKey: #atomicMethod ifAbsent: nil! ! !CompiledMethod methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:11'! newAtomicMethod ^ ACCompiler atomicMethodFor: self! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/6/2007 15:30'! beAtomic self propertyAt: #atomic put: true! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/5/2007 19:39'! isAtomic ^ self propertyAt: #atomic ifAbsentPut: [ false ]! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/7/2007 08:11'! primitive ^ primitiveNode ifNotNil: [ :node | node num ]! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:09'! atomic ^ ACTransaction within: self! ! TestCase subclass: #ACTransactionalTest instanceVariableNames: 'value array' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! ACTransactionalTest subclass: #ACBasicTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/5/2007 19:16'! testAccessor self assert: [ self value: true. self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/5/2007 19:16'! testAccessorRead self value: true. self assert: [ self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/5/2007 19:16'! testAccessorWrite [ self value: true ] atomic. self assert: self value! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/7/2007 07:36'! testBasicContext self assert: [ thisContext home ] atomic == thisContext! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/7/2007 07:36'! testBasicSelf self assert: [ self ] atomic == self! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 13:17'! testBasicSuper self assert: [ super ] atomic == self! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 14:37'! testGlobal self assert: [ GlobalValue := true. GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 14:37'! testGlobalRead GlobalValue := true. self assert: [ GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 14:37'! testGlobalWrite [ GlobalValue := true ] atomic. self assert: GlobalValue! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 16:22'! testInstance self assert: [ value := true. value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 16:23'! testInstanceRead value := true. self assert: [ value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/4/2007 16:23'! testInstanceWrite [ value := true ] atomic. self assert: value! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testLiteral self assert: [ Value := true. Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testLiteralRead Value := true. self assert: [ Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testLiteralWrite [ Value := true ] atomic. self assert: Value! ! !ACBasicTest methodsFor: 'testing' stamp: 'lr 5/7/2007 07:36'! testLoop "This code showed some bug in the exception handling." | current | [ current := SortedCollection. [ current == nil ] whileFalse: [ current == Object ifTrue: [ ^ self ]. current := current superclass ] ] atomic. self assert: current == Object! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:04'! testTemp | temp | self assert: [ temp := true. temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:03'! testTempRead | temp | temp := true. self assert: [ temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:04'! testTempWrite | temp | [ temp := true ] atomic. self assert: temp! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/7/2007 11:43'! testVariable self assert: [ array at: 1 put: true; at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:03'! testVariableRead array at: 1 put: true. self assert: [ array at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:03'! testVariableWrite [ array at: 1 put: true ] atomic. self assert: (array at: 1)! ! ACTransactionalTest subclass: #ACCollectionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testArrayLong | arr | arr := Array new: 10 withAll: 1. [ 3 to: 10 do: [ :each | arr at: each put: (arr at: each - 1) + (arr at: each - 2) ] ] atomic. 3 to: 10 do: [ :each | self assert: (arr at: each) - (arr at: each - 1) = (arr at: each - 2) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testArrayShort | arr | arr := Array new: 10 withAll: 1. 3 to: 10 do: [ :each | [ arr at: each put: (arr at: each - 1) + (arr at: each - 2) ] atomic ]. 3 to: 10 do: [ :each | self assert: (arr at: each) - (arr at: each - 1) = (arr at: each - 2) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testBagLong | bag | bag := Bag new. [ 1 to: 10 do: [ :each | bag add: each; add: each ] ] atomic. self assert: bag size = 20. 1 to: 10 do: [ :each | self assert: (bag occurrencesOf: each) = 2 ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testBagShort | bag | bag := Bag new. 1 to: 10 do: [ :each | [ bag add: each; add: each ] atomic ]. self assert: bag size = 20. 1 to: 10 do: [ :each | self assert: (bag occurrencesOf: each) = 2 ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testDictionaryLong | dict | dict := Dictionary new. [ 1 to: 10 do: [ :each | dict at: each put: each ] ] atomic. self assert: dict size = 10. 1 to: 10 do: [ :each | self assert: (dict at: each) = each ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testDictionaryShort | dict | dict := Dictionary new. 1 to: 10 do: [ :each | [ dict at: each put: each ] atomic ]. self assert: dict size = 10. 1 to: 10 do: [ :each | self assert: (dict at: each) = each ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testSetLong | set | set := Set new. [ 1 to: 10 do: [ :each | set add: each ] ] atomic. self assert: set size = 10. 1 to: 10 do: [ :each | self assert: (set includes: each) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testSetShort | set | set := Set new. 1 to: 10 do: [ :each | [ set add: each ] atomic ]. self assert: set size = 10. 1 to: 10 do: [ :each | self assert: (set includes: each) ]! ! ACTransactionalTest subclass: #ACErrorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testAccessor self should: [ [ self value: true. self assert: self value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testInst self should: [ [ value := true. self assert: value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: value isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testLiteral self should: [ [ Value := true. self assert: Value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: Value isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/7/2007 14:36'! testTemp | temp | self should: [ [ temp := true. self assert: temp. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: temp = true! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testVar self should: [ [ array at: 1 put: true. self assert: (array at: 1). 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACTransactionalTest class methodsFor: 'initialization' stamp: 'lr 5/4/2007 14:37'! initialize self environment at: #GlobalValue put: nil! ! !ACTransactionalTest methodsFor: 'running' stamp: 'lr 5/4/2007 14:37'! setUp value := nil. array := Array new: 1. Value := nil. GlobalValue := nil! ! !ACTransactionalTest methodsFor: 'utilities' stamp: 'lr 5/3/2007 15:59'! start: anInteger processes: aBlock | semaphores | aBlock fixTemps. semaphores := (1 to: anInteger) collect: [ :each | Semaphore new ]. semaphores do: [ :each | [ aBlock value. each signal ] fixTemps fork ]. semaphores do: [ :each | each wait ]! ! !ACTransactionalTest methodsFor: 'accessing' stamp: 'lr 5/3/2007 15:59'! value ^ value! ! !ACTransactionalTest methodsFor: 'accessing' stamp: 'lr 5/3/2007 15:59'! value: anObject value := anObject! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/6/2007 11:53'! atomicMethod ^ self properties at: #atomicMethod ifAbsentPut: [ self newAtomicMethod ]! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/5/2007 09:57'! flushAtomic ^ self properties removeKey: #atomicMethod ifAbsent: nil! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:11'! newAtomicMethod ^ ACCompiler atomicMethodFor: self! ! Object subclass: #ACBenchmark instanceVariableNames: '' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! ACBenchmark class instanceVariableNames: 'value'! ACBenchmark class instanceVariableNames: 'value'! !ACBenchmark class methodsFor: 'utilities' stamp: 'lr 5/9/2007 10:16'! benchmark: aOriginalBlock reference: aReferenceBlock label: aString "Assert that aFastBlock is executed faster than aSlow block. The two blocks should be relatively fast and have no side effects, as they are executed multiple times." | originalCount originalTime referenceCount referenceTime factor | originalCount := referenceCount := 1. [ (originalTime := [ originalCount timesRepeat: aOriginalBlock ] timeToRun) < 500 ] whileTrue: [ originalCount := originalCount * 2 ]. [ (referenceTime := [ referenceCount timesRepeat: aReferenceBlock ] timeToRun) < 50 ] whileTrue: [ referenceCount := referenceCount * 2 ]. factor := ((originalTime * referenceCount) / (originalCount * referenceTime)) asFloat. Transcript show: aString; show: ': '; show: (factor roundTo: 0.001); cr! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:19'! benchmarkActivation "self benchmarkActivation" self benchmark: [ [ ] atomic ] reference: [ [ ] value ] label: 'Activation'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:17'! benchmarkBinding "self benchmarkBinding" self benchmark: [ [ 100000 timesRepeat: [ Value ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ Value ] ] value ] label: 'Binding Read'. self benchmark: [ [ 100000 timesRepeat: [ Value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ Value := nil ] ] value ] label: 'Binding Write'.! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:20'! benchmarkInstance "self benchmarkInstance" self benchmark: [ [ 100000 timesRepeat: [ value ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ value ] ] value ] label: 'Instance Read'. self benchmark: [ [ 100000 timesRepeat: [ value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ value := nil ] ] value ] label: 'Instance Write'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:19'! benchmarkSend "self benchmarkSend" self benchmark: [ [ 100000 timesRepeat: [ #( nil ) size ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) size ] ] value ] label: 'Send'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:20'! benchmarkVariable "self benchmarkVariable" self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] value ] label: 'Variable Read'. self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] value ] label: 'Variable Write'! ! Object subclass: #ACChange instanceVariableNames: 'transaction value previous' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:29'! transaction: aTransaction ^ self new initializeWithTransaction: aTransaction! ! !ACChange methodsFor: 'actions' stamp: 'lr 4/27/2007 11:09'! apply self write: self value! ! !ACChange methodsFor: 'testing' stamp: 'lr 4/25/2007 13:33'! hasChanged ^ self previous ~~ self value! ! !ACChange methodsFor: 'testing' stamp: 'lr 4/25/2007 13:33'! hasConflict ^ self previous ~~ self read! ! !ACChange methodsFor: 'initialization' stamp: 'lr 5/7/2007 06:53'! initializeWithTransaction: aTransaction aTransaction changes add: self. transaction := aTransaction! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/25/2007 10:53'! previous ^ previous! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/25/2007 11:23'! previous: anObject previous := anObject! ! !ACChange methodsFor: 'printing' stamp: 'lr 5/4/2007 14:20'! printOn: aStream super printOn: aStream. " aStream nextPutAll: ' value: '; print: self value "! ! !ACChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:57'! read "Read the value from the receiver." self subclassResponsibility! ! !ACChange methodsFor: 'actions' stamp: 'lr 4/25/2007 11:23'! update self value: self read. self previous: self value! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:23'! value "Read the value local to the receivers transaction." ^ value! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 10:46'! value: aValue "Write the value local to the receivers transaction." ^ value := aValue! ! !ACChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:58'! write: anObject "Write anObject into the receiver." self subclassResponsibility! ! ACChange subclass: #ACGlobalChange instanceVariableNames: 'binding' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACGlobalChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! binding: aBinding | transaction | transaction := ACTransaction current. ^ transaction globalChanges at: aBinding ifAbsentPut: [ (self transaction: transaction) binding: aBinding; update ]! ! !ACGlobalChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:22'! binding ^ binding! ! !ACGlobalChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:22'! binding: aBinding binding := aBinding! ! !ACGlobalChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:23'! read ^ self binding value! ! !ACGlobalChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:23'! write: anObject self binding value: anObject! ! ACChange subclass: #ACInstanceChange instanceVariableNames: 'object offset' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACInstanceChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! object: anObject offset: anInteger | transaction slots change | transaction := ACTransaction current. slots := transaction instanceChanges at: anObject ifAbsentPut: [ Array new: anObject class instSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self transaction: transaction) object: anObject; offset: anInteger; update) ]. ^ change! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:25'! object ^ object! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:25'! object: anObject object := anObject! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:24'! offset ^ offset! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:24'! offset: anInteger offset := anInteger! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:25'! read ^ self object instVarAt: self offset! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:25'! write: anObject self object instVarAt: self offset put: anObject! ! ACChange subclass: #ACVariableChange instanceVariableNames: 'object offset' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACVariableChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! object: anObject offset: anInteger | transaction slots change | transaction := ACTransaction current. slots := transaction instanceChanges at: anObject ifAbsentPut: [ Array new: anObject basicSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self transaction: transaction) object: anObject; offset: anInteger; update) ]. ^ change! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:30'! object ^ object! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:30'! object: anObject object := anObject! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:21'! offset ^ offset! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:20'! offset: anInteger offset := anInteger! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 5/7/2007 08:26'! read ^ self object basicAt: self offset! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 5/7/2007 08:26'! write: anObject self object basicAt: self offset put: anObject! ! Object subclass: #ACTransaction instanceVariableNames: 'context changes globalChanges instanceChanges variableChanges' classVariableNames: '' poolDictionaries: 'ContextPart' category: 'Transactional-Model'! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 09:22'! current ^ ACCurrentTransaction signal! ! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 07:09'! within: aBlock ^ self new within: aBlock! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 08:24'! abort changes := globalChanges := instanceChanges := variableChanges := nil! ! !ACTransaction methodsFor: 'private' stamp: 'lr 5/7/2007 07:35'! basicCommit | changed conflicts | changed := changes select: [ :each | each hasChanged ]. conflicts := changed select: [ :each | each hasConflict ]. conflicts isEmpty ifFalse: [ ACConflict changes: conflicts ]. changed do: [ :each | each apply ]! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 08:24'! begin changes := OrderedCollection new. globalChanges := IdentityDictionary new. instanceChanges := IdentityDictionary new. variableChanges := IdentityDictionary new! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 5/7/2007 06:37'! changes ^ changes! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 06:37'! commit [ self basicCommit ] valueUnpreemptively! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 5/7/2007 06:37'! context ^ context! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! globalChanges ^ globalChanges! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! instanceChanges ^ instanceChanges! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! variableChanges ^ variableChanges! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 15:16'! within: aBlock | result | self begin. [ result := ACCurrentTransaction use: self during: aBlock ] ifCurtailed: [ self abort ]. self commit. ^ result! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self class isVariable ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! at: index put: value "Primitive. Assumes receiver is indexable. Store the argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self class isVariable ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:46'! atomicAt: anInteger ^ (ACVariableChange object: self offset: anInteger) value! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:46'! atomicAt: anInteger put: anObject ^ (ACVariableChange object: self offset: anInteger) value: anObject! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 06:32'! atomicInstVarAt: anInteger ^ (ACInstanceChange object: self offset: anInteger) value! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 06:32'! atomicInstVarAt: anInteger put: anObject ^ (ACInstanceChange object: self offset: anInteger) value: anObject! ! !Object methodsFor: '*transactional' stamp: 'lr 5/6/2007 12:19'! atomicPerform: aSelector withArguments: anArray | method | method := self class lookupSelector: aSelector. method ifNil: [ ^ self perform: aSelector withArguments: anArray ]. ^ self withArgs: anArray executeMethod: method atomicMethod! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:46'! basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:47'! 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." "Access beyond fixed variables." ^self basicAt: index - self class instSize ! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:47'! 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." "Access beyond fixed fields" ^self basicAt: anInteger - self class instSize put: anObject! ! !Exception methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:56'! resumeUnchecked: resumptionValue "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." | ctxt | outerContext ifNil: [ signalContext return: resumptionValue ] ifNotNil: [ ctxt _ outerContext. outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer" ctxt return: resumptionValue ]. ! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:46'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^self at: index! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:46'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^self at: index put: value! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:59'! atomicValue ^ (ACGlobalChange binding: self) value! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:59'! atomicValue: anObject ^ (ACGlobalChange binding: self) value: anObject! ! PECompilerPlugin subclass: #ACCompiler instanceVariableNames: 'active' classVariableNames: 'Enabled' poolDictionaries: '' category: 'Transactional-Model'! !ACCompiler class methodsFor: 'public' stamp: 'lr 5/7/2007 13:54'! atomicMethodFor: aCompiledMethod "Answer the atomic counterpart of aCompiledMethod. Methods with the pragma #atomic are considered to be already atomic. Methods with the pragma #atomic: will use the annotation code for the atomic counterpart." | methodNode methodClass | methodNode := aCompiledMethod methodNode. methodNode pragmas do: [ :each | each pragma keyword = #atomic ifTrue: [ ^ aCompiledMethod compiledMethod ]. each pragma keyword = #atomic: ifTrue: [ methodClass := aCompiledMethod methodClass. methodNode := methodClass parserClass new parse: each pragma arguments first class: methodClass. ^ methodNode generate compiledMethod ] ]. ^ methodNode copy beAtomic generate compiledMethod! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/7/2007 07:02'! initialize Enabled := true! ! !ACCompiler class methodsFor: 'plugin-interface' stamp: 'lr 5/7/2007 07:02'! isCompilerBackendPlugin ^ Enabled ifNil: [ false ]! ! !ACCompiler class methodsFor: 'plugin-interface' stamp: 'lr 5/7/2007 07:02'! priority ^ GPTransformer priority - 1! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/7/2007 14:30'! acceptAssignmentNode: aNode | gplink | self visitNode: aNode value. self isActive ifFalse: [ ^ self ]. (self reservedNames includes: aNode name) ifTrue: [ ^ self ]. gplink := GPLink new instead. aNode variable ifTemp: [ ^ self ] ifInstance: [ gplink metaObject: #object; selector: #atomicInstVarAt:put:; arguments: #(offset newValue) ] ifGlobal: [ gplink metaObject: #binding; selector: #atomicValue:; arguments: #(newValue) ]. aNode link: gplink! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/7/2007 09:34'! acceptBlockNode: aNode (self shouldEnter: aNode) ifFalse: [ self visitNode: aNode body ] ifTrue: [ self isActive ifTrue: [ aNode parent selector: #value ] ifFalse: [ self active: true. [ self visitNode: aNode body ] ensure: [ self active: false ] ] ]! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/9/2007 10:09'! acceptDoItNode: aNode self halt.! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/7/2007 10:44'! acceptMessageNode: aNode | gplink | super acceptMessageNode: aNode. self isActive ifFalse: [ ^ self ]. aNode isInline ifTrue: [ ^ self ]. gplink := GPLink metaObject: #receiver. gplink instead; arguments: #(selector arguments); selector: #atomicPerform:withArguments:. aNode link: gplink! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/9/2007 10:09'! acceptMethodNode: aNode self active: aNode isAtomic. self visitNode: aNode body! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/7/2007 06:49'! acceptSequenceNode: aNode aNode statements do: [ :each | self visitNode: each ]! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/7/2007 14:30'! acceptVariableNode: aNode | gplink | self isActive ifFalse: [ ^ self ]. (self reservedNames includes: aNode name) ifTrue: [ ^ self ]. gplink := GPLink new instead. aNode ifTemp: [ ^ self ] ifInstance: [ gplink metaObject: #object; selector: #atomicInstVarAt:; arguments: #(offset) ] ifGlobal: [ gplink metaObject: #binding; selector: #atomicValue; arguments: #() ]. aNode link: gplink! ! !ACCompiler methodsFor: 'accessing' stamp: 'lr 5/7/2007 09:33'! active: aBoolean active := aBoolean! ! !ACCompiler methodsFor: 'testing' stamp: 'lr 5/7/2007 09:33'! isActive ^ active! ! !ACCompiler methodsFor: 'accessing' stamp: 'lr 5/7/2007 09:33'! reservedNames ^ #( 'self' 'super' 'thisContext' )! ! !ACCompiler methodsFor: 'testing' stamp: 'lr 5/7/2007 09:33'! shouldEnter: aNode ^ aNode isBlock and: [ aNode parent notNil and: [ aNode parent isMessage and: [ aNode parent selector = #atomic ] ] ]! ! Error subclass: #ACConflict instanceVariableNames: 'changes' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !ACConflict class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 07:16'! changes: aCollection ^ self new changes: aCollection; signal! ! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/7/2007 07:16'! changes ^ changes! ! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/7/2007 07:16'! changes: aCollection changes := aCollection! ! Error subclass: #ACInvalidTransaction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! ACTransactionalTest initialize! ACCompiler initialize!