[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-205-g145911f

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=145911fc6f661db233e8a2458605b587836e3474

The branch, wip-cps-bis has been updated
       via  145911fc6f661db233e8a2458605b587836e3474 (commit)
       via  2a5b3f44f48b74c74b33a9c47943f88eaf25b087 (commit)
      from  324418bc1967e809daf8ae25eb33e0ca1c8d3d07 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 145911fc6f661db233e8a2458605b587836e3474
Author: Mark H Weaver <address@hidden>
Date:   Sat Aug 17 06:04:34 2013 -0400

    Improve handling of environments in rtl-compilation.test.
    
    * test-suite/tests/rtl-compilation.test (run-rtl): Accept 'env' keyword
      option.  Call the compiled thunk with 'current-module' set to that
      environment.
      ("top-level define"): New test.
      ("top-level set!"): Reworked from existing test.

commit 2a5b3f44f48b74c74b33a9c47943f88eaf25b087
Author: Mark H Weaver <address@hidden>
Date:   Sat Aug 17 05:37:45 2013 -0400

    RTL VM: Rename 'apply' instruction to 'tail-apply'.
    
    * libguile/vm-engine.c (apply, tail-apply): apply -> tail-apply.
      (RETURN_VALUE_LIST): goto op_apply -> goto op_tail_apply.
    
    * libguile/vm.c (rtl_apply_code): scm_rtl_op_apply ->
      scm_rtl_op_tail_apply.

-----------------------------------------------------------------------

Summary of changes:
 libguile/vm-engine.c                  |    6 +++---
 libguile/vm.c                         |    2 +-
 test-suite/tests/rtl-compilation.test |   29 ++++++++++++++++++-----------
 3 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 8a6d973..396a8d5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -664,7 +664,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     fp[1] = vals;                                       \
     RESET_FRAME (3);                                    \
     ip = (scm_t_uint32 *) rtl_apply_code;               \
-    goto op_apply;                                      \
+    goto op_tail_apply;                                 \
   } while (0)
 
 #define BR_NARGS(rel)                           \
@@ -1282,13 +1282,13 @@ RTL_VM_NAME (SCM vm, SCM program, SCM *argv, size_t 
nargs_)
       NEXT (0);
     }
 
-  /* apply _:24
+  /* tail-apply _:24
    *
    * Tail-apply the procedure in local slot 0 to the rest of the
    * arguments.  This instruction is part of the implementation of
    * `apply', and is not generated by the compiler.
    */
-  VM_DEFINE_OP (11, apply, "apply", OP1 (U8_X24))
+  VM_DEFINE_OP (11, tail_apply, "tail-apply", OP1 (U8_X24))
     {
       int i, list_idx, list_len, nargs;
       SCM list;
diff --git a/libguile/vm.c b/libguile/vm.c
index ad41180..5f6a5a0 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -603,7 +603,7 @@ static const scm_t_uint32 rtl_boot_continuation_code[] = {
 };
 
 static const scm_t_uint32 rtl_apply_code[] = {
-  SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set 
*/
+  SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0) /* proc in r1, args from r2, 
nargs set */
 };
 
 static const scm_t_uint32 rtl_values_code[] = {
diff --git a/test-suite/tests/rtl-compilation.test 
b/test-suite/tests/rtl-compilation.test
index dc81b68..ca27181 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -26,10 +26,12 @@
    (compile exp #:env env #:to 'rtl
             #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
 
-(define (run-rtl exp)
-  ((compile-via-rtl exp)))
-
-(define test-var #f)
+(define* (run-rtl exp #:key (env (make-fresh-user-module)))
+  (let ((thunk (compile-via-rtl exp #:env env)))
+    (save-module-excursion
+     (lambda ()
+       (set-current-module env)
+       (thunk)))))
 
 (with-test-prefix "tail context"
   (pass-if-equal 1
@@ -41,13 +43,18 @@
   (pass-if-equal (if #f #f)
       (run-rtl '(if #f #f)))
 
-  (pass-if-equal (list 1 (if #f #f))
-      (begin
-        (set! test-var #f)
-        (let ((result ((compile-via-rtl
-                        '(set! test-var 1)
-                        #:env (current-module)))))
-          (list test-var result))))
+  (pass-if-equal "top-level define"
+      (list (if #f #f) 1)
+    (let ((mod (make-fresh-user-module)))
+      (let ((result (run-rtl '(define v 1) #:env mod)))
+        (list result (module-ref mod 'v)))))
+
+  (pass-if-equal "top-level set!"
+      (list (if #f #f) 1)
+    (let ((mod (make-fresh-user-module)))
+      (module-define! mod 'v #f)
+      (let ((result (run-rtl '(set! v 1) #:env mod)))
+        (list result (module-ref mod 'v)))))
 
   (pass-if-equal cons
       (run-rtl 'cons))


hooks/post-receive
-- 
GNU Guile