;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: GOSUB for Lisp
;;   Created: 2021-02-03
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2021 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(defpackage :gosub
  (:use :common-lisp)
  (:shadow #:go #:return #:tagbody))

(in-package :gosub)

;;;; GOSUB for Common Lisp

;; So finally you could have subroutines in Lisp! We extend TAGBODY to
;; also have GOSUB and RETURN.

;; The idea is to turn a TAGBODY into a LABELS. Each tag is turned
;; into a local function. A GO then is an invokation of one of these
;; local functions. These local functions (unless there is RETURN) do
;; not return but always have another GO in tail position.

;; To ensure that a GO is in tail position, we wrap a BLOCK around the
;; body of a local function and say:

;;   (GO tag)  => (PROGN (tag-fun) (RETURN-FROM block))

;; A GOSUB is a tag that can return and we say:

;;   (GOSUB tag) => (tag-fun)

;; RETURN now simply is to make the current block return

;;   (RETURN) => (RETURN-FROM block)

;;;; Implementation

(defmacro tagbody (&body body &environment env)
  (let ((start (gensym "START."))
        (end (gensym "END."))
        (block-name (gensym "BLOCK."))
        funs
        tagmap)
    ;; Parse the TAGBODY body into local function definitions for
    ;; LABELS (funs) and a mapping of tag names to local function
    ;; names (tagmap). A mandatory start tag (start) is inserted and a
    ;; final CL:GO to an end CL tag. We do this in reverse because
    ;; that is easier.
    (let (cur-body)
      (dolist (form (cons `(cl:go ,end)
                          (reverse (cons start body))))
        (cond ((atom form)
               (when (assoc form tagmap)
                 (error "Duplicate tag - ~S" form))
               (let ((name (make-symbol (format nil "L.~A" form))))
                 (push (cons form name) tagmap)
                 (push `(,name () (block ,block-name ,@cur-body))
                       funs)
                 (setq cur-body (list `(,name)))))
              (t
               (push form cur-body)))))
    ;;
    (let ((whole (gensym "WHOLE."))
          (tag (gensym "TAG."))
          (q (gensym "Q.")))
      `(CL:TAGBODY
          (MACROLET
              ((GOSUB (&WHOLE ,whole ,tag)
                 (LET ((,q (ASSOC ,tag ',tagmap)))
                   (COND ((NULL ,q)
                          (MACROEXPAND ,whole ',env))
                         (T
                          `(,(CDR ,q))))))
               (GO (&WHOLE ,whole ,tag)
                 (LET ((,q (ASSOC ,tag ',tagmap)))
                   (COND ((NULL ,q)
                          (MACROEXPAND ,whole ',env))
                         (T
                          `(PROGN
                             (,(CDR ,q))
                             (RETURN-FROM ,',block-name))))))
               (RETURN ()
                 `(RETURN-FROM ,',block-name)))
            ;;
            (LABELS ,funs
              (,(cdr (assoc start tagmap)))
              (error "~S without ~S." '(return) 'gosub)))
          ,end))))

(defmacro go (tag)
  (error "Cannot ~S to tag ~S." 'go tag))

(defmacro gosub (tag)
  (error "Cannot ~S to tag ~S." 'gosub tag))

(defmacro return ()
  (error "~S outside ~S." 'return 'tagbody))

;;;; Pointless demo

(defun foo (&aux (i 0) s d n)
  (tagbody
     (setq n 10)
     (gosub foo)
     (go end)

   foo
     ;; TAGBODYs nest
     (tagbody
        (setq i 0 s 0 d 0)
      10
        (gosub bar)                     ;we can call outer
                                        ;subroutines.
        (incf i)
        (when (< i n)
          (go 10)))
     (return)

   bar
     (print `(s = ,s))
     (gosub incs)
     (incf d)
     (return)

   incs
     (incf s d)
     (return)
   end))