Hi Jason,
Thank you for the writeup of Henry G. Baker (1992). The implementation of tagbody/go by catch/throw seems important to internalize. It will definitely help with testing the semantics of tagbody/go.
Unfortunately, as Philipp mentioned in a later email, support for tail-call optimization (TCO) is currently lacking according to [stackoverflow.com (2017)]. Worse, it was *removed* from Google's V8 JavaScript implementation in late 2017. This seems to necessitate a (loop (case ...)) based approach, because SERIES may be used for loops with iteration counts greater than the stack size. Nevertheless, not all is lost.
PARENSCRIPT already compiles (block nil ((lambda () (return 3)))) as catch/throw correctly. Note, the call in the body of the BLOCK. So at least some dynamic ((lambda () (go ...))) calls should be compilable; hopefully all of them. Even if it only captures 70% of all use cases, that is way more than zero.
Cheers, Andrew
Henry G. Baker (1992): TITLE: Metacircular Semantics for Common Lisp Special Forms URL: https://plover.com/~mjd/misc/hbaker-archive/MetaCircular.html
[stackoverflow.com (2017)], Answer by T.J. Crowder: TITLE: ES6 Tail Recursion Optimisation Stack Overflow, URL: https://stackoverflow.com/questions/42788139/es6-tail-recursion-optimisation...
On Thu, May 19, 2022 at 08:32:34PM -0700, Jason Miller wrote:
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 andrew@easton24.de 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:
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.
My understanding of the CL:TAGBODY definition in the CLHS [4] may be wrong. Which alternate interpretations does anybody here know of?
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#SECTION003400000...
b. https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node362.html#SECTION003500000...
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 |#