[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.11-77-g7a71a
From: |
Mark H Weaver |
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.11-77-g7a71a45 |
Date: |
Mon, 29 Sep 2014 03:58:32 +0000 |
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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.11-77-g7a71a45,
Mark H Weaver <=