SystemOrganization addCategory: #'Transactional-Core'! SystemOrganization addCategory: #'Transactional-Tests'! TestCase subclass: #ACTestCase instanceVariableNames: 'value array' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! !ACTestCase methodsFor: 'running' stamp: 'lr 4/27/2007 09:34'! setUp array := Array new: 1. value := nil. Value := nil! ! !ACTestCase methodsFor: 'utilities' stamp: 'lr 4/25/2007 14:03'! 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 ]! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/23/2007 13:17'! testBasicContext self assert: [ thisContext home ] atomic == thisContext! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 16:49'! testBasicInstRead value := true. self assert: [ value ] atomic! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 13:16'! testBasicInstWrite [ value := true ] atomic. self assert: value! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 16:20'! testBasicLiteralRead Value := true. self assert: [ Value ] atomic! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 16:20'! testBasicLiteralWrite [ Value := true ] atomic. self assert: Value! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/23/2007 13:17'! testBasicSelf self assert: [ self ] atomic == self! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/23/2007 13:17'! testBasicSuper self assert: [ super ] atomic == self! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 13:16'! testBasicTempRead | temp | temp := true. self assert: [ temp ] atomic! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/23/2007 13:16'! testBasicTempWrite | temp | [ temp := true ] atomic. self assert: temp! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/27/2007 09:34'! testBasicVarRead array at: 1 put: true. self assert: [ array at: 1 ] atomic! ! !ACTestCase methodsFor: 'testing-basic' stamp: 'lr 4/27/2007 09:35'! testBasicVarWrite [ array at: 1 put: true ] atomic. self assert: (array at: 1)! ! !ACTestCase methodsFor: 'testing-errors' stamp: 'lr 4/27/2007 11:14'! testErrorInst self should: [ [ value := true. self assert: value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: value isNil! ! !ACTestCase methodsFor: 'testing-errors' stamp: 'lr 4/25/2007 11:36'! testErrorLiteral self should: [ [ Value := true. self assert: Value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: Value isNil! ! !ACTestCase methodsFor: 'testing-errors' stamp: 'lr 4/27/2007 09:35'! testErrorVar self should: [ [ array at: 1 put: true. self assert: (array at: 1). 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACTestCase methodsFor: 'testing-advanced' stamp: 'lr 4/26/2007 11:12'! testParallelDictionary | hash | hash := Dictionary new. 1 to: 100 do: [ :each | [ hash at: each put: 1 "(hash at: each ifAbsentPut: [ 0 ]) + 1" ] atomic ]. 1 to: 100 do: [ :each | self assert: (hash at: each) = 1 ]! ! !ContextPart methodsFor: '*transactional' stamp: 'lr 4/25/2007 11:13'! atomic ^ ACTransaction within: self! ! 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 4/27/2007 11:04'! 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 4/25/2007 11:05'! in: aTransaction offset: anInteger | receiver slots change | receiver := aTransaction context receiver. slots := aTransaction instanceChanges at: receiver ifAbsentPut: [ Array new: receiver class instSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self in: aTransaction) receiver: receiver; 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 4/25/2007 10:56'! 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 4/27/2007 09:25'! 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 4/27/2007 09:23'! 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 4/27/2007 11:48'! 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 4/27/2007 13:44'! interpret: aBlock | signal | context := [ aBlock on: Exception do: [ :error | signal := error ] ] asContext. context privSender: thisContext. [ context ~~ thisContext and: [ signal isNil ] ] whileTrue: [ context := context interpretNextInstructionFor: self ]. ^ signal isNil ifFalse: [ thisContext nextHandlerContext handleSignal: signal ] 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 4/27/2007 10:47'! popIntoReceiverVariable: anInteger "Remove top of stack and store into instance variable of method bytecode." (ACInstanceChange in: self offset: anInteger + 1) value: context pop. ^ context! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/25/2007 13:34'! popIntoTemporaryVariable: anInteger "Remove top of stack and store into temporary variable of method bytecode." ^ context popIntoTemporaryVariable: anInteger! ! !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 4/27/2007 13:43'! 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 offset: anInteger + 1) value! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/25/2007 13:34'! pushTemporaryVariable: anInteger "Push contents of temporary variable whose index is the argument, offset, on top of stack bytecode." ^ context pushTemporaryVariable: anInteger! ! !ACTransaction methodsFor: 'interpreting' stamp: 'lr 4/27/2007 11:53'! 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)). ^ context ]. class := aBoolean ifTrue: [ (context method literalAt: context method numLiterals) value superclass ] ifFalse: [ receiver class ]. method := class lookupSelector: aSelector. method isNil ifTrue: [ ^ context send: #doesNotUnderstand: to: receiver with: (Array with: (Message selector: aSelector arguments: arguments)) super: aBoolean ]. primitive := method primitive. primitive == 0 ifFalse: [ (primitive == 60 and: [ class ~~ MethodContext and: [ class ~~ BlockContext ] ]) ifTrue: [ ^ context push: (ACVariableChange in: self receiver: receiver offset: (arguments at: 1)) value ]. (primitive == 61 and: [ class ~~ MethodContext and: [ class ~~ BlockContext ] ]) 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 4/27/2007 13:43'! storeIntoReceiverVariable: anInteger "Store top of stack into instance variable of method bytecode." (ACInstanceChange in: self offset: anInteger + 1) value: context top. ^ context! ! !ACTransaction methodsFor: 'delegated' stamp: 'lr 4/25/2007 13:34'! storeIntoTemporaryVariable: anInteger "Store top of stack into temporary variable of method bytecode." ^ context storeIntoTemporaryVariable: anInteger! ! !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! ! Error subclass: #ACConflict instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'!