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.! ! !String methodsFor: '*transactional-override' stamp: 'lr 5/25/2007 11:36'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !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/25/2007 09:13'! atomic ^ ACTransaction new do: self! ! !BlockContext methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:13'! atomicIfConflict: aBlock ^ ACTransaction new do: self ifConflict: aBlock! ! !BlockContext methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:14'! atomicRetry ^ ACTransaction new retry: 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:57'! testStreamContents [ array := Array streamContents: [ :stream | 1 to: 10 do: [ :each | stream nextPut: each ] ] ] atomic. self assert: (1 to: 10) asArray = array! ! !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/30/2007 12:19'! transaction ^ Processor activeProcess currentTransaction! ! !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/30/2007 16:10'! 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; tab; show: ((referenceTime / 1000.0) roundTo: 0.01); tab; show: ((originalTime / 1000.0) roundTo: 0.01); tab; show: ((originalTime / referenceTime) asFloat roundTo: 0.01); cr! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/30/2007 16:16'! benchmarkActivation "self benchmarkActivation" self benchmark: [ 10000000 timesRepeat: [ [ ] atomic ] ] reference: [ 10000000 timesRepeat: [ [ ] value ] ] label: 'Activation'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/30/2007 16:17'! benchmarkBinding "self benchmarkBinding" self benchmark: [ [ 10000000 timesRepeat: [ Value ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ Value ] ] value ] label: 'Binding Read'. self benchmark: [ [ 10000000 timesRepeat: [ Value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ Value := nil ] ] value ] label: 'Binding Write'.! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/30/2007 16:17'! benchmarkInstance "self benchmarkInstance" self benchmark: [ [ 10000000 timesRepeat: [ value ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ value ] ] value ] label: 'Instance Read'. self benchmark: [ [ 10000000 timesRepeat: [ value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ value := nil ] ] value ] label: 'Instance Write'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/30/2007 16:17'! benchmarkSend "self benchmarkSend" self benchmark: [ [ 10000000 timesRepeat: [ nil flag: #zork ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ nil flag: #zork ] ] value ] label: 'Message invokation'. self benchmark: [ [ 10000000 timesRepeat: [ nil flag: #zork ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ 1 + 2 ] ] value ] label: 'Message invokation (fast)'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/30/2007 16:18'! benchmarkVariable "self benchmarkVariable" self benchmark: [ [ 10000000 timesRepeat: [ #( nil ) at: 1 ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ #( nil ) at: 1 ] ] value ] label: 'Variable Read'. self benchmark: [ [ 10000000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] atomic. [] value ] reference: [ [] atomic. [ 10000000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] value ] label: 'Variable Write'! ! Object subclass: #ACChange instanceVariableNames: 'original previous working' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACChange class methodsFor: 'instance-creation' stamp: 'lr 5/25/2007 11:04'! on: anObject ^ self basicNew initializeOn: anObject! ! !ACChange methodsFor: 'actions' stamp: 'lr 5/25/2007 10:47'! apply original restoreSnapshot: working! ! !ACChange methodsFor: 'testing' stamp: 'lr 5/25/2007 10:48'! hasChanged ^ (working isIdenticalToSnapshot: previous) not! ! !ACChange methodsFor: 'testing' stamp: 'lr 5/25/2007 10:48'! hasConflict ^ (original isIdenticalToSnapshot: previous) not! ! !ACChange methodsFor: 'initialization' stamp: 'lr 5/25/2007 11:05'! initializeOn: anObject original := anObject. working := original snapshotCopy. previous := working snapshotCopy! ! !ACChange methodsFor: 'accessing' stamp: 'lr 5/25/2007 10:54'! original ^ original! ! !ACChange methodsFor: 'accessing' stamp: 'lr 5/25/2007 10:54'! previous ^ previous! ! !ACChange methodsFor: 'printing' stamp: 'lr 5/25/2007 11:06'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' ['; print: original; nextPut: $]! ! !ACChange methodsFor: 'accessing' stamp: 'lr 5/25/2007 10:54'! working ^ working! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/25/2007 11:22'! 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/25/2007 11:23'! 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/25/2007 11:17'! atomicInstVarAt: anInteger ^ self workingCopy instVarAt: anInteger! ! !Object methodsFor: '*transactional' stamp: 'lr 5/25/2007 11:18'! atomicInstVarAt: anInteger put: anObject ^ self workingCopy instVarAt: anInteger put: anObject! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/25/2007 11:23'! 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/25/2007 11:23'! 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' stamp: 'lr 5/25/2007 09:34'! compareSnapshotTo: anObject self primitiveFailed! ! !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/25/2007 11:24'! 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/25/2007 11:24'! 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! ! !Object methodsFor: '*transactional' stamp: 'lr 5/25/2007 10:44'! isIdenticalToSnapshot: anObject 1 to: self class instSize do: [ :index | (self instVarAt: index) == (anObject instVarAt: index) ifFalse: [ ^ false ] ]. self class isVariable ifTrue: [ 1 to: self size do: [ :index | (self at: index) == (anObject at: index) ifFalse: [ ^ false ] ] ]. ^ true! ! !Object methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:33'! restoreSnapshot: anObject self primitiveFailed! ! !Object methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:33'! snapshotCopy self primitiveFailed! ! !Object methodsFor: '*transactional' stamp: 'lr 5/30/2007 12:11'! workingCopy "Answer a working copy to be used within the context of the current transaction." | transaction | transaction := Processor activeProcess currentTransaction ifNil: [ self error: 'No active transaction' ]. ^ (transaction changeFor: self) working! ! !ReadStream methodsFor: '*transactional-override' stamp: 'lr 5/14/2007 16:21'! next = readLimit 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)]! ! !Process methodsFor: '*transactional' stamp: 'lr 5/30/2007 12:09'! currentTransaction ^ currentTransaction! ! !Process methodsFor: '*transactional' stamp: 'lr 5/30/2007 12:09'! currentTransaction: aTransaction currentTransaction := aTransaction! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/25/2007 11:18'! atomicValue ^ self workingCopy value! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/25/2007 11:18'! atomicValue: anObject ^ self workingCopy value: anObject! ! !WriteStream methodsFor: '*transactional-override' stamp: 'lr 5/14/2007 16:23'! nextPut: anObject = writeLimit ifTrue: [ self pastEndPut: anObject ] ifFalse: [ collection at: (position := position + 1) 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]! ! Error subclass: #ACConflict instanceVariableNames: 'transaction' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/25/2007 09:04'! transaction ^ transaction! ! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/25/2007 09:04'! transaction: aTransaction transaction := aTransaction! ! Error subclass: #ACInvalidTransaction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !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]! ! Object subclass: #ACTransaction instanceVariableNames: 'context changes' classVariableNames: '' poolDictionaries: 'ContextPart' category: 'Transactional-Model'! !ACTransaction methodsFor: 'protected' stamp: 'lr 5/25/2007 10:56'! abort "Abort a transaction." context := changes := nil! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/30/2007 12:18'! abort: aValue "Abort a transaction." thisContext swapSender: context. self abort. ^ aValue! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 5/25/2007 10:57'! begin "Start a transaction." changes := IdentityDictionary new! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 5/25/2007 10:53'! changeFor: anObject ^ changes at: anObject ifAbsentPut: [ ACChange on: anObject ]! ! !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/25/2007 09:10'! commit "Commit a transaction." self commitIfConflict: [ self singalConflict ]! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 5/25/2007 10:59'! commitIfConflict: aBlock "Commit a transaction atomically." | changed | changed := Array streamContents: [ :stream | changes valuesDo: [ :each | each hasChanged ifTrue: [ stream nextPut: each ] ] ]. [ (changed anySatisfy: [ :each | each hasConflict ]) ifTrue: [ aBlock value ]. changed do: [ :each | each apply ] ] valueUninterruptably! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/25/2007 11:00'! do: aBlock ^ self do: aBlock ifConflict: [ self signalConflict ]! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/30/2007 12:11'! do: aBlock ifConflict: aConflictBlock "Evaluate aBLock within a new transaction, unless we are already in an existing transactional context. Evaluate aConflictBlock if the transaction conflicts with concurrent edits." | result | self begin. context := thisContext sender. Processor activeProcess currentTransaction: self. [ result := aBlock ifCurtailed: [ self abort ] ] ensure: [ Processor activeProcess currentTransaction: nil ]. self commitIfConflict: aConflictBlock. ^ result! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/25/2007 11:01'! retry: aBlock "Unconditionally retry to evaluate aBlock until there are no conflict." ^ self do: aBlock ifConflict: [ self retry: aBlock ]! ! !ACTransaction methodsFor: 'private' stamp: 'lr 5/25/2007 09:05'! signalConflict ^ ACConflict new transaction: self; signal! ! !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" ! ! !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 ] ]! ! !Array methodsFor: '*transactional-override' stamp: 'lr 5/25/2007 11:37'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:14'! atomic ^ ACTransaction new do: self! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:14'! atomicIfConflict: aBlock ^ ACTransaction new do: self ifConflict: aBlock! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/25/2007 09:15'! atomicRetry ^ ACTransaction new retry: self! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:37'! atomicMethod ^ ACCompiler atomicMethodFor: self! ! !ByteArray methodsFor: '*transactional-override' stamp: 'lr 5/25/2007 11:35'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !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 ]. ! ! !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! ! !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 ] ]! ! 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/14/2007 16:20'! 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. #atomicInstead: will use the annotiation code for atomic transformation." | 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 ]. each pragma keyword = #atomicInstead: ifTrue: [ methodClass := aCompiledMethod methodClass. methodNode := methodClass parserClass new parse: each pragma arguments first class: methodClass ] ]. ^ [ methodNode copy beAtomic generate compiledMethod ] ifError: [ self atomicFail: aCompiledMethod ]! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/30/2007 12:08'! 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:. Process addInstVarName: 'currentTransaction'! ! !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/30/2007 12:09'! unload Enabled := false. SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. Smalltalk allClassesAndTraits do: [ :ea | ea flushAtomic. ea class flushAtomic ] displayingProgress: 'Flushing Atomic Methods'. Process removeInstVarName: 'currentTransaction'! ! !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!