Re: Adding CL:TAGBODY for SERIES support

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