summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-07-03 12:02:30 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-07-03 12:02:30 -0700
commitdb1bf07b053a057b25cd4be683d6e2b017f9856f (patch)
tree61c881681bcd079ba07946b29d136e5cc530c06b
parent166a76bc0a18f9b5294953264f98e887ce153320 (diff)
downloadtxr-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.tl24
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)