diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-07-03 12:02:30 -0700 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-07-03 12:02:30 -0700 |
commit | db1bf07b053a057b25cd4be683d6e2b017f9856f (patch) | |
tree | 61c881681bcd079ba07946b29d136e5cc530c06b | |
parent | 166a76bc0a18f9b5294953264f98e887ce153320 (diff) | |
download | txr-db1bf07b053a057b25cd4be683d6e2b017f9856f.tar.gz txr-db1bf07b053a057b25cd4be683d6e2b017f9856f.tar.bz2 txr-db1bf07b053a057b25cd4be683d6e2b017f9856f.zip |
compiler: inline lambda: broken : args to optionals.
The compiler test case fails on cases which pass a : value to
an optional argument, which is supposed to trigger defaulting.
* stdlib/compiler.tl (lambda-apply-transform): When processing
an optional argument, if the argument is other than a constant
expression evaluating to the : symbol, add an entry into a
new check-opts list. This is later traversed to add code
before the lambda body to check the optional parmeters for :
values and do the init-form processing. The test cases pass
with this, but it needs to be done in the case when optional
values come from the apply list also; this is not being
tested.
-rw-r--r-- | stdlib/compiler.tl | 24 |
1 files changed, 19 insertions, 5 deletions
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index b1b3681a..23c86ce8 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -2008,24 +2008,32 @@ (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr (let* ((pars (new (fun-param-parser lm-args lm-expr))) (fix-vals (mapcar (ret (gensym)) fix-arg-exprs)) + (fix-arg-iter fix-arg-exprs) + (check-opts) (ign-1 (gensym)) (ign-2 (gensym)) (al-val (gensym)) (shadow-p (let ((all-vars (append pars.req pars.(opt-syms) (if pars.rest (list pars.rest))))) - (or (isec all-vars fix-arg-exprs) + (or (isec all-vars fix-arg-iter) (member apply-list-expr all-vars))))) - ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) + ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-iter) (let* ,(build (if apply-list-expr (add ^(,al-val ,apply-list-expr))) (while (and fix-vals pars.req) - (add ^(,(pop pars.req) ,(pop fix-vals)))) + (add ^(,(pop pars.req) ,(pop fix-vals))) + (pop fix-arg-iter)) (while (and fix-vals pars.opt) (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (add ^(,var-sym ,(pop fix-vals))) + (add ^(,var-sym ,(car fix-vals))) (if have-sym - (add ^(,have-sym t))))) + (add ^(,have-sym t))) + (unless (and (constantp (car fix-arg-iter)) + (neq (eval (car fix-arg-iter)) :)) + (push (list* var-sym have-sym init-form) check-opts))) + (pop fix-vals) + (pop fix-arg-iter)) (cond ((and (null pars.req) (null pars.opt)) @@ -2079,6 +2087,12 @@ (add ^(,have-sym))))) (when pars.rest (add ^(,pars.rest)))))) + ,*(mapcar (tb ((var-sym have-sym . init-form)) + ^(when (eq ,var-sym :) + (set ,var-sym ,init-form) + ,*(if have-sym + ^((set ,have-sym nil))))) + (nreverse check-opts)) ,*lm-body)))))) (defun system-symbol-p (sym) |