[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.11-77-g7a71a45

[Mark H Weaver]

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=7a71a45cfd6092402d540e9bc5d2432941a8a336

The branch, stable-2.0 has been updated
       via  7a71a45cfd6092402d540e9bc5d2432941a8a336 (commit)
       via  ff4af3df238815e434b62693a3c02b8213667ebe (commit)
      from  447af515a3ca2525974efa12fea8513223540403 (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 7a71a45cfd6092402d540e9bc5d2432941a8a336
Author: Mark H Weaver <address@hidden>
Date:   Sun Sep 28 12:51:11 2014 -0400

    peval: Handle optional argument inits that refer to previous arguments.
    
    Fixes <http://bugs.gnu.org/17634>.
    Reported by Josep Portella Florit <address@hidden>.
    
    * module/language/tree-il/peval.scm (inlined-application): When inlining
      an application whose operator is a lambda expression with optional
      arguments that rely on default initializers, expand into a series of
      nested let expressions, to ensure that previous arguments are in scope
      when the default initializers are evaluated.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add tests.

commit ff4af3df238815e434b62693a3c02b8213667ebe
Author: Mark H Weaver <address@hidden>
Date:   Wed Sep 24 22:03:58 2014 -0400

    doc: Improve description of vector-unfold and vector-unfold-right.
    
    * doc/ref/srfi-modules.texi (SRFI-43 Constructors)[vector-unfold]:
      Improve description.
    * module/srfi/srfi-43.scm (vector-unfold, vector-unfold-right):
      Improve docstrings.

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

Summary of changes:
 doc/ref/srfi-modules.texi         |   14 +++---
 module/language/tree-il/peval.scm |   94 +++++++++++++++++++++++++++++-------
 module/srfi/srfi-43.scm           |   16 +++---
 test-suite/tests/peval.test       |   86 +++++++++++++++++++++++++++++++++-
 4 files changed, 175 insertions(+), 35 deletions(-)

diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index b1776c6..2cf9fd1 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 
2007, 2008,
address@hidden   2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, 
Inc.
address@hidden Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014
address@hidden   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node SRFI Support
@@ -4524,11 +4524,11 @@ Create and return a vector whose elements are @var{x} 
@enddots{}.
 @end deffn
 
 @deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{}
-The fundamental vector constructor.  Create a vector whose length is
address@hidden and iterates across each index k from 0 up to
address@hidden - 1, applying @var{f} at each iteration to the current index
-and current seeds, in that order, to receive n + 1 values: first, the
-element to put in the kth slot of the new vector and n new seeds for
+The fundamental vector constructor.  Create a vector whose length
+is @var{length} and iterates across each index k from 0 up to
address@hidden - 1, applying @var{f} at each iteration to the current
+index and current seeds, in that order, to receive n + 1 values: the
+element to put in the kth slot of the new vector, and n new seeds for
 the next iteration.  It is an error for the number of seeds to vary
 between iterations.
 
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index bd92edc..7dfbf6f 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014 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
@@ -1313,24 +1313,80 @@ top-level bindings from ENV and return the resulting 
expression."
                    (nopt (if opt (length opt) 0))
                    (key (source-expression proc)))
               (define (inlined-application)
-                (make-let src
-                          (append req
-                                  (or opt '())
-                                  (if rest (list rest) '()))
-                          gensyms
-                          (if (> nargs (+ nreq nopt))
-                              (append (list-head orig-args (+ nreq nopt))
-                                      (list
-                                       (make-application
-                                        #f
-                                        (make-primitive-ref #f 'list)
-                                        (drop orig-args (+ nreq nopt)))))
-                              (append orig-args
-                                      (drop inits (- nargs nreq))
-                                      (if rest
-                                          (list (make-const #f '()))
-                                          '())))
-                          body))
+                (cond
+                 ((= nargs (+ nreq nopt))
+                  (make-let src
+                            (append req
+                                    (or opt '())
+                                    (if rest (list rest) '()))
+                            gensyms
+                            (append orig-args
+                                    (if rest
+                                        (list (make-const #f '()))
+                                        '()))
+                            body))
+                 ((> nargs (+ nreq nopt))
+                  (make-let src
+                            (append req
+                                    (or opt '())
+                                    (list rest))
+                            gensyms
+                            (append (take orig-args (+ nreq nopt))
+                                    (list (make-application
+                                           #f
+                                           (make-primitive-ref #f 'list)
+                                           (drop orig-args (+ nreq nopt)))))
+                            body))
+                 (else
+                  ;; Here we handle the case where nargs < nreq + nopt,
+                  ;; so the rest argument (if any) will be empty, and
+                  ;; there will be optional arguments that rely on their
+                  ;; default initializers.
+                  ;;
+                  ;; The default initializers of optional arguments
+                  ;; may refer to earlier arguments, so in the general
+                  ;; case we must expand into a series of nested let
+                  ;; expressions.
+                  ;;
+                  ;; In the generated code, the outermost let
+                  ;; expression will bind all arguments provided by
+                  ;; the application's argument list, as well as the
+                  ;; empty rest argument, if any.  Each remaining
+                  ;; optional argument that relies on its default
+                  ;; initializer will be bound within an inner let.
+                  ;;
+                  ;; rest-gensyms, rest-vars and rest-inits will have
+                  ;; either 0 or 1 elements.  They are oddly named, but
+                  ;; allow simpler code below.
+                  (let*-values
+                      (((non-rest-gensyms rest-gensyms)
+                        (split-at gensyms (+ nreq nopt)))
+                       ((provided-gensyms default-gensyms)
+                        (split-at non-rest-gensyms nargs))
+                       ((provided-vars default-vars)
+                        (split-at (append req opt) nargs))
+                       ((rest-vars)
+                        (if rest (list rest) '()))
+                       ((rest-inits)
+                        (if rest
+                            (list (make-const #f '()))
+                            '()))
+                       ((default-inits)
+                        (drop inits (- nargs nreq))))
+                    (make-let src
+                              (append provided-vars rest-vars)
+                              (append provided-gensyms rest-gensyms)
+                              (append orig-args rest-inits)
+                              (fold-right (lambda (var gensym init body)
+                                            (make-let src
+                                                      (list var)
+                                                      (list gensym)
+                                                      (list init)
+                                                      body))
+                                          body
+                                          default-vars
+                                          default-gensyms
+                                          default-inits))))))
 
               (cond
                ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index c1612aa..153b0cb 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -104,10 +104,10 @@
 
 The fundamental vector constructor.  Create a vector whose length is
 LENGTH and iterates across each index k from 0 up to LENGTH - 1,
-applying F at each iteration to the current index and current seeds,
-in that order, to receive n + 1 values: first, the element to put in
-the kth slot of the new vector and n new seeds for the next iteration.
-It is an error for the number of seeds to vary between iterations."
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration.  It is an
+error for the number of seeds to vary between iterations."
     ((f len)
      (assert-procedure f 'vector-unfold)
      (assert-nonneg-exact-integer len 'vector-unfold)
@@ -154,10 +154,10 @@ It is an error for the number of seeds to vary between 
iterations."
 
 The fundamental vector constructor.  Create a vector whose length is
 LENGTH and iterates across each index k from LENGTH - 1 down to 0,
-applying F at each iteration to the current index and current seeds,
-in that order, to receive n + 1 values: first, the element to put in
-the kth slot of the new vector and n new seeds for the next iteration.
-It is an error for the number of seeds to vary between iterations."
+applying F at each iteration to the current index and current seeds, in
+that order, to receive n + 1 values: the element to put in the kth slot
+of the new vector, and n new seeds for the next iteration.  It is an
+error for the number of seeds to vary between iterations."
     ((f len)
      (assert-procedure f 'vector-unfold-right)
      (assert-nonneg-exact-integer len 'vector-unfold-right)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 5b003d2..2183429 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <address@hidden> --- May 2009
 ;;;;
-;;;;   Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, 
Inc.
+;;;;   Copyright (C) 2009-2014 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
@@ -411,6 +411,90 @@
     (const 7))
 
   (pass-if-peval
+    ;; Higher order with optional argument (default uses earlier argument).
+    ;; <http://bugs.gnu.org/17634>
+    ((lambda* (f x #:optional (y (+ 3 (car x))))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 12))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments
+    ;; (default uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 20))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (one caller-supplied value,
+    ;; one default that uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (const 4))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (caller-supplied values).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (const 21))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments (one
+    ;; caller-supplied value, one default that uses earlier optional
+    ;; argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (apply (primitive list) (const ()) (const 4)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (apply (primitive list) (const ()) (const 21)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals and rest).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17
+     8
+     3)
+    (let (r) (_) ((apply (primitive list) (const 8) (const 3)))
+      (apply (primitive list) (lexical r _) (const 21))))
+
+  (pass-if-peval
     ;; Higher order with optional argument (caller-supplied value).
     ((lambda* (f x #:optional (y 0))
        (+ y (f (* (car x) (cadr x)))))


hooks/post-receive
-- 
GNU Guile