From 878c0dded993f02f19d4a46c365b5bd12e3d9030 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 23 Mar 2018 22:17:08 -0700 Subject: compiler: hoist quoting out of bind expander. * share/txr/stdlib/compiler.tl (expand-bind-mac-params): Take the context form and error forms as separate arguments instead of calculating one from the other. Moreover, they are no longer assumed to be objects to be quoted and inserted but rather expressions to be substituted into the code directly. This gives the caller flexibility to make them calculated. (compiler comp-tree-bind, compiler comp-tree-case): Make the compensating adjustments to preserve the behavior. --- share/txr/stdlib/compiler.tl | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) (limited to 'share') diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 5f997d0d..00e758ea 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -629,7 +629,10 @@ (tree-bind (op params obj . body) form (with-gensyms (obj-var) (let ((expn (expand ^(let ((,obj-var ,obj)) - ,(expand-bind-mac-params form params nil + ,(expand-bind-mac-params ^',form + ^',(rlcp ^(,(car form)) + form) + params nil obj-var t nil body))))) me.(compile oreg env expn))))) @@ -641,6 +644,8 @@ (obj-var (cdar nenv.(extend-var (gensym)))) (err-blk (cdar nenv.(extend-var (gensym)))) (lout (gensym "l")) + (ctx-form ^',form) + (err-form ^',(rlcp ^(,(car form)) form)) (objfrag me.(compile oreg env obj)) (cfrags (collect-each ((c cases) (i (range 1))) @@ -649,8 +654,8 @@ (set ,obj-var.sym ,obj-immut-var.sym) ,(expand-bind-mac-params - form params - nil obj-var.sym : + ctx-form err-form + params nil obj-var.sym : err-blk.sym body)))) (lerrtest (gensym "l")) @@ -806,12 +811,11 @@ (let ((opt-pars (mapcar [iffi atom list] raw-opt-pars))) (list (nreverse key-pars) req-pars opt-pars rest-par))))) -(defun expand-bind-mac-params (ctx-form params menv-var +(defun expand-bind-mac-params (ctx-form err-form params menv-var obj-var strict err-block body) - (let (vars gen-stk (plen (gensym)) - (err-form (rlcp ^(,(car ctx-form)) ctx-form))) + (let (vars gen-stk (plen (gensym))) (macrolet ((berr (too-few-p) - ^^(sys:bind-mac-error ',err-form ',params + ^^(sys:bind-mac-error ,err-form ',params ,obj-var ,',too-few-p))) (labels ((get-gen () (or (pop gen-stk) (gensym))) @@ -844,7 +848,7 @@ (push sym vars) (caseq key (:whole ^((set ,sym ,obj-var))) - (:form ^((set ,sym ',ctx-form))) + (:form ^((set ,sym ,ctx-form))) (:env ^((set ,sym ,menv-var)))))) ,*(append-each ((p req-pars)) (cond -- cgit v1.2.3