Plaster

#+(or)(series::install :macro t :shadow t) (cl:defpackage TAGBODY-PS (:use cl) (:import-from parenscript:ps parenscript:ps* ;; parenscript:switch also needs parenscript:break, ;; but this clashes with cl:break. parenscript:switch parenscript:defpsmacro #+(or)series-expand:series-expand)) (in-package "TAGBODY-PS") (defun gensymsn (sym) (gensym (symbol-name sym))) #| ;; (SETF name) in (FLET ...) (let ((bla 3)) (flet ((get-bla () bla) ((setf get-bla) (new-val) (setf bla new-val))) (list bla (get-bla) (setf (get-bla) 4) (get-bla) bla))) |# #| What about copy-on-write handlers? |# (defmacro with-go-tag-data-structure-helpers (&body body) "The helpers are modelled after constructor, predicate, copier, selectors, mutators, readers, writers and accessors provided by (cl:defstruct ...). The printed representation is that of lists. Use a list-based data structure for the information associated with go-tags, so that the translation code can be compiled to other programming languages more easily. CL structures and CL classes may not have nice compilation targets as opposed to a property list (plist) or an association list (alist) and the related helpers. Remember (cl:with-slots ...) and (cl:with-accessors ...). Fields / Information: 1. go-tag: a CL GO tag, so a symbol or an integer 2. switch-var: a symbol, usually a gensym 3. block-var: a symbol, usually a gensym 4. case-counter: an integer Examples: (with-go-tag-data-structure-helpers (make-go-tag-info :go-tag 'foo :switch-var (gensym \"switch-\") :block-var (gensym \"block-\"))) (with-go-tag-data-structure-helpers (go-tag-info-p (make-go-tag-info :go-tag 'foo :switch-var (gensym \"switch-\") :block-var (gensym \"block-\")))) (with-go-tag-data-structure-helpers (copy-go-tag-info (make-go-tag-info :go-tag 'foo :switch-var (gensym \"switch-\") :block-var (gensym \"block-\")))) Constructor: (make-go-tag-info &key go-tag switch-var block-var case-counter) Predicate: (go-tag-info-p ...) Copier: (copy-go-tag-info ...) Readers / Selectors: (go-tag-info-go-tag ...) (go-tag-info-switch-var ...) (go-tag-info-block-var ...) (go-tag-info-case-counter ...) Writers / Mutators: (setf (go-tag-info-go-tag ...) new-go-tag) (setf (go-tag-info-switch-var ...) new-switch-var) (setf (go-tag-info-block-var ...) new-block-var) (setf (go-tag-info-case-counter ...) new-case-counter) Accessors: (go-tag-info-go-tag ...) (go-tag-info-switch-var ...) (go-tag-info-block-var ...) (go-tag-info-case-counter ...)" ;; Implementation note: Use macros and symbol-macros ;; so that (cl:setf ...) works without additional ;; implementation overhead. `(flet ((make-go-tag-info (&key go-tag switch-var block-var case-counter) "" (check-type go-tag (or symbol integer)) (check-type switch-var symbol) (check-type block-var symbol) (check-type case-counter integer) `('go-tag-info :go-tag ,go-tag :switch-var ,switch-var :block-var ,block-var :case-counter ,case-counter) #|`(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))|#) (go-tag-info-p (obj) "Don't force the order of the plist keys." (and (listp obj) (eq 'go-tag-info (first obj)) ;; Quicker check for (= (length obj) 9) (let ((tail (nthcdr (1- 9) obj))) (and tail (not (cdr tail)))) (let ((data-plist (cdr obj))) (and (typep (getf data-plist :go-tag) '(or symbol integer)) (typep (getf data-plist :switch-var) 'symbol) (typep (getf data-plist :block-var) 'symbol) (typep (getf data-plist :case-counter) 'integer))) ;; Return OBJ upon success for function chaining. obj)) (copy-go-tag-info (go-tag-info) (copy-seq go-tag-info)) (go-tag-info-go-tag (go-tag-info) (destructuring-bind (_go-tag-info-symbol &key go-tag &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) go-tag)) ((setf go-tag-info-go-tag) (new-go-tag go-tag-info) (destructuring-bind (_go-tag-info-symbol &key go-tag &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) (setf go-tag new-go-tag))) (go-tag-info-switch-var (go-tag-info) (destructuring-bind (_go-tag-info-symbol &key switch-var &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) switch-var)) ((setf go-tag-info-switch-var) (new-switch-var go-tag-info) (destructuring-bind (_go-tag-info-symbol &key switch-var &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) (setf switch-var new-switch-var))) (go-tag-info-block-var (go-tag-info) (destructuring-bind (_go-tag-info-symbol &key block-var &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) block-var)) ((setf go-tag-info-block-var) (new-block-var go-tag-info) (destructuring-bind (_go-tag-info-symbol &key block-var &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) (setf block-var new-block-var))) (go-tag-info-case-counter (go-tag-info) (destructuring-bind (_go-tag-info-symbol &key case-counter &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) case-counter) #|(error "Currently unimplemented.")|#) ((setf go-tag-info-case-counter) (new-case-counter go-tag-info) (destructuring-bind (_go-tag-info-symbol &key case-counter &allow-other-keys) go-tag-info (declare (ignore _go-tag-info-symbol)) (setf case-counter new-case-counter)) #|(error "Currently unimplemented.")|#)) ,@body)) #+() (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 (gensymsn 'outer-block-1-)) (inner-block-1 (gensymsn 'inner-block-1-)) (switch-var-1 (gensymsn 'switch-var-1-)) (outer-block-2 (gensymsn 'outer-block-2-)) (inner-block-2 (gensymsn '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 ;;;; Needs to be a lisp instead of a parenscript macro, ;;;; because (parenscript:defpsmacro ...) is a ;;;; lisp form instead of a parenscript form. (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)))))))) |# ;;;; Needs to be a lisp instead of a parenscript macro, ;;;; because (parenscript:defpsmacro ...) is a ;;;; lisp form instead of a parenscript form. (defmacro with-tagbody-parenscript-helpers (&body body) `(with-tagbody-helpers (labels ((new-go-bindings (switch-var block-var last-case-counter new-tb-go-tags) (mapcar (lambda (go-tag case-counter) ;; List of list structures. Use similar to an alist. (with-go-tag-data-structure-helpers (make-go-tag-info :go-tag go-tag :switch-var switch-var :block-var block-var :case-counter case-counter)) ;; alist #|`(,go-tag (setf ,switch-var ',go-tag) (return-from ,block-var))|#) new-tb-go-tags (loop for i from (1+ last-case-counter) repeat (length new-tb-go-tags) collect i))) (grouping-to-case-forms (grouped-tb-body new-case-counter old-and-new-go-bindings) (mapcar (lambda (go-tag-case) (destructuring-bind (go-tag &rest case-body) go-tag-case `(,(with-go-tag-data-structure-helpers ; ,go-tag (go-tag-info-case-counter (find go-tag ;; Sorted newest to oldest. old-and-new-go-bindings :key #'go-tag-info-go-tag))) ,(format nil "tagbody-go-tag: ~A" go-tag) ;; Handle nested tagbody ;; forms correctly. (tagbody-recursive (,old-and-new-go-bindings ,new-case-counter) ,@case-body)))) grouped-tb-body)) (tb-body-to-switch (outer-block-var inner-block-var preamble grouped-tb-body first-tag switch-var new-case-counter old-and-new-go-bindings) `(block ,outer-block-var ,@preamble (parenscript:let ((,switch-var ,(with-go-tag-data-structure-helpers (go-tag-info-case-counter (find first-tag ;; Sorted newest to oldest. old-and-new-go-bindings :key #'go-tag-info-go-tag))))) (loop do (block ,inner-block-var (parenscript:macrolet ((go (go-tag) (with-go-tag-data-structure-helpers (let ((gti (find go-tag ',old-and-new-go-bindings :key #'go-tag-info-go-tag))) `(progn ,(format nil "GOTO/JMP tagbody-go-tag: ~A" go-tag) (setf ,(go-tag-info-switch-var gti) ,(go-tag-info-case-counter gti)) (return-from ,(go-tag-info-block-var gti))))) #|`(progn ,@(cdr (assoc go-tag ',old-and-new-go-bindings)))|#)) ;;#+sbcl #+() (declare (sb-ext:disable-package-locks cl:go)) (switch ,switch-var ,@(grouping-to-case-forms grouped-tb-body new-case-counter 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))) ;; TODO 2023-01-21: Update for new-case-counter. `((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 ;; TODO 2023-01-21: Update for new-case-counter. `((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))))))))) |# ;; At some point I need the PS-macro TAGBODY. ;; Note, that the PS-macro must return valid ;; JavaScript code. This means that the lisp ;; macro-expansion has to occur before a list ;; is returned from the PS-macro. Maybe using ;; macroexpand-all and a strategy similar to ;; cl-who-gzip works here too. ;; ;; Needs to be a parenscript macro, because it ;; create a lexical macro-binding for (tagbody ...) ;; which is supposed to be macroexpanded ;; by parenscript's compiler. (defpsmacro tagbody-recursive ((&optional outer-go-bindings (last-case-counter 0)) &body body) "Recursion information OUTER-GO-BINDINGS only by nested calls. Confer recursion flag of #'CL:READ. Also known as: with-tagbody-for-parenscript-recursive." (let ((outer-block-var (gensymsn 'outer-block-var-)) (inner-block-var (gensymsn 'inner-block-var-)) (switch-var (gensymsn 'switch-var-))) `(parenscript:macrolet ((tagbody (&body tb-body) (with-tagbody-parenscript-helpers (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 ;; Self-evaluating integer. ;; No quoting necessary. ,last-case-counter new-go-tags) ',outer-go-bindings))) ;;(format t "new go tags: ~A~%" new-go-tags) ;;(format t "first go tag: ~A~%" first-go-tag) ;;(format t "old and new bindings: ~A~%" old-and-new-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 ;; Self-evaluating integer. ;; No quoting necessary. (+ ,last-case-counter (length new-go-tags)) old-and-new-go-bindings)))))) ,@body))) ;; Needs to be a parenscript macro, because it ;; create a macro-binding for (tagbody ...) ;; which is supposed to be macroexpanded ;; by parenscript's compiler. (defpsmacro tagbody (&body tb-body) `(tagbody-recursive () ; empty tagbody bindings ;; lexical (tagbody ...) form ;; established by (parenscript:macrolet ...) (tagbody ,@tb-body))) #| ;; TESTS |# #+() (parenscript:ps* (series-expand '(collect (map-fn '(values T T) #'floor #z(9 99 999) #z(1 2 3))))) #+() (parenscript:ps* `(tagbody-recursive () ,@(series-expand '(collect (map-fn '(values T T) #'floor #z(9 99 999)) #z(1 2 3))))) #+() (parenscript::ps-macroexpand-1 '(tagbody a 1 b 2 (go a) c 3)) #+() (parenscript::ps-macroexpand-1 '(tagbody a 1 b 2 (go a) c 3)) #+() (parenscript::ps* '(tagbody a 1 b 2 (go a) c 3)) #+() (parenscript::ps-macroexpand-1 '(tagbody a 1 b (tagbody x (go c) y (go z) z) 2 (go a) c 3)) #+() (parenscript::ps* '(tagbody a 1 b (tagbody x (go c) y (go z) z) 2 (go a) c 3)) #+() (parenscript::ps* '(tagbody (preamble-1) a 1 b (tagbody x (go c) y (go z) z) 2 (go a) c 3)) #+() (parenscript::ps* '(tagbody (preamble-1) a 1 b (tagbody (preamble-2) x (go c) y (go z) z) 2 (go a) c 3))