[Guile-commits] GNU Guile branch, master, updated. v2.1.0-132-g4f2b34f

[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=4f2b34ff640060ec7e75a922db110d7850b6c1c7

The branch, master has been updated
       via  4f2b34ff640060ec7e75a922db110d7850b6c1c7 (commit)
       via  020602791b3f929e2d65ffdd8d67977763d6883e (commit)
       via  16371014d6231394dbfc9c5cc9dfcceabd8bc234 (commit)
       via  39c5363b4fbd32f1c895e8fa8b0c8dd067907947 (commit)
       via  fb135e12a473fd9a1612a59f904cfb90877fe775 (commit)
      from  b86b70feced7d2be203be0738e1bab8d1e81a11e (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 4f2b34ff640060ec7e75a922db110d7850b6c1c7
Merge: 1637101 0206027
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 11 16:40:49 2011 +0100

    Merge remote-tracking branch 'origin/stable-2.0'

commit 16371014d6231394dbfc9c5cc9dfcceabd8bc234
Merge: b86b70f 39c5363
Author: Andy Wingo <address@hidden>
Date:   Fri Nov 11 16:27:30 2011 +0100

    Merge remote-tracking branch 'origin/stable-2.0'

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

Summary of changes:
 libguile/bitvectors.c                    |    6 +++---
 module/language/tree-il/compile-glil.scm |   22 ++++++++++++++++++++++
 test-suite/tests/bitvectors.test         |   21 ++++++++++++++++++---
 test-suite/tests/gc.test                 |   28 +++++++++++++++++++---------
 test-suite/tests/tree-il.test            |    4 +++-
 5 files changed, 65 insertions(+), 16 deletions(-)

diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index 12dd136..5b5a1b8 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -568,7 +568,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
            "\n"
            "If @var{kv} is a bit vector, then those entries where it has\n"
            "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
-           "@var{kv} and @var{v} must be the same length.  When @var{obj}\n"
+           "@var{v} must be at least as long as @var{kv}.  When @var{obj}\n"
            "is @code{#t} it's like @var{kv} is OR'ed into @var{v}.  Or when\n"
            "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
            "\n"
@@ -611,10 +611,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
       ssize_t kv_inc;
       const scm_t_uint32 *kv_bits;
       
-      kv_bits = scm_bitvector_elements (v, &kv_handle,
+      kv_bits = scm_bitvector_elements (kv, &kv_handle,
                                        &kv_off, &kv_len, &kv_inc);
 
-      if (v_len != kv_len)
+      if (v_len < kv_len)
        scm_misc_error (NULL,
                        "bit vectors must have equal length",
                        SCM_EOL);
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index 28c31f3..31e9a70 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -240,6 +240,24 @@
           (if (eq? context 'tail)
               (emit-code #f (make-glil-call 'return 1)))))
     
+    ;; After lexical binding forms in non-tail context, call this
+    ;; function to clear stack slots, allowing their previous values to
+    ;; be collected.
+    (define (clear-stack-slots context syms)
+      (case context
+        ((push drop)
+         (for-each (lambda (v)
+                     (and=>
+                      ;; Can be #f if the var is labels-allocated.
+                      (hashq-ref allocation v)
+                      (lambda (h)
+                        (pmatch (hashq-ref h self)
+                          ((#t _ . ,n)
+                           (emit-code #f (make-glil-void))
+                           (emit-code #f (make-glil-lexical #t #f 'set n)))
+                          (,loc (error "bad let var allocation" x loc))))))
+                   syms))))
+
     (record-case x
       ((<void>)
        (case context
@@ -748,6 +766,7 @@
                      (,loc (error "bad let var allocation" x loc))))
                  (reverse gensyms))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src in-order? names gensyms vals body)
@@ -780,6 +799,7 @@
                        (,loc (error "bad letrec var allocation" x loc))))
                    (reverse gensyms))))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<fix> src names gensyms vals body)
@@ -868,6 +888,7 @@
          (comp-tail body)
          (if new-RA
              (emit-label new-RA))
+         (clear-stack-slots context gensyms)
          (emit-code #f (make-glil-unbind))))
 
       ((<let-values> src exp body)
@@ -893,6 +914,7 @@
                           (,loc (error "bad let-values var allocation" x 
loc))))
                       (reverse gensyms))
             (comp-tail body)
+            (clear-stack-slots context gensyms)
             (emit-code #f (make-glil-unbind))))))
 
       ;; much trickier than i thought this would be, at first, due to the need
diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test
index 9833b3b..c16fb4d 100644
--- a/test-suite/tests/bitvectors.test
+++ b/test-suite/tests/bitvectors.test
@@ -1,6 +1,6 @@
 ;;;; bitvectors.test --- tests guile's bitvectors     -*- scheme -*-
 ;;;;
-;;;; Copyright 2010 Free Software Foundation, Inc.
+;;;; Copyright 2010, 2011 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -55,5 +55,20 @@
       (uniform-vector-set! bv 0 #t)
       (pass-if (eqv? (uniform-vector-ref bv 0) #t)))))
 
-
-
+(with-test-prefix "bit-set*!"
+  (pass-if "#t"
+    (let ((v (bitvector #t #t #f #f)))
+      (bit-set*! v #*1010 #t)
+      (equal? v #*1110)))
+  (pass-if "#f"
+    (let ((v (bitvector #t #t #f #f)))
+      (bit-set*! v #*1010 #f)
+      (equal? v #*0100)))
+  (pass-if "#t, shorter"
+    (let ((v (bitvector #t #t #f #f)))
+      (bit-set*! v #*101 #t)
+      (equal? v #*1110)))
+  (pass-if "#f, shorter"
+    (let ((v (bitvector #t #t #f #f)))
+      (bit-set*! v #*101 #f)
+      (equal? v #*0100))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 57643e8..25dc577 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -16,8 +16,10 @@
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
 
-(use-modules (ice-9 documentation)
-            (test-suite lib))
+(define-module (test-suite tests gc)
+  #:use-module (ice-9 documentation)
+  #:use-module (test-suite lib)
+  #:use-module ((system base compile) #:select (compile)))
 
 
 ;;;
@@ -62,10 +64,8 @@
       (add-hook! after-gc-hook thunk)
       (gc)
       (remove-hook! after-gc-hook thunk)
-      foo)))
+      foo))
 
-
-(with-test-prefix "gc"
   (pass-if "Unused modules are removed"
     (let* ((guard (make-guardian))
            (total 1000))
@@ -76,12 +76,22 @@
       (stack-cleanup 20)
 
       (gc)
-      (gc) ;; twice: have to kill the weak vectors.
-      (gc) ;; thrice: because the test doesn't succeed with only
-           ;; one gc round. not sure why.
+      (gc)   ;; twice: have to kill the weak vectors.
+      (gc)   ;; thrice: because the test doesn't succeed with only
+      ;; one gc round. not sure why.
 
       (= (let lp ((i 0))
            (if (guard)
                (lp (1+ i))
                i))
-         total))))
+         total)))
+
+  (pass-if "Lexical vars are collectable"
+    (procedure?
+     (compile
+      '(begin
+         (define guardian (make-guardian))
+         (let ((f (lambda () (display "test\n"))))
+           (guardian f))
+         (gc)(gc)(gc)
+         (guardian))))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 6733f74..8d125f5 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -396,7 +396,9 @@
             (call new-frame 0) (toplevel ref bar) (call call 0)
             (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 
2)
             (lexical #t #f ref 2) (lexical #t #t set 0)
-            (lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
+            (lexical #t #f ref 3) (lexical #t #t set 1)
+            (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear 
bindings
+            (unbind)
             (lexical #t #t ref 0) (lexical #t #t ref 1)
             (call add 2) (call return 1) (unbind)))
   


hooks/post-receive
-- 
GNU Guile