Let Over Lambda nlet-tail

;; this macro writes a macro which evaluates the arguments, updates the bindings and jumps out to a tagbody label when called.
;; the code generated by that macro, combined with the tagbody block, essentially forms a recursive call.
;; when the recursive call ends, we jump out to a block label in order to return the result of the final function call,
;; rather than letting the tagbody wind down - because tagbody always returns nil.
(defmacro! nlet-tail (n letargs &rest body)
  (let ((gs (loop for i in letargs
                  collect (gensym))))
    `(macrolet ;; this backquote is generated by the macro and hence actually executed
         ((,n ,gs ;; here we don't gensym n, because we want it to be lexically available in the ,@body
            `(progn ;; this backquote represents what is returned by the macro we just defined (n, or fact below)
               (psetq ;; psetq evaluates pairs all at once (psetq a 1 b 2 c 3)
                ,@(apply #'nconc
                         ;; here, we are doing multi-arg mapcar with list to perform a zip
                         ;; (apply #'nconc (mapcar #'list '(a b c) (list 1 2 3)))
                         ;; => (A 1 B 2 C 3)
                         (mapcar
                          #'list
                          ',(mapcar #'car letargs)
                          (list ,@gs))))
               ;; having generated code to set all the letargs to the values provided by the letargs,
               ;; we now generate the code to GOTO the inner tagbody
               ;; go expects a label, and we're interested in ,g!n. So we have to unquote to execute it, then quote the thing we want to return
               (go ,',g!n)))) ;; go is a GOTO to the named tag inside tagbody
       ;; ok, now the macro is defined we fill out the body
       (block ,g!b ;; this is skipped on first run through, but is generated so we have a nice way to escape. we gensym it to avoid capture
         (let ,letargs
           (tagbody ,g!n
              (return-from ,g!b ;; when this finishes executing, we jump out to block
                ;; however, arguments are eagerly evaluated! So it has to run the body first.
                ;; recursive calls in the body will jump us back to the tagbody, meaning the return doesn't happen until
                ;; body terminates. Much better than having to check a return value every time!
                (progn ,@body))))))))

(defun nlet-tail-fact (n)
  (nlet-tail fact ((n n) (acc 1))
             (if (zerop n)
                 acc
                 (fact (- n 1) (* acc n)))))

;; OTHER BITS

;; probably won't work unless you have a very old lisp
#-sbcl
(defun flatten (x)
  (inspect x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec
                       (car x)
                       (rec (cdr x) acc))))))
    (rec x nil)))

;; https://stackoverflow.com/questions/33724300/macros-that-write-macros-compile-error
;; need to match the sb-impl::comma struct explicitly
#+sbcl
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((eq (type-of x) 'sb-impl::comma)
                    (rec (sb-impl::comma-expr x) acc))
                   ((atom x) (cons x acc))
                   (t (rec
                       (car x)
                       (rec (cdr x) acc))))))
    (rec x nil)))


(defun g!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "G!"
                :start1 0
                :end1 2)))


(defun o!-symbol-p (s)
  (and (symbolp s)
       (> (length (symbol-name s)) 2)
       (string= (symbol-name s)
                "O!"
                :start1 0
                :end1 2)))

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a  args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defun o!-symbol-to-g!-symbol (s)
  (symb "G!"
        (subseq (symbol-name s) 2)))

(defmacro defmacro/g! (name args &rest body)
  (let ((syms (remove-duplicates
               (remove-if-not #'g!-symbol-p
                              (flatten body)))))
    `(defmacro ,name ,args
       (let ,(mapcar
              (lambda (s)
                `(,s (gensym ,(subseq
                               (symbol-name s)
                               2))))
              syms)
         ,@body))))


(defmacro defmacro! (name args &rest body)
  ;; first, convert all the o!s to g!s, so we can pass it on
  (let* ((os (remove-if-not #'o!-symbol-p args))
         (gs (mapcar #'o!-symbol-to-g!-symbol os)))
    `(defmacro/g! ,name ,args
       `(let ,(mapcar #'list (list ,@gs) (list ,@os))
          ,(progn ,@body)))))