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 6/7/2007 15:15'! 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 6/7/2007 12:10'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^ home at: index! ! !BlockContext methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 12:11'! 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 mutex doneCount'! ACBenchmark class instanceVariableNames: 'value mutex doneCount'! !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: 'btree' stamp: 'lr 5/31/2007 17:11'! benchmarkParallel "self benchmarkParallel" | semaphore data doneCount repeatCount time | semaphore := Semaphore forMutualExclusion. 1 to: 70 do: [ :processCount | Smalltalk garbageCollect. data := BTree new. doneCount := 0. repeatCount := 500. processCount timesRepeat: [ [ repeatCount timesRepeat: [ self twoAtomicUpdates: data ]. semaphore critical: [ doneCount := doneCount + 1 ] ] forkAt: Processor activeProcess priority ]. time := [ [ doneCount < processCount ] whileTrue: [ Processor yield ] ] timeToRun. Transcript show: processCount; tab; show: time; cr ]! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 6/1/2007 09:26'! benchmarkPier "self benchmarkPier" | kernel semaphore processCount result pages counts | 1 to: 50 do: [ :processCount | kernel := self newKernelAtomic. semaphore := Semaphore forMutualExclusion. pages := Array new: processCount. counts := Array new: processCount withAll: 0. 1 to: processCount do: [ :e | self doAdd: e asString on: kernel. pages at: e put: (kernel root childrenDecoration at: e asString) ]. Smalltalk garbageCollect; garbageCollect. Transcript show: processCount; tab. doneCount := 0. Processor activeProcess priority: 40. 1 to: processCount do: [ :index | [ [ counts at: index put: (self doEdit: (pages at: index) on: kernel) ] ensure: [ semaphore critical: [ doneCount := doneCount + 1 ] ] ] fixTemps forkAt: 35 named: 'test' ]. result := [ Processor activeProcess priority: 30. [ doneCount < processCount ] whileTrue: [ Processor yield ] ] timeToRun. Transcript show: result; tab. Transcript show: counts min asFloat; tab. Transcript show: counts average asFloat; tab. Transcript show: counts max asFloat; cr ]! ! !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'! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 5/31/2007 23:32'! doAdd: aString on: aKernel | context | context := PRContext kernel: aKernel structure: aKernel root command: (PRAddCommand new name: aString; type: PRPage; yourself). context command execute! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 6/1/2007 09:34'! doEdit: aStructure on: aKernel | context | context := PRContext kernel: aKernel structure: aStructure command: (PREditCommand new write: '!!Paragraphs As carriage returns are preserved, simply add a newline to begin a new paragraph. !!Headers A line starting with ==!!==s becomes a header line. !!Horizontal Line A line starting with ==_== (underline) becomes a horizontal line. This is often used to separate topics. !!Lists Using lines starting with ==#==s and ==-==s, creates a list: -A block of lines, where each line starts with ==-== is transformed into a bulleted list, where each line is an entry. -A block of lines, where each line starts with ==#== is transformed into an ordered list, where each line is an entry. -Lists can be nested. Thus, a line starting with ==#-== is an element of a bulleted list that is part of an ordered list. !!Tables To create a table, start off the lines with ==|== and separate the elements with ==|==s. Each new line represents a new row of the table. The contents of cells can be aligned left, centered or aligned right by using ==|{==, ==||== or ==|}== respectively. !!Preformatted To create a preformatted section, begin each line with =====. A preformatted section uses equally spaced text so that spacing is preserved. !!Links To create a link, put it between ==\*==s. All links have the following form ==\*reference\*== or ==\*alias>reference\*==, where the reference is depending on the kind of link that is created. The contents of some links, e.g. links pointing to image-files, can be embedded into the current document by using ==\+==s: ==\+reference\+==. However not all types of links support embedding and will quietly ignore it. !!!!Internal Links If a structure with the given title exists in the wiki (e.g. ==\*Path\*==), a link to that item shows up when the page is saved. In case the path points to an non-existing structure, the user will be offered the possibility to create a new one when clicking on the link. The path can be any absolute or relative reference within the wiki. !!!!External Links -If the link is an URL (e.g. ==\*http://www.lukas-renggli.ch\*==), a link to the external page shows up. -If the link is an e-mail address (e.g. ==\*renggli@iam.unibe.ch\*==), a link to mail that person shows up. -If the link is an ISBN number (e.g. ==\*isbn:3446202102\*==), a link to the given book shows up. -If the link is an RFC number (e.g. ==\*rfc:2616\*==), a link to the given RFC page shows up. !!Formatting There is some sugar for basic font formattings: -To make something ""bold"", surround it with \"" -To make something' using: PRPage descriptionContents; yourself). ^ [ 5 timesRepeat: [ context command execute ] ] timeToRun / 5.0! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 5/31/2007 21:21'! newKernel: aPersistency ^ PRKernel new persistency: aPersistency; root: (PRPage named: 'root'); yourself! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 5/31/2007 21:22'! newKernelAtomic ^ self newKernel: PRAtomicPersistency new! ! !ACBenchmark class methodsFor: 'pier' stamp: 'lr 5/31/2007 21:22'! newKernelLock ^ self newKernel: PRNullPersistency new! ! !ACBenchmark class methodsFor: 'btree' stamp: 'lr 5/31/2007 17:11'! twoAtomicUpdates: aDictionary [ [ aDictionary at: SmallInteger maxVal atRandom put: 0; at: SmallInteger maxVal atRandom put: 0 ] atomic ] on: ACConflict do: [ self twoAtomicUpdates: aDictionary ]! ! !ACBenchmark class methodsFor: 'btree' stamp: 'lr 6/1/2007 11:01'! twoMutexUpdates: aDictionary mutex critical: [ aDictionary at: SmallInteger maxVal atRandom put: 0; at: SmallInteger maxVal atRandom put: 0 ]! ! 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 6/7/2007 13:32'! 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 6/7/2007 13:32'! 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-atomic' stamp: 'lr 6/7/2007 12:12'! atomicAt: anInteger ^ self workingCopy at: anInteger! ! !Object methodsFor: '*transactional-atomic' stamp: 'lr 6/7/2007 12:12'! atomicAt: anInteger put: anObject ^ self workingCopy at: anInteger put: anObject! ! !Object methodsFor: '*transactional-atomic' stamp: 'lr 6/7/2007 13:39'! atomicBasicAt: anInteger ^ self workingCopy basicAt: anInteger! ! !Object methodsFor: '*transactional-atomic' stamp: 'lr 6/7/2007 13:39'! atomicBasicAt: anInteger put: anObject ^ self workingCopy basicAt: anInteger put: anObject! ! !Object methodsFor: '*transactional-atomic' stamp: 'lr 6/7/2007 12:12'! atomicInstVarAt: anInteger ^ self workingCopy instVarAt: anInteger! ! !Object methodsFor: '*transactional-atomic' stamp: 'lr 6/7/2007 12:12'! atomicInstVarAt: anInteger put: anObject ^ self workingCopy instVarAt: anInteger put: anObject! ! !Object methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 13:33'! 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 6/7/2007 13:33'! 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 6/7/2007 15:06'! 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 6/7/2007 13:41'! 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." ^ self basicAt: index - self class instSize! ! !Object methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 13:41'! 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." ^ self basicAt: anInteger - self class instSize put: anObject! ! !Object methodsFor: '*transactional' stamp: 'lr 6/7/2007 15:05'! 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 6/7/2007 13:47'! restoreSnapshot: anObject self primitiveFailed! ! !Object methodsFor: '*transactional' stamp: 'lr 6/7/2007 13:48'! 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' stamp: 'lr 6/7/2007 15:16'! atomicNext ^ position >= readLimit ifFalse: [ collection at: (position := position + 1) ]! ! !ReadStream methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 15:16'! next "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)]! ! !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! ! !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! ! !WriteStream methodsFor: '*transactional' stamp: 'lr 6/7/2007 15:17'! atomicNextPut: anObject ((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: [ collection at: (position := position + 1) put: anObject ]! ! !WriteStream methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 15:20'! nextPut: 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 6/7/2007 12:11'! 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 6/7/2007 12:09'! abort "Abort a transaction." context := changes := nil! ! !ACTransaction methodsFor: 'public' stamp: 'lr 6/7/2007 12:09'! abort: aValue "Abort a transaction." thisContext swapSender: context. self abort. ^ aValue! ! !ACTransaction methodsFor: 'private' stamp: 'lr 6/7/2007 16:41'! atomicDo: aBlock ifConflict: aConflictBlock ^ aBlock value! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 6/7/2007 12:09'! 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 6/7/2007 12:10'! checkpoint "Checkpoint a transaction." self commit; begin! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 6/7/2007 16:47'! commit "Commit a transaction." self commitIfConflict: [ self signalConflict ]! ! !ACTransaction methodsFor: 'protected' stamp: 'lr 6/7/2007 12:10'! commitIfConflict: aBlock "Commit a transaction atomically." [ changes do: [ :each | each hasConflict ifTrue: [ ^ aBlock value ] ]. changes do: [ :each | each hasChanged ifTrue: [ each apply ] ] ] valueUnpreemptively! ! !ACTransaction methodsFor: 'public' stamp: 'lr 6/7/2007 16:10'! do: aBlock "Start a transaction with aBlock." ^ self do: aBlock ifConflict: [ self signalConflict ]! ! !ACTransaction methodsFor: 'public' stamp: 'lr 6/7/2007 16:41'! 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 6/7/2007 12:10'! retry: aBlock "Unconditionally retry to evaluate aBlock until there are no conflict." ^ self do: aBlock ifConflict: [ self retry: aBlock ]! ! !ACTransaction methodsFor: 'private' stamp: 'lr 6/7/2007 16:46'! signalConflict ^ ACConflict new transaction: self; signal! ! !ContextPart methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 12:11'! 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 6/7/2007 12:11'! 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" ! ! !ContextPart methodsFor: '*transactional' stamp: 'lr 5/31/2007 15:49'! workingCopy ^ self! ! !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/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! ! !SequenceableCollection methodsFor: '*transactional' stamp: 'lr 6/7/2007 15:14'! atomicReplaceFrom: start to: stop with: replacement startingAt: repStart | index repOff | repOff := repStart - start. index := start - 1. [ (index := index + 1) <= stop ] whileTrue: [ self at: index put: (replacement at: repOff + index) ]! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:37'! atomicMethod ^ ACCompiler atomicMethodFor: self! ! !Exception methodsFor: '*transactional' stamp: 'lr 6/7/2007 12:11'! 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 ]. ! ! !ByteArray methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 15:15'! 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! ! !Message methodsFor: '*transactional' stamp: 'lr 5/14/2007 13:16'! receiverClassFor: anObject! ! !Array methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 15:15'! 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! ! 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 6/1/2007 08:44'! atomicMethod: aMessage missing: aReceiver "This method is called whenever a missing atomic method is called. Installs a whole hierarchy of atomic methods." | selector | selector := aMessage selector asNormalSelector. ProtoObject withAllSubclassesDo: [ :class | (class methodDictionary includesKey: selector) ifTrue: [ class methodDictionary at: aMessage selector put: (class methodDictionary at: selector) atomicMethod ] ]! ! !ACCompiler class methodsFor: 'actions' stamp: 'lr 6/7/2007 16:08'! 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 | methodNode := [ aCompiledMethod methodNode ] ifError: [ ^ self atomicFail: aCompiledMethod ]. (methodNode isKindOf: RBMethodNode) ifFalse: [ ^ self atomicFail: aCompiledMethod ]. methodNode pragmas do: [ :each | each pragma keyword = #atomicDoNotTransform ifTrue: [ ^ aCompiledMethod compiledMethod ]. each pragma keyword = #atomic: ifTrue: [ ^ (aCompiledMethod methodClass lookupSelector: each pragma arguments first) atomicMethod ] ]. ^ [ 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 6/1/2007 11:00'! acceptBlockNode: aNode (self isActive or: [ aNode isInlined ]) ifTrue: [ ^ self visitNode: aNode body ]. (aNode parent notNil and: [ aNode parent isMessage and: [ #( atomic atomicIfConflict: atomicRetry ) includes: aNode parent selector ] ]) 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' )! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 12:12'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^ self at: index! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 6/7/2007 12:12'! 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 ] ]! ! ACTransactionalTest initialize! ACCompiler initialize!