Adding CL:TAGBODY for SERIES support
Jason Miller
jason at milr.com
Fri May 20 03:32:34 UTC 2022
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 at 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:
>
> 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 , at 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 , at body))
>
> ;; Default to standard CL form.
> (defmacro go (&body body)
> "See CL:go."
> `(cl:go , at 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))))
> , at 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)
> , at 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)
> `(, at 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))))
> , at 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
> , at 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))))))
> , at 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)
> , at 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
> , at 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)))))))
> , at 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))))))
> , at 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 , at body))
>
> ;; Default to standard CL form.
> (defmacro go (&body body)
> "See CL:go."
> `(cl:go , at 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))))))
> , at 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)
> , at 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
> , at 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)))))))
> , at 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))))))
> , at body))))
>
> #|
> ;; TESTS
> |#
More information about the parenscript-devel
mailing list