SystemOrganization addCategory: #'Transactional-Model'! SystemOrganization addCategory: #'Transactional-Tests'! SystemOrganization addCategory: #'Transactional-Errors'! !String methodsFor: '*transactional' stamp: 'lr 5/10/2007 11:47'! asAtomicSelector ^ Symbol intern: self atomicPrefix , self! ! !String methodsFor: '*transactional' stamp: 'lr 5/10/2007 11:47'! asNormalSelector ^ Symbol intern: (self allButFirst: self atomicPrefix size)! ! !String methodsFor: '*transactional' stamp: 'lr 4/16/2007 09:48'! atomicPrefix ^ '__atomic__'! ! !String methodsFor: '*transactional' stamp: 'lr 4/16/2007 09:48'! isAtomicSelector ^ self beginsWith: self atomicPrefix! ! !String methodsFor: '*transactional-override' stamp: 'lr 5/10/2007 12:02'! numArgs "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction." | firstChar numColons excess start ix | self size = 0 ifTrue: [^ -1]. self isAtomicSelector ifTrue: [ ^ self asNormalSelector numArgs ]. firstChar _ self at: 1. (firstChar isLetter or: [firstChar = $:]) ifTrue: ["Fast reject if any chars are non-alphanumeric" (self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1]. "Fast colon count" numColons _ 0. start _ 1. [(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0] whileTrue: [numColons _ numColons + 1. start _ ix + 1]. numColons = 0 ifTrue: [^ 0]. firstChar = $: ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"] ifFalse: [excess _ 0]. self last = $: ifTrue: [^ numColons - excess] ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]]. firstChar isSpecial ifTrue: [self size = 1 ifTrue: [^ 1]. 2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]]. ^ 1]. ^ -1.! ! !Behavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 13:19'! atomicMethods ^ Array streamContents: [ :stream | self methodDictionary keysAndValuesDo: [ :key :value | key isAtomicSelector ifTrue: [ stream nextPut: value ] ] ]! ! !Behavior methodsFor: '*transactional' stamp: 'lr 5/11/2007 16:01'! flushAtomic | copy | self methodDictionary keysDo: [ :each | each isAtomicSelector ifTrue: [ copy := copy ifNil: [ self methodDictionary copy ]. copy removeDangerouslyKey: each ifAbsent: [] ] ]. copy ifNotNil: [ self methodDictionary become: copy ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys reject: [ :each | each isAtomicSelector ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:06'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: [ :selector | selector isAtomicSelector ifFalse: [ selectorBlock value: selector ] ]! ! !BlockContext methodsFor: '*transactional' stamp: 'lr 5/9/2007 15:37'! 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/9/2007 10:37'! atomicMethod ^ 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 ]! ! TestCase subclass: #ACTransactionalTest instanceVariableNames: 'value array' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! ACTransactionalTest subclass: #ACAbortTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACAbortTest methodsFor: 'testing-abort' stamp: 'lr 5/14/2007 09:11'! testAbortAccessor self assert: [ self value: true; abort: self value ] atomic. self assert: self value isNil! ! !ACAbortTest methodsFor: 'testing-abort' stamp: 'lr 5/14/2007 09:11'! testAbortInstance self assert: [ value := true. self abort: value ] atomic. self assert: value isNil! ! !ACAbortTest methodsFor: 'testing-abort' stamp: 'lr 5/14/2007 09:12'! testAbortLiteral self assert: [ Value := true. self abort: Value ] atomic. self assert: Value isNil! ! !ACAbortTest methodsFor: 'testing-abort' stamp: 'lr 5/14/2007 09:12'! testAbortTemp | temp | self assert: [ temp := true. self abort: temp ] atomic. self assert: temp! ! !ACAbortTest methodsFor: 'testing-abort' stamp: 'lr 5/14/2007 09:12'! testAbortVariable self assert: [ array at: 1 put: true. self abort: (array at: 1) ] atomic. self assert: (array at: 1) isNil! ! !ACAbortTest methodsFor: 'testing-check' stamp: 'lr 5/14/2007 09:13'! testCheckAccessor self assert: [ self value: true; checkpoint; abort: self value ] atomic. self assert: self value! ! !ACAbortTest methodsFor: 'testing-check' stamp: 'lr 5/14/2007 09:13'! testCheckInstance self assert: [ value := true. self checkpoint. self abort: value ] atomic. self assert: value! ! !ACAbortTest methodsFor: 'testing-check' stamp: 'lr 5/14/2007 09:13'! testCheckLiteral self assert: [ Value := true. self checkpoint. self abort: Value ] atomic. self assert: Value! ! !ACAbortTest methodsFor: 'testing-check' stamp: 'lr 5/14/2007 09:13'! testCheckTemp | temp | self assert: [ temp := true. self checkpoint. self abort: temp ] atomic. self assert: temp! ! !ACAbortTest methodsFor: 'testing-check' stamp: 'lr 5/14/2007 09:13'! testCheckVariable self assert: [ array at: 1 put: true. self checkpoint. self abort: (array at: 1) ] atomic. self assert: (array at: 1)! ! !ACAbortTest methodsFor: 'testing-error' stamp: 'lr 5/14/2007 08:39'! testErrorAccessor self should: [ [ self value: true. self assert: self value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACAbortTest methodsFor: 'testing-error' stamp: 'lr 5/14/2007 08:39'! testErrorInstance self should: [ [ value := true. self assert: value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: value isNil! ! !ACAbortTest methodsFor: 'testing-error' stamp: 'lr 5/14/2007 08:39'! testErrorLiteral self should: [ [ Value := true. self assert: Value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: Value isNil! ! !ACAbortTest methodsFor: 'testing-error' stamp: 'lr 5/14/2007 08:43'! testErrorTemp | temp | self should: [ [ temp := true. self assert: temp. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: temp! ! !ACAbortTest methodsFor: 'testing-error' stamp: 'lr 5/14/2007 08:39'! testErrorVariable self should: [ [ array at: 1 put: true. self assert: (array at: 1). 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! ACTransactionalTest subclass: #ACBasicTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessor self assert: [ self value: true. self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessorRead self value: true. self assert: [ self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessorWrite [ self value: true ] atomic. self assert: self value! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 14:56'! testBasicContext self assert: [ thisContext home ] atomic == thisContext! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 11:18'! testBasicSelf self assert: [ self ] atomic == self! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 11:18'! testBasicSuper self assert: [ super ] atomic == self! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobal self assert: [ GlobalValue := true. GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobalRead GlobalValue := true. self assert: [ GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobalWrite [ GlobalValue := true ] atomic. self assert: GlobalValue! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedAndOr self assert: [ true and: [ true ] ] atomic. self deny: [ false and: [ true ] ] atomic. self deny: [ true and: [ false ] ] atomic. self deny: [ false and: [ false ] ] atomic. self assert: [ true or: [ true ] ] atomic. self assert: [ false or: [ true ] ] atomic. self assert: [ true or: [ false ] ] atomic. self deny: [ false and: [ false ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/11/2007 15:07'! testInlinedArray self assert: [ { } ] atomic = #( ). self assert: [ { 1 } ] atomic = #( 1 ). self assert: [ { 1. 2 } ] atomic = #( 1 2 ). self assert: [ { 1. 2. 3 } ] atomic = #( 1 2 3 ). self assert: [ { 1. 2. 3. 4 } ] atomic = #( 1 2 3 4 ). self assert: [ { 1. 2. 3. 4. 5 } ] atomic = #( 1 2 3 4 5 ). self assert: [ { 1. 2. 3. 4. 5. 6 } ] atomic = #( 1 2 3 4 5 6 )! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/11/2007 15:23'! testInlinedArrayNested self assert: [ { { } } ] atomic = #( ( ) ). self assert: [ { { 1 } } ] atomic = #( ( 1 ) ). self assert: [ { { 1. 2 } } ] atomic = #( ( 1 2 ) ). self assert: [ { { 1. 2 }. { 3 } } ] atomic = #( ( 1 2 ) ( 3 ) ). self assert: [ { { 1. 2 }. { 3. 4 } } ] atomic = #( ( 1 2 ) ( 3 4 ) )! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedIfNil self assert: [ nil ifNil: [ true ] ] atomic. self assert: [ 1 ifNotNil: [ true ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedIfTrue self assert: [ true ifTrue: [ true ] ] atomic. self assert: [ false ifFalse: [ true ] ] atomic. self assert: [ true ifTrue: [ true ] ifFalse: [ false ] ] atomic. self assert: [ false ifFalse: [ true ] ifTrue: [ false ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 11:42'! testInlinedToDo | x | x := 0. [ 1 to: 10 do: [ :i | x := x + i ] ] atomic. self assert: x = 55. x := 0. [ 1 to: 10 by: 2 do: [ :i | x := x + i ] ] atomic. self assert: x = 25 ! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 15:14'! testInlinedWhile | i x | i := 1. x := 0. [ [ x := x + i. i := i + 1. i <= 10 ] whileTrue ] atomic. self assert: x = 55. i := 1. x := 0. [ [ i <= 10 ] whileTrue: [ x := x + i. i := i + 1 ] ] atomic. self assert: x = 55. i := 1. x := 0. [ [ x := x + i. i := i + 1. i > 10 ] whileFalse ] atomic. self assert: x = 55. i := 1. x := 0. [ [ i > 10 ] whileFalse: [ x := x + i. i := i + 1 ] ] atomic. self assert: x = 55! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstance self assert: [ value := true. value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstanceRead value := true. self assert: [ value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstanceWrite [ value := true ] atomic. self assert: value! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteral self assert: [ Value := true. Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteralRead Value := true. self assert: [ Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteralWrite [ Value := true ] atomic. self assert: Value! ! !ACBasicTest methodsFor: 'testing' stamp: 'lr 5/10/2007 09:48'! testLoop "This code showed some bug in the exception handling." | current | [ current := SortedCollection. [ current == nil ] whileFalse: [ current == Object ifTrue: [ ^ self ]. current := current superclass ] ] value. self assert: current == Object! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendBinary self assert: [ 1 + 2 ] atomic = 3! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendKeyword self assert: [ 2 raisedTo: 3 ] atomic = 8! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendUnary self assert: [ 1 negated ] atomic = -1! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTemp | temp | self assert: [ temp := true. temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTempRead | temp | temp := true. self assert: [ temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTempWrite | temp | [ temp := true ] atomic. self assert: temp! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testVariable self assert: [ array at: 1 put: true; at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testVariableRead array at: 1 put: true. self assert: [ array at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! 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/10/2007 14:19'! 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-streams' stamp: 'lr 5/14/2007 15:44'! testReadStream | stream | stream := (1 to: 10) asArray readStream. [ 1 to: 10 do: [ :each | self assert: stream next = each ] ] atomic! ! !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) ]! ! !ACCollectionTest methodsFor: 'testing-streams' stamp: 'lr 5/14/2007 15:45'! testWriteStream | stream | stream := (Array new: 10) writeStream. [ 1 to: 10 do: [ :each | stream nextPut: each ] ] atomic. self assert: (1 to: 10) asArray = stream contents! ! !ACTransactionalTest class methodsFor: 'initialization' stamp: 'lr 5/4/2007 14:37'! initialize self environment at: #GlobalValue put: nil! ! !ACTransactionalTest methodsFor: 'utilities' stamp: 'lr 5/14/2007 08:46'! abort: anObject self transaction abort: anObject! ! !ACTransactionalTest methodsFor: 'utilities' stamp: 'lr 5/14/2007 09:14'! checkpoint self transaction checkpoint! ! !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/14/2007 08:46'! transaction ^ ACTransaction current! ! !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! ! TestCase subclass: #ACUtilitiesTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/10/2007 11:48'! testAsAtomicSelector self assert: #string asAtomicSelector == #'__atomic__string'. self assert: #linesDo: asAtomicSelector == #'__atomic__linesDo:'. self assert: #indexOf:startingAt: asAtomicSelector == #'__atomic__indexOf:startingAt:'. self assert: #// asAtomicSelector == #'__atomic__//'! ! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/10/2007 11:48'! testAsNormalSelector self assert: #'__atomic__string' asNormalSelector == #string. self assert: #'__atomic__linesDo:' asNormalSelector == #linesDo:. self assert: #'__atomic__indexOf:startingAt:' asNormalSelector == #indexOf:startingAt:. self assert: #'__atomic__//' asNormalSelector == #//! ! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:29'! testIsAtomicSelector self deny: #string isAtomicSelector. self deny: #linesDo: isAtomicSelector. self deny: #indexOf:startingAt: isAtomicSelector. self deny: #// isAtomicSelector. self assert: #'__atomic__string' isAtomicSelector. self assert: #'__atomic__linesDo:' isAtomicSelector. self assert: #'__atomic__indexOf:startingAt:' isAtomicSelector. self assert: #'__atomic__//:' isAtomicSelector! ! !ACUtilitiesTest methodsFor: 'testing-symbol' stamp: 'lr 5/10/2007 11:59'! testIsInfix self deny: #string isInfix. self deny: #'__atomic__string' isInfix. self deny: #linesDo: isInfix. self deny: #'__atomic__linesDo:' isInfix. self deny: #indexOf:startingAt: isInfix. self deny: #'__atomic__indexOf:startingAt:' isInfix. self assert: #// isInfix. self assert: #'__atomic__//' isInfix! ! !ACUtilitiesTest methodsFor: 'testing-symbol' stamp: 'lr 5/10/2007 11:58'! testIsKeyword self deny: #string isKeyword. self deny: #'__atomic__string' isKeyword. self assert: #linesDo: isKeyword. self assert: #'__atomic__linesDo:' isKeyword. self assert: #indexOf:startingAt: isKeyword. self assert: #'__atomic__indexOf:startingAt:' isKeyword. self deny: #// isKeyword. self deny: #'__atomic__//' isKeyword! ! !ACUtilitiesTest methodsFor: 'testing-symbol' stamp: 'lr 5/10/2007 11:56'! testIsUnary self assert: #string isUnary. self assert: #'__atomic__string' isUnary. self deny: #linesDo: isUnary. self deny: #'__atomic__linesDo:' isUnary. self deny: #indexOf:startingAt: isUnary. self deny: #'__atomic__indexOf:startingAt:' isUnary. self deny: #// isUnary. self deny: #'__atomic__//' isUnary! ! !ACUtilitiesTest methodsFor: 'testing-symbol' stamp: 'lr 5/10/2007 11:55'! testNumArgs self assert: #string numArgs = 0. self assert: #'__atomic__string' numArgs = 0. self assert: #linesDo: numArgs = 1. self assert: #'__atomic__linesDo:' numArgs = 1. self assert: #indexOf:startingAt: numArgs = 2. self assert: #'__atomic__indexOf:startingAt:' numArgs = 2. self assert: #// numArgs = 1. self assert: #'__atomic__//' numArgs = 1! ! !Symbol methodsFor: '*transactional-override' stamp: 'lr 5/10/2007 12:01'! precedence "Answer the receiver's precedence, assuming it is a valid Smalltalk message selector or 0 otherwise. The numbers are 1 for unary, 2 for binary and 3 for keyword selectors." self isAtomicSelector ifTrue: [ ^ self asNormalSelector precedence ]. self size = 0 ifTrue: [^ 0]. self first isLetter ifFalse: [^ 2]. self last = $: ifTrue: [^ 3]. ^ 1! ! 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/11/2007 14:44'! 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." | originalTime referenceTime | originalTime := aOriginalBlock timeToRun. referenceTime := aReferenceBlock timeToRun. Transcript show: aString; show: ': '; show: (originalTime / referenceTime) asFloat; cr! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/11/2007 13:25'! benchmarkActivation "self benchmarkActivation" self benchmark: [ 100000 timesRepeat: [ [ ] atomic ] ] reference: [ 100000 timesRepeat: [ [ ] value ] ] label: 'Activation'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/11/2007 13:25'! benchmarkBinding "self benchmarkBinding" self benchmark: [ [ 100000 timesRepeat: [ Value ] ] atomic ] reference: [ 100000 timesRepeat: [ Value ] ] label: 'Binding Read'. self benchmark: [ [ 100000 timesRepeat: [ Value := nil ] ] atomic ] reference: [ 100000 timesRepeat: [ Value := nil ] ] label: 'Binding Write'.! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/11/2007 13:25'! benchmarkInstance "self benchmarkInstance" self benchmark: [ [ 100000 timesRepeat: [ value ] ] atomic ] reference: [ 100000 timesRepeat: [ value ] ] label: 'Instance Read'. self benchmark: [ [ 100000 timesRepeat: [ value := nil ] ] atomic ] reference: [ 100000 timesRepeat: [ value := nil ] ] label: 'Instance Write'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/11/2007 14:58'! benchmarkSend "self benchmarkSend" self benchmark: [ [ 10000 timesRepeat: [ nil flag: #zork ] ] atomic ] reference: [ 10000 timesRepeat: [ nil flag: #zork ] ] label: 'Send'. self benchmark: [ [ 10000 timesRepeat: [ #( a b c ) collect: [ :e | e ] ] ] atomic ] reference: [ 10000 timesRepeat: [ #( a b c ) collect: [ :e | e ] ] ] label: 'Send (Collections)'. self benchmark: [ [ 33 benchFib ] atomic ] reference: [ 33 benchFib ] label: 'Send (Fibonacci)'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/11/2007 13:37'! benchmarkVariable "self benchmarkVariable" self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] atomic ] reference: [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] label: 'Variable Read'. self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] atomic ] reference: [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] 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 methodsFor: '*transactional-override' stamp: 'lr 5/10/2007 14:08'! 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/10/2007 14:08'! 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 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-override' stamp: 'lr 5/10/2007 14:08'! 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/10/2007 14:08'! 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/11/2007 13:08'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." aMessage selector isAtomicSelector ifTrue: [ ACCompiler atomicMethod: aMessage missing: self ] ifFalse: [ MessageNotUnderstood new message: aMessage; receiver: self; signal ]. ^ aMessage sentTo: self. ! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/10/2007 14:13'! 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/10/2007 14:08'! 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! ! !ReadStream methodsFor: '*transactional-override' stamp: 'lr 5/14/2007 15:41'! next = readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]'> "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !WriteStream methodsFor: '*transactional-override' stamp: 'lr 5/14/2007 15:40'! nextPut: anObject = writeLimit ifTrue: [^ self pastEndPut: anObject] ifFalse: [position _ position + 1. ^collection at: position put: anObject]'> "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." ((collection class == ByteString) and: [ anObject isCharacter and:[anObject isOctetCharacter not]]) ifTrue: [ collection _ (WideString from: collection). ^self nextPut: anObject. ]. position >= writeLimit ifTrue: [^ self pastEndPut: anObject] ifFalse: [position _ position + 1. ^collection at: position put: anObject]! ! !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! ! 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'! 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 ]! ! Object subclass: #ACTransaction instanceVariableNames: 'context changes globalChanges instanceChanges variableChanges' classVariableNames: '' poolDictionaries: 'ContextPart' category: 'Transactional-Model'! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/14/2007 09:03'! current ^ ACCurrentTransaction signal! ! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 07:09'! within: aBlock ^ self new within: aBlock! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 5/14/2007 09:15'! abort "Abort a transaction." context := changes := globalChanges := instanceChanges := variableChanges := nil! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/14/2007 09:15'! abort: aValue "Abort a transaction." thisContext swapSender: context. self abort. ^ aValue! ! !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: 'protected' stamp: 'lr 5/14/2007 09:14'! begin "Start a transaction." 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/14/2007 09:09'! checkpoint "Checkpoint a transaction." self commit; begin! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 5/14/2007 08:45'! commit [ self basicCommit ] valueUnpreemptively! ! !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/14/2007 09:16'! within: aBlock | result | self begin. context := thisContext sender. [ result := ACCurrentTransaction use: self during: aBlock ] ifCurtailed: [ self abort ]. self commit. ^ result! ! !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" ! ! !Integer methodsFor: '*transactional-override' stamp: 'lr 5/11/2007 14:59'! timesRepeat: aBlock "Evaluate the argument, aBlock, the number of times represented by the receiver." | count | count _ 1. [count <= self] whileTrue: [aBlock value. count _ count + 1]! ! !TraitBehavior methodsFor: '*transactional' stamp: 'lr 5/11/2007 15:58'! flushAtomic | changed copy | changed := false. copy := self methodDictionary copy. self methodDictionary keysDo: [ :each | each isAtomicSelector ifTrue: [ copy removeDangerouslyKey: each ifAbsent: []. changed := true ] ]. changed ifTrue: [ self methodDictionary become: copy ]! ! !TraitBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !RBMessageNode class methodsFor: '*transactional' stamp: 'lr 5/10/2007 11:43'! receiver: aValueNode atomicSelector: aSymbol arguments: anotherValueNodes ^ self new receiver: aValueNode; arguments: anotherValueNodes; atomicSelector: aSymbol; yourself! ! !RBMessageNode methodsFor: '*transactional' stamp: 'lr 5/9/2007 14:50'! atomicSelector: aSelector | keywords numArgs | aSelector isAtomicSelector ifTrue: [ self error: 'Normal selector expected: ' , aSelector ]. selector := aSelector asAtomicSelector. keywords := aSelector keywords. numArgs := selector last = $: ifTrue: [ keywords size ] ifFalse: [ 0 ]. selectorParts := numArgs = 0 ifTrue: [ Array with: (RBIdentifierToken value: selector start: nil) ] ifFalse: [ keywords collect: [ :each | RBKeywordToken value: each start: nil ] ]! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/9/2007 15:36'! atomic ^ ACTransaction within: self! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:37'! atomicMethod ^ ACCompiler atomicMethodFor: self! ! !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 ]. ! ! !TPureBehavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 13:19'! atomicMethods ^ Array streamContents: [ :stream | self methodDictionary keysAndValuesDo: [ :key :value | key isAtomicSelector ifTrue: [ stream nextPut: value ] ] ]! ! !TPureBehavior methodsFor: '*transactional' stamp: 'lr 5/11/2007 16:01'! flushAtomic | copy | self methodDictionary keysDo: [ :each | each isAtomicSelector ifTrue: [ copy := copy ifNil: [ self methodDictionary copy ]. copy removeDangerouslyKey: each ifAbsent: [] ] ]. copy ifNotNil: [ self methodDictionary become: copy ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys reject: [ :each | each isAtomicSelector ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:06'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: [ :selector | selector isAtomicSelector ifFalse: [ selectorBlock value: selector ] ]! ! !Message methodsFor: '*transactional' stamp: 'lr 5/14/2007 13:16'! receiverClassFor: anObject! ! !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! ! PECompilerPlugin subclass: #ACCompiler instanceVariableNames: 'active' classVariableNames: 'Enabled' poolDictionaries: '' category: 'Transactional-Model'! !ACCompiler class methodsFor: 'actions' stamp: 'lr 5/11/2007 15:10'! atomicFail: aCompiledMethod "Failed to compile aCompiledMethod. Show error in transcript and install the origianl method." Transcript show: 'ERROR: '; show: aCompiledMethod methodClass; show: '>>#'; show: aCompiledMethod selector; cr. ^ aCompiledMethod! ! !ACCompiler class methodsFor: 'actions' stamp: 'lr 5/14/2007 15:25'! atomicMethod: aMessage missing: aReceiver "This method is called whenever a missing atomic method is called. Installs a whole hierarchy of atomic methods." | selector class | selector := aMessage selector asNormalSelector. class := aMessage lookupClass ifNil: [ aReceiver class ]. class := (class whichClassIncludesSelector: selector) ifNil: [ Object ]. class withAllSubclassesDo: [ :subclass | (subclass methodDictionary includesKey: selector) ifTrue: [ subclass methodDictionary at: aMessage selector put: (subclass methodDictionary at: selector) atomicMethod ] ]! ! !ACCompiler class methodsFor: 'actions' stamp: 'lr 5/11/2007 15:09'! 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 isKindOf: RBMethodNode) ifFalse: [ ^ self atomicFail: aCompiledMethod ]. 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 ] ifError: [ self atomicFail: aCompiledMethod ]! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/10/2007 14:51'! initialize Enabled := true. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #method change: #Added using: #onMethodAdded:; notify: self ofSystemChangesOfItem: #method change: #Modified using: #onMethodAdded:; notify: self ofSystemChangesOfItem: #method change: #Removed using: #onMethodRemoved:! ! !ACCompiler class methodsFor: 'accessing' stamp: 'lr 5/10/2007 14:55'! isCompilerBackendPlugin ^ Enabled ifNil: [ Enabled := false ]! ! !ACCompiler class methodsFor: 'events' stamp: 'lr 5/10/2007 14:55'! onMethodAdded: anObject anObject itemClass methodDict at: anObject itemSelector asAtomicSelector put: (anObject itemClass methodDict at: anObject itemSelector) atomicMethod! ! !ACCompiler class methodsFor: 'events' stamp: 'lr 5/10/2007 14:52'! onMethodRemoved: anObject anObject itemClass methodDict removeKey: anObject itemSelector asAtomicSelector ifAbsent: nil! ! !ACCompiler class methodsFor: 'accessing' stamp: 'lr 5/10/2007 14:55'! priority ^ GPTransformer priority - 1! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/11/2007 13:18'! unload Enabled := false. SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. Smalltalk allClassesAndTraits do: [ :ea | ea flushAtomic. ea class flushAtomic ] displayingProgress: 'Flushing Atomic Methods'! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/9/2007 15:39'! acceptAssignmentNode: aNode | gplink | self visitNode: aNode value. self isActive ifFalse: [ ^ 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/9/2007 15:38'! acceptBlockNode: aNode (self isActive or: [ aNode isInlined ]) ifTrue: [ ^ self visitNode: aNode body ]. (aNode parent notNil and: [ aNode parent isMessage and: [ aNode parent selector = #atomic ] ]) ifFalse: [ ^ self visitNode: aNode body ]. self active: true. [ self visitNode: aNode body ] ensure: [ self active: false ]! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/10/2007 11:43'! acceptMessageNode: aNode super acceptMessageNode: aNode. self isActive ifFalse: [ ^ self ]. aNode isInline ifTrue: [ ^ self ]. aNode replaceWith: (RBMessageNode receiver: aNode receiver atomicSelector: aNode selector arguments: aNode arguments)! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/9/2007 11:57'! 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/9/2007 14:52'! 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/9/2007 14:21'! active: aBoolean active := aBoolean! ! !ACCompiler methodsFor: 'testing' stamp: 'lr 5/7/2007 09:33'! isActive ^ active! ! !ACCompiler methodsFor: 'accessing' stamp: 'lr 5/9/2007 14:21'! reservedNames ^ #( 'self' 'super' 'thisContext' )! ! ACTransactionalTest initialize! ACCompiler initialize!