Adding CL:TAGBODY for SERIES support

Jason Miller jason at milr.com
Fri May 20 03:32:34 UTC 2022


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

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

On Fri, 20 May 2022 10:13:03 +0930 Andrew Easton <andrew at easton24.de> wrote:
> Hello everyone,
> 
> It seems valuable to compile SERIES [1] macros with
> PARENSCRIPT [2], however, parenscript does not currently
> seem to support CL:TAGBODY [3,4].  Even poking around the
> HyperSpec and discovering that CL:DO provides *not* an
> implicit progn, but an implicit tagbody [5], does not
> help.  The (PARENSCRIPT:DO ...)-form only has an implicit
> progn around the body [3].
> 
> I have started to implement TAGBODY for PARENSCRIPT
> [A,B,C].  The general idea is to imitate a jump table
> by looping over a switch-case.  A GO (C-terminology:
> jump) then sets the switch-variable to the next jump
> destination.  The loop subsequently causes the switch
> to branch to the jump target in the switch-variable.
> Leaving the tagbody means leaving the loop.
> 
> There are complications.  Common Lisp allows nested
> tagbody-forms.  Common Lisp allows go-tags to be
> referenced within the lexical scope *and* the dynamic
> extent of a tagbody form.  This means that a LAMBDA
> can close over a go-tag and jump there, see an
> example in [B], of how inconvenient this can become
> for compilation to JavaScript.
> 
> PARENSCRIPT is well-designed.  Its compilation of
> BLOCKs, LOOPs and SWITCHes seems to permit
> compilation of a TAGBODY to JavaScript code.
> PARENSCRIPT even handles RETURNing from a BLOCK via a
> LAMBDA by automatically creating a JavaScript try-catch.
> This seems to curb the inconveniences brought on by
> lexical closures jumping to go-tags in the TAGBODY's
> dynamic extent.
> 
> I need help in the following points:
> 
> 1. I need a code review of the algorithm.
>    The implementation in [B] seems to be
>    satisfactory.  There are some test cases and
>    examples.  Most there is the most hairy example I
>    could find up to now.  I may have missed crucial
>    details.
> 
> 2. My understanding of the CL:TAGBODY definition in
>    the CLHS [4] may be wrong.  Which alternate
>    interpretations does anybody here know of?
> 
> 3. What examples of PARENSCRIPT:DEFPSMACRO do you
>    know, that might help me understand its semantics?
>    I would hazard a guess at DEFPSMACRO being a
>    facility to add TAGBODY to PARENSCRIPT, however,
>    my understanding of DEFPSMACRO is very bad and I
>    do not know where to start tinkering with it to
>    further my understanding.
> 
> 
> Kind regards,
> Andrew Easton
> 
> 
> 
> === Attachments ===
> 
> [A] 2022-05-20_defmacro-series-expand.lisp
> 
> [B] 2022-05-20_parenscript-devel_tagbody-code-short.lisp
> 
> [C] 2022-05-20_parenscript-devel_tagbody-code-long.lisp
> The long version contains some dead-ends that were
> encountered during development.  This is an important
> source of counter-examples.
> 
> 
> 
> 
> === References ===
> 
> [1] The SERIES macro package
> a. https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node347.html#SECTION003400000000000000000
> 
> b. https://www.cs.cmu.edu/Groups/AI/html/cltl/clm/node362.html#SECTION003500000000000000000
> 
> c. https://dspace.mit.edu/handle/1721.1/6035
> 
> d. https://dspace.mit.edu/handle/1721.1/6031
> 
> e. (ql:quickload :series)
> 
> f. https://sourceforge.net/projects/series/
> 
> [2] Parenscript
> https://parenscript.common-lisp.dev/
> 
> [3] Parenscript Reference manual (updated 2019-10-15)
> https://parenscript.common-lisp.dev/reference.html
> 
> [4] Common Lisp HyperSpec (CLHS) entry for CL:TAGBODY
> http://www.lispworks.com/documentation/HyperSpec/Body/s_tagbod.htm#tagbody
> 
> [5] Common Lisp HyperSpec (CLHS) entry for CL:DO
> http://www.lispworks.com/documentation/HyperSpec/Body/m_do_do.htm#do
> ;;  The functions codify, mergify and
> ;;  graphify handle the actual compilation
> ;;  of series expressions.
> ;;  Excellent work, Mr. Waters and all your
> ;;  co-workers as well as the subsequent
> ;;  maintainers of package SERIES.
> ;;
> (defmacro series-expand (&body body)
>   `(let (series::*renames*
>          series::*env*)
>      (series::codify
>        (series::mergify
>          (series::graphify
>            (quote (progn , at body)))))))
> 
> ;; Look at series:process-top and
> ;;  series:starting-series-expr.
> (ql:quickload '(:series
>                 :parenscript
>                 :trivial-macroexpand-all))
> 
> (series::install :shadow t)
> 
> (import '(parenscript:ps
>           parenscript:ps*
> 	  trivial-macroexpand-all:macroexpand-all))
> 
> 
> ;; Explicitly circumvent package lock
> ;;  on package CL to allow shadowing
> ;;  by macrolet for series to paren-
> ;;  script translation.
> (shadow '(tagbody go))
> 
> ;; Default to standard CL form.
> (defmacro tagbody (&body body)
>   "See CL:tagbody."
>   `(cl:tagbody , at body))
> 
> ;; Default to standard CL form.
> (defmacro go (&body body)
>   "See CL:go."
>   `(cl:go , at body))
> 
> 
> (load #p"2022-05-20_defmacro-series-expand.lisp")
> 
> (parenscript:ps*
>   (series-expand
>     (collect (map-fn '(values T T)
> 		     #'floor #z(9 99 999)
> 		     #z(1 2 3)))))
> 
> ;; Problem: Parenscript does *not* know
> ;;  how to compile TAGBODY. Suggestion:
> ;;  compile into (loop (case ...)) with
> ;;  a go-variable where the (case ...)
> ;;  selects between the jump targets.
> ;;  This should be easily made compatible
> ;;  with (series::producing ...) given
> ;;  the additional constraints for
> ;;  series::producing.
> 
> (defun go-tag-p (obj)
>   (or (integerp obj)
>       (symbolp obj)))
> 
> (defun first-go-tag (tagbody-body)
>   "Remember, that (cl:tagbody ...) is a
>   *special* form."
>   (flet ((rec (pos body-rest)
> 	   (cond
> 	     ((go-tag-p (first body-rest))
> 	      (values pos (first body-rest)))
> 	     (t
> 	      (rec (1+ pos) (rest body-rest))))))
>     (rec 0 tagbody-body)))
> 
> (defmacro with-ps-from-series-tagbody (&body body)
>   (let ((outside-block (gensym (symbol-name 'outside-block-)))
> 	(case-block (gensym (symbol-name 'case-block-)))
> 	(case-tag-var (gensym (symbol-name 'case-tag-var-)))
> 	go-tags) ; an alist
>     `(macrolet ((tagbody (&rest body)
> 		  (let* ((case-body
> 			  (reduce (lambda (acc body-entry)
> 		                    (cond
> 				      ;; Case 1: A go-tag.
> 				      ((or (integerp body-entry)
> 				           (symbolp body-entry))
> 				       (append acc
> 					       `(((,body-entry)))))
> 
> 				      ;; Case 2: Executable code.
> 				      (t
> 				       (append
> 					 (butlast acc)
> 					 (list
> 				           (append (car (last acc))
> 						   (list body-entry)))))))
> 			         body
> 				 :initial-value `(case ,case-tag-var)))
>                          ;; How are tagbody forms
> 			 ;;  where the first tag is not
> 			 ;;  the first element of the body
> 			 ;;  to be detected and handled?
>                          (first-tag)
> 		         ;; Terminate when walking
> 			 ;;  past the end of the original
> 			 ;;  tagbody form.
> 		         (case-body-with-terminator
> 			   (append
> 			     (butlast case-body)
> 		             (list (append (car (last case-body))
> 					   '((return-from ,outside-block)))))))
> 		    `(block ,outside-block
> 		       (let ((,case-tag-var))
> 		         (loop do
> 			   (block ,case-block
> 			       ,case-body-with-terminator))))))
>                (go (tag)
> 		 `(progn
> 		    (setf ,case-tag-var ,tag)
> 		    (return-from ,case-block)))))))
> 
> ;; (ps (case :foo (:foo 3)))
> ;; (ps (case 'foo ('foo 3)))
> ;; (ps (case 4 (4 :bar)))
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> 
> ;; ===============================
> ;; 2022-02-18
> 
> 
> (defmacro with-tagbody-helpers (&body body)
>   `(labels
>        ((go-tag-p (obj)
>           (or (symbolp obj) (integerp obj)))
> 
>         (tb-go-tags (tb-body)
>           (remove-if-not #'go-tag-p tb-body))
> 
>         (split-and-group-tb-body (tb-body)
>           "Returns two values.
>           1. The preamble -- code without a preceding tag
>           2. Grouping of tags and subsequent code."
>  
>           (if (null tb-body)
> 	    (return-from split-and-group-tb-body
> 		         (values nil nil)))
>           (let ((acc `((,(first tb-body))))
> 	        (preamble-p (not (go-tag-p (first tb-body)))))
> 	    (loop for tbf in (rest tb-body) do
> 	      (if (go-tag-p tbf)
> 	        (push `(,tbf) acc)
> 	        (push tbf (first acc))))
>             (setf acc (nreverse (mapcar #'nreverse acc)))
> 	    (if preamble-p
> 	      (values (first acc) (rest acc))
> 	      (values nil acc))))
>      , at body)))
> 
> (defmacro with-tagbody-parenscript-helpers (&body body)
>   `(with-tagbody-helpers
>      (labels
> 	 ((tb-body-to-switch (switch-var old-and-new-go-tags grouped-tb-body)
> 	    `(switch ,switch-var
> 	       ,@(mapcar (lambda (go-tag-case)
> 			   (destructuring-bind
> 			       (go-tag &rest case-body)
> 			       go-tag-case
> 			     `(case ,go-tag
> 				;; Handle nested tagbody
> 				;;  forms correctly.
> 				(tagbody-recursive (,old-and-new-go-tags)
> 				  , at case-body))))
> 			 grouped-tb-body)))
> 
> 	  (new-go-bindings (while-var switch-var break-p-var new-tb-go-tags)
> 	    (mapcar (lambda (go-tag)
> 		      `(,go-tag
> 			(,while-var T)
> 			(,switch-var ,go-tag)
> 			(,break-p-var nil)))
> 		    new-tb-go-tags))
> 
> 	  (add-breakout-to-old-go-bindings (while-var
> 					    break-p-var
> 					    old-go-bindings-alist)
> 	    (mapcar (lambda (gtb)
> 		      `(, at gtb (,while-var nil) (,break-p-var T)))
> 		    old-go-bindings-alist))
> 
> 	  (update-go-bindings (while-var
> 			       switch-var
> 			       break-p-var
> 			       new-tb-go-tags
> 			       old-go-bindings-alist)
>             ;; Order matters. New bindings must shadow
> 	    ;;  old bindings during alist lookups.
>             (append (new-go-bindings while-var
> 				     switch-var
> 	                             break-p-var
> 				     new-tb-go-tags)
>                     (add-breakout-to-old-go-bindings
> 		      while-var
> 		      break-p-var
> 		      old-go-bindings-alist))))
>        , at body)))
> 
> (defmacro tagbody-recursive ((&optional outer-go-bindings)
>                              &body body)
>   "Recursion information only by nested calls. Confer
>    recursion flag of #'CL:READ."
>   `(with-tagbody-parenscript-helpers
>      (let ((while-var (gensym (symbol-name 'while-var-)))
>            (switch-var (gensym (symbol-name 'switch-var-)))
>            (break-p-var (gensym (symbol-name 'break-p-var-))))
> 	 (declare (ignorable break-p-var))
>        (macrolet ((tagbody (&body tb-body)
> 		    (let* ((new-go-tags (tb-go-tags tb-body))
> 			   (old-and-new-go-bindings
> 			     (update-go-bindings
> 			       while-var
> 			       switch-var
> 			       break-p-var
> 			       new-go-tags
> 			       ',outer-go-bindings)))
> 		      (multiple-value-bind
> 			  (preamble tb-groups)
>                           (split-and-group-tb-body tb-body)
> 		        `(progn
> 			   , at preamble
> 		           (do ((,while-var T))
> 			       ((null ,while-var))
> 			     (macrolet
> 				 ((go (go-tag)
> 					`(progn
> 					   (setf
> 					     ,@(reduce
> 						 #'append
> 					         (cdr
> 						   (assoc
> 					             go-tag
> 					  ,',old-and-new-go-bindings))))
> 					   (break) #|switch|#)))
> 	                       ,@(tb-body-to-switch 
> 				   switch-var
> 				   old-and-new-go-bindings
> 				   tb-groups)))
>                            ;; Necessary for jump from inner
> 			   ;;  tagbody to outer tagbody
> 			   ;;  with trailing code
> 			   ;;  behind the inner tagbody.
> 			   ;;  This trailing code
> 			   ;;  needs to be skipped.
> 			   ,@(if outer-go-bindings
> 			       ((if ,break-p-var (break))))))))
> 		   )
> 
>        ))))
> 
> 
> 
> 
> #|
> Hairy Example:
> 
> (tagbody 
>   (outer-prologue)
>  outer-a
>   (tagbody
>     (inner-prologue)
>    inner-a
>     (go inner-b)
>    inner-b
>     (go outer-a)
>    inner-c
>     ;; Note, that the following two jumps are valid,
>     ;;  because they fall both within the lexical scope as
>     ;;  well as the dynamic extent of the inner and the
>     ;;  outer tagbody forms.
>     (if (foo)
>       (funcall (lambda () (go inner-d)))
>       (funcall (lambda () (go outer-a))))
>    inner-d
>     (inner-epilogue))
>   (inner-epilogue-outside-of-the-inner-tagbody)
>  outer-b
>  outer-c
>   (outer-epilogue))
> 
> 
> 
> ;; 2022-02-23: (lambda () (go ...))
> 
> 
> // Firefox 78.15.0esr (64-bit)
> var go_tag = 'foo';
> var while_var = true;
> while(while_var) {var cls = undefined; switch (go_tag)
> {
>   case 'foo': cls = function () {break;}; case 'bar':
>   while_var = false; cls();
>   }}
> 
> // => Uncaught SyntaxError: unlabeled break must be inside loop or switch
> 
> while(while_var) while_block: {var cls = undefined;
> switch (go_tag) {
>   case 'foo': cls = function () {break while_block;};
>   case 'bar': while_var = false; cls();
>   }}
> 
> // => Uncaught SyntaxError: label not found
> 
> while_block: { while(while_var) {var cls = undefined;
> switch (go_tag) {
>   case 'foo': cls = function () {break while_block;};
>   case 'bar': while_var = false; cls();
>   }}}
> 
> // => Uncaught SyntaxError: label not found
> 
> while_block: { while(while_var) {var cls = undefined;
> switch (go_tag) {
>   case 'foo': break while_block; case 'bar': while_var
>   = false; cls();
>   }}}
> 
> // => undefined
> 
>   (ps
>     (block outer-block
>       (switch svar
> 	(foo ((lambda ()
>                 (return-from outer-block 123)))))))
> 
> ;; =>
>  "(function () {
>     try {
>       switch (svar) {
>         case foo:
>           __PS_MV_REG = [];
>           return
>           (function () { 
>               __PS_MV_REG = [];
> 
>               throw
>               { '__ps_block_tag' : 'outerBlock',
>                 '__ps_value' : 123 };
>           })(); 
>       };
>     }
>     catch (_ps_err2)
>     { if (_ps_err2 && 'outerBlock' === _ps_err2['__ps_block_tag'])
>       { return _ps_err2['__ps_value']; 
>       }
>       else {
>         throw _ps_err2; 
>       };
>     };
>   })();"
> 
> 
> ;; So either I compile try-catch manually, or I fall
> ;;  back to using (block ... (while T (switch ...))) for now.
> 
> ;; Use (def-ps-macro tagbody-rec ...) to define
> ;;  tagbody as a ps macro. Does this mean that the
> ;;  macro only exists in the scope of a (ps ...) form?
> 
> ;; Use (block gs-outer (loop do (block gs-inner (switch ...))))
> ;;  to handle (tagbody tag ((lambda () (go tag)))). The
> ;;  (go ...) form is insinde a lexical closure.
> ;;  Parenscript handles this nicely, when the closure
> ;;  adjusted to ((lambda () (setf gs-switch-var 'tag)
> ;;                          (return-from gs-inner))).
> 
> ;; Set up the switch-var correctly. It needs to be
> ;;  initialized with the first tag. The prologue
> ;;  should be handled separately anyway to keep the jump
> ;;  table of the resulting switch case small for the
> ;;  benefit of the CPUs branch predictor and instruction
> ;;  cache while looping over the switch-case.
> ;;
> ;;  (let ((gs-switch-var first-tag)) (switch gs-switch-var ...))
> 
> 
> ;; 2022-02-24
> 
> ;; Parenscript example:
> 
> (let ((outer-block-1 (gensym (symbol-name 'outer-block-1-)))
>       (inner-block-1 (gensym (symbol-name 'inner-block-1-)))
>       (switch-var-1 (gensym (symbol-name 'switch-var-1-)))
>       (outer-block-2 (gensym (symbol-name 'outer-block-2-)))
>       (inner-block-2 (gensym (symbol-name 'inner-block-2-))))
>   `(block ,outer-block-1
>      (prologue-1)
>      (let ((,switch-var-1 tagbody-1-first-tag))
>        (loop do
>          (block ,inner-block-1
> 	   (switch ,switch-var-1
> 	     (case tagbody-1-tag-1
> 	       (foo)
> 	       (block ,outer-block-2
> 		 (prologue-2)
> 		 (let ((,switch-var-2 tagbody-2-first-tag))
> 		   (loop do
> 		     (block ,inner-block-2
> 		       (switch ,switch-var-2
> 	                 (case tagbody-2-tag-1)
> 			   ;; inner jump: (go tagbody-2-tag-2)
>                            (progn
> 			     (setf ,switch-var-2 'tagbody-2-tag-2)
> 			     (return-from ,inner-block-2))
> 			   ;; outer jump: (go tagbody-1-tag-2)
>                            (progn
> 			     (setf ,switch-var-1 'tagbody-1-tag-2)
> 			     (return-from ,inner-block-1))
> 	                 (case tagbody-2-tag-2)
>                            ;; Walking off the end of tagbody-2
> 		           (return-from ,outer-block-2))))))
>                ;; Code to skip when jumping from the
> 	       ;;  inner tagbody to a go tag in the
> 	       ;;  outer tagbody. Nevertheless, it has
> 	       ;;  to be run, when walking off the end of
> 	       ;;  the inner tagbody.
> 	       (bar))
> 	       (case tagbody-1-tag-2
> 		 (baz)
>                  ;; Walking off the end of tagbody-1
> 		 (return-from ,outer-block-1))))))))
> 
> 
> 
> |#
> 
> 
> ;; ===============================
> ;; 2022-03-19
> 
> (defmacro with-tagbody-helpers (&body body)
>   `(labels
>        ((go-tag-p (obj)
>           (or (symbolp obj) (integerp obj)))
> 
>         (tb-go-tags (tb-body)
>           (remove-if-not #'go-tag-p tb-body))
> 
>         (first-go-tag (tb-body)
> 	  ;; Find-if does *not* work cleanly.  It fails
> 	  ;;  to distinguish between a tag named nil
> 	  ;;  and the absence of go tags.  The latter
> 	  ;;  is solely having a preamble in the
> 	  ;;  tagbody form.
> 	  "Returns two values like CL:GETHASH.
> 	  1. First tag.
> 	  2. Whether a tag was found. Relevant in case
> 	  the first return value is NIL.
> 
> 	  Note, that NIL is a valid go-tag."
> 	  (block first-go-tag
> 	    (loop for form in tb-body
> 	      do (if (go-tag-p form)
> 		   (return-from first-go-tag
> 		     (values form t))))
>             (return-from first-go-tag
> 	      (values nil nil))))
>   
>         (split-and-group-tb-body (tb-body)
>           "Returns two values.
>           1. The preamble -- code without a preceding tag
>           2. Grouping of tags and subsequent code."
>  
> 	  (block split-and-group-tb-body
>             (if (null tb-body)
> 	      (return-from split-and-group-tb-body
> 		           (values nil nil)))
>             (let ((acc `((,(first tb-body))))
> 	          (preamble-p (not (go-tag-p (first tb-body)))))
> 	      (loop for tbf in (rest tb-body) do
> 	        (if (go-tag-p tbf)
> 	          (push `(,tbf) acc)
> 	          (push tbf (first acc))))
>               (setf acc (nreverse (mapcar #'nreverse acc)))
> 	      (if preamble-p
> 	        (values (first acc) (rest acc))
> 	        (values nil acc))))))
>      , at body))
> 
> #|
> ;; TESTS
> (with-tagbody-helpers
>   (and (go-tag-p 'foo)
>        (go-tag-p 'bar)
>        (go-tag-p 3)
>        (go-tag-p -9)
> 
>        (not (go-tag-p 1.3))
> 
>        (equal
> 	 (tb-go-tags
> 	   (rest '(tagbody
> 		    (preamble-1-1)
> 		    (preamble-1-2)
> 		   tag1
> 		    (foo)
> 		   tag2
> 		    (bar))))
>          '(tag1 tag2))
> 
>        (eq
> 	 (first-go-tag
> 	   (rest '(tagbody
> 		    (preamble-1-1)
> 		    (preamble-1-2)
> 		   tag1
> 		    (foo)
> 		   tag2
> 		    (bar))))
>          'tag1)
> 
> 	 (multiple-value-bind (preamble grouping)
> 	     (split-and-group-tb-body
> 	       (rest '(tagbody
> 		        (preamble-1-1)
> 		        (preamble-1-2)
> 		       tag1
> 		        (foo)
> 		       tag2
> 		        (bar))))
>            (and
> 	     (equal preamble
> 		    '((preamble-1-1)
> 		      (preamble-1-2)))
> 	     (equal grouping
> 		    '((tag1 (foo))
> 		      (tag2 (bar))))))))
> |#
> 
> 
> 
> (defmacro with-tagbody-parenscript-helpers (&body body)
>   `(with-tagbody-helpers
>      (labels
> 	 ((new-go-bindings (switch-var block-var new-tb-go-tags)
> 	    (mapcar (lambda (go-tag)
> 		      ;; alist
> 		      `(,go-tag
> 			(setf ,switch-var ',go-tag)
> 			(return-from ,block-var)))
> 		    new-tb-go-tags))
> 	 (grouping-to-case-forms (grouped-tb-body
> 				   old-and-new-go-bindings)
> 	    (mapcar (lambda (go-tag-case)
> 	              (destructuring-bind
> 		          (go-tag &rest case-body)
> 			  go-tag-case
> 			`(case ,go-tag
> 		           ;; Handle nested tagbody
> 		           ;;  forms correctly.
> 		           (tagbody-recursive (,old-and-new-go-bindings)
> 		             , at case-body))))
> 	            grouped-tb-body))
> 
> 	  (tb-body-to-switch (outer-block-var
> 	                      inner-block-var
> 			      preamble
>                               grouped-tb-body
> 			      first-tag
> 			      switch-var
> 			      old-and-new-go-bindings)
>             `(block ,outer-block-var
> 	       , at preamble
> 	       (let ((,switch-var ',first-tag))
> 	         (loop do
> 		   (block ,inner-block-var
> 	             (macrolet ((go (go-tag)
> 				  `(progn
> 			             ,@(cdr (assoc
> 					      go-tag
> 					      ',old-and-new-go-bindings)))))
> 		       (switch ,switch-var
> 		         ,@(grouping-to-case-forms
> 			     grouped-tb-body
> 			     old-and-new-go-bindings)))
>                      ;; Fall-through after end of tagbody form
> 	             (return-from ,outer-block-var)))))))
>        , at body)))
> 
> #|
> ;; TESTS
> (with-tagbody-parenscript-helpers
>   (and
>     (let ((switch-1-var '#:switch-1-var)
> 	  (inner-block-1-var '#:inner-block-1-var)
>           (outer-block-1-var '#:outer-block-1-var))
> 
>       (equal
>         (new-go-bindings switch-1-var
>                          inner-block-1-var
> 	                 '(tb-1-tag1 tb-1-tag2))
>         ;; alist
>         `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1)
> 	             (return-from ,inner-block-1-var))
>           (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2)
> 	             (return-from ,inner-block-1-var))))
> 
>       (equal
> 	(grouping-to-case-forms
>           '((tag1 (foo) (tagbody tb-2-tag-1) (hoge))
> 	    (tag2 (bar)))
>           `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1)
> 		       (return-from ,inner-block-1-var))
>             (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2)
> 		       (return-from ,inner-block-1-var))))
>         `((CASE TAG1
> 	    (TAGBODY-RECURSIVE
> 		(((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1)
> 			     (RETURN-FROM ,INNER-BLOCK-1-VAR))
> 	          (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2)
> 			     (RETURN-FROM ,inner-block-1-var))))
>               (FOO)
> 	      (TAGBODY TB-2-TAG-1)
> 	      (HOGE)))
> 	  (CASE TAG2
> 	    (TAGBODY-RECURSIVE
> 		(((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1)
> 			     (RETURN-FROM ,INNER-BLOCK-1-VAR))
>                   (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2)
> 			     (RETURN-FROM ,inner-block-1-var))))
> 	      (BAR)))))
> 
> 
>           (equalp ; Needs #'cl:equalP instead of #'cl:equal.
> 	    (tb-body-to-switch
> 	      outer-block-1-var
> 	      inner-block-1-var
> 	      '((preamble-1-1) (preamble-1-2))
> 	      '((tb-1-tag-1 (foo)
> 			    (tagbody tb-2-tag-1)
> 			    (tagbody tb-1-tag-1) ; Shadows outer tag!
> 			    (hoge))
> 		(tb-1-tag-2 (bar)))
> 	      'tb-1-tag-1
> 	      switch-1-var
> 	      `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1)
> 			    (return-from ,inner-block-1-var))
>                 (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2)
> 			    (return-from ,inner-block-1-var))))
> 
> 	    `(BLOCK ,OUTER-BLOCK-1-VAR
> 	       (PREAMBLE-1-1)
> 	       (PREAMBLE-1-2)
> 	       (LET ((,SWITCH-1-VAR 'TB-1-TAG-1))
> 		 (LOOP DO
> 		   (BLOCK ,INNER-BLOCK-1-VAR
> 		     (MACROLET
> 			 ((GO (GO-TAG)
> 		            `(PROGN
> 			       ,@(CDR
> 				   (ASSOC GO-TAG
> 				          '((TB-1-TAG-1
> 					      (SETF ,switch-1-var 'TB-1-TAG-1)
> 					      (RETURN-FROM ,inner-block-1-var))
> 					    (TB-1-TAG-2
> 					      (SETF ,switch-1-var 'TB-1-TAG-2)
> 					      (RETURN-FROM ,inner-block-1-var))))))))
>                        (SWITCH ,switch-1-var
> 			 (CASE TB-1-TAG-1
> 			   (TAGBODY-RECURSIVE
> 			       (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1)
> 					     (RETURN-FROM ,inner-block-1-var))
> 				 (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2)
> 					     (RETURN-FROM ,inner-block-1-var))))
> 		             (FOO)
> 			     (TAGBODY TB-2-TAG-1)
> 			     (TAGBODY TB-1-TAG-1) ; Shadows outer tag!
> 			     (HOGE)))
> 			 (CASE TB-1-TAG-2
> 			   (TAGBODY-RECURSIVE
> 			       (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1)
> 					     (RETURN-FROM ,inner-block-1-var))
> 				 (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2)
> 					     (RETURN-FROM ,inner-block-1-var))))
> 			     (BAR)))))
>                      (RETURN-FROM ,outer-block-1-var)))))))))
> |#
> 
> 
> 
> (defmacro tagbody-recursive ((&optional outer-go-bindings)
>                              &body body)
>   "Recursion information OUTER-GO-BINDINGS only by
>    nested calls.  Confer recursion flag of #'CL:READ."
>   `(with-tagbody-parenscript-helpers
>      (let ((outer-block-var (gensym (symbol-name 'outer-block-var-)))
>            (inner-block-var (gensym (symbol-name 'inner-block-var-)))
>            (switch-var (gensym (symbol-name 'switch-var-))))
>        (macrolet ((tagbody (&body tb-body)
> 		    (let* ((new-go-tags (tb-go-tags tb-body))
> 			   (first-go-tag (first-go-tag tb-body))
> 			   (old-and-new-go-bindings
> 			     ;; alist
> 	                     (append
> 			       (new-go-bindings switch-var
> 						inner-block-var
> 						new-go-tags)
>                                outer-go-bindings)))
> 		      (multiple-value-bind
> 			  (preamble tb-groups)
>                           (split-and-group-tb-body tb-body)
> 	                (tb-body-to-switch (outer-block-var
> 	                                    inner-block-var
> 			                    preamble
>                                             tb-groups
> 			                    first-go-tag
> 			                    switch-var
> 			                    old-and-new-go-bindings))))))
>          , at body))))
> 
> #|
> ;; TESTS
> |#
> (ql:quickload '(:series
>                 :parenscript
>                 :trivial-macroexpand-all))
> 
> (series::install :shadow t)
> 
> (import '(parenscript:ps
>           parenscript:ps*
> 	  trivial-macroexpand-all:macroexpand-all))
> 
> 
> ;; Explicitly circumvent package lock
> ;;  on package CL to allow shadowing
> ;;  by macrolet for series to paren-
> ;;  script translation.
> (shadow '(tagbody go))
> 
> ;; Default to standard CL form.
> (defmacro tagbody (&body body)
>   "See CL:tagbody."
>   `(cl:tagbody , at body))
> 
> ;; Default to standard CL form.
> (defmacro go (&body body)
>   "See CL:go."
>   `(cl:go , at body))
> 
> 
> (load #p"2022-05-20_defmacro-series-expand.lisp")
> 
> (parenscript:ps*
>   (series-expand
>     (collect (map-fn '(values T T)
> 		     #'floor #z(9 99 999)
> 		     #z(1 2 3)))))
> 
> ;; Problem: Parenscript does *not* know
> ;;  how to compile TAGBODY. Suggestion:
> ;;  compile into (loop (case ...)) with
> ;;  a go-variable where the (case ...)
> ;;  selects between the jump targets.
> ;;  This should be easily made compatible
> ;;  with (series::producing ...) given
> ;;  the additional constraints for
> ;;  series::producing.
> 
> 
> 
> ;; 2022-02-24
> 
> ;; Parenscript example:
> 
> (let ((outer-block-1 (gensym (symbol-name 'outer-block-1-)))
>       (inner-block-1 (gensym (symbol-name 'inner-block-1-)))
>       (switch-var-1 (gensym (symbol-name 'switch-var-1-)))
>       (outer-block-2 (gensym (symbol-name 'outer-block-2-)))
>       (inner-block-2 (gensym (symbol-name 'inner-block-2-))))
>   `(block ,outer-block-1
>      (prologue-1)
>      (let ((,switch-var-1 tagbody-1-first-tag))
>        (loop do
>          (block ,inner-block-1
> 	   (switch ,switch-var-1
> 	     (case tagbody-1-tag-1
> 	       (foo)
> 	       (block ,outer-block-2
> 		 (prologue-2)
> 		 (let ((,switch-var-2 tagbody-2-first-tag))
> 		   (loop do
> 		     (block ,inner-block-2
> 		       (switch ,switch-var-2
> 	                 (case tagbody-2-tag-1)
> 			   ;; inner jump: (go tagbody-2-tag-2)
>                            (progn
> 			     (setf ,switch-var-2 'tagbody-2-tag-2)
> 			     (return-from ,inner-block-2))
> 			   ;; outer jump: (go tagbody-1-tag-2)
>                            (progn
> 			     (setf ,switch-var-1 'tagbody-1-tag-2)
> 			     (return-from ,inner-block-1))
> 	                 (case tagbody-2-tag-2)
>                            ;; Walking off the end of tagbody-2
> 		           (return-from ,outer-block-2))))))
>                ;; Code to skip when jumping from the
> 	       ;;  inner tagbody to a go tag in the
> 	       ;;  outer tagbody. Nevertheless, it has
> 	       ;;  to be run, when walking off the end of
> 	       ;;  the inner tagbody.
> 	       (bar))
> 	       (case tagbody-1-tag-2
> 		 (baz)
>                  ;; Walking off the end of tagbody-1
> 		 (return-from ,outer-block-1))))))))
> 
> 
> 
> |#
> 
> 
> ;; ===============================
> ;; 2022-03-19
> 
> (defmacro with-tagbody-helpers (&body body)
>   `(labels
>        ((go-tag-p (obj)
>           (or (symbolp obj) (integerp obj)))
> 
>         (tb-go-tags (tb-body)
>           (remove-if-not #'go-tag-p tb-body))
> 
>         (first-go-tag (tb-body)
> 	  ;; Find-if does *not* work cleanly.  It fails
> 	  ;;  to distinguish between a tag named nil
> 	  ;;  and the absence of go tags.  The latter
> 	  ;;  is solely having a preamble in the
> 	  ;;  tagbody form.
> 	  "Returns two values like CL:GETHASH.
> 	  1. First tag.
> 	  2. Whether a tag was found. Relevant in case
> 	  the first return value is NIL.
> 
> 	  Note, that NIL is a valid go-tag."
> 	  (block first-go-tag
> 	    (loop for form in tb-body
> 	      do (if (go-tag-p form)
> 		   (return-from first-go-tag
> 		     (values form t))))
>             (return-from first-go-tag
> 	      (values nil nil))))
>   
>         (split-and-group-tb-body (tb-body)
>           "Returns two values.
>           1. The preamble -- code without a preceding tag
>           2. Grouping of tags and subsequent code."
>  
> 	  (block split-and-group-tb-body
>             (if (null tb-body)
> 	      (return-from split-and-group-tb-body
> 		           (values nil nil)))
>             (let ((acc `((,(first tb-body))))
> 	          (preamble-p (not (go-tag-p (first tb-body)))))
> 	      (loop for tbf in (rest tb-body) do
> 	        (if (go-tag-p tbf)
> 	          (push `(,tbf) acc)
> 	          (push tbf (first acc))))
>               (setf acc (nreverse (mapcar #'nreverse acc)))
> 	      (if preamble-p
> 	        (values (first acc) (rest acc))
> 	        (values nil acc))))))
>      , at body))
> 
> #|
> ;; TESTS
> (with-tagbody-helpers
>   (and (go-tag-p 'foo)
>        (go-tag-p 'bar)
>        (go-tag-p 3)
>        (go-tag-p -9)
> 
>        (not (go-tag-p 1.3))
> 
>        (equal
> 	 (tb-go-tags
> 	   (rest '(tagbody
> 		    (preamble-1-1)
> 		    (preamble-1-2)
> 		   tag1
> 		    (foo)
> 		   tag2
> 		    (bar))))
>          '(tag1 tag2))
> 
>        (eq
> 	 (first-go-tag
> 	   (rest '(tagbody
> 		    (preamble-1-1)
> 		    (preamble-1-2)
> 		   tag1
> 		    (foo)
> 		   tag2
> 		    (bar))))
>          'tag1)
> 
> 	 (multiple-value-bind (preamble grouping)
> 	     (split-and-group-tb-body
> 	       (rest '(tagbody
> 		        (preamble-1-1)
> 		        (preamble-1-2)
> 		       tag1
> 		        (foo)
> 		       tag2
> 		        (bar))))
>            (and
> 	     (equal preamble
> 		    '((preamble-1-1)
> 		      (preamble-1-2)))
> 	     (equal grouping
> 		    '((tag1 (foo))
> 		      (tag2 (bar))))))))
> |#
> 
> 
> 
> (defmacro with-tagbody-parenscript-helpers (&body body)
>   `(with-tagbody-helpers
>      (labels
> 	 ((new-go-bindings (switch-var block-var new-tb-go-tags)
> 	    (mapcar (lambda (go-tag)
> 		      ;; alist
> 		      `(,go-tag
> 			(setf ,switch-var ',go-tag)
> 			(return-from ,block-var)))
> 		    new-tb-go-tags))
> 	 (grouping-to-case-forms (grouped-tb-body
> 				   old-and-new-go-bindings)
> 	    (mapcar (lambda (go-tag-case)
> 	              (destructuring-bind
> 		          (go-tag &rest case-body)
> 			  go-tag-case
> 			`(case ,go-tag
> 		           ;; Handle nested tagbody
> 		           ;;  forms correctly.
> 		           (tagbody-recursive (,old-and-new-go-bindings)
> 		             , at case-body))))
> 	            grouped-tb-body))
> 
> 	  (tb-body-to-switch (outer-block-var
> 	                      inner-block-var
> 			      preamble
>                               grouped-tb-body
> 			      first-tag
> 			      switch-var
> 			      old-and-new-go-bindings)
>             `(block ,outer-block-var
> 	       , at preamble
> 	       (let ((,switch-var ',first-tag))
> 	         (loop do
> 		   (block ,inner-block-var
> 	             (macrolet ((go (go-tag)
> 				  `(progn
> 			             ,@(cdr (assoc
> 					      go-tag
> 					      ',old-and-new-go-bindings)))))
> 		       (switch ,switch-var
> 		         ,@(grouping-to-case-forms
> 			     grouped-tb-body
> 			     old-and-new-go-bindings)))
>                      ;; Fall-through after end of tagbody form
> 	             (return-from ,outer-block-var)))))))
>        , at body)))
> 
> #|
> ;; TESTS
> (with-tagbody-parenscript-helpers
>   (and
>     (let ((switch-1-var '#:switch-1-var)
> 	  (inner-block-1-var '#:inner-block-1-var)
>           (outer-block-1-var '#:outer-block-1-var))
> 
>       (equal
>         (new-go-bindings switch-1-var
>                          inner-block-1-var
> 	                 '(tb-1-tag1 tb-1-tag2))
>         ;; alist
>         `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1)
> 	             (return-from ,inner-block-1-var))
>           (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2)
> 	             (return-from ,inner-block-1-var))))
> 
>       (equal
> 	(grouping-to-case-forms
>           '((tag1 (foo) (tagbody tb-2-tag-1) (hoge))
> 	    (tag2 (bar)))
>           `((tb-1-tag1 (setf ,switch-1-var 'tb-1-tag1)
> 		       (return-from ,inner-block-1-var))
>             (tb-1-tag2 (setf ,switch-1-var 'tb-1-tag2)
> 		       (return-from ,inner-block-1-var))))
>         `((CASE TAG1
> 	    (TAGBODY-RECURSIVE
> 		(((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1)
> 			     (RETURN-FROM ,INNER-BLOCK-1-VAR))
> 	          (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2)
> 			     (RETURN-FROM ,inner-block-1-var))))
>               (FOO)
> 	      (TAGBODY TB-2-TAG-1)
> 	      (HOGE)))
> 	  (CASE TAG2
> 	    (TAGBODY-RECURSIVE
> 		(((TB-1-TAG1 (SETF ,SWITCH-1-VAR 'TB-1-TAG1)
> 			     (RETURN-FROM ,INNER-BLOCK-1-VAR))
>                   (TB-1-TAG2 (SETF ,switch-1-var 'TB-1-TAG2)
> 			     (RETURN-FROM ,inner-block-1-var))))
> 	      (BAR)))))
> 
> 
>           (equalp ; Needs #'cl:equalP instead of #'cl:equal.
> 	    (tb-body-to-switch
> 	      outer-block-1-var
> 	      inner-block-1-var
> 	      '((preamble-1-1) (preamble-1-2))
> 	      '((tb-1-tag-1 (foo)
> 			    (tagbody tb-2-tag-1)
> 			    (tagbody tb-1-tag-1) ; Shadows outer tag!
> 			    (hoge))
> 		(tb-1-tag-2 (bar)))
> 	      'tb-1-tag-1
> 	      switch-1-var
> 	      `((tb-1-tag-1 (setf ,switch-1-var 'tb-1-tag-1)
> 			    (return-from ,inner-block-1-var))
>                 (tb-1-tag-2 (setf ,switch-1-var 'tb-1-tag-2)
> 			    (return-from ,inner-block-1-var))))
> 
> 	    `(BLOCK ,OUTER-BLOCK-1-VAR
> 	       (PREAMBLE-1-1)
> 	       (PREAMBLE-1-2)
> 	       (LET ((,SWITCH-1-VAR 'TB-1-TAG-1))
> 		 (LOOP DO
> 		   (BLOCK ,INNER-BLOCK-1-VAR
> 		     (MACROLET
> 			 ((GO (GO-TAG)
> 		            `(PROGN
> 			       ,@(CDR
> 				   (ASSOC GO-TAG
> 				          '((TB-1-TAG-1
> 					      (SETF ,switch-1-var 'TB-1-TAG-1)
> 					      (RETURN-FROM ,inner-block-1-var))
> 					    (TB-1-TAG-2
> 					      (SETF ,switch-1-var 'TB-1-TAG-2)
> 					      (RETURN-FROM ,inner-block-1-var))))))))
>                        (SWITCH ,switch-1-var
> 			 (CASE TB-1-TAG-1
> 			   (TAGBODY-RECURSIVE
> 			       (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1)
> 					     (RETURN-FROM ,inner-block-1-var))
> 				 (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2)
> 					     (RETURN-FROM ,inner-block-1-var))))
> 		             (FOO)
> 			     (TAGBODY TB-2-TAG-1)
> 			     (TAGBODY TB-1-TAG-1) ; Shadows outer tag!
> 			     (HOGE)))
> 			 (CASE TB-1-TAG-2
> 			   (TAGBODY-RECURSIVE
> 			       (((TB-1-TAG-1 (SETF ,switch-1-var 'TB-1-TAG-1)
> 					     (RETURN-FROM ,inner-block-1-var))
> 				 (TB-1-TAG-2 (SETF ,switch-1-var 'TB-1-TAG-2)
> 					     (RETURN-FROM ,inner-block-1-var))))
> 			     (BAR)))))
>                      (RETURN-FROM ,outer-block-1-var)))))))))
> |#
> 
> 
> 
> (defmacro tagbody-recursive ((&optional outer-go-bindings)
>                              &body body)
>   "Recursion information OUTER-GO-BINDINGS only by
>    nested calls.  Confer recursion flag of #'CL:READ."
>   `(with-tagbody-parenscript-helpers
>      (let ((outer-block-var (gensym (symbol-name 'outer-block-var-)))
>            (inner-block-var (gensym (symbol-name 'inner-block-var-)))
>            (switch-var (gensym (symbol-name 'switch-var-))))
>        (macrolet ((tagbody (&body tb-body)
> 		    (let* ((new-go-tags (tb-go-tags tb-body))
> 			   (first-go-tag (first-go-tag tb-body))
> 			   (old-and-new-go-bindings
> 			     ;; alist
> 	                     (append
> 			       (new-go-bindings switch-var
> 						inner-block-var
> 						new-go-tags)
>                                outer-go-bindings)))
> 		      (multiple-value-bind
> 			  (preamble tb-groups)
>                           (split-and-group-tb-body tb-body)
> 	                (tb-body-to-switch (outer-block-var
> 	                                    inner-block-var
> 			                    preamble
>                                             tb-groups
> 			                    first-go-tag
> 			                    switch-var
> 			                    old-and-new-go-bindings))))))
>          , at body))))
> 
> #|
> ;; TESTS
> |#



More information about the parenscript-devel mailing list