Adding CL:TAGBODY for SERIES support
Andrew Easton
andrew at easton24.de
Mon May 30 02:08:48 UTC 2022
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-stack-overflow
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 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