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

Conflicts:
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm
	test-suite/tests/tree-il.test

module/language/tree-il.scm

@@ -332,9 +332,9 @@
     ((<let-values> exp body)
      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 
-    ((<dynwind> body winder unwinder)
+    ((<dynwind> winder body unwinder)
-     `(dynwind ,(unparse-tree-il body)
+     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
-               ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
+               ,(unparse-tree-il unwinder)))
 
     ((<dynlet> fluids vals body)
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)

module/language/tree-il/peval.scm

@@ -523,16 +523,18 @@ top-level bindings from ENV and return the resulting expression."
            (and tail (make-seq src head tail)))))))
 
   (define (constant-expression? x)
-    ;; Return true if X is constant---i.e., if it is known to have no
+    ;; Return true if X is constant, for the purposes of copying or
-    ;; effects, does not allocate storage for a mutable object, and does
+    ;; elision---i.e., if it is known to have no effects, does not
-    ;; not access mutable data (like `car' or toplevel references).
+    ;; allocate storage for a mutable object, and does not access
+    ;; mutable data (like `car' or toplevel references).
     (let loop ((x x))
       (match x
         (($ <void>) #t)
         (($ <const>) #t)
         (($ <lambda>) #t)
-        (($ <lambda-case> _ req opt rest kw inits _ body alternate)
+        (($ <lambda-case> _ req opt rest kw inits syms body alternate)
-         (and (every loop inits) (loop body)
+         (and (not (any assigned-lexical? syms))
+              (every loop inits) (loop body)
               (or (not alternate) (loop alternate))))
         (($ <lexical-ref> _ _ gensym)
          (not (assigned-lexical? gensym)))
@@ -550,10 +552,12 @@ top-level bindings from ENV and return the resulting expression."
          (and (loop body) (every loop args)))
         (($ <seq> _ head tail)
          (and (loop head) (loop tail)))
-        (($ <let> _ _ _ vals body)
+        (($ <let> _ _ syms vals body)
-         (and (every loop vals) (loop body)))
+         (and (not (any assigned-lexical? syms))
-        (($ <letrec> _ _ _ _ vals body)
+              (every loop vals) (loop body)))
-         (and (every loop vals) (loop body)))
+        (($ <letrec> _ _ _ syms vals body)
+         (and (not (any assigned-lexical? syms))
+              (every loop vals) (loop body)))
         (($ <fix> _ _ _ vals body)
          (and (every loop vals) (loop body)))
         (($ <let-values> _ exp body)
@@ -824,8 +828,10 @@ top-level bindings from ENV and return the resulting expression."
                  (ops (make-bound-operands vars new vals visit))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
-         (if (and (const? body*)
+         (if (and (const? body*) (every constant-expression? vals))
-                  (every constant-expression? vals))
+             ;; We may have folded a loop completely, even though there
+             ;; might be cyclical references between the bound values.
+             ;; Handle this degenerate case specially.
              body*
              (prune-bindings ops in-order? body* counter ctx
                              (lambda (names gensyms vals body)
@@ -858,8 +864,39 @@ top-level bindings from ENV and return the resulting expression."
                (_ #f))
              (make-let-values lv-src producer (for-tail consumer)))))
       (($ <dynwind> src winder body unwinder)
-       (make-dynwind src (for-value winder) (for-tail body)
+       (let ((pre (for-value winder))
-                     (for-value unwinder)))
+             (body (for-tail body))
+             (post (for-value unwinder)))
+         (cond
+          ((not (constant-expression? pre))
+           (cond
+            ((not (constant-expression? post))
+             (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (record-new-temporary! 'post post-sym 1)
+               (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       (make-lexical-ref #f 'post post-sym)))))
+            (else
+             (let ((pre-sym (gensym "pre ")))
+               (record-new-temporary! 'pre pre-sym 1)
+               (make-let src '(pre) (list pre-sym) (list pre)
+                         (make-dynwind src
+                                       (make-lexical-ref #f 'pre pre-sym)
+                                       body
+                                       post))))))
+          ((not (constant-expression? post))
+           (let ((post-sym (gensym "post ")))
+             (record-new-temporary! 'post post-sym 1)
+             (make-let src '(post) (list post-sym) (list post)
+                       (make-dynwind src
+                                     pre
+                                     body
+                                     (make-lexical-ref #f 'post post-sym)))))
+          (else
+           (make-dynwind src pre body post)))))
       (($ <dynlet> src fluids vals body)
        (make-dynlet src (map for-value fluids) (map for-value vals)
                     (for-tail body)))

module/rnrs/lists.scm

@@ -22,8 +22,7 @@
 	  remv remq memp member memv memq assp assoc assv assq cons*)
   (import (rnrs base (6))
           (only (guile) filter member memv memq assoc assv assq cons*)
-	  (rename (only (srfi srfi-1) fold 
+	  (rename (only (srfi srfi-1) any 
-			              any 
 				      every 
 				      remove 
 				      member 
@@ -32,7 +31,6 @@
 				      partition
 				      fold-right 
 				      filter-map)
-		  (fold fold-left) 
 		  (any exists) 
 		  (every for-all)
 		  (remove remp)
@@ -40,6 +38,14 @@
 		  (member memp-internal)
 		  (assoc assp-internal)))
 
+  (define (fold-left combine nil list . lists)
+    (define (fold nil lists)
+      (if (exists null? lists)
+          nil
+          (fold (apply combine nil (map car lists))
+                (map cdr lists))))
+    (fold nil (cons list lists)))
+
   (define (remove obj list) (remp (lambda (elt) (equal? obj elt)) list))
   (define (remv obj list) (remp (lambda (elt) (eqv? obj elt)) list))
   (define (remq obj list) (remp (lambda (elt) (eq? obj elt)) list))

module/rnrs/records/syntactic.scm

@@ -134,13 +134,13 @@
               (let* ((fields (if (unspecified? _fields) '() _fields))
                      (field-names (list->vector (map car fields)))
                      (field-accessors
-                      (fold-left (lambda (x c lst)
+                      (fold-left (lambda (lst x c)
                                    (cons #`(define #,(cadr x)
                                              (record-accessor record-name #,c))
                                          lst))
                                  '() fields (sequence (length fields))))
                      (field-mutators
-                      (fold-left (lambda (x c lst)
+                      (fold-left (lambda (lst x c)
                                    (if (caddr x)
                                        (cons #`(define #,(caddr x)
                                                  (record-mutator record-name

test-suite/tests/r6rs-lists.test

@@ -30,3 +30,29 @@
     (let ((d '((3 a) (1 b) (4 c))))
       (equal? (assp even? d) '(4 c)))))
 
+(with-test-prefix "fold-left"
+  (pass-if "fold-left sum"
+    (equal? (fold-left + 0 '(1 2 3 4 5))
+            15))
+  (pass-if "fold-left reverse"
+    (equal? (fold-left (lambda (a e) (cons e a)) '() '(1 2 3 4 5))
+            '(5 4 3 2 1)))
+  (pass-if "fold-left max-length"
+    (equal? (fold-left (lambda (max-len s)
+                         (max max-len (string-length s)))
+                       0
+                       '("longest" "long" "longer"))
+            7))
+  (pass-if "fold-left with-cons"
+    (equal? (fold-left cons '(q) '(a b c))
+            '((((q) . a) . b) . c)))
+  (pass-if "fold-left sum-multiple"
+    (equal? (fold-left + 0 '(1 2 3) '(4 5 6))
+            21))
+  (pass-if "fold-left pairlis"
+    (equal? (fold-left (lambda (accum e1 e2)
+                         (cons (cons e1 e2) accum))
+                       '((d . 4))
+                       '(a b c)
+                       '(1 2 3))
+            '((c . 3) (b . 2) (a . 1) (d  . 4)))))

test-suite/tests/tree-il.test

@@ -1461,6 +1461,24 @@
    (cdr (list (bar) 0))
    (seq (call (toplevel bar)) (primcall list (const 0))))
   
+  (pass-if-peval
+   ;; Non-constant guards get lexical bindings.
+   (dynamic-wind foo (lambda () bar) baz)
+   (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
+        (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+  
+  (pass-if-peval
+   ;; Constant guards don't need lexical bindings.
+   (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+   (dynwind
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ()) (toplevel foo))))
+    (toplevel bar)
+    (lambda ()
+      (lambda-case
+       ((() #f #f #f () ()) (toplevel baz))))))
+  
   (pass-if-peval
    ;; Prompt is removed if tag is unreferenced
    (let ((tag (make-prompt-tag)))