SystemOrganization addCategory: #'Transactional-Core'! SystemOrganization addCategory: #'Transactional-Interpreter'! SystemOrganization addCategory: #'Transactional-Tests'! RBProgramNodeVisitor subclass: #TRTransactionInterpreter instanceVariableNames: 'transaction temps' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Interpreter'! TRTransactionInterpreter subclass: #TRBlockInterpreter uses: TBlock instanceVariableNames: 'methodInterpreter outerInterpreter blockNode' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Interpreter'! TRBlockInterpreter class uses: TBlock classTrait instanceVariableNames: ''! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! blockNode ^blockNode! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! blockNode: aBlockNode blockNode := aBlockNode! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! codeNode ^blockNode! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! isBlock ^ true! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodClass ^methodInterpreter methodClass! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodInterpreter ^methodInterpreter! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodInterpreter: aMethodInterpreter methodInterpreter := aMethodInterpreter! ! !TRBlockInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! nodesForInstrumentation ^Array with: self blockNode copy! ! TRTransactionInterpreter subclass: #TRMethodInterpreter instanceVariableNames: 'receiver methodNode instanceVariableMap escaper' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Interpreter'! !TRMethodInterpreter class methodsFor: 'execution' stamp: 'lr 4/23/2007 10:58'! transaction: aTransaction run: aMethodNode with: anArray in: anObject ^ self new transaction: aTransaction; methodNode: aMethodNode; initializeArgumentsWith: anArray; receiver: anObject; run! ! !TRMethodInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:36'! acceptBlockNode: aBlockNode ^ self blockInterpreterClass block: aBlockNode interpreter: self! ! !TRMethodInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:35'! acceptMethodNode: aMethodNode aMethodNode isPrimitive ifTrue: [ self executePrimitve: aMethodNode ] ifFalse: [ self interpret: aMethodNode ]! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! arguments ^self codeNode arguments collect: [ :each | temps at: each name ]! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! codeNode ^methodNode! ! !TRMethodInterpreter methodsFor: 'executing' stamp: 'lr 4/23/2007 10:07'! executePrimitve: aMethodNode | newMethodNode newBody newMethod | newMethodNode := aMethodNode copy. newBody := RBSequenceNode statement: ( RBMessageNode receiver: (PEObjectLiteralNode value: self) selector: #interpret: argument: (PEObjectLiteralNode value: aMethodNode)). newMethodNode body: newBody. newMethod := (ASTTranslator new visitNode: newMethodNode; ir) compiledMethodWith: #(0 0 0 0). self return: (newMethod valueWithReceiver: self receiver arguments: self arguments)! ! !TRMethodInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! instanceVariableAt: aString ^self receiver instVarAt: (self instanceVariableMap at: aString)! ! !TRMethodInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! instanceVariableAt: aString put: anObject ^self receiver instVarAt: (self instanceVariableMap at: aString) put: anObject! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! instanceVariableMap instanceVariableMap isNil ifTrue: [ instanceVariableMap := Dictionary new. receiver class allInstVarNames withIndexDo: [ :each :index | instanceVariableMap at: each put: index ] ]. ^instanceVariableMap! ! !TRMethodInterpreter methodsFor: 'executing' stamp: 'lr 4/23/2007 10:07'! interpret: aMethodNode self visitNode: aMethodNode body. self returnSelf! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodClass ^methodNode methodClass! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodInterpreter ^self! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodNode: aMethodNode methodNode := aMethodNode! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! receiver ^receiver! ! !TRMethodInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! receiver: anObject receiver := anObject! ! !TRMethodInterpreter methodsFor: 'returning' stamp: 'lr 4/23/2007 10:07'! return: anObject escaper value: anObject! ! !TRMethodInterpreter methodsFor: 'executing' stamp: 'lr 4/23/2007 10:36'! run ^ self withEscaper: [ self visitNode: methodNode ]! ! !TRMethodInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! temporaryVariableAt: aString ^temps at: aString! ! !TRMethodInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! temporaryVariableAt: aString put: anObject ^temps at: aString put: anObject! ! !TRMethodInterpreter methodsFor: 'visiting' stamp: 'lr 4/23/2007 10:07'! visitBlockArguments: aNodeCollection self shouldNotImplement! ! !TRMethodInterpreter methodsFor: 'escaping' stamp: 'lr 4/23/2007 10:07'! withEscaper: aBlock | old | old := escaper. escaper := [ :value | ^ value ]. ^ aBlock ensure: [ escaper := old ]! ! !TRTransactionInterpreter class methodsFor: 'initializeation' stamp: 'lr 4/23/2007 11:21'! transaction: aTransaction ^ self new initializeWithTransaction: aTransaction! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:27'! acceptArrayNode: anArrayNode ^ anArrayNode children collect: [ :each | self visitNode: each ]! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 11:04'! acceptAssignmentNode: anAssignmentNode | value | value := self visitNode: anAssignmentNode value. self write: value to: anAssignmentNode. ^ value! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:29'! acceptBlockNode: aBlockNode self subclassResponsibility! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 11:09'! acceptCascadeNode: aCascadeNode | receiver result | receiver := self visitNode: aCascadeNode receiver. aCascadeNode messages do: [ :each | result := self newMethodInterpreter run: (receiver class >> each selector) methodNode with: (each arguments collect: [ :argument | self visitNode: argument]) ]. ^ result! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:30'! acceptLiteralNode: aLiteralNode ^ aLiteralNode value ! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 11:18'! acceptMessageNode: aMessageNode | receiver class | receiver := self visitNode: aMessageNode receiver. class := aMessageNode isSuperSend ifFalse: [ receiver class ] ifTrue: [ (receiver class whichClassIncludesSelector: aMessageNode selector) superclass ]. ^ self newMethodInterpreter run: (class >> aMessageNode selector) with: (aMessageNode arguments collect: [ :each | self visitNode: each ]) in: receiver ! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 10:31'! acceptReturnNode: aReturnNode self return: (self visitNode: aReturnNode value)! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 11:18'! acceptSequenceNode: aSequenceNode | result | result := nil. aSequenceNode statements do: [ :each | result := self visitNode: each ]. ^ result! ! !TRTransactionInterpreter methodsFor: 'accepting' stamp: 'lr 4/23/2007 11:19'! acceptVariableNode: aVariableNode | name | name := aVariableNode name. name = 'self' ifTrue: [ ^ self receiver ]. name = 'super' ifTrue: [ ^ self receiver ]. name = 'true' ifTrue: [ ^ true ]. name = 'false' ifTrue: [ ^ false ]. name = 'nil' ifTrue: [ ^ nil ]. name = 'thisContext' ifTrue: [ ^ self halt ]. ^ self readFrom: aVariableNode! ! !TRTransactionInterpreter methodsFor: 'private' stamp: 'lr 4/23/2007 10:34'! blockInterpreterClass ^ TRBlockInterpreter! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! codeNode self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'initialization' stamp: 'lr 4/23/2007 10:09'! initializeArgumentsWith: anArray | localTempNames | localTempNames := self codeNode tempNames. temps := Dictionary new: (localTempNames size). localTempNames do: [ :each | temps at: each put: nil ]. self codeNode arguments withIndexDo: [ :each :index | temps at: each name put: (anArray at: index) ].! ! !TRTransactionInterpreter methodsFor: 'initialization' stamp: 'lr 4/23/2007 11:20'! initializeWithTransaction: aTransaction! ! !TRTransactionInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! instanceVariableAt: aString self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! instanceVariableAt: aString put: anObject self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodClass self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! methodInterpreter self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'private' stamp: 'lr 4/23/2007 10:39'! methodInterpreterClass ^ TRMethodInterpreter! ! !TRTransactionInterpreter methodsFor: 'creational' stamp: 'lr 4/23/2007 11:22'! newBlockInterpreter ^ self blockInterpreterClass transaction: self transaction! ! !TRTransactionInterpreter methodsFor: 'creational' stamp: 'lr 4/23/2007 11:21'! newMethodInterpreter ^ self methodInterpreterClass transaction: self transaction! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! receiver self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'returning' stamp: 'lr 4/23/2007 10:38'! return: anObject self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'returning' stamp: 'lr 4/23/2007 10:38'! returnSelf self return: self receiver! ! !TRTransactionInterpreter methodsFor: 'initialization' stamp: 'lr 4/23/2007 10:43'! run: anArray temps := Array with: self codeNode scope tempVars! ! !TRTransactionInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! set: aVariable toValue: anObject aVariable ifTemp: [ self temporaryVariableAt: aVariable name put: anObject ] ifInstance: [ self instanceVariableAt: aVariable name put: anObject ] ifGlobal: [ (self receiver class bindingOf: aVariable name) value: anObject ]. ^anObject! ! !TRTransactionInterpreter methodsFor: 'initialization' stamp: 'lr 4/23/2007 11:20'! setTransaction: aTransaction transaction := aTransaction! ! !TRTransactionInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! temporaryVariableAt: aString self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'accessing-variables' stamp: 'lr 4/23/2007 10:07'! temporaryVariableAt: aString put: anObject self subclassResponsibility ! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! temps ^temps! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:07'! temps: aDictionary temps := aDictionary! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:09'! transaction ^ transaction! ! !TRTransactionInterpreter methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:59'! transaction: aTransaction transaction := aTransaction! ! Object subclass: #ACChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! ACChange subclass: #ACGlobalChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! ACChange subclass: #ACInstanceChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! ACChange subclass: #ACTempChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! Object subclass: #ACTransaction instanceVariableNames: 'log' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Core'! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 4/23/2007 10:22'! do: aBlock ^ self do: aBlock arguments: #()! ! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 4/23/2007 10:22'! do: aBlock arguments: anArray ^ self to: aBlock send: #valueWithArguments: arguments: anArray! ! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 4/23/2007 10:19'! to: anObject send: aSelector arguments: anArray | interpreter | interpreter := PEMethodInterpreter new. interpreter receiver: anObject; transaction: self new; methodNode: (anObject class >> aSelector) methodNode; initializeArgumentsWith: anArray. ^ interpreter new! ! !ACTransaction methodsFor: 'public' stamp: 'lr 3/16/2007 15:05'! abort ! ! !ACTransaction methodsFor: 'public' stamp: 'lr 3/16/2007 15:05'! commit ! ! !ACTransaction methodsFor: 'initialization' stamp: 'lr 4/23/2007 10:14'! initialize super initialize. log := OrderedCollection new! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 4/23/2007 10:13'! log ^ log! ! !ACTransaction methodsFor: 'private' stamp: 'lr 4/23/2007 10:29'! readFrom: aVariableNode! ! !ACTransaction methodsFor: 'private' stamp: 'lr 4/23/2007 10:29'! write: anObject to: aVariableNode! ! TestCase subclass: #ACTestCase instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACTestCase methodsFor: 'testing-mocks' stamp: 'lr 4/16/2007 09:24'! nested "self >> #nested" [ [] atomic ] atomic! ! !ACTestCase methodsFor: 'testing-mocks' stamp: 'lr 4/16/2007 09:24'! self "self >> #self" [] atomic! ! !ACTestCase methodsFor: 'testing-special' stamp: 'lr 4/16/2007 09:24'! testAtomicContext "self >> #testAtomicContext" self assert: [ thisContext sender ] atomic == thisContext! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/16/2007 09:29'! testAtomicInstRead "self >> #testAtomicInstRead" "self run: #testAtomicInstRead" value := true. self assert: [ value ] atomic! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/16/2007 09:29'! testAtomicInstWrite "self >> #testAtomicInstWrite" "self run: #testAtomicInstWrite" [ value := true ] atomic. self assert: value! ! !ACTestCase methodsFor: 'testing-special' stamp: 'lr 4/16/2007 09:29'! testAtomicSelf "self >> #testAtomicSelf" self assert: [ self ] atomic == self! ! !ACTestCase methodsFor: 'testing-special' stamp: 'lr 4/16/2007 09:29'! testAtomicSuper "self >> #testAtomicSuper" self assert: [ super ] atomic == self! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/16/2007 09:29'! testAtomicTempRead "self >> #testAtomicTempRead" "self run: #testAtomicTempRead" | temp | temp := true. self assert: [ temp ] atomic! ! !ACTestCase methodsFor: 'testing' stamp: 'lr 4/16/2007 09:29'! testAtomicTempWrite "self >> #testAtomicTempWrite" "self run: #testAtomicTempWrite" | temp | [ temp := true ] atomic. self assert: temp! ! !ACTestCase methodsFor: 'testing-compiler' stamp: 'lr 4/16/2007 10:26'! testInlinedMethods "self run: #testInlinedMethods" | atomicMethod | atomicMethod := self class methodDictionary at: thisContext selector asAtomicSelector. "code to analyze" self isNil ifTrue: [ self halt ]. "assertions" self assert: (atomicMethod literalArray includes: ('h' , 'alt') asAtomicSelector). self deny: (atomicMethod literalArray includes: ('i' , 'sNil') asAtomicSelector). self deny: (atomicMethod literalArray includes: ('i' , 'ifTrue:') asAtomicSelector)! !