SystemOrganization addCategory: #'Transactional-Core'! SystemOrganization addCategory: #'Transactional-Tests'! Error subclass: #ACConflict instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ContextPart methodsFor: '*transactional' stamp: 'lr 4/25/2007 11:13'! atomic ^ ACTransaction within: self! ! !ContextPart methodsFor: '*transactional' stamp: 'lr 5/3/2007 15:55'! isContext ^ true! ! Object subclass: #ACChange instanceVariableNames: 'transaction value previous' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ACChange class methodsFor: 'instance-creation' stamp: 'lr 4/23/2007 16:22'! in: 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 4/25/2007 11:11'! 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: #ACInstanceChange instanceVariableNames: 'receiver index' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ACInstanceChange class methodsFor: 'instance-creation' stamp: 'lr 5/4/2007 13:47'! in: aTransaction receiver: anObject offset: anInteger | slots change | slots := aTransaction instanceChanges at: anObject ifAbsentPut: [ Array new: anObject class instSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self in: aTransaction) receiver: anObject; index: anInteger; update) ]. ^ change! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:37'! index ^ index! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:37'! index: anInteger index := anInteger! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 11:23'! read ^ self receiver instVarAt: self index! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:37'! receiver ^ receiver! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:37'! receiver: anObject receiver := anObject! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:56'! write: anObject self receiver instVarAt: self index put: anObject! ! ACChange subclass: #ACLiteralChange instanceVariableNames: 'association' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ACLiteralChange class methodsFor: 'instance-creation' stamp: 'lr 4/25/2007 11:05'! in: aTransaction association: anAssociation ^ aTransaction literalChanges at: anAssociation ifAbsentPut: [ (self in: aTransaction) association: anAssociation; update ]! ! !ACLiteralChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:39'! association ^ association! ! !ACLiteralChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:38'! association: anAssociation association := anAssociation! ! !ACLiteralChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:56'! read ^ self association value! ! !ACLiteralChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 14:15'! write: anObject self association value: anObject! ! ACChange subclass: #ACVariableChange instanceVariableNames: 'receiver index' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ACVariableChange class methodsFor: 'instance-creation' stamp: 'lr 4/27/2007 09:27'! in: aTransaction receiver: anObject offset: anInteger | slots change | slots := aTransaction variableChanges at: anObject ifAbsentPut: [ Array new: anObject basicSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self in: aTransaction) receiver: anObject; index: anInteger; update) ]. ^ change! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 09:25'! index ^ index! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 09:25'! index: anInteger index := anInteger! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 15:09'! read ^ self receiver basicAt: self index! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 09:25'! receiver ^ receiver! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 09:25'! receiver: anObject receiver := anObject! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 4/27/2007 09:25'! write: anObject self receiver basicAt: self index put: anObject! ! Object subclass: #ACTransaction instanceVariableNames: 'context changes instanceChanges variableChanges literalChanges' classVariableNames: '' poolDictionaries: 'ContextPart' category: 'Transactional-Core'! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 4/25/2007 11:12'! within: aBlock ^ self basicNew within: aBlock! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/4/2007 14:29'! abort changes := instanceChanges := variableChanges := literalChanges := nil! ! !ACTransaction methodsFor: 'public' stamp: 'lr 4/27/2007 11:58'! begin changes := OrderedCollection new. instanceChanges := IdentityDictionary new. variableChanges := IdentityDictionary new. literalChanges := IdentityDictionary new! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:30'! blockReturnTop "Return Top Of Stack bytecode." ^ context blockReturnTop! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 4/25/2007 11:10'! changes ^ changes! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/3/2007 15:38'! commit [ changes := changes select: [ :each | each hasChanged ]. changes do: [ :each | each hasConflict ifTrue: [ ACConflict signal ] ]. changes do: [ :each | each apply ] ] valueUnpreemptively! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:33'! context ^ context! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:30'! doDup "Duplicate Top Of Stack bytecode." ^ context doDup! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:30'! doPop "Remove Top Of Stack bytecode." ^ context doPop! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 4/25/2007 11:03'! instanceChanges ^ instanceChanges! ! !ACTransaction methodsFor: 'private' stamp: 'lr 5/4/2007 14:53'! interpret: aBlock | signal | signal := ACVariableChange in: self receiver: thisContext offset: 2. context := [ aBlock on: Exception do: [ :error | signal := error ] ] asContext. context privSender: thisContext. [ context == thisContext or: [ signal value notNil ] ] whileFalse: [ context willSend ifTrue: [ Transcript show: context; cr; show: context tempsAndValues; cr ]. context := context interpretNextInstructionFor: self ]. ^ signal value isNil ifFalse: [ thisContext nextHandlerContext handleSignal: signal value ] ifTrue: [ context pop ]! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:30'! jump: offset "Unconditional Jump bytecode." ^ context jump: offset! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! jump: offset if: condition "Conditional Jump bytecode." ^ context jump: offset if: condition ! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 4/25/2007 11:03'! literalChanges ^ literalChanges! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! methodReturnConstant: value "Return Constant bytecode." ^ context methodReturnConstant: value ! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! methodReturnReceiver "Return Self bytecode." ^ context methodReturnReceiver! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! methodReturnTop "Return Top Of Stack bytecode." ^ context methodReturnTop! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 4/27/2007 10:47'! popIntoLiteralVariable: anAssociation "Remove top of stack and store into literal variable." (ACLiteralChange in: self association: anAssociation) value: context pop. ^ context! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 13:49'! popIntoReceiverVariable: anInteger "Remove top of stack and store into instance variable of method bytecode." (ACInstanceChange in: self receiver: context receiver offset: anInteger + 1) value: context pop. ^ context! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 14:45'! popIntoTemporaryVariable: anInteger "Remove top of stack and store into temporary variable of method bytecode." (ACVariableChange in: self receiver: context home offset: anInteger + 1) value: context pop. ^ context! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." ^ context pushActiveContext! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:31'! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." ^ context pushConstant: value! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 4/27/2007 13:43'! pushLiteralVariable: anAssociation "Push contents of anAssociation on top of stack." ^ context push: (ACLiteralChange in: self association: anAssociation) value! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/23/2007 13:37'! pushReceiver "Push Active Context's Receiver on Top Of Stack bytecode." ^ context pushReceiver! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 13:48'! pushReceiverVariable: anInteger "Push contents of the receiver's instance variable whose index is the argument on top of stack bytecode." ^ context push: (ACInstanceChange in: self receiver: context receiver offset: anInteger + 1) value! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 14:47'! pushTemporaryVariable: anInteger "Push contents of temporary variable whose index is the argument, offset, on top of stack bytecode." ^ context push: (ACVariableChange in: self receiver: context home offset: anInteger + 1) value! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 15:07'! send: aSelector super: aBoolean numArgs: anInteger "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." | receiver arguments answer class method primitive | arguments := Array new: anInteger. anInteger to: 1 by: -1 do: [ :i | arguments at: i put: context pop ]. receiver := context pop. aSelector == #doPrimitive:method:receiver:args: ifTrue: [ ^ context push: (receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4)) ]. class := aBoolean ifFalse: [ receiver class ] ifTrue: [ (context method literalAt: context method numLiterals) value superclass ]. method := class lookupSelector: aSelector. method ifNil: [ ^ context send: #doesNotUnderstand: to: receiver with: (Array with: (Message selector: aSelector arguments: arguments)) super: aBoolean ]. primitive := method primitive. primitive == 0 ifFalse: [ primitive >= 264 ifTrue: [ ^ self pushReceiverVariable: primitive - 264 ]. (primitive == 60 and: [ receiver isContext ]) ifTrue: [ ^ context push: (ACVariableChange in: self receiver: receiver offset: (arguments at: 1)) value ]. (primitive == 61 and: [ receiver isContext ]) ifTrue: [ ^ context push: ((ACVariableChange in: self receiver: receiver offset: (arguments at: 1)) value: (arguments at: 2)) ]. answer := context doPrimitive: primitive method: method receiver: receiver args: arguments. answer == PrimitiveFailToken ifFalse: [ ^ answer ] ]. ^ context activateMethod: method withArgs: arguments receiver: receiver class: class! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 4/27/2007 13:43'! storeIntoLiteralVariable: anAssociation "Store Top Of Stack Into Literal Variable Of Method bytecode." (ACLiteralChange in: self association: anAssociation) value: context top. ^ context! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 13:48'! storeIntoReceiverVariable: anInteger "Store top of stack into instance variable of method bytecode." (ACInstanceChange in: self receiver: context receiver offset: anInteger + 1) value: context top. ^ context! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 5/4/2007 14:45'! storeIntoTemporaryVariable: anInteger "Store top of stack into temporary variable of method bytecode." (ACVariableChange in: self receiver: context home offset: anInteger + 1) value: context top. ^ context! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 4/27/2007 09:22'! variableChanges ^ variableChanges! ! !ACTransaction methodsFor: 'public' stamp: 'lr 4/25/2007 11:12'! within: aBlock | result | self begin. [ result := self interpret: aBlock ] ifCurtailed: [ self abort ]. self commit. ^ result! ! !Object methodsFor: '*transactional' stamp: 'lr 5/3/2007 15:55'! isContext ^ false! ! 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/3/2007 14:04'! testAccessor self assert: [ self value: true. self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testAccessorRead self value: true. self assert: [ self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testAccessorWrite [ self value: true ] atomic. self assert: self value! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/4/2007 15:00'! testBasicContext self assert: [ thisContext home ] atomic == thisContext! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 13:17'! 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/3/2007 14:02'! testInstance self assert: [ value := true. value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! testInstanceRead value := true. self assert: [ value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/3/2007 14:02'! 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/4/2007 14:56'! testLoop "This code showed some bug in the exception handling." " ACBasicTest run: #testLoop " " | 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/3/2007 14:03'! 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/3/2007 15:58'! testArray | 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/3/2007 15:58'! testBag | 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/3/2007 15:58'! testDictionary | 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/3/2007 15:58'! testSet | 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/4/2007 14:51'! testTemp | temp | self should: [ [ temp := true. self assert: temp. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: temp isNil! ! !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! ! ACTransactionalTest initialize!