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