From ed2a61da442ac22f8433c06634f749fbda4b1972 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 19 Jul 2021 06:17:49 -0700 Subject: op: fix bug in do. The June 30 09e70c914ca83b5c7405aa633864db49f27efa05, subject "op: refactor do handling", introduced a regression breaking the tags.tl program. An implicit argument gets inserted twice: [[(do op list @1)] 'x] -> (x x) ;; incorrect/weird This was spotted by Paul A. Patience while working on extending tags.tl for Emacs. It's not exactly a regression because the original behavior is not documented or tested, and has issues; we simply cannot roll back the commit; a proper fix is required. How the above call is now supposed to work is that: - the @1 parameter belongs to the op, not to the do. - the do therefore has no explicitly given parameters of its own. - therefore the do inserts its parameter. In other words (do op list @1) is formally equivalent to (do op list @1 @@1). Both levels of function indirection require an argument: [[(do op list @1) 'x] 'y] -> (y x) [[(do op list @1 @@1) 'x] 'y] -> (y x) * stdlib/op.tl (sys:op-ctx): The structure gets a new slot, nested, which is a flag indicating whether unprocessed nested metas occur. This is critically needed because the sys:op-alpha-rename passes which are called with do-nested-metas being false do not insert nested metas into the gens list; they transform them and leave them in the syntax. Yet we must make decisions based on their presence. Conretely, we must be able to tell that (do op list @@1) has a meta against the outer (do ...), while we are just processing the do. (sys:op-alpha-rename): When replacing a nested meta syntax with the macro invocation, we set the nested flag of the parent context true. (sys:op-expand): Bring back the do-gen; we need it. We cannot simply insert @1 into the syntax, because that is not lexically transparent. If we add @1 to (do op ...) then that @1 is interpreted as belonging to the op, not to the do. We must also check the new Boolean flag nested to properly detect whether we have metas, including unexpanded nested metas. * tests/012/op.tl: New test cases combining (do op ...). --- stdlib/op.tl | 65 +++++++++++++++++++++++++++++---------------------------- tests/012/op.tl | 8 +++++++ 2 files changed, 41 insertions(+), 32 deletions(-) diff --git a/stdlib/op.tl b/stdlib/op.tl index 751c56e5..7dffa6ee 100644 --- a/stdlib/op.tl +++ b/stdlib/op.tl @@ -27,7 +27,7 @@ (defvar sys:*op-ctx*) (sys:make-struct-type - 'sys:op-ctx nil nil '(form gens up meta rec recvar) nil + 'sys:op-ctx nil nil '(form gens up meta rec recvar nested) nil (lambda (me) (slotset me 'up sys:*op-ctx*) (slotset me 'meta (gensym "meta-"))) @@ -72,7 +72,9 @@ (or (sys:op-meta-p arg) (sys:op-rec-p arg) (equal arg '(sys:var usr:rec)))) - ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))) + (let ((up (slot ctx 'up))) + (slotset up 'nested t) + ^(,(slot up 'meta) (quote ,arg)))) ((sys:op-rec-p f) ^(,(sys:op-ensure-rec ctx) ,*(rest arg))) (t f)))) @@ -101,50 +103,45 @@ (ctx (make-struct 'sys:op-ctx ^(form ,f))) (sys:*op-ctx* ctx) (sym (car f)) + (do-gen (if (eq sym 'do) (gensym))) (syntax-0 (if (eq sym 'do) args ^[,*args])) (syntax-1 (if (or (null syntax-0) (neq sym 'do) compat) - ;; not do, or empty do syntax, or compat mode. + ;; Not do, or empty do syntax, or compat mode. (sys:op-alpha-rename f e syntax-0 nil) - ;; try to expand args as-is, catching errors + ;; Try to expand args as-is, catching errors. (let ((syn (op-ignerr (sys:op-alpha-rename f e syntax-0 nil)))) (if syn - ;; args expanded - (if (slot ctx 'gens) - ;; there are metas: okay, use expansion as-is. + ;; Args expanded. + (if (or (slot ctx 'gens) (slot ctx 'nested)) + ;; There are metas: okay, use expansion as-is. syn - ;; no metas: add @1 at the end and expand + ;; No metas: add do-gen at the end and expand ;; again, without catching errors. (sys:op-alpha-rename f e (append syntax-0 - '(@1)) + (list do-gen)) nil)) - ;; args didn't expand, thus need the extra - ;; element. But we can't add a @1 because by - ;; doing so we could be introducing metas. - ;; We add a gensym instead to try to satisfy - ;; the syntax without adding metas. If all works, - ;; we can use a symacrolet pass to replace - ;; that gensym with @1. + ;; Args didn't expand, so let's try it with + ;; do-gen added. (let ((syn (sys:op-alpha-rename f e (append syntax-0 - (list (gensym))) + (list do-gen)) nil))) - ;; It didn't blow up with the gensym. But - ;; if there are metas, we don't want to be - ;; be adding this gensym. We know that the - ;; form does not expand without the gensym. - ;; So we repeat that expansion, but this time - ;; without op-ignerr. This will flush out - ;; the error. - (when (slot ctx 'gens) - (sys:op-alpha-rename f e syntax-0 nil)) - ;; There were no metas. OK, let's augment - ;; syntax-0 with @1 instead of the gensym. - (sys:op-alpha-rename f e - (append syntax-0 '(@1)) - nil)))))) + ;; It didn't blow up with the do-gen. However, if + ;; there are metas, we must not be adding this + ;; gensym. Thus, this case is erroneous: it doesn't + ;; expand unless we add an element, which we must not. + ;; Thus we just expand it again without the do-gen, + ;; without op-ignerr, to let the error propagate. + (when (or (slot ctx 'gens) (slot ctx 'nested)) + (sys:op-alpha-rename f e syntax-0 nil) + ;; Just in case: we don't expect to reach this: + ['compile-error f "internal error"]) + ;; There were no metas. Let's return the + ;; form augmented with do-gen. + syn))))) (syntax-2 (sys:op-alpha-rename f e syntax-1 t)) (metas (slot ctx 'gens)) (rec (slot ctx 'rec)) @@ -160,7 +157,11 @@ ;; no cadr here to avoid circular autoload ^[sys:apply ,(car (cdr syntax-2)) (append ,rest-sym (list ,*fargs-l1))])) - ((or metas (eq sym 'do)) syntax-2) + (metas syntax-2) + ((eq sym 'do) + (let ((arg1 (sys:ensure-op-arg ctx 1))) + ^(symacrolet ((,do-gen ,arg1)) + ,syntax-2))) (t (append syntax-2 rest-sym)))))) (let ((metas (slot ctx 'gens))) (cond diff --git a/tests/012/op.tl b/tests/012/op.tl index 12969dcc..0cdc3e7b 100644 --- a/tests/012/op.tl +++ b/tests/012/op.tl @@ -74,3 +74,11 @@ (mtest (flow 1 (+ 2) [dup *] (let ((x @1)) x)) 9 (flow #S(time year 2021) .year succ) 2022) + +(mtest + [[(do op list)] 2] :error + [[(do op list) 2]] (2) + [[(do op list @@1) 1] 2] (1 2) + [[(do op list @1)] 2] :error + [[(do op list @1) 1] 2] (2 1) + [[(do op list @@1 @1) 1] 2] (1 2)) -- cgit v1.2.3