mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

peval: Handle optional argument inits that refer to previous arguments.

Browse source 
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.
This commit is contained in:
Mark H Weaver 2014-09-28 12:51:11 -04:00
parent ff4af3df23
commit 7a71a45cfd
2 changed files with 160 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

94
module/language/tree-il/peval.scm
View file

@ -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))))

86
test-suite/tests/peval.test
View file

@ -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
@ -410,6 +410,90 @@
'(2 3))
(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))