diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-06-29 21:52:46 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-06-29 21:52:46 -0700 |
| commit | 0de65a6edc3631ce50ad5f5082ff82a45be867d0 (patch) | |
| tree | be3c77edbd0f42d87f254f7c5e9433477d6336ea /stdlib | |
| parent | 05500916c74317905fb6f75088f50606a9b562af (diff) | |
| download | txr-0de65a6edc3631ce50ad5f5082ff82a45be867d0.tar.gz txr-0de65a6edc3631ce50ad5f5082ff82a45be867d0.tar.bz2 txr-0de65a6edc3631ce50ad5f5082ff82a45be867d0.zip | |
op: bug in do: must insert @1 into unexpanded form.
In the case when the do syntax has no metavariables, and it
expands as-is without the addition of symbol in the tail
position, we are doing something wrong: we are adding the
@1 into the expanded version of the form, rather than
the original. For instance:
1> (expand '(do pop a))
(lambda (#:arg-1-0017 . #:arg-rest-0016)
(prog1 (car a)
(sys:setq a (cdr a))
#:arg-1-0017))
Here, the @1 was inserted into the (prog1 ...) form
which is the expansion of pop. This is incorrect;
it must be inserted into the original (pop a)
syntax as (pop a @1).
* op.tl (op-expand): In this case when there are no
metas and no do-gen that can be replaced by @1 via
symacrolet, go back to the original args syntax,
add the arg1 meta into that syntax, and process it
from the beginning through parallel expansions
steps.
* tests/012/op.tl: Couple of tests added.
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/op.tl | 8 |
1 files changed, 6 insertions, 2 deletions
diff --git a/stdlib/op.tl b/stdlib/op.tl index 182055f0..06e87633 100644 --- a/stdlib/op.tl +++ b/stdlib/op.tl @@ -137,8 +137,12 @@ (let ((arg1 (sys:ensure-op-arg ctx 1))) ^(symacrolet ((,do-gen ,arg1)) ,syntax-2))) - (t (let ((arg1 (sys:ensure-op-arg ctx 1))) - (append syntax-2 (list arg1)))))) + (t (let* ((arg1 (sys:ensure-op-arg ctx 1)) + (syntax-0-alt (append args (list arg1))) + (syntax-1-alt (sys:op-alpha-rename f e + syntax-0-alt + nil))) + (sys:op-alpha-rename f e syntax-1-alt t))))) (t (append syntax-2 rest-sym)))))) (let ((metas (slot ctx 'gens))) (cond |