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

Conflicts:
	module/ice-9/psyntax-pp.scm
	module/language/tree-il/compile-glil.scm

module/ice-9/boot-9.scm

@@ -3411,7 +3411,7 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define %auto-compilation-options
   ;; Default `compile-file' option when auto-compiling.
-  '(#:warnings (unbound-variable arity-mismatch)))
+  '(#:warnings (unbound-variable arity-mismatch format)))
 
 (define* (load-in-vicinity dir path #:optional reader)
   ;; Returns the .go file corresponding to `name'. Does not search load
@@ -3470,8 +3470,14 @@ module '(ice-9 q) '(make-q q-length))}."
                  (else #f))))))
       (lambda (k . args)
         (format (current-error-port)
-                ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
-                name k args)
+                ";;; WARNING: compilation of ~a failed:\n" name)
+        (for-each (lambda (s)
+                    (if (not (string-null? s))
+                        (format (current-error-port) ";;; ~a\n" s)))
+                  (string-split
+                   (call-with-output-string
+                    (lambda (port) (print-exception port #f k args)))
+                   #\newline))
         #f)))
 
   (define (absolute-path? path)

module/ice-9/psyntax.scm

@@ -2425,7 +2425,8 @@
     (set! generate-temporaries
           (lambda (ls)
             (arg-check list? ls 'generate-temporaries)
-            (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
+            (let ((mod (cons 'hygiene (module-name (current-module)))))
+              (map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
 
     (set! free-identifier=?
           (lambda (x y)

module/language/tree-il/compile-glil.scm

@@ -207,10 +207,12 @@
          ;; write source info for proc
          (if src (emit-code #f (make-glil-source src)))
          ;; compile the body, yo
-         (flatten body allocation x self-label (car (hashq-ref allocation x))
-                  emit-code)))))))
+         (flatten-lambda-case body allocation x self-label
+                              (car (hashq-ref allocation x))
+                              emit-code)))))))
 
-(define (flatten x allocation self self-label fix-labels emit-code)
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+                             emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
@@ -218,7 +220,7 @@
 
   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
-  (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+  (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
     (define (comp-tail tree) (comp tree context RA MVRA))
     (define (comp-push tree) (comp tree 'push #f #f))
     (define (comp-drop tree) (comp tree 'drop #f #f))
@@ -252,41 +254,26 @@
       
       ((<call> src proc args)
        (cond
-        ;; self-call in tail position
+        ;; call to the same lambda-case in tail position
         ((and (lexical-ref? proc)
               self-label (eq? (lexical-ref-gensym proc) self-label)
-              (eq? context 'tail))
-         (let lp ((lcase (lambda-body self)))
-           (cond
-            ((and (lambda-case? lcase)
-                  (not (lambda-case-kw lcase))
-                  (not (lambda-case-rest lcase))
-                  (= (length args)
-                     (+ (length (lambda-case-req lcase))
-                        (or (and=> (lambda-case-opt lcase) length) 0))))
-             ;; we have a case that matches the args; evaluate new
-             ;; values, rename variables and goto the case label
-             (for-each comp-push args)
-             (for-each (lambda (sym)
-                         (pmatch (hashq-ref (hashq-ref allocation sym) self)
-                           ((#t #f . ,index) ; unboxed
-                            (emit-code #f (make-glil-lexical #t #f 'set index)))
-                           ((#t #t . ,index) ; boxed
-                            ;; new box
-                            (emit-code #f (make-glil-lexical #t #t 'box index)))
-                           (,x (error "bad lambda-case arg allocation" x))))
-                       (reverse (lambda-case-gensyms lcase)))
-             (emit-branch src 'br (car (hashq-ref allocation lcase))))
-            ((lambda-case? lcase)
-             ;; no match, try next case
-             (lp (lambda-case-alternate lcase)))
-            (else
-             ;; no cases left -- use the normal tail call mechanism. we
-             ;; can't just shuffle the args down and jump back to the
-             ;; self label, because we don't have space.
-             (comp-push proc)
-             (for-each comp-push args)
-             (emit-code src (make-glil-call 'tail-call (length args)))))))
+              (eq? context 'tail)
+              (not (lambda-case-kw lcase))
+              (not (lambda-case-rest lcase))
+              (= (length args)
+                 (+ (length (lambda-case-req lcase))
+                    (or (and=> (lambda-case-opt lcase) length) 0))))
+         (for-each comp-push args)
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t #f . ,index) ; unboxed
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       ((#t #t . ,index) ; boxed
+                        ;; new box
+                        (emit-code #f (make-glil-lexical #t #t 'box index)))
+                       (,x (error "bad lambda-case arg allocation" x))))
+                   (reverse (lambda-case-gensyms lcase)))
+         (emit-branch src 'br (car (hashq-ref allocation lcase))))
         
         ;; lambda, the ultimate goto
         ((and (lexical-ref? proc)
@@ -378,20 +365,37 @@
               (else
                (comp-tail (make-primcall src 'apply (cons proc args))))))))
 
-         ((values . _) (guard (not (eq? context 'push)))
+         ((values . _)
           ;; tail: (lambda () (values '(1 2)))
           ;; drop: (lambda () (values '(1 2)) 3)
           ;; push: (lambda () (list (values '(10 12)) 1))
           ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
           (case context
             ((drop) (for-each comp-drop args) (maybe-emit-return))
+            ((push)
+             (case (length args)
+               ((0)
+                ;; FIXME: This is surely an error.  We need to add a
+                ;; values-mismatch warning pass.
+                (comp-push (make-call src (make-primitive-ref #f 'values)
+                                      '())))
+               ((1)
+                (comp-push (car args)))
+               (else
+                ;; Taking advantage of unspecified order of evaluation of
+                ;; arguments.
+                (for-each comp-drop (cdr args))
+                (comp-push (car args)))))
             ((vals)
              (for-each comp-push args)
              (emit-code #f (make-glil-const (length args)))
              (emit-branch src 'br MVRA))
             ((tail)
              (for-each comp-push args)
-             (emit-code src (make-glil-call 'return/values (length args))))))
+             (emit-code src (let ((len (length args)))
+                              (if (= len 1)
+                                  (make-glil-call 'return 1)
+                                  (make-glil-call 'return/values len)))))))
         
          ((@call-with-values ,producer ,consumer)
           ;; CONSUMER
@@ -724,7 +728,8 @@
          (if alternate-label
              (begin
                (emit-label alternate-label)
-               (comp-tail alternate)))))
+               (flatten-lambda-case alternate allocation self self-label
+                                    fix-labels emit-code)))))
       
       ((<let> src names gensyms vals body)
        (for-each comp-push vals)

module/language/tree-il/primitives.scm

@@ -249,7 +249,7 @@
 
 (define-primitive-expander +
   () 0
-  (x) x
+  (x) (values x)
   (x y) (if (and (const? y)
                  (let ((y (const-exp y)))
                    (and (number? y) (exact? y) (= y 1))))
@@ -267,7 +267,7 @@
   
 (define-primitive-expander *
   () 1
-  (x) x
+  (x) (values x)
   (x y z . rest) (* x (* y z . rest)))
   
 (define-primitive-expander -
@@ -313,7 +313,7 @@
 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 
 (define-primitive-expander cons*
-  (x) x
+  (x) (values x)
   (x y) (cons x y)
   (x y . rest) (cons x (cons* y . rest)))
 
@@ -332,8 +332,6 @@
 (define-primitive-expander call/cc (proc)
   (@call-with-current-continuation proc))
 
-(define-primitive-expander values (x) x)
-
 (define-primitive-expander make-struct (vtable tail-size . args)
   (if (and (const? tail-size)
            (let ((n (const-exp tail-size)))

module/system/base/language.scm

@@ -1,6 +1,6 @@
 ;;; Multi-language support
 
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 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
@@ -112,7 +112,6 @@
 ;;;
 
 (define *current-language* (make-fluid))
-(fluid-set! *current-language* 'scheme)
 
 (define (current-language)
-  (fluid-ref *current-language*))
+  (or (fluid-ref *current-language*) 'scheme))