diff options
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 140 |
1 files changed, 75 insertions, 65 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index ba7ffb68..5d7a9daa 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1070,7 +1070,8 @@ apply-list-arg (car (last args)))) me.(compile oreg env (expand (lambda-apply-transform lambda reg-args - apply-list-arg))))) + apply-list-arg + nil))))) (defmeth compiler comp-for (me oreg env form) (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form @@ -1497,70 +1498,79 @@ (mac-param-bind form (op name def) form ^(sys:rt-defsymacro ',name ',def))) -(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr) - (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)) - (ign-sym (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) - (member apply-list-expr all-vars))))) - ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) - (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)))) - (while (and fix-vals pars.opt) - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (add ^(,var-sym ,(pop fix-vals))) - (if have-sym - (add ^(,have-sym t))))) - (cond - ((and (null pars.req) - (null pars.opt)) - (if fix-vals - (if pars.rest - (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr))) - (lambda-too-many-args lm-expr)) - (when (or pars.rest apply-list-expr) - (add ^(,(or pars.rest ign-sym) ,apply-list-expr))))) - ((and fix-vals apply-list-expr) - (lambda-too-many-args lm-expr)) - (apply-list-expr - (when pars.req - (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) - (lambda-short-apply-list))))) - (while pars.req - (add ^(,(pop pars.req) (pop ,al-val)))) - (while pars.opt - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (cond - (have-sym - (add ^(,var-sym (if ,al-val - (car ,al-val) - ,init-form))) - (add ^(,have-sym (when ,al-val - (pop ,al-val) - t)))) - (t (add ^(,var-sym (if ,al-val - (pop ,al-val) - ,init-form))))))) - (when pars.rest - (add ^(,pars.rest ,al-val)))) - (pars.req - (lambda-too-few-args lm-expr)) - (pars.opt - (while pars.opt - (tree-bind (var-sym : init-form have-sym) (pop pars.opt) - (add ^(,var-sym ,init-form)) - (if have-sym - (add ^(,have-sym))))) - (when pars.rest - (add ^(,pars.rest)))))) - ,*lm-body))))) +(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed) + (if (and (not recursed) + apply-list-expr + (constantp apply-list-expr)) + (let* ((apply-list-val (eval apply-list-expr)) + (apply-atom (nthlast 0 apply-list-val)) + (apply-fixed (butlastn 0 apply-list-val))) + (lambda-apply-transform lm-expr (append fix-arg-exprs + (mapcar (ret ^',@1) apply-fixed)) + ^',apply-atom t)) + (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)) + (ign-sym (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) + (member apply-list-expr all-vars))))) + ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) + (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)))) + (while (and fix-vals pars.opt) + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,(pop fix-vals))) + (if have-sym + (add ^(,have-sym t))))) + (cond + ((and (null pars.req) + (null pars.opt)) + (if fix-vals + (if pars.rest + (add ^(,pars.rest (list* ,*fix-arg-exprs ,apply-list-expr))) + (lambda-too-many-args lm-expr)) + (when (or pars.rest apply-list-expr) + (add ^(,(or pars.rest ign-sym) ,apply-list-expr))))) + ((and fix-vals apply-list-expr) + (lambda-too-many-args lm-expr)) + (apply-list-expr + (when pars.req + (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) + (lambda-short-apply-list))))) + (while pars.req + (add ^(,(pop pars.req) (pop ,al-val)))) + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (cond + (have-sym + (add ^(,var-sym (if ,al-val + (car ,al-val) + ,init-form))) + (add ^(,have-sym (when ,al-val + (pop ,al-val) + t)))) + (t (add ^(,var-sym (if ,al-val + (pop ,al-val) + ,init-form))))))) + (when pars.rest + (add ^(,pars.rest ,al-val)))) + (pars.req + (lambda-too-few-args lm-expr)) + (pars.opt + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,init-form)) + (if have-sym + (add ^(,have-sym))))) + (when pars.rest + (add ^(,pars.rest)))))) + ,*lm-body)))))) (defun system-symbol-p (sym) (member (symbol-package sym) |