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

Conflicts:
	GUILE-VERSION
	libguile/deprecated.c
	libguile/gc-malloc.c
	module/language/tree-il/peval.scm

test-suite/tests/coverage.test

@@ -1,6 +1,6 @@
 ;;;; coverage.test --- Code coverage.    -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 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
@@ -35,6 +35,12 @@
 
 (define %test-vm (make-vm))
 
+(define test-procedure
+  (compile '(lambda (x)
+              (if (> x 2)
+                  (- x 2)
+                  (+ x 2)))))
+
 
 (with-test-prefix "instrumented/executed-lines"
 
@@ -156,6 +162,18 @@
                             (else    #f))))
                       counts))))))
 
+  (pass-if "case-lambda"
+    (let ((proc (code "cl.scm"  "(case-lambda       ;; 0
+                                   ((x)   (+ x 3))  ;; 1
+                                   ((x y) (+ x y))) ;; 2")))
+      (let-values (((data result)
+                    (with-code-coverage %test-vm
+                      (lambda ()
+                        (+ (proc 1) (proc 2 3))))))
+        (let ((counts (line-execution-counts data "cl.scm")))
+          (and (pair? counts)
+               (lset= equal? '((0 . 2) (1 . 1) (2 . 1)) counts))))))
+
   (pass-if "all code on one line"
     ;; There are several proc/IP pairs pointing to this source line, yet the hit
     ;; count for the line should be 1.
@@ -179,6 +197,16 @@
              (= 3 result)
              (= (procedure-execution-count data proc) 2)))))
 
+  (pass-if "case-lambda"
+    (let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
+      (let-values (((data result)
+                    (with-code-coverage %test-vm
+                      (lambda ()
+                        (+ (proc 1) (proc 2 3))))))
+        (and (coverage-data? data)
+             (= 6 result)
+             (= (procedure-execution-count data proc) 2)))))
+
   (pass-if "never"
     (let ((proc (code "foo.scm" "(lambda (x y) x)")))
       (let-values (((data result)
@@ -204,7 +232,16 @@
                               (make-pointer (object-address 2)))))))
         (and (coverage-data? data)
              (= (object-address 3) (pointer-address result))
-             (= (procedure-execution-count data proc) 1))))))
+             (= (procedure-execution-count data proc) 1)))))
+
+  (pass-if "called from eval"
+    (let-values (((data result)
+                  (with-code-coverage %test-vm
+                    (lambda ()
+                      (eval '(test-procedure 123) (current-module))))))
+      (and (coverage-data? data)
+           (= (test-procedure 123) result)
+           (= (procedure-execution-count data test-procedure) 1)))))
 
 
 (with-test-prefix "instrumented-source-files"

test-suite/tests/goops.test

@@ -206,8 +206,15 @@
                        (x #:accessor x #:init-value 123)
                        (z #:accessor z #:init-value 789))
                     (current-module))
-              (eval '(equal? (x (make <qux>)) 123) (current-module)))))
-     
+              (eval '(equal? (x (make <qux>)) 123) (current-module)))
+
+     (pass-if-exception "cannot redefine fields of <class>"
+       '(misc-error . "cannot be redefined")
+       (eval '(begin
+                (define-class <test-class> (<class>) 
+                  name) 
+                (make <test-class>))
+             (current-module)))))
 
 (with-test-prefix "defining generics"
 

test-suite/tests/match.test.upstream

@@ -27,6 +27,7 @@
 (test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
 (test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
 (test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
+(test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
 
 (test "ellipses" '((a b c) (1 2 3))
   (match '((a . 1) (b . 2) (c . 3))

test-suite/tests/tree-il.test

@@ -624,6 +624,19 @@
             (toplevel ref bar) (call call/cc 1)
             (call tail-call 1))))
 
+
+(with-test-prefix "labels allocation"
+  (pass-if "http://debbugs.gnu.org/9769"
+    ((compile '(lambda ()
+                 (let ((fail (lambda () #f)))
+                   (let ((test (lambda () (fail))))
+                     (test))
+                   #t))
+              ;; Prevent inlining.  We're testing analyze.scm's
+              ;; labels allocator here, and inlining it will
+              ;; reduce the entire thing to #t.
+              #:opts '(#:partial-eval? #f)))))
+
 
 (with-test-prefix "partial evaluation"
 
@@ -759,6 +772,21 @@
          (loop (cdr l) (+ sum (car l)))))
    (const 10))
 
+  (pass-if-peval resolve-primitives
+   (let ((string->chars
+          (lambda (s)
+            (define (char-at n)
+              (string-ref s n))
+            (define (len)
+              (string-length s))
+            (let loop ((i 0))
+              (if (< i (len))
+                  (cons (char-at i)
+                        (loop (1+ i)))
+                  '())))))
+     (string->chars "yo"))
+   (apply (primitive list) (const #\y) (const #\o)))
+
   (pass-if-peval
     ;; Primitives in module-refs are resolved (the expansion of `pmatch'
     ;; below leads to calls to (@@ (system base pmatch) car) and