[Guile-commits] GNU Guile branch, master, updated. v2.1.0-125-g2f4aae6

[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=2f4aae6bce7986ad724b374d1a72a6d4c48b462c

The branch, master has been updated
       via  2f4aae6bce7986ad724b374d1a72a6d4c48b462c (commit)
       via  acdf4fcc059df325f66698090359b3455725c865 (commit)
       via  8ee0b28b4d51dac704c151bf7f6d1874018ed3ae (commit)
       via  5e9b9059a334be0427eeb37eee6627dd595dc567 (commit)
       via  16d3e0133d9e5fd1052be69bfeec3b243d832ed4 (commit)
       via  d825841db0eb920150d6734b8928b6a3decbca0e (commit)
      from  215fe3a89119319fa0bb953ede574b38bea143ab (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 2f4aae6bce7986ad724b374d1a72a6d4c48b462c
Merge: 215fe3a acdf4fc
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 9 17:04:44 2011 +0100

    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

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

Summary of changes:
 module/language/tree-il.scm       |    6 ++--
 module/language/tree-il/peval.scm |   63 +++++++++++++++++++++++++++++-------
 module/rnrs/lists.scm             |   12 +++++--
 module/rnrs/records/syntactic.scm |    4 +-
 test-suite/tests/r6rs-lists.test  |   26 +++++++++++++++
 test-suite/tests/tree-il.test     |   18 ++++++++++
 6 files changed, 108 insertions(+), 21 deletions(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index cd6b01e..1723525 100644
--- a/module/language/tree-il.scm
+++ b/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 ,(unparse-tree-il body)
-               ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
+    ((<dynwind> winder body unwinder)
+     `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
+               ,(unparse-tree-il unwinder)))
 
     ((<dynlet> fluids vals body)
      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index f7733a5..634f257 100644
--- a/module/language/tree-il/peval.scm
+++ b/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
-    ;; effects, does not allocate storage for a mutable object, and does
-    ;; not access mutable data (like `car' or toplevel references).
+    ;; Return true if X is constant, for the purposes of copying or
+    ;; elision---i.e., if it is known to have no effects, does not
+    ;; 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)
-         (and (every loop inits) (loop body)
+        (($ <lambda-case> _ req opt rest kw inits syms body alternate)
+         (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)
-         (and (every loop vals) (loop body)))
-        (($ <letrec> _ _ _ _ vals body)
-         (and (every loop vals) (loop body)))
+        (($ <let> _ _ syms vals body)
+         (and (not (any assigned-lexical? syms))
+              (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*)
-                  (every constant-expression? vals))
+         (if (and (const? body*) (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)
-                     (for-value unwinder)))
+       (let ((pre (for-value winder))
+             (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)))
diff --git a/module/rnrs/lists.scm b/module/rnrs/lists.scm
index 812ce5f..0671e77 100644
--- a/module/rnrs/lists.scm
+++ b/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 
-                                     any 
+         (rename (only (srfi srfi-1) 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))
diff --git a/module/rnrs/records/syntactic.scm 
b/module/rnrs/records/syntactic.scm
index a497b90..bde6f93 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/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
diff --git a/test-suite/tests/r6rs-lists.test b/test-suite/tests/r6rs-lists.test
index ba645ed..030091f 100644
--- a/test-suite/tests/r6rs-lists.test
+++ b/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)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 3db4afd..5bab593 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1462,6 +1462,24 @@
    (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)))
      (call-with-prompt tag


hooks/post-receive
-- 
GNU Guile