[Help-smalltalk] [PATCH] Add BlockClosure>>#cull: and friends

[Paolo Bonzini]

These are a bit cleverly named, but that's what the VW guys adopted. 
It's extended versions of #valueWithPossibleArgument: (which never 
entered GNU Smalltalk because of the ugly name, but is there in Squeak).

I chose to implement it in the VM for speed and because the needed code 
is possibly less than with a pure Smalltalk implementation.

Paolo

2008-05-12  Paolo Bonzini  <address@hidden>

        * kernel/BlkClosure.st: Add #cull:, #cull:cull:, #cull:cull:cull:.
        * kernel/ExcHandling.st: Use it for the exception handlers.
        * kernel/Object.st: Use it for #ifNotNil:.
        * tests/blocks.st: New tests.
        * tests/blocks.ok: Regenerate.

libgst:
2008-05-12  Paolo Bonzini  <address@hidden>

        * libgst/interp.c: Adjust send_block_value prototype.
        * libgst/interp-bc.inl: Support block argument culling.
        * libgst/interp-jit.inl: Support block argument culling.
        * libgst/prims.def: Add primitives for block argument culling.
        * libgst/vm.def: Adjust calls to send_block_value.


diff --git a/NEWS b/NEWS
index 3a968e9..634e68b 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,11 @@ List of user-visible changes in GNU Smalltalk
 
 NEWS FROM 3.0.2 TO 3.0a
 
+o   BlockClosure methods #cull:, #cull:cull:, #cull:cull:cull:
+    evaluate blocks removing parameters that are not accepted by
+    the block.  Thanks to this new functionality, the parameter to
+    #on:do: and #ifNotNil: can be omitted.
+
 o   CObjects can be backed with garbage-collected (as opposed to
     heap-allocated) storage.  Using this is not always possible, for
     example for CObjects stored by external libraries or passed to
diff --git a/examples/Case.st b/examples/Case.st
index 3dd6054..1ec28d0 100644
--- a/examples/Case.st
+++ b/examples/Case.st
@@ -59,12 +59,12 @@ test: anObject
 !Case methodsFor: 'testing'!
 
 test: anObject
-    test _ anObject.
-    found _ false.
+    test := anObject.
+    found := false.
 !
 
 reset
-    found _ false
+    found := false
 !
 
 else: aBlock
@@ -94,10 +94,8 @@ when: aBlock do: aBlock2
 !Case methodsFor: 'private'!
 
 do: aBlock
-    found _ true.
-    ^result := (aBlock numArgs = 0
-       ifTrue: [ aBlock value ]
-       ifFalse: [ aBlock value: test ])
+    found := true.
+    ^result := (aBlock cull: test)
 ! !
 
 
diff --git a/kernel/BlkClosure.st b/kernel/BlkClosure.st
index 0b45506..63c9446 100644
--- a/kernel/BlkClosure.st
+++ b/kernel/BlkClosure.st
@@ -410,14 +410,11 @@ creation of Processes from blocks.'>
 
     forkWithoutPreemption [
        "Evaluate the receiver in a process that cannot be preempted.
-        If the receiver expect a parameter, pass the current process
-        (can be useful for queuing interrupts from within the
-        uninterruptible process)."
+        If the receiver expect a parameter, pass the current process."
 
        <category: 'multiple process'>
        | closure args process result |
-       closure := [self valueWithArguments: args].
-       args := self numArgs = 0 ifTrue: [#()] ifFalse: [{Processor 
activeProcess}].
+       closure := [self cull: Processor activeProcess].
        ^Process 
            on: closure
            at: Processor unpreemptedPriority
@@ -590,6 +587,33 @@ creation of Processes from blocks.'>
        SystemExceptions.WrongArgumentCount signal
     ]
 
+    cull: arg1 [
+       "Evaluate the receiver, passing arg1 as the only parameter if
+        the receiver has parameters."
+
+       <category: 'built ins'>
+       <primitive: VMpr_BlockClosure_cull>
+       SystemExceptions.WrongArgumentCount signal
+    ]
+
+    cull: arg1 cull: arg2 [
+       "Evaluate the receiver, passing arg1 and arg2 as parameters if
+        the receiver accepts them."
+
+       <category: 'built ins'>
+       <primitive: VMpr_BlockClosure_cull>
+       SystemExceptions.WrongArgumentCount signal
+    ]
+
+    cull: arg1 cull: arg2 cull: arg3 [
+       "Evaluate the receiver, passing arg1, arg2 and arg3 as parameters if
+        the receiver accepts them."
+
+       <category: 'built ins'>
+       <primitive: VMpr_BlockClosure_cull>
+       SystemExceptions.WrongArgumentCount signal
+    ]
+
     valueWithArguments: argumentsArray [
        "Evaluate the receiver passing argArray's elements as the parameters"
 
diff --git a/kernel/ExcHandling.st b/kernel/ExcHandling.st
index 31b4b23..4e8eb7d 100644
--- a/kernel/ExcHandling.st
+++ b/kernel/ExcHandling.st
@@ -684,7 +684,7 @@ with a lower priority.'>
                [:object | 
                self resetHandler.
                ^object].
-       result := handlerBlock value: self.
+       result := handlerBlock cull: self.
        resumeBoolean 
            ifTrue: 
                [self resetHandler.
diff --git a/kernel/Object.st b/kernel/Object.st
index 90e0bff..733bbd9 100644
--- a/kernel/Object.st
+++ b/kernel/Object.st
@@ -143,7 +143,7 @@ All classes in the system are subclasses of me.'>
         notNilBlock, passing the receiver."
 
        <category: 'testing functionality'>
-       ^notNilBlock value: self
+       ^notNilBlock cull: self
     ]
 
     ifNotNil: notNilBlock [
@@ -151,7 +151,7 @@ All classes in the system are subclasses of me.'>
         Else answer nil."
 
        <category: 'testing functionality'>
-       ^notNilBlock value: self
+       ^notNilBlock cull: self
     ]
 
     ifNotNil: notNilBlock ifNil: nilBlock [
@@ -159,7 +159,7 @@ All classes in the system are subclasses of me.'>
         notNilBlock, passing the receiver."
 
        <category: 'testing functionality'>
-       ^notNilBlock value: self
+       ^notNilBlock cull: self
     ]
 
     isCObject [
diff --git a/libgst/interp-bc.inl b/libgst/interp-bc.inl
index cafa13b..093940f 100644
--- a/libgst/interp-bc.inl
+++ b/libgst/interp-bc.inl
@@ -396,7 +396,7 @@ _gst_send_method (OOP methodOOP)
 
 
 static mst_Boolean
-send_block_value (int numArgs)
+send_block_value (int numArgs, int cull_up_to)
 {
   OOP closureOOP;
   block_header header;
@@ -406,10 +406,15 @@ send_block_value (int numArgs)
   closureOOP = STACK_AT (numArgs);
   closure = (gst_block_closure) OOP_TO_OBJ (closureOOP);
   header = ((gst_compiled_block) OOP_TO_OBJ (closure->block))->header;
+
+  /* Check numArgs.  Remove up to CULL_UP_TO extra arguments if needed.  */
   if UNCOMMON (numArgs != header.numArgs)
     {
-      /* check numArgs asap */
-      return (true);
+      if (numArgs < header.numArgs || numArgs > header.numArgs + cull_up_to)
+        return (true);
+
+      POP_N_OOPS (numArgs - header.numArgs);
+      numArgs = header.numArgs;
     }
 
   /* prepare the new state, loading data from the closure */
diff --git a/libgst/interp-jit.inl b/libgst/interp-jit.inl
index 297a8f6..8f7c291 100644
--- a/libgst/interp-jit.inl
+++ b/libgst/interp-jit.inl
@@ -286,7 +286,7 @@ _gst_send_method (OOP methodOOP)
 }
 
 static mst_Boolean
-send_block_value (int numArgs)
+send_block_value (int numArgs, int cull_up_to)
 {
   OOP closureOOP;
   OOP receiverClass;
@@ -296,10 +296,15 @@ send_block_value (int numArgs)
   closureOOP = STACK_AT (numArgs);
   closure = (gst_block_closure) OOP_TO_OBJ (closureOOP);
   header = ((gst_compiled_block) OOP_TO_OBJ (closure->block))->header;
+
+  /* Check numArgs.  Remove up to CULL_UP_TO extra arguments if needed.  */
   if UNCOMMON (numArgs != header.numArgs)
     {
-      /* check numArgs asap */
-      return (true);
+      if (numArgs < header.numArgs || numArgs > header.numArgs + cull_up_to)
+        return (true);
+
+      POP_N_OOPS (numArgs - header.numArgs);
+      numArgs = header.numArgs;
     }
 
   receiverClass = IS_INT (closure->receiver)
diff --git a/libgst/interp.c b/libgst/interp.c
index 18d2573..18c661f 100644
--- a/libgst/interp.c
+++ b/libgst/interp.c
@@ -424,9 +424,10 @@ static inline OOP create_args_array (int numArgs);
    the arguments in the block context, which have been copied out of
    the caller's context. 
 
-   On failure return true, on success (i.e. if NUMARGS matches what
-   the BlockClosure says) return false.  */
-static mst_Boolean send_block_value (int numArgs);
+   The block should accept between NUMARGS - CULL_UP_TO and
+   NUMARGS arguments.  If this is not true (failure) return true;
+   on success return false.  */
+static mst_Boolean send_block_value (int numArgs, int cull_up_to);
 
 /* This is a kind of simplified _gst_send_message_internal that,
    instead of setting up a context for a particular receiver, stores
diff --git a/libgst/prims.def b/libgst/prims.def
index 5f242cc..6237fd8 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -2581,7 +2581,19 @@ primitive VMpr_Continuation_resume [fail,reload_ip]
 primitive VMpr_BlockClosure_value [fail,reload_ip,cache_new_ip]
 {
   _gst_primitives_executed++;
-  if UNCOMMON (send_block_value (numArgs))
+  if UNCOMMON (send_block_value (numArgs, 0))
+    PRIM_FAILED;
+  else
+    PRIM_SUCCEEDED_RELOAD_IP;
+}
+
+/* BlockClosure cull:
+   BlockClosure cull:cull:
+   BlockClosure cull:cull:cull: */
+primitive VMpr_BlockClosure_cull [fail,reload_ip]
+{
+  _gst_primitives_executed++;
+  if UNCOMMON (send_block_value (numArgs, numArgs))
     PRIM_FAILED;
   else
     PRIM_SUCCEEDED_RELOAD_IP;
@@ -2598,7 +2610,7 @@ primitive VMpr_BlockClosure_valueAndResumeOnUnwind 
[fail,reload_ip]
 
   context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop);
   context->flags |= MCF_IS_UNWIND_CONTEXT;
-  if UNCOMMON (send_block_value (numArgs))
+  if UNCOMMON (send_block_value (numArgs, 0))
     PRIM_FAILED;
   else
     PRIM_SUCCEEDED_RELOAD_IP;
@@ -2621,7 +2633,7 @@ primitive VMpr_BlockClosure_valueWithArguments 
[fail,reload_ip]
       for (i = 1; i <= numArgs; i++)
        PUSH_OOP (ARRAY_AT (oop2, i));
 
-      if UNCOMMON (send_block_value (numArgs))
+      if UNCOMMON (send_block_value (numArgs, 0))
        {
          POP_N_OOPS (numArgs);
          PUSH_OOP (oop2);
@@ -5026,7 +5038,7 @@ primitive VMpr_Behavior_primCompileIfError 
[fail,succeed,reload_ip]
          xfree (_gst_first_error_str);
          _gst_first_error_str = _gst_first_error_file = NULL;
          _gst_report_errors = oldReportErrors;
-         if (send_block_value (3))
+         if (send_block_value (3, 3))
            PRIM_FAILED;
          else
            PRIM_SUCCEEDED_RELOAD_IP;
diff --git a/libgst/vm.def b/libgst/vm.def
index bd00206..f85ef29 100644
--- a/libgst/vm.def
+++ b/libgst/vm.def
@@ -632,7 +632,7 @@ operation VALUE_SPECIAL ( rec -- rec ) {
   EXPORT_REGS ();
   if (UNCOMMON (IS_INT (rec))
       || UNCOMMON (OOP_CLASS (rec) != _gst_block_closure_class)
-      || UNCOMMON (send_block_value (0)))
+      || UNCOMMON (send_block_value (0, 0)))
     SEND_MESSAGE (_gst_builtin_selectors[VALUE_SPECIAL].symbol, 0);
 
   IMPORT_REGS ();
@@ -644,7 +644,7 @@ operation VALUE_COLON_SPECIAL ( rec blk_arg -- rec blk_arg 
) {
   EXPORT_REGS ();
   if (UNCOMMON (IS_INT (rec))
       || UNCOMMON (OOP_CLASS (rec) != _gst_block_closure_class)
-      || UNCOMMON (send_block_value (1)))
+      || UNCOMMON (send_block_value (1, 0)))
     SEND_MESSAGE (_gst_builtin_selectors[VALUE_COLON_SPECIAL].symbol, 1);
 
   IMPORT_REGS ();
diff --git a/tests/blocks.ok b/tests/blocks.ok
index 37f1d8d..6952443 100644
--- a/tests/blocks.ok
+++ b/tests/blocks.ok
@@ -72,3 +72,50 @@ returned value is 55
 Execution begins...
  error: return from a dead method context
 returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+ error: wrong number of arguments
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+ error: wrong number of arguments
+returned value is nil
+
+Execution begins...
+returned value is 1
+
+Execution begins...
+returned value is 2
+
+Execution begins...
+returned value is 3
diff --git a/tests/blocks.st b/tests/blocks.st
index c9641e8..8be78fc 100644
--- a/tests/blocks.st
+++ b/tests/blocks.st
@@ -153,3 +153,22 @@ Eval [
 Eval [ (nil blockTest11: 3) value ]    "should be invalid; we're returning to 
non-
                                         existent parent"
 
+"Various tests on #cull:cull:cull: and friends."
+Eval [   [] cull: 1     ]
+Eval [   [] cull: 1 cull: 2     ]
+Eval [   [] cull: 1 cull: 2 cull: 3    ]
+
+Eval [   [:a |a] cull: 1     ]
+Eval [   [:a |a] cull: 1 cull: 2     ]
+Eval [   [:a |a] cull: 1 cull: 2 cull: 3    ]
+
+Eval [   [:a :b |a] cull: 1     ]
+Eval [   [:a :b |a] cull: 1 cull: 2   ]
+Eval [   [:a :b |a] cull: 1 cull: 2 cull: 3   ]
+Eval [   [:a :b |b] cull: 1 cull: 2    ]
+Eval [   [:a :b |b] cull: 1 cull: 2 cull: 3    ]
+
+Eval [   [:a :b :c |a] cull: 1 cull: 2    ]
+Eval [   [:a :b :c |a] cull: 1 cull: 2 cull: 3    ]
+Eval [   [:a :b :c |b] cull: 1 cull: 2 cull: 3    ]
+Eval [   [:a :b :c |c] cull: 1 cull: 2 cull: 3    ]