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

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);

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

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))))

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))))))