1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
From fdc2c9e00af5f2721c4e70180d30f45c15adc65a Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Sun, 28 Sep 2014 12:51:11 -0400
Subject: peval: Handle optional argument inits that refer to previous
arguments.
Fixes <http://bugs.gnu.org/17634>.
Reported by Josep Portella Florit <jpf@primfilat.com>.
* 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.
Origin: http://git.savannah.gnu.org/cgit/guile.git/commit/?id=7a71a45cfd6092402d540e9bc5d2432941a8a336
Added-by: Rob Browning <rlb@defaultvalue.org>
---
module/language/tree-il/peval.scm | 94 +++++++++++++++++++++++++++++++--------
test-suite/tests/peval.test | 86 ++++++++++++++++++++++++++++++++++-
2 files changed, 160 insertions(+), 20 deletions(-)
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/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 <wingo@pobox.com> --- 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)))))
|
