diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-23 22:17:08 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-23 22:17:08 -0700 |
| commit | 878c0dded993f02f19d4a46c365b5bd12e3d9030 (patch) | |
| tree | bf389f552f85dc6f1247f47ea80df9518f0a57ad | |
| parent | 4eb3be4a62a87e92d3ad674825611b340c1c38e5 (diff) | |
| download | txr-878c0dded993f02f19d4a46c365b5bd12e3d9030.tar.gz txr-878c0dded993f02f19d4a46c365b5bd12e3d9030.tar.bz2 txr-878c0dded993f02f19d4a46c365b5bd12e3d9030.zip | |
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.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 20 |
1 files changed, 12 insertions, 8 deletions
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 |