Adding CL:TAGBODY for SERIES support
Andrew Easton
andrew at easton24.de
Fri May 20 00:43:03 UTC 2022
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
-------------- next part --------------
;; 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.
-------------- next part --------------
(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
|#
-------------- next part --------------
(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