From db1bf07b053a057b25cd4be683d6e2b017f9856f Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sat, 3 Jul 2021 12:02:30 -0700 Subject: 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. --- stdlib/compiler.tl | 24 +++++++++++++++++++----- 1 file 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) -- cgit v1.2.3