diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-28 06:49:38 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-28 06:49:38 -0700 |
| commit | 37e839a7431520914a008c5df741e5267c16dcca (patch) | |
| tree | e18903fd1e181366a3312d69b3390b79f95c0171 | |
| parent | 817cd83e0165714cb482e4acc54409510a2d0417 (diff) | |
| download | txr-37e839a7431520914a008c5df741e5267c16dcca.tar.gz txr-37e839a7431520914a008c5df741e5267c16dcca.tar.bz2 txr-37e839a7431520914a008c5df741e5267c16dcca.zip | |
compiler: pass whole form to comp-fun-form.
* share/txr/stdlib/compiler.tl (compiler compile): Pass form
to comp-fun-form rather than sym and (cdr form).
(compile comp-fun-form): Take just a form argument.
Internally destructure to sym and args with tree-bind.
This will allow some special cases added in the future
to have access to the original form.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 39 |
1 files changed, 20 insertions, 19 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index a45d2c09..d2aa1268 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -222,7 +222,7 @@ (compile-error form "unexpanded quasiquote encountered")) (t (compile-error form "special op ~s not handled yet" sym)))) - ((bindable sym) me.(comp-fun-form oreg env sym (cdr form))) + ((bindable sym) me.(comp-fun-form oreg env form)) (t (compile-error form "invalid operator"))))))) (defmeth compiler comp-atom (me oreg form) @@ -748,24 +748,25 @@ (let ((qexp (expand-quasi form))) me.(compile oreg env (expand qexp)))) -(defmeth compiler comp-fun-form (me oreg env sym args) - (caseql sym - ((call apply usr:apply) - (let ((gopcode [%gcall-op% sym]) - (opcode [%call-op% sym])) - (tree-case (car args) - ((op arg) (if (and (eq op 'fun) (bindable arg)) - (let ((fbind env.(lookup-fun arg))) - me.(comp-call-impl oreg env (if fbind opcode gopcode) - (if fbind fbind.loc me.(get-fidx arg)) - (cdr args))) - :)) - (arg me.(comp-call oreg env - (if (eq sym 'usr:apply) 'apply sym) args))))) - (t (let ((fbind env.(lookup-fun sym))) - me.(comp-call-impl oreg env (if fbind 'call 'gcall) - (if fbind fbind.loc me.(get-fidx sym)) - args))))) +(defmeth compiler comp-fun-form (me oreg env form) + (tree-bind (sym . args) form + (caseql sym + ((call apply usr:apply) + (let ((gopcode [%gcall-op% sym]) + (opcode [%call-op% sym])) + (tree-case (car args) + ((op arg) (if (and (eq op 'fun) (bindable arg)) + (let ((fbind env.(lookup-fun arg))) + me.(comp-call-impl oreg env (if fbind opcode gopcode) + (if fbind fbind.loc me.(get-fidx arg)) + (cdr args))) + :)) + (arg me.(comp-call oreg env + (if (eq sym 'usr:apply) 'apply sym) args))))) + (t (let ((fbind env.(lookup-fun sym))) + me.(comp-call-impl oreg env (if fbind 'call 'gcall) + (if fbind fbind.loc me.(get-fidx sym)) + args)))))) (defmeth compiler comp-call (me oreg env opcode args) (tree-bind (fform . fargs) args |