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