diff options
Diffstat (limited to 'main/guile/0016-peval-Handle-optional-argument-inits-that-refer-to-p.patch')
| -rw-r--r-- | main/guile/0016-peval-Handle-optional-argument-inits-that-refer-to-p.patch | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/main/guile/0016-peval-Handle-optional-argument-inits-that-refer-to-p.patch b/main/guile/0016-peval-Handle-optional-argument-inits-that-refer-to-p.patch new file mode 100644 index 0000000000..c134815c1d --- /dev/null +++ b/main/guile/0016-peval-Handle-optional-argument-inits-that-refer-to-p.patch @@ -0,0 +1,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))))) |