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.

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)