FWIW, I don't know if parenscript's catch/throw is sufficiently full featured for it, but here's an implementation of tagbody with throw/catch https://plover.com/~mjd/misc/hbaker-archive/MetaCircular.html On Fri, 20 May 2022 10:13:03 +0930 Andrew Easton <andrew@easton24.de> wrote:

Hello everyone,

It seems valuable to compile SERIES [1] macros with PARENSCRIPT [2], however, parenscript does not currently seem to support CL:TAGBODY [3,4]. Even poking around the HyperSpec and discovering that CL:DO provides *not* an implicit progn, but an implicit tagbody [5], does not help. The (PARENSCRIPT:DO ...)-form only has an implicit progn around the body [3].

I have started to implement TAGBODY for PARENSCRIPT [A,B,C]. The general idea is to imitate a jump table by looping over a switch-case. A GO (C-terminology: jump) then sets the switch-variable to the next jump destination. The loop subsequently causes the switch to branch to the jump target in the switch-variable. Leaving the tagbody means leaving the loop.

There are complications. Common Lisp allows nested tagbody-forms. Common Lisp allows go-tags to be referenced within the lexical scope *and* the dynamic extent of a tagbody form. This means that a LAMBDA can close over a go-tag and jump there, see an example in [B], of how inconvenient this can become for compilation to JavaScript.

PARENSCRIPT is well-designed. Its compilation of BLOCKs, LOOPs and SWITCHes seems to permit compilation of a TAGBODY to JavaScript code. PARENSCRIPT even handles RETURNing from a BLOCK via a LAMBDA by automatically creating a JavaScript try-catch. This seems to curb the inconveniences brought on by lexical closures jumping to go-tags in the TAGBODY's dynamic extent.

I need help in the following points:

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#SECTION003400000...

b. https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node362.html#SECTION003500000...

c. https://dspace.mit.edu/handle/1721.1/6035

d. https://dspace.mit.edu/handle/1721.1/6031

e. (ql:quickload :series)

f. https://sourceforge.net/projects/series/

[2] Parenscript https://parenscript.common-lisp.dev/

[3] Parenscript Reference manual (updated 2019-10-15) https://parenscript.common-lisp.dev/reference.html

[4] Common Lisp HyperSpec (CLHS) entry for CL:TAGBODY http://www.lispworks.com/documentation/HyperSpec/Body/s_tagbod.htm#tagbody

[5] Common Lisp HyperSpec (CLHS) entry for CL:DO http://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm#do ;; The functions codify, mergify and ;; graphify handle the actual compilation ;; of series expressions. ;; Excellent work, Mr. Waters and all your ;; co-workers as well as the subsequent ;; maintainers of package SERIES. ;; (defmacro series-expand (&body body) `(let (series::*renames* series::*env*) (series::codify (series::mergify (series::graphify (quote (progn ,@body)))))))

;; Look at series:process-top and ;; series:starting-series-expr. (ql:quickload '(:series :parenscript :trivial-macroexpand-all))

(series::install :shadow t)

(import '(parenscript:ps parenscript:ps* trivial-macroexpand-all:macroexpand-all))

;; Explicitly circumvent package lock ;; on package CL to allow shadowing ;; by macrolet for series to paren- ;; script translation. (shadow '(tagbody go))

;; Default to standard CL form. (defmacro tagbody (&body body) "See CL:tagbody." `(cl:tagbody ,@body))

;; Default to standard CL form. (defmacro go (&body body) "See CL:go." `(cl:go ,@body))

(load #p"2022-05-20_defmacro-series-expand.lisp")

(parenscript:ps* (series-expand (collect (map-fn '(values T T) #'floor #z(9 99 999) #z(1 2 3)))))

;; Problem: Parenscript does *not* know ;; how to compile TAGBODY. Suggestion: ;; compile into (loop (case ...)) with ;; a go-variable where the (case ...) ;; selects between the jump targets. ;; This should be easily made compatible ;; with (series::producing ...) given ;; the additional constraints for ;; series::producing.

(defun go-tag-p (obj) (or (integerp obj) (symbolp obj)))

(defun first-go-tag (tagbody-body) "Remember, that (cl:tagbody ...) is a *special* form." (flet ((rec (pos body-rest) (cond ((go-tag-p (first body-rest)) (values pos (first body-rest))) (t (rec (1+ pos) (rest body-rest)))))) (rec 0 tagbody-body)))

(defmacro with-ps-from-series-tagbody (&body body) (let ((outside-block (gensym (symbol-name 'outside-block-))) (case-block (gensym (symbol-name 'case-block-))) (case-tag-var (gensym (symbol-name 'case-tag-var-))) go-tags) ; an alist `(macrolet ((tagbody (&rest body) (let* ((case-body (reduce (lambda (acc body-entry) (cond ;; Case 1: A go-tag. ((or (integerp body-entry) (symbolp body-entry)) (append acc `(((,body-entry)))))

;; Case 2: Executable code. (t (append (butlast acc) (list (append (car (last acc)) (list body-entry))))))) body :initial-value `(case ,case-tag-var))) ;; How are tagbody forms ;; where the first tag is not ;; the first element of the body ;; to be detected and handled? (first-tag) ;; Terminate when walking ;; past the end of the original ;; tagbody form. (case-body-with-terminator (append (butlast case-body) (list (append (car (last case-body)) '((return-from ,outside-block))))))) `(block ,outside-block (let ((,case-tag-var)) (loop do (block ,case-block ,case-body-with-terminator)))))) (go (tag) `(progn (setf ,case-tag-var ,tag) (return-from ,case-block)))))))

;; (ps (case :foo (:foo 3))) ;; (ps (case 'foo ('foo 3))) ;; (ps (case 4 (4 :bar)))

;; =============================== ;; 2022-02-18

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))) ,@body)))

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((tb-body-to-switch (switch-var old-and-new-go-tags grouped-tb-body) `(switch ,switch-var ,@(mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-tags) ,@case-body)))) grouped-tb-body)))

(new-go-bindings (while-var switch-var break-p-var new-tb-go-tags) (mapcar (lambda (go-tag) `(,go-tag (,while-var T) (,switch-var ,go-tag) (,break-p-var nil))) new-tb-go-tags))

(add-breakout-to-old-go-bindings (while-var break-p-var old-go-bindings-alist) (mapcar (lambda (gtb) `(,@gtb (,while-var nil) (,break-p-var T))) old-go-bindings-alist))

(update-go-bindings (while-var switch-var break-p-var new-tb-go-tags old-go-bindings-alist) ;; Order matters. New bindings must shadow ;; old bindings during alist lookups. (append (new-go-bindings while-var switch-var break-p-var new-tb-go-tags) (add-breakout-to-old-go-bindings while-var break-p-var old-go-bindings-alist)))) ,@body)))

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((while-var (gensym (symbol-name 'while-var-))) (switch-var (gensym (symbol-name 'switch-var-))) (break-p-var (gensym (symbol-name 'break-p-var-)))) (declare (ignorable break-p-var)) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (old-and-new-go-bindings (update-go-bindings while-var switch-var break-p-var new-go-tags ',outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) `(progn ,@preamble (do ((,while-var T)) ((null ,while-var)) (macrolet ((go (go-tag) `(progn (setf ,@(reduce #'append (cdr (assoc go-tag ,',old-and-new-go-bindings)))) (break) #|switch|#))) ,@(tb-body-to-switch switch-var old-and-new-go-bindings tb-groups))) ;; Necessary for jump from inner ;; tagbody to outer tagbody ;; with trailing code ;; behind the inner tagbody. ;; This trailing code ;; needs to be skipped. ,@(if outer-go-bindings ((if ,break-p-var (break)))))))) )

))))

#| Hairy Example:

(tagbody (outer-prologue) outer-a (tagbody (inner-prologue) inner-a (go inner-b) inner-b (go outer-a) inner-c ;; Note, that the following two jumps are valid, ;; because they fall both within the lexical scope as ;; well as the dynamic extent of the inner and the ;; outer tagbody forms. (if (foo) (funcall (lambda () (go inner-d))) (funcall (lambda () (go outer-a)))) inner-d (inner-epilogue)) (inner-epilogue-outside-of-the-inner-tagbody) outer-b outer-c (outer-epilogue))

;; 2022-02-23: (lambda () (go ...))

// Firefox 78.15.0esr (64-bit) var go_tag = 'foo'; var while_var = true; while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break;}; case 'bar': while_var = false; cls(); }}

// => Uncaught SyntaxError: unlabeled break must be inside loop or switch

while(while_var) while_block: {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break while_block;}; case 'bar': while_var = false; cls(); }}

// => Uncaught SyntaxError: label not found

while_block: { while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break while_block;}; case 'bar': while_var = false; cls(); }}}

// => Uncaught SyntaxError: label not found

while_block: { while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': break while_block; case 'bar': while_var = false; cls(); }}}

// => undefined

(ps (block outer-block (switch svar (foo ((lambda () (return-from outer-block 123)))))))

;; => "(function () { try { switch (svar) { case foo: __PS_MV_REG = []; return (function () { __PS_MV_REG = [];

throw { '__ps_block_tag' : 'outerBlock', '__ps_value' : 123 }; })(); }; } catch (_ps_err2) { if (_ps_err2 && 'outerBlock' === _ps_err2['__ps_block_tag']) { return _ps_err2['__ps_value']; } else { throw _ps_err2; }; }; })();"

;; So either I compile try-catch manually, or I fall ;; back to using (block ... (while T (switch ...))) for now.

;; Use (def-ps-macro tagbody-rec ...) to define ;; tagbody as a ps macro. Does this mean that the ;; macro only exists in the scope of a (ps ...) form?

;; Use (block gs-outer (loop do (block gs-inner (switch ...)))) ;; to handle (tagbody tag ((lambda () (go tag)))). The ;; (go ...) form is insinde a lexical closure. ;; Parenscript handles this nicely, when the closure ;; adjusted to ((lambda () (setf gs-switch-var 'tag) ;; (return-from gs-inner))).

;; Set up the switch-var correctly. It needs to be ;; initialized with the first tag. The prologue ;; should be handled separately anyway to keep the jump ;; table of the resulting switch case small for the ;; benefit of the CPUs branch predictor and instruction ;; cache while looping over the switch-case. ;; ;; (let ((gs-switch-var first-tag)) (switch gs-switch-var ...))

;; 2022-02-24

;; Parenscript example:

(let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) (inner-block-1 (gensym (symbol-name 'inner-block-1-))) (switch-var-1 (gensym (symbol-name 'switch-var-1-))) (outer-block-2 (gensym (symbol-name 'outer-block-2-))) (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) `(block ,outer-block-1 (prologue-1) (let ((,switch-var-1 tagbody-1-first-tag)) (loop do (block ,inner-block-1 (switch ,switch-var-1 (case tagbody-1-tag-1 (foo) (block ,outer-block-2 (prologue-2) (let ((,switch-var-2 tagbody-2-first-tag)) (loop do (block ,inner-block-2 (switch ,switch-var-2 (case tagbody-2-tag-1) ;; inner jump: (go tagbody-2-tag-2) (progn (setf ,switch-var-2 'tagbody-2-tag-2) (return-from ,inner-block-2)) ;; outer jump: (go tagbody-1-tag-2) (progn (setf ,switch-var-1 'tagbody-1-tag-2) (return-from ,inner-block-1)) (case tagbody-2-tag-2) ;; Walking off the end of tagbody-2 (return-from ,outer-block-2)))))) ;; Code to skip when jumping from the ;; inner tagbody to a go tag in the ;; outer tagbody. Nevertheless, it has ;; to be run, when walking off the end of ;; the inner tagbody. (bar)) (case tagbody-1-tag-2 (baz) ;; Walking off the end of tagbody-1 (return-from ,outer-block-1))))))))

|#

;; =============================== ;; 2022-03-19

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(first-go-tag (tb-body) ;; Find-if does *not* work cleanly. It fails ;; to distinguish between a tag named nil ;; and the absence of go tags. The latter ;; is solely having a preamble in the ;; tagbody form. "Returns two values like CL:GETHASH. 1. First tag. 2. Whether a tag was found. Relevant in case the first return value is NIL.

Note, that NIL is a valid go-tag." (block first-go-tag (loop for form in tb-body do (if (go-tag-p form) (return-from first-go-tag (values form t)))) (return-from first-go-tag (values nil nil))))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(block split-and-group-tb-body (if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))))) ,@body))

#| ;; TESTS (with-tagbody-helpers (and (go-tag-p 'foo) (go-tag-p 'bar) (go-tag-p 3) (go-tag-p -9)

(not (go-tag-p 1.3))

(equal (tb-go-tags (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) '(tag1 tag2))

(eq (first-go-tag (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) 'tag1)

(multiple-value-bind (preamble grouping) (split-and-group-tb-body (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) (and (equal preamble '((preamble-1-1) (preamble-1-2))) (equal grouping '((tag1 (foo)) (tag2 (bar)))))))) |#

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((new-go-bindings (switch-var block-var new-tb-go-tags) (mapcar (lambda (go-tag) ;; alist `(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))) new-tb-go-tags)) (grouping-to-case-forms (grouped-tb-body old-and-new-go-bindings) (mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-bindings) ,@case-body)))) grouped-tb-body))

(tb-body-to-switch (outer-block-var inner-block-var preamble grouped-tb-body first-tag switch-var old-and-new-go-bindings) `(block ,outer-block-var ,@preamble (let ((,switch-var ',first-tag)) (loop do (block ,inner-block-var (macrolet ((go (go-tag) `(progn ,@(cdr (assoc go-tag ',old-and-new-go-bindings))))) (switch ,switch-var ,@(grouping-to-case-forms grouped-tb-body old-and-new-go-bindings))) ;; Fall-through after end of tagbody form (return-from ,outer-block-var))))))) ,@body)))

#| ;; TESTS (with-tagbody-parenscript-helpers (and (let ((switch-1-var '#:switch-1-var) (inner-block-1-var '#:inner-block-1-var) (outer-block-1-var '#:outer-block-1-var))

(equal (new-go-bindings switch-1-var inner-block-1-var '(tb-1-tag1 tb-1-tag2)) ;; alist `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var))))

(equal (grouping-to-case-forms '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) (tag2 (bar))) `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var)))) `((CASE TAG1 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (HOGE))) (CASE TAG2 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (BAR)))))

(equalp ; Needs #'cl:equalP instead of #'cl:equal. (tb-body-to-switch outer-block-1-var inner-block-1-var '((preamble-1-1) (preamble-1-2)) '((tb-1-tag-1 (foo) (tagbody tb-2-tag-1) (tagbody tb-1-tag-1) ; Shadows outer tag! (hoge)) (tb-1-tag-2 (bar))) 'tb-1-tag-1 switch-1-var `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) (return-from ,inner-block-1-var)) (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) (return-from ,inner-block-1-var))))

`(BLOCK ,OUTER-BLOCK-1-VAR (PREAMBLE-1-1) (PREAMBLE-1-2) (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) (LOOP DO (BLOCK ,INNER-BLOCK-1-VAR (MACROLET ((GO (GO-TAG) `(PROGN ,@(CDR (ASSOC GO-TAG '((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))))))) (SWITCH ,switch-1-var (CASE TB-1-TAG-1 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (TAGBODY TB-1-TAG-1) ; Shadows outer tag! (HOGE))) (CASE TB-1-TAG-2 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (BAR))))) (RETURN-FROM ,outer-block-1-var))))))))) |#

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information OUTER-GO-BINDINGS only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) (inner-block-var (gensym (symbol-name 'inner-block-var-))) (switch-var (gensym (symbol-name 'switch-var-)))) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (first-go-tag (first-go-tag tb-body)) (old-and-new-go-bindings ;; alist (append (new-go-bindings switch-var inner-block-var new-go-tags) outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) (tb-body-to-switch (outer-block-var inner-block-var preamble tb-groups first-go-tag switch-var old-and-new-go-bindings)))))) ,@body))))

#| ;; TESTS |# (ql:quickload '(:series :parenscript :trivial-macroexpand-all))

(series::install :shadow t)

(import '(parenscript:ps parenscript:ps* trivial-macroexpand-all:macroexpand-all))

;; Explicitly circumvent package lock ;; on package CL to allow shadowing ;; by macrolet for series to paren- ;; script translation. (shadow '(tagbody go))

;; Default to standard CL form. (defmacro tagbody (&body body) "See CL:tagbody." `(cl:tagbody ,@body))

;; Default to standard CL form. (defmacro go (&body body) "See CL:go." `(cl:go ,@body))

(load #p"2022-05-20_defmacro-series-expand.lisp")

(parenscript:ps* (series-expand (collect (map-fn '(values T T) #'floor #z(9 99 999) #z(1 2 3)))))

;; Problem: Parenscript does *not* know ;; how to compile TAGBODY. Suggestion: ;; compile into (loop (case ...)) with ;; a go-variable where the (case ...) ;; selects between the jump targets. ;; This should be easily made compatible ;; with (series::producing ...) given ;; the additional constraints for ;; series::producing.

;; 2022-02-24

;; Parenscript example:

(let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) (inner-block-1 (gensym (symbol-name 'inner-block-1-))) (switch-var-1 (gensym (symbol-name 'switch-var-1-))) (outer-block-2 (gensym (symbol-name 'outer-block-2-))) (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) `(block ,outer-block-1 (prologue-1) (let ((,switch-var-1 tagbody-1-first-tag)) (loop do (block ,inner-block-1 (switch ,switch-var-1 (case tagbody-1-tag-1 (foo) (block ,outer-block-2 (prologue-2) (let ((,switch-var-2 tagbody-2-first-tag)) (loop do (block ,inner-block-2 (switch ,switch-var-2 (case tagbody-2-tag-1) ;; inner jump: (go tagbody-2-tag-2) (progn (setf ,switch-var-2 'tagbody-2-tag-2) (return-from ,inner-block-2)) ;; outer jump: (go tagbody-1-tag-2) (progn (setf ,switch-var-1 'tagbody-1-tag-2) (return-from ,inner-block-1)) (case tagbody-2-tag-2) ;; Walking off the end of tagbody-2 (return-from ,outer-block-2)))))) ;; Code to skip when jumping from the ;; inner tagbody to a go tag in the ;; outer tagbody. Nevertheless, it has ;; to be run, when walking off the end of ;; the inner tagbody. (bar)) (case tagbody-1-tag-2 (baz) ;; Walking off the end of tagbody-1 (return-from ,outer-block-1))))))))

|#

;; =============================== ;; 2022-03-19

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(first-go-tag (tb-body) ;; Find-if does *not* work cleanly. It fails ;; to distinguish between a tag named nil ;; and the absence of go tags. The latter ;; is solely having a preamble in the ;; tagbody form. "Returns two values like CL:GETHASH. 1. First tag. 2. Whether a tag was found. Relevant in case the first return value is NIL.

Note, that NIL is a valid go-tag." (block first-go-tag (loop for form in tb-body do (if (go-tag-p form) (return-from first-go-tag (values form t)))) (return-from first-go-tag (values nil nil))))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(block split-and-group-tb-body (if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))))) ,@body))

#| ;; TESTS (with-tagbody-helpers (and (go-tag-p 'foo) (go-tag-p 'bar) (go-tag-p 3) (go-tag-p -9)

(not (go-tag-p 1.3))

(equal (tb-go-tags (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) '(tag1 tag2))

(eq (first-go-tag (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) 'tag1)

(multiple-value-bind (preamble grouping) (split-and-group-tb-body (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) (and (equal preamble '((preamble-1-1) (preamble-1-2))) (equal grouping '((tag1 (foo)) (tag2 (bar)))))))) |#

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((new-go-bindings (switch-var block-var new-tb-go-tags) (mapcar (lambda (go-tag) ;; alist `(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))) new-tb-go-tags)) (grouping-to-case-forms (grouped-tb-body old-and-new-go-bindings) (mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-bindings) ,@case-body)))) grouped-tb-body))

(tb-body-to-switch (outer-block-var inner-block-var preamble grouped-tb-body first-tag switch-var old-and-new-go-bindings) `(block ,outer-block-var ,@preamble (let ((,switch-var ',first-tag)) (loop do (block ,inner-block-var (macrolet ((go (go-tag) `(progn ,@(cdr (assoc go-tag ',old-and-new-go-bindings))))) (switch ,switch-var ,@(grouping-to-case-forms grouped-tb-body old-and-new-go-bindings))) ;; Fall-through after end of tagbody form (return-from ,outer-block-var))))))) ,@body)))

#| ;; TESTS (with-tagbody-parenscript-helpers (and (let ((switch-1-var '#:switch-1-var) (inner-block-1-var '#:inner-block-1-var) (outer-block-1-var '#:outer-block-1-var))

(equal (new-go-bindings switch-1-var inner-block-1-var '(tb-1-tag1 tb-1-tag2)) ;; alist `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var))))

(equal (grouping-to-case-forms '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) (tag2 (bar))) `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var)))) `((CASE TAG1 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (HOGE))) (CASE TAG2 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (BAR)))))

(equalp ; Needs #'cl:equalP instead of #'cl:equal. (tb-body-to-switch outer-block-1-var inner-block-1-var '((preamble-1-1) (preamble-1-2)) '((tb-1-tag-1 (foo) (tagbody tb-2-tag-1) (tagbody tb-1-tag-1) ; Shadows outer tag! (hoge)) (tb-1-tag-2 (bar))) 'tb-1-tag-1 switch-1-var `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) (return-from ,inner-block-1-var)) (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) (return-from ,inner-block-1-var))))

`(BLOCK ,OUTER-BLOCK-1-VAR (PREAMBLE-1-1) (PREAMBLE-1-2) (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) (LOOP DO (BLOCK ,INNER-BLOCK-1-VAR (MACROLET ((GO (GO-TAG) `(PROGN ,@(CDR (ASSOC GO-TAG '((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))))))) (SWITCH ,switch-1-var (CASE TB-1-TAG-1 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (TAGBODY TB-1-TAG-1) ; Shadows outer tag! (HOGE))) (CASE TB-1-TAG-2 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (BAR))))) (RETURN-FROM ,outer-block-1-var))))))))) |#

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information OUTER-GO-BINDINGS only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) (inner-block-var (gensym (symbol-name 'inner-block-var-))) (switch-var (gensym (symbol-name 'switch-var-)))) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (first-go-tag (first-go-tag tb-body)) (old-and-new-go-bindings ;; alist (append (new-go-bindings switch-var inner-block-var new-go-tags) outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) (tb-body-to-switch (outer-block-var inner-block-var preamble tb-groups first-go-tag switch-var old-and-new-go-bindings)))))) ,@body))))

#| ;; TESTS |#

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

FWIW, I don't know if parenscript's catch/throw is sufficiently full featured for it, but here's an implementation of tagbody with throw/catch

https://plover.com/~mjd/misc/hbaker-archive/MetaCircular.html

On Fri, 20 May 2022 10:13:03 +0930 Andrew Easton <andrew@easton24.de> wrote:

...

Hello everyone,

It seems valuable to compile SERIES [1] macros with PARENSCRIPT [2], however, parenscript does not currently seem to support CL:TAGBODY [3,4]. Even poking around the HyperSpec and discovering that CL:DO provides *not* an implicit progn, but an implicit tagbody [5], does not help. The (PARENSCRIPT:DO ...)-form only has an implicit progn around the body [3].

I have started to implement TAGBODY for PARENSCRIPT [A,B,C]. The general idea is to imitate a jump table by looping over a switch-case. A GO (C-terminology: jump) then sets the switch-variable to the next jump destination. The loop subsequently causes the switch to branch to the jump target in the switch-variable. Leaving the tagbody means leaving the loop.

There are complications. Common Lisp allows nested tagbody-forms. Common Lisp allows go-tags to be referenced within the lexical scope *and* the dynamic extent of a tagbody form. This means that a LAMBDA can close over a go-tag and jump there, see an example in [B], of how inconvenient this can become for compilation to JavaScript.

PARENSCRIPT is well-designed. Its compilation of BLOCKs, LOOPs and SWITCHes seems to permit compilation of a TAGBODY to JavaScript code. PARENSCRIPT even handles RETURNing from a BLOCK via a LAMBDA by automatically creating a JavaScript try-catch. This seems to curb the inconveniences brought on by lexical closures jumping to go-tags in the TAGBODY's dynamic extent.

I need help in the following points:

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#SECTION003400000...

b. https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node362.html#SECTION003500000...

c. https://dspace.mit.edu/handle/1721.1/6035

d. https://dspace.mit.edu/handle/1721.1/6031

e. (ql:quickload :series)

f. https://sourceforge.net/projects/series/

[2] Parenscript https://parenscript.common-lisp.dev/

[3] Parenscript Reference manual (updated 2019-10-15) https://parenscript.common-lisp.dev/reference.html

[4] Common Lisp HyperSpec (CLHS) entry for CL:TAGBODY http://www.lispworks.com/documentation/HyperSpec/Body/s_tagbod.htm#tagbody

[5] Common Lisp HyperSpec (CLHS) entry for CL:DO http://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm#do ;; The functions codify, mergify and ;; graphify handle the actual compilation ;; of series expressions. ;; Excellent work, Mr. Waters and all your ;; co-workers as well as the subsequent ;; maintainers of package SERIES. ;; (defmacro series-expand (&body body) `(let (series::*renames* series::*env*) (series::codify (series::mergify (series::graphify (quote (progn ,@body)))))))

;; Look at series:process-top and ;; series:starting-series-expr. (ql:quickload '(:series :parenscript :trivial-macroexpand-all))

(series::install :shadow t)

(import '(parenscript:ps parenscript:ps* trivial-macroexpand-all:macroexpand-all))

;; Explicitly circumvent package lock ;; on package CL to allow shadowing ;; by macrolet for series to paren- ;; script translation. (shadow '(tagbody go))

;; Default to standard CL form. (defmacro tagbody (&body body) "See CL:tagbody." `(cl:tagbody ,@body))

;; Default to standard CL form. (defmacro go (&body body) "See CL:go." `(cl:go ,@body))

(load #p"2022-05-20_defmacro-series-expand.lisp")

(parenscript:ps* (series-expand (collect (map-fn '(values T T) #'floor #z(9 99 999) #z(1 2 3)))))

;; Problem: Parenscript does *not* know ;; how to compile TAGBODY. Suggestion: ;; compile into (loop (case ...)) with ;; a go-variable where the (case ...) ;; selects between the jump targets. ;; This should be easily made compatible ;; with (series::producing ...) given ;; the additional constraints for ;; series::producing.

(defun go-tag-p (obj) (or (integerp obj) (symbolp obj)))

(defun first-go-tag (tagbody-body) "Remember, that (cl:tagbody ...) is a *special* form." (flet ((rec (pos body-rest) (cond ((go-tag-p (first body-rest)) (values pos (first body-rest))) (t (rec (1+ pos) (rest body-rest)))))) (rec 0 tagbody-body)))

(defmacro with-ps-from-series-tagbody (&body body) (let ((outside-block (gensym (symbol-name 'outside-block-))) (case-block (gensym (symbol-name 'case-block-))) (case-tag-var (gensym (symbol-name 'case-tag-var-))) go-tags) ; an alist `(macrolet ((tagbody (&rest body) (let* ((case-body (reduce (lambda (acc body-entry) (cond ;; Case 1: A go-tag. ((or (integerp body-entry) (symbolp body-entry)) (append acc `(((,body-entry)))))

;; Case 2: Executable code. (t (append (butlast acc) (list (append (car (last acc)) (list body-entry))))))) body :initial-value `(case ,case-tag-var))) ;; How are tagbody forms ;; where the first tag is not ;; the first element of the body ;; to be detected and handled? (first-tag) ;; Terminate when walking ;; past the end of the original ;; tagbody form. (case-body-with-terminator (append (butlast case-body) (list (append (car (last case-body)) '((return-from ,outside-block))))))) `(block ,outside-block (let ((,case-tag-var)) (loop do (block ,case-block ,case-body-with-terminator)))))) (go (tag) `(progn (setf ,case-tag-var ,tag) (return-from ,case-block)))))))

;; (ps (case :foo (:foo 3))) ;; (ps (case 'foo ('foo 3))) ;; (ps (case 4 (4 :bar)))

;; =============================== ;; 2022-02-18

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))) ,@body)))

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((tb-body-to-switch (switch-var old-and-new-go-tags grouped-tb-body) `(switch ,switch-var ,@(mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-tags) ,@case-body)))) grouped-tb-body)))

(new-go-bindings (while-var switch-var break-p-var new-tb-go-tags) (mapcar (lambda (go-tag) `(,go-tag (,while-var T) (,switch-var ,go-tag) (,break-p-var nil))) new-tb-go-tags))

(add-breakout-to-old-go-bindings (while-var break-p-var old-go-bindings-alist) (mapcar (lambda (gtb) `(,@gtb (,while-var nil) (,break-p-var T))) old-go-bindings-alist))

(update-go-bindings (while-var switch-var break-p-var new-tb-go-tags old-go-bindings-alist) ;; Order matters. New bindings must shadow ;; old bindings during alist lookups. (append (new-go-bindings while-var switch-var break-p-var new-tb-go-tags) (add-breakout-to-old-go-bindings while-var break-p-var old-go-bindings-alist)))) ,@body)))

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((while-var (gensym (symbol-name 'while-var-))) (switch-var (gensym (symbol-name 'switch-var-))) (break-p-var (gensym (symbol-name 'break-p-var-)))) (declare (ignorable break-p-var)) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (old-and-new-go-bindings (update-go-bindings while-var switch-var break-p-var new-go-tags ',outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) `(progn ,@preamble (do ((,while-var T)) ((null ,while-var)) (macrolet ((go (go-tag) `(progn (setf ,@(reduce #'append (cdr (assoc go-tag ,',old-and-new-go-bindings)))) (break) #|switch|#))) ,@(tb-body-to-switch switch-var old-and-new-go-bindings tb-groups))) ;; Necessary for jump from inner ;; tagbody to outer tagbody ;; with trailing code ;; behind the inner tagbody. ;; This trailing code ;; needs to be skipped. ,@(if outer-go-bindings ((if ,break-p-var (break)))))))) )

))))

#| Hairy Example:

(tagbody (outer-prologue) outer-a (tagbody (inner-prologue) inner-a (go inner-b) inner-b (go outer-a) inner-c ;; Note, that the following two jumps are valid, ;; because they fall both within the lexical scope as ;; well as the dynamic extent of the inner and the ;; outer tagbody forms. (if (foo) (funcall (lambda () (go inner-d))) (funcall (lambda () (go outer-a)))) inner-d (inner-epilogue)) (inner-epilogue-outside-of-the-inner-tagbody) outer-b outer-c (outer-epilogue))

;; 2022-02-23: (lambda () (go ...))

// Firefox 78.15.0esr (64-bit) var go_tag = 'foo'; var while_var = true; while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break;}; case 'bar': while_var = false; cls(); }}

// => Uncaught SyntaxError: unlabeled break must be inside loop or switch

while(while_var) while_block: {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break while_block;}; case 'bar': while_var = false; cls(); }}

// => Uncaught SyntaxError: label not found

while_block: { while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': cls = function () {break while_block;}; case 'bar': while_var = false; cls(); }}}

// => Uncaught SyntaxError: label not found

while_block: { while(while_var) {var cls = undefined; switch (go_tag) { case 'foo': break while_block; case 'bar': while_var = false; cls(); }}}

// => undefined

(ps (block outer-block (switch svar (foo ((lambda () (return-from outer-block 123)))))))

;; => "(function () { try { switch (svar) { case foo: __PS_MV_REG = []; return (function () { __PS_MV_REG = [];

throw { '__ps_block_tag' : 'outerBlock', '__ps_value' : 123 }; })(); }; } catch (_ps_err2) { if (_ps_err2 && 'outerBlock' === _ps_err2['__ps_block_tag']) { return _ps_err2['__ps_value']; } else { throw _ps_err2; }; }; })();"

;; So either I compile try-catch manually, or I fall ;; back to using (block ... (while T (switch ...))) for now.

;; Use (def-ps-macro tagbody-rec ...) to define ;; tagbody as a ps macro. Does this mean that the ;; macro only exists in the scope of a (ps ...) form?

;; Use (block gs-outer (loop do (block gs-inner (switch ...)))) ;; to handle (tagbody tag ((lambda () (go tag)))). The ;; (go ...) form is insinde a lexical closure. ;; Parenscript handles this nicely, when the closure ;; adjusted to ((lambda () (setf gs-switch-var 'tag) ;; (return-from gs-inner))).

;; Set up the switch-var correctly. It needs to be ;; initialized with the first tag. The prologue ;; should be handled separately anyway to keep the jump ;; table of the resulting switch case small for the ;; benefit of the CPUs branch predictor and instruction ;; cache while looping over the switch-case. ;; ;; (let ((gs-switch-var first-tag)) (switch gs-switch-var ...))

;; 2022-02-24

;; Parenscript example:

(let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) (inner-block-1 (gensym (symbol-name 'inner-block-1-))) (switch-var-1 (gensym (symbol-name 'switch-var-1-))) (outer-block-2 (gensym (symbol-name 'outer-block-2-))) (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) `(block ,outer-block-1 (prologue-1) (let ((,switch-var-1 tagbody-1-first-tag)) (loop do (block ,inner-block-1 (switch ,switch-var-1 (case tagbody-1-tag-1 (foo) (block ,outer-block-2 (prologue-2) (let ((,switch-var-2 tagbody-2-first-tag)) (loop do (block ,inner-block-2 (switch ,switch-var-2 (case tagbody-2-tag-1) ;; inner jump: (go tagbody-2-tag-2) (progn (setf ,switch-var-2 'tagbody-2-tag-2) (return-from ,inner-block-2)) ;; outer jump: (go tagbody-1-tag-2) (progn (setf ,switch-var-1 'tagbody-1-tag-2) (return-from ,inner-block-1)) (case tagbody-2-tag-2) ;; Walking off the end of tagbody-2 (return-from ,outer-block-2)))))) ;; Code to skip when jumping from the ;; inner tagbody to a go tag in the ;; outer tagbody. Nevertheless, it has ;; to be run, when walking off the end of ;; the inner tagbody. (bar)) (case tagbody-1-tag-2 (baz) ;; Walking off the end of tagbody-1 (return-from ,outer-block-1))))))))

|#

;; =============================== ;; 2022-03-19

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(first-go-tag (tb-body) ;; Find-if does *not* work cleanly. It fails ;; to distinguish between a tag named nil ;; and the absence of go tags. The latter ;; is solely having a preamble in the ;; tagbody form. "Returns two values like CL:GETHASH. 1. First tag. 2. Whether a tag was found. Relevant in case the first return value is NIL.

Note, that NIL is a valid go-tag." (block first-go-tag (loop for form in tb-body do (if (go-tag-p form) (return-from first-go-tag (values form t)))) (return-from first-go-tag (values nil nil))))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(block split-and-group-tb-body (if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))))) ,@body))

#| ;; TESTS (with-tagbody-helpers (and (go-tag-p 'foo) (go-tag-p 'bar) (go-tag-p 3) (go-tag-p -9)

(not (go-tag-p 1.3))

(equal (tb-go-tags (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) '(tag1 tag2))

(eq (first-go-tag (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) 'tag1)

(multiple-value-bind (preamble grouping) (split-and-group-tb-body (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) (and (equal preamble '((preamble-1-1) (preamble-1-2))) (equal grouping '((tag1 (foo)) (tag2 (bar)))))))) |#

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((new-go-bindings (switch-var block-var new-tb-go-tags) (mapcar (lambda (go-tag) ;; alist `(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))) new-tb-go-tags)) (grouping-to-case-forms (grouped-tb-body old-and-new-go-bindings) (mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-bindings) ,@case-body)))) grouped-tb-body))

(tb-body-to-switch (outer-block-var inner-block-var preamble grouped-tb-body first-tag switch-var old-and-new-go-bindings) `(block ,outer-block-var ,@preamble (let ((,switch-var ',first-tag)) (loop do (block ,inner-block-var (macrolet ((go (go-tag) `(progn ,@(cdr (assoc go-tag ',old-and-new-go-bindings))))) (switch ,switch-var ,@(grouping-to-case-forms grouped-tb-body old-and-new-go-bindings))) ;; Fall-through after end of tagbody form (return-from ,outer-block-var))))))) ,@body)))

#| ;; TESTS (with-tagbody-parenscript-helpers (and (let ((switch-1-var '#:switch-1-var) (inner-block-1-var '#:inner-block-1-var) (outer-block-1-var '#:outer-block-1-var))

(equal (new-go-bindings switch-1-var inner-block-1-var '(tb-1-tag1 tb-1-tag2)) ;; alist `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var))))

(equal (grouping-to-case-forms '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) (tag2 (bar))) `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var)))) `((CASE TAG1 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (HOGE))) (CASE TAG2 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (BAR)))))

(equalp ; Needs #'cl:equalP instead of #'cl:equal. (tb-body-to-switch outer-block-1-var inner-block-1-var '((preamble-1-1) (preamble-1-2)) '((tb-1-tag-1 (foo) (tagbody tb-2-tag-1) (tagbody tb-1-tag-1) ; Shadows outer tag! (hoge)) (tb-1-tag-2 (bar))) 'tb-1-tag-1 switch-1-var `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) (return-from ,inner-block-1-var)) (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) (return-from ,inner-block-1-var))))

`(BLOCK ,OUTER-BLOCK-1-VAR (PREAMBLE-1-1) (PREAMBLE-1-2) (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) (LOOP DO (BLOCK ,INNER-BLOCK-1-VAR (MACROLET ((GO (GO-TAG) `(PROGN ,@(CDR (ASSOC GO-TAG '((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))))))) (SWITCH ,switch-1-var (CASE TB-1-TAG-1 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (TAGBODY TB-1-TAG-1) ; Shadows outer tag! (HOGE))) (CASE TB-1-TAG-2 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (BAR))))) (RETURN-FROM ,outer-block-1-var))))))))) |#

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information OUTER-GO-BINDINGS only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) (inner-block-var (gensym (symbol-name 'inner-block-var-))) (switch-var (gensym (symbol-name 'switch-var-)))) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (first-go-tag (first-go-tag tb-body)) (old-and-new-go-bindings ;; alist (append (new-go-bindings switch-var inner-block-var new-go-tags) outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) (tb-body-to-switch (outer-block-var inner-block-var preamble tb-groups first-go-tag switch-var old-and-new-go-bindings)))))) ,@body))))

#| ;; TESTS |# (ql:quickload '(:series :parenscript :trivial-macroexpand-all))

(series::install :shadow t)

(import '(parenscript:ps parenscript:ps* trivial-macroexpand-all:macroexpand-all))

;; Explicitly circumvent package lock ;; on package CL to allow shadowing ;; by macrolet for series to paren- ;; script translation. (shadow '(tagbody go))

;; Default to standard CL form. (defmacro tagbody (&body body) "See CL:tagbody." `(cl:tagbody ,@body))

;; Default to standard CL form. (defmacro go (&body body) "See CL:go." `(cl:go ,@body))

(load #p"2022-05-20_defmacro-series-expand.lisp")

(parenscript:ps* (series-expand (collect (map-fn '(values T T) #'floor #z(9 99 999) #z(1 2 3)))))

;; Problem: Parenscript does *not* know ;; how to compile TAGBODY. Suggestion: ;; compile into (loop (case ...)) with ;; a go-variable where the (case ...) ;; selects between the jump targets. ;; This should be easily made compatible ;; with (series::producing ...) given ;; the additional constraints for ;; series::producing.

;; 2022-02-24

;; Parenscript example:

(let ((outer-block-1 (gensym (symbol-name 'outer-block-1-))) (inner-block-1 (gensym (symbol-name 'inner-block-1-))) (switch-var-1 (gensym (symbol-name 'switch-var-1-))) (outer-block-2 (gensym (symbol-name 'outer-block-2-))) (inner-block-2 (gensym (symbol-name 'inner-block-2-)))) `(block ,outer-block-1 (prologue-1) (let ((,switch-var-1 tagbody-1-first-tag)) (loop do (block ,inner-block-1 (switch ,switch-var-1 (case tagbody-1-tag-1 (foo) (block ,outer-block-2 (prologue-2) (let ((,switch-var-2 tagbody-2-first-tag)) (loop do (block ,inner-block-2 (switch ,switch-var-2 (case tagbody-2-tag-1) ;; inner jump: (go tagbody-2-tag-2) (progn (setf ,switch-var-2 'tagbody-2-tag-2) (return-from ,inner-block-2)) ;; outer jump: (go tagbody-1-tag-2) (progn (setf ,switch-var-1 'tagbody-1-tag-2) (return-from ,inner-block-1)) (case tagbody-2-tag-2) ;; Walking off the end of tagbody-2 (return-from ,outer-block-2)))))) ;; Code to skip when jumping from the ;; inner tagbody to a go tag in the ;; outer tagbody. Nevertheless, it has ;; to be run, when walking off the end of ;; the inner tagbody. (bar)) (case tagbody-1-tag-2 (baz) ;; Walking off the end of tagbody-1 (return-from ,outer-block-1))))))))

|#

;; =============================== ;; 2022-03-19

(defmacro with-tagbody-helpers (&body body) `(labels ((go-tag-p (obj) (or (symbolp obj) (integerp obj)))

(tb-go-tags (tb-body) (remove-if-not #'go-tag-p tb-body))

(first-go-tag (tb-body) ;; Find-if does *not* work cleanly. It fails ;; to distinguish between a tag named nil ;; and the absence of go tags. The latter ;; is solely having a preamble in the ;; tagbody form. "Returns two values like CL:GETHASH. 1. First tag. 2. Whether a tag was found. Relevant in case the first return value is NIL.

Note, that NIL is a valid go-tag." (block first-go-tag (loop for form in tb-body do (if (go-tag-p form) (return-from first-go-tag (values form t)))) (return-from first-go-tag (values nil nil))))

(split-and-group-tb-body (tb-body) "Returns two values. 1. The preamble -- code without a preceding tag 2. Grouping of tags and subsequent code."

(block split-and-group-tb-body (if (null tb-body) (return-from split-and-group-tb-body (values nil nil))) (let ((acc `((,(first tb-body)))) (preamble-p (not (go-tag-p (first tb-body))))) (loop for tbf in (rest tb-body) do (if (go-tag-p tbf) (push `(,tbf) acc) (push tbf (first acc)))) (setf acc (nreverse (mapcar #'nreverse acc))) (if preamble-p (values (first acc) (rest acc)) (values nil acc)))))) ,@body))

#| ;; TESTS (with-tagbody-helpers (and (go-tag-p 'foo) (go-tag-p 'bar) (go-tag-p 3) (go-tag-p -9)

(not (go-tag-p 1.3))

(equal (tb-go-tags (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) '(tag1 tag2))

(eq (first-go-tag (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) 'tag1)

(multiple-value-bind (preamble grouping) (split-and-group-tb-body (rest '(tagbody (preamble-1-1) (preamble-1-2) tag1 (foo) tag2 (bar)))) (and (equal preamble '((preamble-1-1) (preamble-1-2))) (equal grouping '((tag1 (foo)) (tag2 (bar)))))))) |#

(defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((new-go-bindings (switch-var block-var new-tb-go-tags) (mapcar (lambda (go-tag) ;; alist `(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))) new-tb-go-tags)) (grouping-to-case-forms (grouped-tb-body old-and-new-go-bindings) (mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(case ,go-tag ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-bindings) ,@case-body)))) grouped-tb-body))

(tb-body-to-switch (outer-block-var inner-block-var preamble grouped-tb-body first-tag switch-var old-and-new-go-bindings) `(block ,outer-block-var ,@preamble (let ((,switch-var ',first-tag)) (loop do (block ,inner-block-var (macrolet ((go (go-tag) `(progn ,@(cdr (assoc go-tag ',old-and-new-go-bindings))))) (switch ,switch-var ,@(grouping-to-case-forms grouped-tb-body old-and-new-go-bindings))) ;; Fall-through after end of tagbody form (return-from ,outer-block-var))))))) ,@body)))

#| ;; TESTS (with-tagbody-parenscript-helpers (and (let ((switch-1-var '#:switch-1-var) (inner-block-1-var '#:inner-block-1-var) (outer-block-1-var '#:outer-block-1-var))

(equal (new-go-bindings switch-1-var inner-block-1-var '(tb-1-tag1 tb-1-tag2)) ;; alist `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var))))

(equal (grouping-to-case-forms '((tag1 (foo) (tagbody tb-2-tag-1) (hoge)) (tag2 (bar))) `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1) (return-from ,inner-block-1-var)) (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2) (return-from ,inner-block-1-var)))) `((CASE TAG1 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (HOGE))) (CASE TAG2 (TAGBODY-RECURSIVE (((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1) (RETURN-FROM ,INNER-BLOCK-1-VAR)) (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2) (RETURN-FROM ,inner-block-1-var)))) (BAR)))))

(equalp ; Needs #'cl:equalP instead of #'cl:equal. (tb-body-to-switch outer-block-1-var inner-block-1-var '((preamble-1-1) (preamble-1-2)) '((tb-1-tag-1 (foo) (tagbody tb-2-tag-1) (tagbody tb-1-tag-1) ; Shadows outer tag! (hoge)) (tb-1-tag-2 (bar))) 'tb-1-tag-1 switch-1-var `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1) (return-from ,inner-block-1-var)) (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2) (return-from ,inner-block-1-var))))

`(BLOCK ,OUTER-BLOCK-1-VAR (PREAMBLE-1-1) (PREAMBLE-1-2) (LET ((,SWITCH-1-VAR 'TB-1-TAG-1)) (LOOP DO (BLOCK ,INNER-BLOCK-1-VAR (MACROLET ((GO (GO-TAG) `(PROGN ,@(CDR (ASSOC GO-TAG '((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))))))) (SWITCH ,switch-1-var (CASE TB-1-TAG-1 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (FOO) (TAGBODY TB-2-TAG-1) (TAGBODY TB-1-TAG-1) ; Shadows outer tag! (HOGE))) (CASE TB-1-TAG-2 (TAGBODY-RECURSIVE (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1) (RETURN-FROM ,inner-block-1-var)) (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2) (RETURN-FROM ,inner-block-1-var)))) (BAR))))) (RETURN-FROM ,outer-block-1-var))))))))) |#

(defmacro tagbody-recursive ((&optional outer-go-bindings) &body body) "Recursion information OUTER-GO-BINDINGS only by nested calls. Confer recursion flag of #'CL:READ." `(with-tagbody-parenscript-helpers (let ((outer-block-var (gensym (symbol-name 'outer-block-var-))) (inner-block-var (gensym (symbol-name 'inner-block-var-))) (switch-var (gensym (symbol-name 'switch-var-)))) (macrolet ((tagbody (&body tb-body) (let* ((new-go-tags (tb-go-tags tb-body)) (first-go-tag (first-go-tag tb-body)) (old-and-new-go-bindings ;; alist (append (new-go-bindings switch-var inner-block-var new-go-tags) outer-go-bindings))) (multiple-value-bind (preamble tb-groups) (split-and-group-tb-body tb-body) (tb-body-to-switch (outer-block-var inner-block-var preamble tb-groups first-go-tag switch-var old-and-new-go-bindings)))))) ,@body))))

#| ;; TESTS |#

Hello everyone, How’s it going? There is now a working version of (parenscript:defpsmacro tagbody (&body body) …)), See my blog post here: "https://dapperdrake.neocities.org/faster-loops-javascript <https://dapperdrake.neocities.org/faster-loops-javascript>” . This adds nestable (tagbody … (tagbody …) …)) forms as a user-land library to parenscript. Apologies for missing documentation. It will be added gradually. Also, hosting a tarball on Neocities.org is planned in future as well as somehow getting the library into quicklisp. A name like parenscript-tagbody-go seems useful. This code is still missing the check of *DEFINED-OPERATORS*. How is that supposed to look? Cheers, Andrew

On May 29, 2022, at 20:24, Andrew Easton <andrew@easton24.de> wrote:

Hi Philipp,

That sounds like a good plan.

From my current vantage point, this seems like step three. I just got done with at step one. Step two is for me to get acquainted with the parenscript codebase.

I will get a feel the existing code base and then we can take the next steps from there.

I already cloned the git repository to my local development machine. The current commit for branch master seems to be:

commit 1fd720bc4e2bc5ed92064391b730b9d4db35462a (HEAD -> master) | Author: Vladimir Sedach <vas@oneofus.la> | Date: Wed Jun 17 20:29:19 2020 -0700

Regarding tail-call optimization in JavaScript: Jason Miller also recommended that. Unfortunately, I dug up information indicating that it is unsupported in Google's V8 JavaScript implementation, see [stackoverflow.com (2017)].

Quoting part of my reply to Jason for the benefit of future readers of this specific email:

...

[...] 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

[stackoverflow.com (2017)], Answer by T.J. Crowder: TITLE: ES6 Tail Recursion Optimisation Stack Overflow, URL: https://stackoverflow.com/questions/42788139/es6-tail-recursion-optimisation...

On Sat, May 21, 2022 at 10:58:57AM +0200, Philipp Marek wrote:

...

Hi Andrew,

first of all -- how about registering on gitlab.common-lisp.net, so that you can become a developer for [1] and work with a branch using a Merge Request? It would be much easier to track your progress (and individual changes) that way.

...

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.

Hmmm, okay. My first thought would've been to use a function for each part and just do tail recursion... but it seems that this isn't really supported in Javascript?!

...

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.

Yeah... that would be a good reason for simple function calls and tail recursion.

...

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.

I'll take a look - but please let's try to get it into the git repo first, so that any discussions have some common state to refer to.

...

2. My understanding of the CL:TAGBODY definition in the CLHS [4] may be wrong. Which alternate interpretations does anybody here know of?

What are your questions, or points of confusion?

Ad 1: https://gitlab.common-lisp.net/parenscript/parenscript

Answering my own question, it seems to at least have some support, but the following rather simple test-case seems to trip it up somehow: (parenscript:ps (defun bar () (tagbody (go x) (alert "hi") x))) -Jason On Fri, 27 Jan 2023 13:54:37 -0800 Jason Miller <jason@milr.com> wrote:

Neat! I'll take a closer look later.

Does it fully support the strange combination of lexical scope and dynamic extent that CL:TAGBODY does?

For example:

(defun foo (x) (funcall x)) (tagbody (foo (lambda () (go x))) (format t "This does not happen~%") x)

-Jason

On Fri, 27 Jan 2023 09:00:58 -0700 Andrew Easton <Andrew@Easton24.com> wrote:

...

Hello everyone,

How’s it going?

There is now a working version of (parenscript:defpsmacro tagbody (&body body) …)), See my blog post here: "https://dapperdrake.neocities.org/faster-loops-javascript <https://dapperdrake.neocities.org/faster-loops-javascript>” .

This adds nestable (tagbody … (tagbody …) …)) forms as a user-land library to parenscript.

Apologies for missing documentation. It will be added gradually. Also, hosting a tarball on Neocities.org is planned in future as well as somehow getting the library into quicklisp. A name like parenscript-tagbody-go seems useful.

This code is still missing the check of *DEFINED-OPERATORS*. How is that supposed to look?

Cheers, Andrew

...

On May 29, 2022, at 20:24, Andrew Easton <andrew@easton24.de> wrote:

Hi Philipp,

That sounds like a good plan.

From my current vantage point, this seems like step three. I just got done with at step one. Step two is for me to get acquainted with the parenscript codebase.

I will get a feel the existing code base and then we can take the next steps from there.

I already cloned the git repository to my local development machine. The current commit for branch master seems to be:

commit 1fd720bc4e2bc5ed92064391b730b9d4db35462a (HEAD -> master) | Author: Vladimir Sedach <vas@oneofus.la> | Date: Wed Jun 17 20:29:19 2020 -0700

Regarding tail-call optimization in JavaScript: Jason Miller also recommended that. Unfortunately, I dug up information indicating that it is unsupported in Google's V8 JavaScript implementation, see [stackoverflow.com (2017)].

Quoting part of my reply to Jason for the benefit of future readers of this specific email:

...

[...] 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

[stackoverflow.com (2017)], Answer by T.J. Crowder: TITLE: ES6 Tail Recursion Optimisation Stack Overflow, URL: https://stackoverflow.com/questions/42788139/es6-tail-recursion-optimisation...

On Sat, May 21, 2022 at 10:58:57AM +0200, Philipp Marek wrote:

...

Hi Andrew,

first of all -- how about registering on gitlab.common-lisp.net, so that you can become a developer for [1] and work with a branch using a Merge Request? It would be much easier to track your progress (and individual changes) that way.

...

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.

Hmmm, okay. My first thought would've been to use a function for each part and just do tail recursion... but it seems that this isn't really supported in Javascript?!

...

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.

Yeah... that would be a good reason for simple function calls and tail recursion.

...

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.

I'll take a look - but please let's try to get it into the git repo first, so that any discussions have some common state to refer to.

...

2. My understanding of the CL:TAGBODY definition in the CLHS [4] may be wrong. Which alternate interpretations does anybody here know of?

What are your questions, or points of confusion?

Ad 1: https://gitlab.common-lisp.net/parenscript/parenscript

Hi Jason, Thank you very much for raising the preamble issue. It seems like it is fixable, see below. The idea of a “preamble” will probably be removed. Fix still needs to be implemented by me. The blog post has been amended to document this bug. Search for “TODO BUG #2”. ;; TODO BUG #2 2023-02-28 (parenscript:ps* '(defun bar () (tagbody (go x) (alert "hi") x))) #| returns "defun(bar, null, (function () { go(x); alert('hi'); var switchVar295 = 1; while (true) { switch (switchVar295) { case 1: 'tagbody-go-tag: X'; }; __PS_MV_REG = []; return; }; })());” |# This output is incorrect. There should be no "go(x);" under any relevant circumstances as by the CLHS definition of (tagbody ...) and (go ...) . The problem seems to be that the search for the "preamble" only checks for go-tags and not for (go ...) forms. This seems to be easily fixable by amending the preamble search to terminate upon encountering a top-level (go ...) form. Problem: (tagbody (funcall (lambda () (go x))) (alert "hi") x) still has the same behaviour, *without* involving a (go ...) form at the top level of the (tagbody ...). Alternative proposal: Do away with the preamble and instead add a dummy gensymmed jump tag at the beginning of the (tagbody ...). That jump-tag should, conceptually, be unreachable. All (go ...) forms are then affected by the (macrolet ((go ...)) ...) wrappers being placed already. Then the preamble analysis becomes dead code and can be removed. See Jason Miller's first bug reported on 2023-01-27 for current problems with wrapping (go ...) forms inside of (lambda ...) forms. Cheers, Andrew

On Jan 27, 2023, at 15:16, Jason Miller <jason@milr.com> wrote:

(parenscript:ps (defun bar () (tagbody (go x) (alert "hi") x)))

Hello everyone, How’s it going? What is a good path forward for adding (tagbody …) to ParenScript? Package “parenscript-tagbody-go” [1] currently provides a beta-version implementation using (defpsmacro …). It seems like originally, even classes and objects were user-land macro packages outside of lisp implementations. Nevertheless, integration into package “parenscript” seems to help with usability and discoverability. The implementation seems to be mostly working. Jason’s bug report seem to be fixed. Two more bugs concerning duplicate labels and empty (tagbody) forms were fixed as well. There is now also a preliminary package “parenscript-series” [2] that already offers a custom js array scanner and two js array collectors. One collector pushes the other unshifts. The push collector was surprisingly difficult to implement, because SERIES macroexpands (push …) in (parenscript:chain arr (parenscript:push elem)) to whatever the current lisp implementation does. On SBCL 2.3.1, for example, it ends up with some SBCL internal form. The solution is (parenscript:funcall (parenscript:getprop arr (quote push)) elem). The biggest problems with collectors and scanners were unimplemented CL forms in ParenScript, e.g. (the …) and (make-list …). It seems to be less work to reimplement the few SERIES operations that use too many of those CL features compared to porting all the missing CL features that the CL SERIES expanders rely on. With this array scanner and these two array collectors, (series:map-fn …) gets translated to JavaScript correctly, without further intervention. So the following works, now that (tagbody …) can be pipelined and compiled: (ps* (series-expand:series-expand '(collect-js-array-push (map-fn T (lambda (x) (* x 2)) (map-fn T #’1+ (scan-js-array '(1 2 3)))))) ;; => #<JavaScript code> ;; => [4, 6, 8] // when evaluated in JavaScript Does it seem useful to integrate “parenscript-tagbody-go” into ParenScript itself or is a standalone package better maintenance-wise? Something like "parenscript-series” seems like it may be better off as a separate package. Nevertheless, SERIES is a pipelining compiler for pre-order traversal and with ParenScript being its own full compiler, integrating SERIES could be valuable. Especially when implementing and composing operations from relational algebra having pipelining is a huge help. Most of the usability mess with SERIES and CL seems to stem from the fact that it was *not* included in the standard and integrated into CL implementations properly [3 (page 55), 4 (page 6)]. SERIES got two honorable mentions in CLtL2 [5,6], but that seems to have been it from a usability standpoint. What does experience suggest on these two matters? Cheers, Andrew [1] https://dapperdrake.neocities.org/faster-loops-javascript [2] https://dapperdrake.neocities.org/faster-loops-javascript <https://dapperdrake.neocities.org/faster-loops-javascript> [3] https://dspace.mit.edu/handle/1721.1/6035 [4] https://dspace.mit.edu/handle/1721.1/6031 [5] http://cltl2.lisp.se/cltl/clm/node347.html#SECTION003400000000000000000 [6] http://cltl2.lisp.se/cltl/clm/node362.html#SECTION003500000000000000000

On Jan 27, 2023, at 09:00, Andrew Easton <Andrew@easton24.com> wrote:

Hello everyone,

How’s it going?

There is now a working version of (parenscript:defpsmacro tagbody (&body body) …)), See my blog post here: "https://dapperdrake.neocities.org/faster-loops-javascript <https://dapperdrake.neocities.org/faster-loops-javascript>” .

This adds nestable (tagbody … (tagbody …) …)) forms as a user-land library to parenscript.

Apologies for missing documentation. It will be added gradually. Also, hosting a tarball on Neocities.org <http://neocities.org/> is planned in future as well as somehow getting the library into quicklisp. A name like parenscript-tagbody-go seems useful.

This code is still missing the check of *DEFINED-OPERATORS*. How is that supposed to look?

Cheers, Andrew

...

On May 29, 2022, at 20:24, Andrew Easton <andrew@easton24.de <mailto:andrew@easton24.de>> wrote:

Hi Philipp,

That sounds like a good plan.

From my current vantage point, this seems like step three. I just got done with at step one. Step two is for me to get acquainted with the parenscript codebase.

I will get a feel the existing code base and then we can take the next steps from there.

I already cloned the git repository to my local development machine. The current commit for branch master seems to be:

commit 1fd720bc4e2bc5ed92064391b730b9d4db35462a (HEAD -> master) | Author: Vladimir Sedach <vas@oneofus.la <mailto:vas@oneofus.la>> | Date: Wed Jun 17 20:29:19 2020 -0700

Regarding tail-call optimization in JavaScript: Jason Miller also recommended that. Unfortunately, I dug up information indicating that it is unsupported in Google's V8 JavaScript implementation, see [stackoverflow.com <http://stackoverflow.com/> (2017)].

Quoting part of my reply to Jason for the benefit of future readers of this specific email:

...

[...] 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

[stackoverflow.com <http://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... <https://stackoverflow.com/questions/42788139/es6-tail-recursion-optimisation-stack-overflow>

On Sat, May 21, 2022 at 10:58:57AM +0200, Philipp Marek wrote:

...

Hi Andrew,

first of all -- how about registering on gitlab.common-lisp.net, so that you can become a developer for [1] and work with a branch using a Merge Request? It would be much easier to track your progress (and individual changes) that way.

...

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.

Hmmm, okay. My first thought would've been to use a function for each part and just do tail recursion... but it seems that this isn't really supported in Javascript?!

...

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.

Yeah... that would be a good reason for simple function calls and tail recursion.

...

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.

I'll take a look - but please let's try to get it into the git repo first, so that any discussions have some common state to refer to.

...

2. My understanding of the CL:TAGBODY definition in the CLHS [4] may be wrong. Which alternate interpretations does anybody here know of?

What are your questions, or points of confusion?

Ad 1: https://gitlab.common-lisp.net/parenscript/parenscript