[PATCH] Allow CallinProcesses to be terminated safely

This is a severe bug (it is bug 158).

I had tried to fix it several times, and the other fixes required ugly
Context games, lots of special casing in the C code, or building complex
Smalltalk objects from within the C code.  They were too complicated and
I never actually set to implement any of them.  This instead is the
simplest fix that can possibly work: we do not need to use #on:do: to
register an exception handler -- the special
UndefinedObject>>#'__terminate' method can register it on its own.

A disadvantage of fixing the thing in the image, is that <=3.0.4 images
will not have the bug fixed when run under 3.0.5.  But the simplicity of
this fix offsets any disadvantage.

Applied to master and stable-3.0.

Paolo

2008-08-18  Paolo Bonzini  <[hidden email]>

        * kernel/AnsiExcept.st: Register an exception handler within
        UndefinedObject>>#'__terminate'.
        * kernel/ContextPart.st: Scan the environment context too for
        #scanBacktraceForAttribute:do:.
        * tests/processes.st: Add testcase.
        * tests/processes.ok: Regenerate.

diff --git a/NEWS b/NEWS
index 6dfba3a..4a7b130 100644
--- a/NEWS
+++ b/NEWS
@@ -169,6 +169,8 @@ o   Swazoo web server.
 
 NEWS FROM 3.0.4 TO 3.0.5
 
+o   CallinProcesses can be terminated with Process>>#terminate.
+
 o   gst-doc implements a -F option to choose output format.  HTML and
     Texinfo are supported (contributed by Thomas Girard).
 
diff --git a/kernel/AnsiExcept.st b/kernel/AnsiExcept.st
index ef42002..97cfbe3 100644
--- a/kernel/AnsiExcept.st
+++ b/kernel/AnsiExcept.st
@@ -452,6 +452,28 @@ Notification subclass: ProcessBeingTerminated [
 
     | semaphore |
 
+    ProcessBeingTerminated class >> initialize [
+ (UndefinedObject>>#'__terminate')
+    descriptor: ((MethodInfo new: 1)
+ methodClass: UndefinedObject;
+ selector: #'__terminate';
+ at: 1 put: (Message
+    selector: #exceptionHandlerSearch:reset:
+    arguments: {
+ [ :context :signal |
+    (self handles: signal)
+ ifTrue: [
+    signal
+ onDoBlock: nil
+ handlerBlock: [ :sig | thisContext environment continue: nil ]
+ onDoContext: nil
+ previousState: nil.
+    #found ]
+ ifFalse: [nil] ].
+ [ :context | ] });
+ yourself)
+    ]
+
     description [
  "Answer a textual description of the exception."
 
@@ -476,7 +498,6 @@ Notification subclass: ProcessBeingTerminated [
 
 ]
 
-
 
 Namespace current: SystemExceptions [
 
@@ -1558,6 +1579,7 @@ Object extend [
 
 
 Eval [
-    Exception initialize
+    Exception initialize.
+    SystemExceptions.ProcessBeingTerminated initialize
 ]
 
diff --git a/kernel/ContextPart.st b/kernel/ContextPart.st
index 6dd05c1..4ba50ef 100644
--- a/kernel/ContextPart.st
+++ b/kernel/ContextPart.st
@@ -418,12 +418,12 @@ methods that can be used in inspection or debugging.'>
  <category: 'enumerating'>
  | ctx attr |
  ctx := self.
- [ctx isNil or: [ctx isEnvironment]] whileFalse:
- [(ctx isBlock not and:
- [attr := ctx method attributeAt: selector ifAbsent: [nil].
- attr notNil])
-    ifTrue: [aBlock value: ctx value: attr].
- ctx := ctx parentContext]
+ [(ctx isBlock not and:
+    [attr := ctx method attributeAt: selector ifAbsent: [nil].
+    attr notNil])
+ ifTrue: [aBlock value: ctx value: attr].
+
+ ctx isEnvironment or: [(ctx := ctx parentContext) isNil]] whileFalse
     ]
 
     scanBacktraceFor: selectors do: aBlock [
diff --git a/libgst/ChangeLog b/libgst/ChangeLog
index be4c3f3..9fbf50d 100644
--- a/libgst/ChangeLog
+++ b/libgst/ChangeLog
@@ -1,3 +1,7 @@
+2008-08-18  Paolo Bonzini  <[hidden email]>
+
+ * libgst/comp.c: Mark the termination method as annotated.
+
 2008-08-17  Paolo Bonzini  <[hidden email]>
 
  * libgst/prims.def: Add socket<->fd conversions.
diff --git a/libgst/comp.c b/libgst/comp.c
index 6545662..0e90230 100644
--- a/libgst/comp.c
+++ b/libgst/comp.c
@@ -460,6 +460,9 @@ _gst_install_initial_methods (void)
      _gst_terminate_symbol,
      _gst_this_category, -1, -1);
 
+  ((gst_compiled_method) OOP_TO_OBJ (termination_method))->header.headerFlag
+    = MTH_ANNOTATED;
+
   install_method (termination_method);
 
   methodsForString = "\
diff --git a/tests/processes.ok b/tests/processes.ok
index 86e7378..912d965 100644
--- a/tests/processes.ok
+++ b/tests/processes.ok
@@ -71,3 +71,6 @@ nil
 2
 2
 returned value is 2
+
+Execution begins...
+nothing should follow... returned value is nil
diff --git a/tests/processes.st b/tests/processes.st
index a61e419..0fadbbb 100644
--- a/tests/processes.st
+++ b/tests/processes.st
@@ -270,3 +270,12 @@ Eval [
     (Processor processEnvironment at: #a) printNl.
     b value printNl
 ]
+
+
+"Test that CallinProcesses can be terminated softly"
+Eval [
+    [ [ Processor activeProcess terminate ] ensure: [ '... ' display ] ]
+ on: SystemExceptions.ProcessBeingTerminated
+ do: [ :sig | 'nothing should follow' display. sig pass ].
+    'failed' displayNl
+]

_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk