From fdc2c9e00af5f2721c4e70180d30f45c15adc65a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 28 Sep 2014 12:51:11 -0400 Subject: peval: Handle optional argument inits that refer to previous arguments. Fixes . Reported by Josep Portella Florit . * 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 --- 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 --- 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). + ;; + ((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)))))