"{ Package: 'exept:regression' }"

"{ NameSpace: RegressionTests }"

TestCase subclass:#ContextTest2

	instanceVariableNames:'exceptionObject ttt'

	classVariableNames:''

	poolDictionaries:''

	category:'tests-Regression'

!

Notification subclass:#MyNotification

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	privateIn:ContextTest2

!

!ContextTest2 methodsFor:'helpers'!

call10_1

    |local|

    ^ self call10_2:[:x | local := x].

!

call10_2:aBlock

    ^ self call10_3:aBlock

!

call10_3:aBlock

!

call9_1

    ^ self call9_2

!

call9_2

    ^ self call9_3

!

call9_3

    ttt := thisContext.

    ^ ttt sender sender

!

downToNextSegmentThenDo:aBlock

    self

	downToSegment:(Processor activeProcess numberOfStackSegments + 1)

	thenDo:aBlock

    "

     self new testUnwind1

    "

!

downToNextSegmentThenUnwindAndDo:aBlock

    self

	downToSegment:(Processor activeProcess numberOfStackSegments + 1)

	thenUnwindAndDo:aBlock

    "

     self new testUnwind2

    "

!

downToSegment:nr thenDo:aBlock

    Processor activeProcess numberOfStackSegments >= nr ifTrue:[

	^  aBlock value

    ].

    self

	downToSegment:(Processor activeProcess numberOfStackSegments + 1)

	thenDo:aBlock

    "

     self new testUnwind1

    "

!

downToSegment:nr thenUnwindAndDo:aBlock

    Processor activeProcess numberOfStackSegments >= nr ifTrue:[

	aBlock home unwindThenDo: aBlock

    ].

    self

	downToSegment:(Processor activeProcess numberOfStackSegments + 1)

	thenUnwindAndDo:aBlock

    "

     self new testUnwind2

    "

!

exceptionObjectIs:ex

    exceptionObject := ex

!

getAssocWithContext

    ^ self getSendersContext -> #foo

!

getSendersContext

    ^ thisContext sender

!

raiseNotification

    NoHandlerError handle:[:ex |

        ex return

    ] do:[

        |t|

%{

  extern void *__contextToDebug__;

  __contextToDebug__ = (void *)__thisContext;

%}.

        t := MyNotification raiseRequestFrom:self.

%{

  extern void *__contextToDebug__;

  __contextToDebug__ = (void *)__thisContext;

%}.

        ^ t

    ].

    ^ nil.

!

raiseWithContext

    AbortOperationRequest raiseWith:self getSendersContext

!

selfReferringContext

    |ref|

    ref := thisContext.

    ^ thisContext

!

senderContext

    ^ thisContext sender

!

senderReferringContext1

    ^ self senderReferringContext:thisContext

!

senderReferringContext2

    ^ self senderContext

!

senderReferringContext:aContext

    ^ aContext

! !

!ContextTest2 methodsFor:'tests'!

testContextRef1

    |assoc|

    assoc := self getAssocWithContext.

    ObjectMemory garbageCollect.

    "

     self new testContextRef1

    "

!

testContextRef10

    |val|

    val := self call10_1.

    ObjectMemory dumpObject:val.

    "

    "

!

testContextRef2

    self getAssocWithContext.

    ObjectMemory garbageCollect.

    "

     self new testContextRef2

    "

!

testContextRef3

    AbortOperationRequest handle:[:ex |

    ] do:[

	self raiseWithContext.

    ].

    ObjectMemory garbageCollect.

    "

     self new testContextRef3

    "

!

testContextRef4

    |con|

    AbortOperationRequest handle:[:ex |

	ObjectMemory garbageCollect.

	con := ex parameter.

	ObjectMemory garbageCollect.

    ] do:[

	self raiseWithContext.

    ].

    ObjectMemory garbageCollect.

    "

     self new testContextRef4

    "

!

testContextRef5

    self selfReferringContext.

    ObjectMemory garbageCollect.

    "

     self new testContextRef5

    "

!

testContextRef6

    self senderReferringContext1.

    ObjectMemory garbageCollect.

    "

     self new testContextRef6

    "

!

testContextRef7

    self senderReferringContext2.

    ObjectMemory garbageCollect.

    "

     self new testContextRef7

    "

!

testContextRef8

    100000 timesRepeat:[

        self raiseNotification.

        self assert:(ObjectMemory spaceOf:exceptionObject suspendedContext) < 4.

    ].

    "

     self new testContextRef8

    "

!

testContextRef9

    |val|

    val := self call9_1.

    ObjectMemory dumpObject:val.

    ObjectMemory dumpObject:ttt.

    "

     self new testContextRef9

    "

!

testProcess1

    |x set lockSet p arg|

    lockSet := Semaphore forMutualExclusion.

    set := Set new.

    x := 1 @ 1.

    arg := x.

    p := [

	[

	    lockSet critical:[set add:arg].

	    arg perform:#x .

	] valueNowOrOnUnwindDo:[

	    lockSet critical:[set remove:arg].

	].

    ] fork.

    "

     self new testProcess1

    "

!

testProcess2

    |x set lockSet p|

    lockSet := Semaphore forMutualExclusion.

    set := Set new.

    x := 1 @ 1.

    p := [:arg |

	[

	    lockSet critical:[set add:arg].

	    arg perform:#x.

	] valueNowOrOnUnwindDo:[

	    lockSet critical:[set remove:arg].

	].

    ] forkWith:(Array with:x).

    "

     self new testProcess2

    "

!

testProcess3

    |x set lockSet p|

    lockSet := Semaphore forMutualExclusion.

    set := Set new.

    x := 1 @ 1.

    p := [:arg |

	[

	    lockSet critical:[set add:arg].

	    arg perform:#x: with:1234.

	] valueNowOrOnUnwindDo:[

	    lockSet critical:[set remove:arg].

	].

    ] forkWith:(Array with:x).

    "

     self new testProcess3

    "

!

testUnwind1

    Transcript showCR:'1'.

    self downToNextSegmentThenDo:[Transcript showCR:'2'. ^  self ].

    Transcript showCR:'3'.

    "

     self new testUnwind1

    "

!

testUnwind2

    Transcript showCR:'1'.

    self downToNextSegmentThenUnwindAndDo:[Transcript showCR:'2'. ^  self ].

    Transcript showCR:'3'.

    "

     self new testUnwind2

    "

!

testUnwind3

    <context: #return>

    |foo|

    Transcript showCR:'1'.

    self downToNextSegmentThenUnwindAndDo:[Transcript showCR:'2'. foo := #foo ].

    Transcript showCR:'3'.

    "

     self new testUnwind3

    "

!

testUnwind4

    |foo|

    Transcript showCR:'1'.

    self downToNextSegmentThenDo:[Transcript showCR:'2'. foo := #foo ].

    Transcript showCR:'3'.

    "

     self new testUnwind4

    "

! !

!ContextTest2::MyNotification class methodsFor:'raising'!

raiseRequestFrom:someone

    "raise a signal proceedable.

     The argument, something is passed both as parameter and originator."

    <context: #return>

    |ex|

    ex := self newExceptionFrom:someone.

someone exceptionObjectIs:ex.

    ^ (ex

        suspendedContext:thisContext sender

        parameter:someone)

            raiseRequest.

! !

!ContextTest2 class methodsFor:'documentation'!

version

    ^ '$Header$'

! !