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 | |
| 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.
| -rw-r--r-- | stdlib/op.tl | 30 | ||||
| -rw-r--r-- | tests/012/op.tl | 11 |
2 files changed, 31 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)))) diff --git a/tests/012/op.tl b/tests/012/op.tl index 0cdc3e7b..5a789219 100644 --- a/tests/012/op.tl +++ b/tests/012/op.tl @@ -82,3 +82,14 @@ [[(do op list @1)] 2] :error [[(do op list @1) 1] 2] (2 1) [[(do op list @@1 @1) 1] 2] (1 2)) + +(mtest + [[[[(do do do op list @1) 1] 2] 3] 4] (4 1 2 3) + [[[[(do do do op list @@1) 1] 2] 3] 4] (3 1 2 4) + [[[[(do do do op list @@@1) 1] 2] 3] 4] (2 1 3 4) + [[[[(do do do op list @@@@1) 1] 2] 3] 4] (1 2 3 4)) + +(mtest + [[[[(do do do op list) 1] 2] 3] 4] (1 2 3 4) + [[[[(do do do op list @1 @@1 @@@1 @@@@1) 1] 2] 3] 4] (4 3 2 1) + [[[[(do do do op list @@@@1 @@@1 @@1 @1) 1] 2] 3] 4] (1 2 3 4)) |