FWIW, I don't know if parenscript's catch/throw is sufficiently full featured for it, but here's an implementation of tagbody with throw/catch
https://plover.com/~mjd/misc/hbaker-archive/MetaCircular.html On Fri, 20 May 2022 10:13:03 +0930 Andrew Easton <[email protected]> wrote: > Hello everyone, > > It seems valuable to compile SERIES [1] macros with > PARENSCRIPT [2], however, parenscript does not currently > seem to support CL:TAGBODY [3,4]. Even poking around the > HyperSpec and discovering that CL:DO provides *not* an > implicit progn, but an implicit tagbody [5], does not > help. The (PARENSCRIPT:DO ...)-form only has an implicit > progn around the body [3]. > > I have started to implement TAGBODY for PARENSCRIPT > [A,B,C]. The general idea is to imitate a jump table > by looping over a switch-case. A GO (C-terminology: > jump) then sets the switch-variable to the next jump > destination. The loop subsequently causes the switch > to branch to the jump target in the switch-variable. > Leaving the tagbody means leaving the loop. > > There are complications. Common Lisp allows nested > tagbody-forms. Common Lisp allows go-tags to be > referenced within the lexical scope *and* the dynamic > extent of a tagbody form. This means that a LAMBDA > can close over a go-tag and jump there, see an > example in [B], of how inconvenient this can become > for compilation to JavaScript. > > PARENSCRIPT is well-designed. Its compilation of > BLOCKs, LOOPs and SWITCHes seems to permit > compilation of a TAGBODY to JavaScript code. > PARENSCRIPT even handles RETURNing from a BLOCK via a > LAMBDA by automatically creating a JavaScript try-catch. > This seems to curb the inconveniences brought on by > lexical closures jumping to go-tags in the TAGBODY's > dynamic extent. > > I need help in the following points: > > 1. I need a code review of the algorithm. > The implementation in [B] seems to be > satisfactory. There are some test cases and > examples. Most there is the most hairy example I > could find up to now. I may have missed crucial > details. > > 2. My understanding of the CL:TAGBODY definition in > the CLHS [4] may be wrong. Which alternate > interpretations does anybody here know of? > > 3. What examples of PARENSCRIPT:DEFPSMACRO do you > know, that might help me understand its semantics? > I would hazard a guess at DEFPSMACRO being a > facility to add TAGBODY to PARENSCRIPT, however, > my understanding of DEFPSMACRO is very bad and I > do not know where to start tinkering with it to > further my understanding. > > > Kind regards, > Andrew Easton > > > > === Attachments === > > [A] 2022-05-20_defmacro-series-expand.lisp > > [B] 2022-05-20_parenscript-devel_tagbody-code-short.lisp > > [C] 2022-05-20_parenscript-devel_tagbody-code-long.lisp > The long version contains some dead-ends that were > encountered during development. This is an important > source of counter-examples. > > > > > === References === > > [1] The SERIES macro package > a. > https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node347.html#SECTION003400000000000000000 > > b. > https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node362.html#SECTION003500000000000000000 > > c. https://dspace.mit.edu/handle/1721.1/6035 > > d. https://dspace.mit.edu/handle/1721.1/6031 > > e. (ql:quickload :series) > > f. https://sourceforge.net/projects/series/ > > [2] Parenscript > https://parenscript.common-lisp.dev/ > > [3] Parenscript Reference manual (updated 2019-10-15) > https://parenscript.common-lisp.dev/reference.html > > [4] Common Lisp HyperSpec (CLHS) entry for CL:TAGBODY > http://www.lispworks.com/documentation/HyperSpec/Body/s_tagbod.htm#tagbody > > [5] Common Lisp HyperSpec (CLHS) entry for CL:DO > http://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm#do > ;; The functions codify, mergify and > ;; graphify handle the actual compilation > ;; of series expressions. > ;; Excellent work, Mr. Waters and all your > ;; co-workers as well as the subsequent > ;; maintainers of package SERIES. > ;; > (defmacro series-expand (&body body) > `(let (series::*renames* > series::*env*) > (series::codify > (series::mergify > (series::graphify > (quote (progn ,@body))))))) > > ;; Look at series:process-top and > ;; series:starting-series-expr. > (ql:quickload '(:series > :parenscript > :trivial-macroexpand-all)) > > (series::install :shadow t) > > (import '(parenscript:ps > parenscript:ps* > trivial-macroexpand-all:macroexpand-all)) > > > ;; Explicitly circumvent package lock > ;; on package CL to allow shadowing > ;; by macrolet for series to paren- > ;; script translation. > (shadow '(tagbody go)) > > ;; Default to standard CL form. > (defmacro tagbody (&body body) > "See CL:tagbody." > `(cl:tagbody ,@body)) > > ;; Default to standard CL form. > (defmacro go (&body body) > "See CL:go." > `(cl:go ,@body)) > > > (load #p"2022-05-20_defmacro-series-expand.lisp") > > (parenscript:ps* > (series-expand > (collect (map-fn '(values T T) > #'floor #z(9 99 999) > #z(1 2 3))))) > > ;; Problem: Parenscript does *not* know > ;; how to compile TAGBODY. Suggestion: > ;; compile into (loop (case ...)) with > ;; a go-variable where the (case ...) > ;; selects between the jump targets. > ;; This should be easily made compatible > ;; with (series::producing ...) given > ;; the additional constraints for > ;; series::producing. > > (defun go-tag-p (obj) > (or (integerp obj) > (symbolp obj))) > > (defun first-go-tag (tagbody-body) > "Remember, that (cl:tagbody ...) is a > *special* form." > (flet ((rec (pos body-rest) > (cond > ((go-tag-p (first body-rest)) > (values pos (first body-rest))) > (t > (rec (1+ pos) (rest body-rest)))))) > (rec 0 tagbody-body))) > > (defmacro with-ps-from-series-tagbody (&body body) > (let ((outside-block (gensym (symbol-name 'outside-block-))) > (case-block (gensym (symbol-name 'case-block-))) > (case-tag-var (gensym (symbol-name 'case-tag-var-))) > go-tags) ; an alist > `(macrolet ((tagbody (&rest body) > (let* ((case-body > (reduce (lambda (acc body-entry) > (cond > ;; Case 1: A go-tag. > ((or (integerp body-entry) > (symbolp body-entry)) > (append acc > `(((,body-entry))))) > > ;; Case 2: Executable code. > (t > (append > (butlast acc) > (list > (append (car (last acc)) > (list body-entry))))))) > body > :initial-value `(case ,case-tag-var))) > ;; How are tagbody forms > ;; where the first tag is not > ;; the first element of the body > ;; to be detected and handled? > (first-tag) > ;; Terminate when walking > ;; past the end of the original > ;; tagbody form. > (case-body-with-terminator > (append > (butlast case-body) > (list (append (car (last case-body)) > '((return-from ,outside-block))))))) > `(block ,outside-block > (let ((,case-tag-var)) > (loop do > (block ,case-block > ,case-body-with-terminator)))))) > (go (tag) > `(progn > (setf ,case-tag-var ,tag) > (return-from ,case-block))))))) > > ;; (ps (case :foo (:foo 3))) > ;; (ps (case 'foo ('foo 3))) > ;; (ps (case 4 (4 :bar))) > > > > > > > > > > > > > > > > > > ;; =============================== > ;; 2022-02-18 > > > (defmacro with-tagbody-helpers (&body body) > `(labels > ((go-tag-p (obj) > (or (symbolp obj) (integerp obj))) > > (tb-go-tags (tb-body) > (remove-if-not #'go-tag-p tb-body)) > > (split-and-group-tb-body (tb-body) > "Returns two values. > 1. The preamble -- code without a preceding tag > 2. Grouping of tags and subsequent code." > > (if (null tb-body) > (return-from split-and-group-tb-body > (values nil nil))) > (let ((acc `((,(first tb-body)))) > (preamble-p (not (go-tag-p (first tb-body))))) > (loop for tbf in (rest tb-body) do > (if (go-tag-p tbf) > (push `(,tbf) acc) > (push tbf (first acc)))) > (setf acc (nreverse (mapcar #'nreverse acc))) > (if preamble-p > (values (first acc) (rest acc)) > (values nil acc)))) > ,@body))) > > (defmacro with-tagbody-parenscript-helpers (&body body) > `(with-tagbody-helpers > (labels > ((tb-body-to-switch (switch-var old-and-new-go-tags grouped-tb-body) > `(switch ,switch-var > ,@(mapcar (lambda (go-tag-case) > (destructuring-bind > (go-tag &rest case-body) > go-tag-case > `(case ,go-tag > ;; Handle nested tagbody > ;; forms correctly. > (tagbody-recursive (,old-and-new-go-tags) > ,@case-body)))) > grouped-tb-body))) > > (new-go-bindings (while-var switch-var break-p-var new-tb-go-tags) > (mapcar (lambda (go-tag) > `(,go-tag > (,while-var T) > (,switch-var ,go-tag) > (,break-p-var nil))) > new-tb-go-tags)) > > (add-breakout-to-old-go-bindings (while-var > break-p-var > old-go-bindings-alist) > (mapcar (lambda (gtb) > `(,@gtb (,while-var nil) (,break-p-var T))) > old-go-bindings-alist)) > > (update-go-bindings (while-var > switch-var > break-p-var > new-tb-go-tags > old-go-bindings-alist) > ;; Order matters. New bindings must shadow > ;; old bindings during alist lookups. > (append (new-go-bindings while-var > switch-var > break-p-var > new-tb-go-tags) > (add-breakout-to-old-go-bindings > while-var > break-p-var > old-go-bindings-alist)))) > ,@body))) > > (defmacro tagbody-recursive ((&optional outer-go-bindings) > &body body) > "Recursion information only by nested calls. Confer > recursion flag of #'CL:READ." > `(with-tagbody-parenscript-helpers > (let ((while-var (gensym (symbol-name 'while-var-))) > (switch-var (gensym (symbol-name 'switch-var-))) > (break-p-var (gensym (symbol-name 'break-p-var-)))) > (declare (ignorable break-p-var)) > (macrolet ((tagbody (&body tb-body) > (let* ((new-go-tags (tb-go-tags tb-body)) > (old-and-new-go-bindings > (update-go-bindings > while-var > switch-var > break-p-var > new-go-tags > ',outer-go-bindings))) > (multiple-value-bind > (preamble tb-groups) > (split-and-group-tb-body tb-body) > `(progn > ,@preamble > (do ((,while-var T)) > ((null ,while-var)) > (macrolet > ((go (go-tag) > `(progn > (setf > ,@(reduce > #'append > (cdr > (assoc > go-tag > ,',old-and-new-go-bindings)))) > (break) #|switch|#))) > ,@(tb-body-to-switch > switch-var > old-and-new-go-bindings > tb-groups))) > ;; Necessary for jump from inner > ;; tagbody to outer tagbody > ;; with trailing code > ;; behind the inner tagbody. > ;; This trailing code > ;; needs to be skipped. > ,@(if outer-go-bindings > ((if ,break-p-var (break)))))))) > ) > > )))) > > > > > #| > Hairy Example: > > (tagbody > (outer-prologue) > outer-a > (tagbody > (inner-prologue) > inner-a > (go inner-b) > inner-b > (go outer-a) > inner-c > ;; Note, that the following two jumps are valid, > ;; because they fall both within the lexical scope as > ;; well as the dynamic extent of the inner and the > ;; outer tagbody forms. > (if (foo) > (funcall (lambda () (go inner-d))) > (funcall (lambda () (go outer-a)))) > inner-d > (inner-epilogue)) > (inner-epilogue-outside-of-the-inner-tagbody) > outer-b > outer-c > (outer-epilogue)) > > > > ;; 2022-02-23: (lambda () (go ...)) > > > // Firefox 78.15.0esr (64-bit) > var go_tag = 'foo'; > var while_var = true; > while(while_var) {var cls = undefined; switch (go_tag) > { > case 'foo': cls = function () {break;}; case 'bar': > while_var = false; cls(); > }} > > // => Uncaught SyntaxError: unlabeled break must be inside loop or switch > > while(while_var) while_block: {var cls = undefined; > switch (go_tag) { > case 'foo': cls = function () {break while_block;}; > case 'bar': while_var = false; cls(); > }} > > // => Uncaught SyntaxError: label not found > > while_block: { while(while_var) {var cls = undefined; > switch (go_tag) { > case 'foo': cls = function () {break while_block;}; > case 'bar': while_var = false; cls(); > }}} > > // => Uncaught SyntaxError: label not found > > while_block: { while(while_var) {var cls = undefined; > switch (go_tag) { > case 'foo': break while_block; case 'bar': while_var > = false; cls(); > }}} > > // => undefined > > (ps > (block outer-block > (switch svar > (foo ((lambda () > (return-from outer-block 123))))))) > > ;; => > "(function () { > try { > switch (svar) { > case foo: > __PS_MV_REG = []; > return > (function () { > __PS_MV_REG = []; > > throw > { '__ps_block_tag' : 'outerBlock', > '__ps_value' : 123 }; > })(); > }; > } > catch (_ps_err2) > { if (_ps_err2 && 'outerBlock' === _ps_err2['__ps_block_tag']) > { return _ps_err2['__ps_value']; > } > else { > throw _ps_err2; > }; > }; > })();" > > > ;; So either I compile try-catch manually, or I fall > ;; back to using (block ... (while T (switch ...))) for now. > > ;; Use (def-ps-macro tagbody-rec ...) to define > ;; tagbody as a ps macro. Does this mean that the > ;; macro only exists in the scope of a (ps ...) form? > > ;; Use (block gs-outer (loop do (block gs-inner (switch ...)))) > ;; to handle (tagbody tag ((lambda () (go tag)))). The > ;; (go ...) form is insinde a lexical closure. > ;; Parenscript handles this nicely, when the closure > ;; adjusted to ((lambda () (setf gs-switch-var 'tag) > ;; (return-from gs-inner))). > > ;; Set up the switch-var correctly. It needs to be > ;; initialized with the first tag. The prologue > ;; should be handled separately anyway to keep the jump > ;; table of the resulting switch case small for the > ;; benefit of the CPUs branch predictor and instruction > ;; cache while looping over the switch-case. > ;; > ;; (let ((gs-switch-var first-tag)) (switch gs-switch-var ...)) > > > ;; 2022-02-24 > > ;; Parenscript example: > > (let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) > (inner-block-1 (gensym (symbol-name 'inner-block-1-))) > (switch-var-1 (gensym (symbol-name 'switch-var-1-))) > (outer-block-2 (gensym (symbol-name 'outer-block-2-))) > (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) > `(block ,outer-block-1 > (prologue-1) > (let ((,switch-var-1 tagbody-1-first-tag)) > (loop do > (block ,inner-block-1 > (switch ,switch-var-1 > (case tagbody-1-tag-1 > (foo) > (block ,outer-block-2 > (prologue-2) > (let ((,switch-var-2 tagbody-2-first-tag)) > (loop do > (block ,inner-block-2 > (switch ,switch-var-2 > (case tagbody-2-tag-1) > ;; inner jump: (go tagbody-2-tag-2) > (progn > (setf ,switch-var-2 'tagbody-2-tag-2) > (return-from ,inner-block-2)) > ;; outer jump: (go tagbody-1-tag-2) > (progn > (setf ,switch-var-1 'tagbody-1-tag-2) > (return-from ,inner-block-1)) > (case tagbody-2-tag-2) > ;; Walking off the end of tagbody-2 > (return-from ,outer-block-2)))))) > ;; Code to skip when jumping from the > ;; inner tagbody to a go tag in the > ;; outer tagbody. Nevertheless, it has > ;; to be run, when walking off the end of > ;; the inner tagbody. > (bar)) > (case tagbody-1-tag-2 > (baz) > ;; Walking off the end of tagbody-1 > (return-from ,outer-block-1)))))))) > > > > |# > > > ;; =============================== > ;; 2022-03-19 > > (defmacro with-tagbody-helpers (&body body) > `(labels > ((go-tag-p (obj) > (or (symbolp obj) (integerp obj))) > > (tb-go-tags (tb-body) > (remove-if-not #'go-tag-p tb-body)) > > (first-go-tag (tb-body) > ;; Find-if does *not* work cleanly. It fails > ;; to distinguish between a tag named nil > ;; and the absence of go tags. The latter > ;; is solely having a preamble in the > ;; tagbody form. > "Returns two values like CL:GETHASH. > 1. First tag. > 2. Whether a tag was found. Relevant in case > the first return value is NIL. > > Note, that NIL is a valid go-tag." > (block first-go-tag > (loop for form in tb-body > do (if (go-tag-p form) > (return-from first-go-tag > (values form t)))) > (return-from first-go-tag > (values nil nil)))) > > (split-and-group-tb-body (tb-body) > "Returns two values. > 1. The preamble -- code without a preceding tag > 2. Grouping of tags and subsequent code." > > (block split-and-group-tb-body > (if (null tb-body) > (return-from split-and-group-tb-body > (values nil nil))) > (let ((acc `((,(first tb-body)))) > (preamble-p (not (go-tag-p (first tb-body))))) > (loop for tbf in (rest tb-body) do > (if (go-tag-p tbf) > (push `(,tbf) acc) > (push tbf (first acc)))) > (setf acc (nreverse (mapcar #'nreverse acc))) > (if preamble-p > (values (first acc) (rest acc)) > (values nil acc)))))) > ,@body)) > > #| > ;; TESTS > (with-tagbody-helpers > (and (go-tag-p 'foo) > (go-tag-p 'bar) > (go-tag-p 3) > (go-tag-p -9) > > (not (go-tag-p 1.3)) > > (equal > (tb-go-tags > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > '(tag1 tag2)) > > (eq > (first-go-tag > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > 'tag1) > > (multiple-value-bind (preamble grouping) > (split-and-group-tb-body > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > (and > (equal preamble > '((preamble-1-1) > (preamble-1-2))) > (equal grouping > '((tag1 (foo)) > (tag2 (bar)))))))) > |# > > > > (defmacro with-tagbody-parenscript-helpers (&body body) > `(with-tagbody-helpers > (labels > ((new-go-bindings (switch-var block-var new-tb-go-tags) > (mapcar (lambda (go-tag) > ;; alist > `(,go-tag > (setf ,switch-var ',go-tag) > (return-from ,block-var))) > new-tb-go-tags)) > (grouping-to-case-forms (grouped-tb-body > old-and-new-go-bindings) > (mapcar (lambda (go-tag-case) > (destructuring-bind > (go-tag &rest case-body) > go-tag-case > `(case ,go-tag > ;; Handle nested tagbody > ;; forms correctly. > (tagbody-recursive (,old-and-new-go-bindings) > ,@case-body)))) > grouped-tb-body)) > > (tb-body-to-switch (outer-block-var > inner-block-var > preamble > grouped-tb-body > first-tag > switch-var > old-and-new-go-bindings) > `(block ,outer-block-var > ,@preamble > (let ((,switch-var ',first-tag)) > (loop do > (block ,inner-block-var > (macrolet ((go (go-tag) > `(progn > ,@(cdr (assoc > go-tag > ',old-and-new-go-bindings))))) > (switch ,switch-var > ,@(grouping-to-case-forms > grouped-tb-body > old-and-new-go-bindings))) > ;; Fall-through after end of tagbody form > (return-from ,outer-block-var))))))) > ,@body))) > > #| > ;; TESTS > (with-tagbody-parenscript-helpers > (and > (let ((switch-1-var '#:switch-1-var) > (inner-block-1-var '#:inner-block-1-var) > (outer-block-1-var '#:outer-block-1-var)) > > (equal > (new-go-bindings switch-1-var > inner-block-1-var > '(tb-1-tag1 tb-1-tag2)) > ;; alist > `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) > (return-from ,inner-block-1-var)) > (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) > (return-from ,inner-block-1-var)))) > > (equal > (grouping-to-case-forms > '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) > (tag2 (bar))) > `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) > (return-from ,inner-block-1-var)) > (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) > (return-from ,inner-block-1-var)))) > `((CASE TAG1 > (TAGBODY-RECURSIVE > (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) > (RETURN-FROM ,INNER-BLOCK-1-VAR)) > (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) > (RETURN-FROM ,inner-block-1-var)))) > (FOO) > (TAGBODY TB-2-TAG-1) > (HOGE))) > (CASE TAG2 > (TAGBODY-RECURSIVE > (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) > (RETURN-FROM ,INNER-BLOCK-1-VAR)) > (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) > (RETURN-FROM ,inner-block-1-var)))) > (BAR))))) > > > (equalp ; Needs #'cl:equalP instead of #'cl:equal. > (tb-body-to-switch > outer-block-1-var > inner-block-1-var > '((preamble-1-1) (preamble-1-2)) > '((tb-1-tag-1 (foo) > (tagbody tb-2-tag-1) > (tagbody tb-1-tag-1) ; Shadows outer tag! > (hoge)) > (tb-1-tag-2 (bar))) > 'tb-1-tag-1 > switch-1-var > `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) > (return-from ,inner-block-1-var)) > (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) > (return-from ,inner-block-1-var)))) > > `(BLOCK ,OUTER-BLOCK-1-VAR > (PREAMBLE-1-1) > (PREAMBLE-1-2) > (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) > (LOOP DO > (BLOCK ,INNER-BLOCK-1-VAR > (MACROLET > ((GO (GO-TAG) > `(PROGN > ,@(CDR > (ASSOC GO-TAG > '((TB-1-TAG-1 > (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 > (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM > ,inner-block-1-var)))))))) > (SWITCH ,switch-1-var > (CASE TB-1-TAG-1 > (TAGBODY-RECURSIVE > (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM ,inner-block-1-var)))) > (FOO) > (TAGBODY TB-2-TAG-1) > (TAGBODY TB-1-TAG-1) ; Shadows outer tag! > (HOGE))) > (CASE TB-1-TAG-2 > (TAGBODY-RECURSIVE > (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM ,inner-block-1-var)))) > (BAR))))) > (RETURN-FROM ,outer-block-1-var))))))))) > |# > > > > (defmacro tagbody-recursive ((&optional outer-go-bindings) > &body body) > "Recursion information OUTER-GO-BINDINGS only by > nested calls. Confer recursion flag of #'CL:READ." > `(with-tagbody-parenscript-helpers > (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) > (inner-block-var (gensym (symbol-name 'inner-block-var-))) > (switch-var (gensym (symbol-name 'switch-var-)))) > (macrolet ((tagbody (&body tb-body) > (let* ((new-go-tags (tb-go-tags tb-body)) > (first-go-tag (first-go-tag tb-body)) > (old-and-new-go-bindings > ;; alist > (append > (new-go-bindings switch-var > inner-block-var > new-go-tags) > outer-go-bindings))) > (multiple-value-bind > (preamble tb-groups) > (split-and-group-tb-body tb-body) > (tb-body-to-switch (outer-block-var > inner-block-var > preamble > tb-groups > first-go-tag > switch-var > old-and-new-go-bindings)))))) > ,@body)))) > > #| > ;; TESTS > |# > (ql:quickload '(:series > :parenscript > :trivial-macroexpand-all)) > > (series::install :shadow t) > > (import '(parenscript:ps > parenscript:ps* > trivial-macroexpand-all:macroexpand-all)) > > > ;; Explicitly circumvent package lock > ;; on package CL to allow shadowing > ;; by macrolet for series to paren- > ;; script translation. > (shadow '(tagbody go)) > > ;; Default to standard CL form. > (defmacro tagbody (&body body) > "See CL:tagbody." > `(cl:tagbody ,@body)) > > ;; Default to standard CL form. > (defmacro go (&body body) > "See CL:go." > `(cl:go ,@body)) > > > (load #p"2022-05-20_defmacro-series-expand.lisp") > > (parenscript:ps* > (series-expand > (collect (map-fn '(values T T) > #'floor #z(9 99 999) > #z(1 2 3))))) > > ;; Problem: Parenscript does *not* know > ;; how to compile TAGBODY. Suggestion: > ;; compile into (loop (case ...)) with > ;; a go-variable where the (case ...) > ;; selects between the jump targets. > ;; This should be easily made compatible > ;; with (series::producing ...) given > ;; the additional constraints for > ;; series::producing. > > > > ;; 2022-02-24 > > ;; Parenscript example: > > (let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) > (inner-block-1 (gensym (symbol-name 'inner-block-1-))) > (switch-var-1 (gensym (symbol-name 'switch-var-1-))) > (outer-block-2 (gensym (symbol-name 'outer-block-2-))) > (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) > `(block ,outer-block-1 > (prologue-1) > (let ((,switch-var-1 tagbody-1-first-tag)) > (loop do > (block ,inner-block-1 > (switch ,switch-var-1 > (case tagbody-1-tag-1 > (foo) > (block ,outer-block-2 > (prologue-2) > (let ((,switch-var-2 tagbody-2-first-tag)) > (loop do > (block ,inner-block-2 > (switch ,switch-var-2 > (case tagbody-2-tag-1) > ;; inner jump: (go tagbody-2-tag-2) > (progn > (setf ,switch-var-2 'tagbody-2-tag-2) > (return-from ,inner-block-2)) > ;; outer jump: (go tagbody-1-tag-2) > (progn > (setf ,switch-var-1 'tagbody-1-tag-2) > (return-from ,inner-block-1)) > (case tagbody-2-tag-2) > ;; Walking off the end of tagbody-2 > (return-from ,outer-block-2)))))) > ;; Code to skip when jumping from the > ;; inner tagbody to a go tag in the > ;; outer tagbody. Nevertheless, it has > ;; to be run, when walking off the end of > ;; the inner tagbody. > (bar)) > (case tagbody-1-tag-2 > (baz) > ;; Walking off the end of tagbody-1 > (return-from ,outer-block-1)))))))) > > > > |# > > > ;; =============================== > ;; 2022-03-19 > > (defmacro with-tagbody-helpers (&body body) > `(labels > ((go-tag-p (obj) > (or (symbolp obj) (integerp obj))) > > (tb-go-tags (tb-body) > (remove-if-not #'go-tag-p tb-body)) > > (first-go-tag (tb-body) > ;; Find-if does *not* work cleanly. It fails > ;; to distinguish between a tag named nil > ;; and the absence of go tags. The latter > ;; is solely having a preamble in the > ;; tagbody form. > "Returns two values like CL:GETHASH. > 1. First tag. > 2. Whether a tag was found. Relevant in case > the first return value is NIL. > > Note, that NIL is a valid go-tag." > (block first-go-tag > (loop for form in tb-body > do (if (go-tag-p form) > (return-from first-go-tag > (values form t)))) > (return-from first-go-tag > (values nil nil)))) > > (split-and-group-tb-body (tb-body) > "Returns two values. > 1. The preamble -- code without a preceding tag > 2. Grouping of tags and subsequent code." > > (block split-and-group-tb-body > (if (null tb-body) > (return-from split-and-group-tb-body > (values nil nil))) > (let ((acc `((,(first tb-body)))) > (preamble-p (not (go-tag-p (first tb-body))))) > (loop for tbf in (rest tb-body) do > (if (go-tag-p tbf) > (push `(,tbf) acc) > (push tbf (first acc)))) > (setf acc (nreverse (mapcar #'nreverse acc))) > (if preamble-p > (values (first acc) (rest acc)) > (values nil acc)))))) > ,@body)) > > #| > ;; TESTS > (with-tagbody-helpers > (and (go-tag-p 'foo) > (go-tag-p 'bar) > (go-tag-p 3) > (go-tag-p -9) > > (not (go-tag-p 1.3)) > > (equal > (tb-go-tags > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > '(tag1 tag2)) > > (eq > (first-go-tag > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > 'tag1) > > (multiple-value-bind (preamble grouping) > (split-and-group-tb-body > (rest '(tagbody > (preamble-1-1) > (preamble-1-2) > tag1 > (foo) > tag2 > (bar)))) > (and > (equal preamble > '((preamble-1-1) > (preamble-1-2))) > (equal grouping > '((tag1 (foo)) > (tag2 (bar)))))))) > |# > > > > (defmacro with-tagbody-parenscript-helpers (&body body) > `(with-tagbody-helpers > (labels > ((new-go-bindings (switch-var block-var new-tb-go-tags) > (mapcar (lambda (go-tag) > ;; alist > `(,go-tag > (setf ,switch-var ',go-tag) > (return-from ,block-var))) > new-tb-go-tags)) > (grouping-to-case-forms (grouped-tb-body > old-and-new-go-bindings) > (mapcar (lambda (go-tag-case) > (destructuring-bind > (go-tag &rest case-body) > go-tag-case > `(case ,go-tag > ;; Handle nested tagbody > ;; forms correctly. > (tagbody-recursive (,old-and-new-go-bindings) > ,@case-body)))) > grouped-tb-body)) > > (tb-body-to-switch (outer-block-var > inner-block-var > preamble > grouped-tb-body > first-tag > switch-var > old-and-new-go-bindings) > `(block ,outer-block-var > ,@preamble > (let ((,switch-var ',first-tag)) > (loop do > (block ,inner-block-var > (macrolet ((go (go-tag) > `(progn > ,@(cdr (assoc > go-tag > ',old-and-new-go-bindings))))) > (switch ,switch-var > ,@(grouping-to-case-forms > grouped-tb-body > old-and-new-go-bindings))) > ;; Fall-through after end of tagbody form > (return-from ,outer-block-var))))))) > ,@body))) > > #| > ;; TESTS > (with-tagbody-parenscript-helpers > (and > (let ((switch-1-var '#:switch-1-var) > (inner-block-1-var '#:inner-block-1-var) > (outer-block-1-var '#:outer-block-1-var)) > > (equal > (new-go-bindings switch-1-var > inner-block-1-var > '(tb-1-tag1 tb-1-tag2)) > ;; alist > `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) > (return-from ,inner-block-1-var)) > (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) > (return-from ,inner-block-1-var)))) > > (equal > (grouping-to-case-forms > '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) > (tag2 (bar))) > `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) > (return-from ,inner-block-1-var)) > (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) > (return-from ,inner-block-1-var)))) > `((CASE TAG1 > (TAGBODY-RECURSIVE > (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) > (RETURN-FROM ,INNER-BLOCK-1-VAR)) > (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) > (RETURN-FROM ,inner-block-1-var)))) > (FOO) > (TAGBODY TB-2-TAG-1) > (HOGE))) > (CASE TAG2 > (TAGBODY-RECURSIVE > (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) > (RETURN-FROM ,INNER-BLOCK-1-VAR)) > (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) > (RETURN-FROM ,inner-block-1-var)))) > (BAR))))) > > > (equalp ; Needs #'cl:equalP instead of #'cl:equal. > (tb-body-to-switch > outer-block-1-var > inner-block-1-var > '((preamble-1-1) (preamble-1-2)) > '((tb-1-tag-1 (foo) > (tagbody tb-2-tag-1) > (tagbody tb-1-tag-1) ; Shadows outer tag! > (hoge)) > (tb-1-tag-2 (bar))) > 'tb-1-tag-1 > switch-1-var > `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) > (return-from ,inner-block-1-var)) > (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) > (return-from ,inner-block-1-var)))) > > `(BLOCK ,OUTER-BLOCK-1-VAR > (PREAMBLE-1-1) > (PREAMBLE-1-2) > (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) > (LOOP DO > (BLOCK ,INNER-BLOCK-1-VAR > (MACROLET > ((GO (GO-TAG) > `(PROGN > ,@(CDR > (ASSOC GO-TAG > '((TB-1-TAG-1 > (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 > (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM > ,inner-block-1-var)))))))) > (SWITCH ,switch-1-var > (CASE TB-1-TAG-1 > (TAGBODY-RECURSIVE > (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM ,inner-block-1-var)))) > (FOO) > (TAGBODY TB-2-TAG-1) > (TAGBODY TB-1-TAG-1) ; Shadows outer tag! > (HOGE))) > (CASE TB-1-TAG-2 > (TAGBODY-RECURSIVE > (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) > (RETURN-FROM ,inner-block-1-var)) > (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) > (RETURN-FROM ,inner-block-1-var)))) > (BAR))))) > (RETURN-FROM ,outer-block-1-var))))))))) > |# > > > > (defmacro tagbody-recursive ((&optional outer-go-bindings) > &body body) > "Recursion information OUTER-GO-BINDINGS only by > nested calls. Confer recursion flag of #'CL:READ." > `(with-tagbody-parenscript-helpers > (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) > (inner-block-var (gensym (symbol-name 'inner-block-var-))) > (switch-var (gensym (symbol-name 'switch-var-)))) > (macrolet ((tagbody (&body tb-body) > (let* ((new-go-tags (tb-go-tags tb-body)) > (first-go-tag (first-go-tag tb-body)) > (old-and-new-go-bindings > ;; alist > (append > (new-go-bindings switch-var > inner-block-var > new-go-tags) > outer-go-bindings))) > (multiple-value-bind > (preamble tb-groups) > (split-and-group-tb-body tb-body) > (tb-body-to-switch (outer-block-var > inner-block-var > preamble > tb-groups > first-go-tag > switch-var > old-and-new-go-bindings)))))) > ,@body)))) > > #| > ;; TESTS > |#
