[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-45-gda7fa08

[Andy Wingo]

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=da7fa082e80b2c3989c90031ee5356e5b65bd00b

The branch, master has been updated
       via  da7fa082e80b2c3989c90031ee5356e5b65bd00b (commit)
       via  1371fe9b149da699320567e5160160169ecdb0be (commit)
       via  b3950ad6d88c5675dadb74c8ce5668daaa1b8692 (commit)
       via  35ac785286a527449b9866b4b9adb78a41e545a7 (commit)
      from  ce4c9a6d00a647892e25d24d703f328afb4be9c3 (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 da7fa082e80b2c3989c90031ee5356e5b65bd00b
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 25 00:41:03 2010 +0100

    more substance to control.test
    
    * test-suite/tests/control.test ("suspend/resume with fluids"):
      ("restarting partial continuations"):
      ("reified continuations", "escape-only continuations"): More tests.
    eval.scm's handling of with-fluids doesn't leave the VM
    
    * module/ice-9/eval.scm (primitive-eval): Implement with-fluids in terms
      of with-fluids, to avoid recursively calling the VM via with-fluids*.

commit 1371fe9b149da699320567e5160160169ecdb0be
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 25 00:32:40 2010 +0100

    eval.scm's handling of with-fluids doesn't leave the VM
    
    * module/ice-9/eval.scm (primitive-eval): Implement with-fluids in terms
      of with-fluids, to avoid recursively calling the VM via with-fluids*.

commit b3950ad6d88c5675dadb74c8ce5668daaa1b8692
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 25 00:18:07 2010 +0100

    error if given an unrewindable partial continuation
    
    * libguile/vm-engine.c (vm_error_continuation_not_rewindable):
    * libguile/vm-i-system.c (partial-cont-call):
    * libguile/vm.h (SCM_VM_CONT_PARTIAL_P):
      (SCM_VM_CONT_REWINDABLE_P): Fix a bug in which we weren't checking if
      a partial continuation was actually rewindable.

commit 35ac785286a527449b9866b4b9adb78a41e545a7
Author: Andy Wingo <address@hidden>
Date:   Thu Feb 25 00:43:44 2010 +0100

    fix embarrassing bug
    
    * libguile/vm.c: Fix embarrassing error regarding the symbolitude of
      vm-error and friends.

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

Summary of changes:
 libguile/vm-engine.c          |    5 +
 libguile/vm-i-system.c        |    4 +
 libguile/vm.c                 |    8 +-
 libguile/vm.h                 |    4 +-
 module/ice-9/eval.scm         |    6 +-
 test-suite/tests/control.test |  162 ++++++++++++++++++++++++++++++++++++++++-
 6 files changed, 181 insertions(+), 8 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 8c188d3..1976f71 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -233,6 +233,11 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
     finish_args = SCM_EOL;
     goto vm_error;
 
+  vm_error_continuation_not_rewindable:
+    err_msg  = scm_from_locale_string ("Unrewindable partial continuation");
+    finish_args = scm_cons (finish_args, SCM_EOL);
+    goto vm_error;
+
   vm_error_bad_wide_string_length:
     err_msg  = scm_from_locale_string ("VM: Bad wide string length: ~S");
     goto vm_error;
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 04ef951..56df727 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -999,6 +999,10 @@ VM_DEFINE_INSTRUCTION (94, partial_cont_call, 
"partial-cont-call", 0, -1, 0)
   POP (intwinds);
   POP (vmcont);
   SYNC_REGISTER ();
+  if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
+    { finish_args = vmcont;
+      goto vm_error_continuation_not_rewindable;
+    }
   vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp);
   CACHE_REGISTER ();
   program = SCM_FRAME_PROGRAM (fp);
diff --git a/libguile/vm.c b/libguile/vm.c
index f53aaf5..85e0e7a 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -752,10 +752,10 @@ scm_bootstrap_vm (void)
   scm_c_register_extension ("libguile", "scm_init_vm",
                             (scm_t_extension_init_func)scm_init_vm, NULL);
 
-  sym_vm_run = scm_from_locale_string ("vm-run");
-  sym_vm_error = scm_from_locale_string ("vm-error");
-  sym_keyword_argument_error = scm_from_locale_string 
("keyword-argument-error");
-  sym_debug = scm_from_locale_string ("debug");
+  sym_vm_run = scm_from_locale_symbol ("vm-run");
+  sym_vm_error = scm_from_locale_symbol ("vm-error");
+  sym_keyword_argument_error = scm_from_locale_symbol 
("keyword-argument-error");
+  sym_debug = scm_from_locale_symbol ("debug");
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =
diff --git a/libguile/vm.h b/libguile/vm.h
index 48e0bb6..ade4bb6 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -102,8 +102,8 @@ struct scm_vm_cont {
 
 #define SCM_VM_CONT_P(OBJ)     (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == 
scm_tc7_vm_cont)
 #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT) & 
SCM_F_VM_CONT_PARTIAL)
-#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT) & 
SCM_F_VM_CONT_REWINDABLE)
+#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & 
SCM_F_VM_CONT_PARTIAL)
+#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & 
SCM_F_VM_CONT_REWINDABLE)
 
 SCM_API SCM scm_load_compiled_with_vm (SCM file);
 
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index f7cb6ce..e38f2df 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -307,7 +307,11 @@
         (('with-fluids (fluids vals . exp))
          (let* ((fluids (map (lambda (x) (eval x env)) fluids))
                 (vals (map (lambda (x) (eval x env)) vals)))
-           (with-fluids* fluids vals (lambda () (eval exp env)))))
+           (let lp ((fluids fluids) (vals vals))
+             (if (null? fluids)
+                 (eval exp env)
+                 (with-fluids (((car fluids) (car vals)))
+                   (lp (cdr fluids) (cdr vals)))))))
         
         (('prompt (tag exp . handler))
          (@prompt (eval tag env)
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index fab2f60..650f255 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -25,6 +25,9 @@
 (define default-tag (fluid-ref %default-prompt-tag))
 
 
+;; For these, the compiler should be able to prove that "k" is not referenced,
+;; so it avoids reifying the continuation. Since that's a slightly different
+;; codepath, we test them both.
 (with-test-prefix "escape-only continuations"
   (pass-if "no values, normal exit"
     (equal? '()
@@ -35,12 +38,169 @@
                      (lambda (k . args)
                        (error "unexpected exit" args))))
               list)))
-  (pass-if "no values, normal exit"
+
+  (pass-if "no values, abnormal exit"
     (equal? '()
             (% default-tag
                (begin
                  (abort default-tag)
                  (error "unexpected exit"))
                (lambda (k . args)
+                 args))))
+
+  (pass-if "single value, normal exit"
+    (equal? '(foo)
+            (call-with-values
+                (lambda ()
+                  (% default-tag
+                     'foo
+                     (lambda (k . args)
+                       (error "unexpected exit" args))))
+              list)))
+
+  (pass-if "single value, abnormal exit"
+    (equal? '(foo)
+            (% default-tag
+               (begin
+                 (abort default-tag 'foo)
+                 (error "unexpected exit"))
+               (lambda (k . args)
+                 args))))
+
+  (pass-if "multiple values, normal exit"
+    (equal? '(foo bar baz)
+            (call-with-values
+                (lambda ()
+                  (% default-tag
+                     (values 'foo 'bar 'baz)
+                     (lambda (k . args)
+                       (error "unexpected exit" args))))
+              list)))
+
+  (pass-if "multiple values, abnormal exit"
+    (equal? '(foo bar baz)
+            (% default-tag
+               (begin
+                 (abort default-tag 'foo 'bar 'baz)
+                 (error "unexpected exit"))
+               (lambda (k . args)
                  args)))))
 
+;;; And the case in which the compiler has to reify the continuation.
+(with-test-prefix "reified continuations"
+  (pass-if "no values, normal exit"
+    (equal? '()
+            (call-with-values
+                (lambda ()
+                  (% default-tag
+                     (values)
+                     (lambda (k . args)
+                       (error "unexpected exit" k args))))
+              list)))
+
+  (pass-if "no values, abnormal exit"
+    (equal? '()
+            (cdr
+             (% default-tag
+                (begin
+                  (abort default-tag)
+                  (error "unexpected exit"))
+                (lambda args
+                  args)))))
+
+  (pass-if "single value, normal exit"
+    (equal? '(foo)
+            (call-with-values
+                (lambda ()
+                  (% default-tag
+                     'foo
+                     (lambda (k . args)
+                       (error "unexpected exit" k args))))
+              list)))
+
+  (pass-if "single value, abnormal exit"
+    (equal? '(foo)
+            (cdr
+             (% default-tag
+                (begin
+                  (abort default-tag 'foo)
+                  (error "unexpected exit"))
+                (lambda args
+                  args)))))
+
+  (pass-if "multiple values, normal exit"
+    (equal? '(foo bar baz)
+            (call-with-values
+                (lambda ()
+                  (% default-tag
+                     (values 'foo 'bar 'baz)
+                     (lambda (k . args)
+                       (error "unexpected exit" k args))))
+              list)))
+
+  (pass-if "multiple values, abnormal exit"
+    (equal? '(foo bar baz)
+            (cdr
+             (% default-tag
+                (begin
+                  (abort default-tag 'foo 'bar 'baz)
+                  (error "unexpected exit"))
+                (lambda args
+                  args))))))
+
+;;; Here we test that instantiation works
+(with-test-prefix "restarting partial continuations"
+  (pass-if "simple"
+    (let ((k (% default-tag
+                (begin (abort default-tag) 'foo)
+                (lambda (k) k))))
+      (eq? (k)
+           'foo))))
+
+(define fl (make-fluid))
+(fluid-set! fl 0)
+
+(with-test-prefix "suspend/resume with fluids"
+  (pass-if "normal"
+    (zero? (% default-tag
+              (fluid-ref fl)
+              error)))
+  (pass-if "with-fluids normal"
+    (equal? (% default-tag
+              (with-fluids ((fl (1+ (fluid-ref fl))))
+                (fluid-ref fl))
+              error)
+            1))
+  (pass-if "normal (post)"
+    (zero? (fluid-ref fl)))
+  (pass-if "with-fluids and fluid-set!"
+    (equal? (% default-tag
+               (with-fluids ((fl (1+ (fluid-ref fl))))
+                 (fluid-set! fl (1+ (fluid-ref fl)))
+                 (fluid-ref fl))
+               error)
+            2))
+  (pass-if "normal (post2)"
+    (zero? (fluid-ref fl)))
+  (pass-if "normal fluid-set!"
+    (equal? (begin
+              (fluid-set! fl (1+ (fluid-ref fl)))
+              (fluid-ref fl))
+            1))
+  (pass-if "reset fluid-set!"
+    (equal? (begin
+              (fluid-set! fl (1- (fluid-ref fl)))
+              (fluid-ref fl))
+            0))
+
+  (let ((k (% default-tag
+              (with-fluids ((fl (1+ (fluid-ref fl))))
+                (abort default-tag)
+                (fluid-ref fl))
+              (lambda (k) k))))
+    (pass-if "pre"
+      (equal? (fluid-ref fl) 0))
+    (pass-if "res"
+      (equal? (k) 1))
+    (pass-if "post"
+      (equal? (fluid-ref fl) 0))))


hooks/post-receive
-- 
GNU Guile