diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-07-19 07:26:56 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-07-19 07:26:56 -0700 |
| commit | ed7185e3fd6307d9c4bc97be606a08bd9ed3502f (patch) | |
| tree | 297c49b83b401c7415288d1adf16a17360203d56 /stdlib | |
| parent | 39b94456cc8e70407641335184fbd8d46c2eadba (diff) | |
| download | txr-ed7185e3fd6307d9c4bc97be606a08bd9ed3502f.tar.gz txr-ed7185e3fd6307d9c4bc97be606a08bd9ed3502f.tar.bz2 txr-ed7185e3fd6307d9c4bc97be606a08bd9ed3502f.zip | |
op: set nested flag in correct context.
* stdlib/op.tl (sys:op-meta-p): Return an extended Boolean value: a true
result is an integer indicating the depth of the variable.
For instance @1 is depth 0, @@1 is depth 1 and so on.
(sys:find-parent): New function.
(sys:op-alpha-rename): When processing a nested meta, do not
set the nested flag in the immediate parent. Use find-parent to go up to
the correct level to which the meta belongs and set the flag there.
* tests/012/op.tl: New test cases which depend on this.
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/op.tl | 30 |
1 files changed, 20 insertions, 10 deletions
diff --git a/stdlib/op.tl b/stdlib/op.tl index 305a82fa..f4825515 100644 --- a/stdlib/op.tl +++ b/stdlib/op.tl @@ -50,9 +50,11 @@ (tree-case exp ((x y . r) (and (null r) (cond - ((eq x 'sys:expr) (sys:op-meta-p y)) - ((eq x 'sys:var) (or (integerp y) - (eq y 'rest)))))))) + ((eq x 'sys:expr) (let ((depth (sys:op-meta-p y))) + (if depth (succ depth)))) + ((eq x 'sys:var) (if (or (integerp y) + (eq y 'rest)) + 0))))))) (defun sys:op-rec-p (exp) (or (tree-case exp @@ -64,17 +66,25 @@ (slotset ctx 'recvar t)) (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-")))) +(defun sys:find-parent (ctx depth) + (for ((more t)) (more ctx) ((if (minusp (sys:setq depth (pred depth))) + (sys:setq more nil))) + (sys:setq ctx (slot ctx 'up)))) + (defun sys:op-alpha-rename (f e op-args do-nested-metas) (let* ((ctx sys:*op-ctx*) (code ^(macrolet ((sys:expr (:form f arg) - (let ((ctx ,ctx)) + (let* ((ctx ,ctx) + (depth (sys:op-meta-p arg)) + (rec (sys:op-rec-p arg)) + (up (slot ctx 'up)) + (par (cond + (depth (sys:find-parent ctx depth)) + (rec up)))) (cond - ((and (slot ctx 'up) - (or (sys:op-meta-p arg) - (sys:op-rec-p arg))) - (let ((up (slot ctx 'up))) - (slotset up 'nested t) - ^(,(slot up 'meta) (quote ,arg)))) + ((and par (or depth rec)) + (slotset par 'nested t) + ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))) ((sys:op-rec-p f) ^(,(sys:op-ensure-rec ctx) ,*(rest arg))) (t f)))) |