いわゆるgotoの一般系として、末尾じゃなくてもTCOありで関数呼び出しする語彙があると、何かの役に立つかもしれない。立ったら良いなぁ。


というわけで、named-letの亜種としてlocal-functionなるものを組んでみた。
local-function で定義する局所関数fの中で
(no-return (f ...))
とすると、C言語でいうfor文中でのcontinueを一般化したような動作をする。

本来の目標は複数の(局所)関数群で相互に行き来できるものだが、それはnamed-letではなくlabelsの亜種として構成するべきか。

```cl
(defvar *local-function-verbose-debug* nil
  "To enable dissassemble each internal function definition in a LOCAL-FUNCTION macro" )

#+clisp   ; for clisp interpreter
(defvar *local-function-force-eliminate-tail-call* nil
  "To enable force to eliminate tail call" )

(defmacro local-function (name (&rest bindings) &body body)
  "LOCAL-FUNCTION enables to describe and execute recuresive local function
  which is similar to the named-let in Scheme language.
  
  LOCAL-FUNCTION supports NO-RETURN function call feature, which will be
  translated into a GO expression.
  NO-RETUREN can be located anywhere upon local-function body.
  
  NOTE: jus on this implementation, NO-RETURN not supported to call other
  functions.

  NOTE: TCO for non NO-RETURN style recursive call is not guaranteed.

  LOCAL-FUNCTION also supports GLOBAL-EXIT-FROM-LOCAL-FUNCTION, similar to
  RETURN, for global exit from a local function.

  e.g.
  (defun fx (x)
    (declare (integer x))
    (local-function f ((i x)) (sum 0)
      (declare (integer i sum))
      (when (> i 0)
        (no-return (f (the integer (1- i)) (the integer (+ sum i)))) )
      (format t \"~&SUM is ~a~%\" sum)
      (global-exit-from-local-function sum) ))  ; or, just sum

  will be expanded to

  (defun fx (x)
    (declare (integer x))
    (block #1=#:G1
      (labels
        ((f (i sum) (declare (integer i sum))
           (tagbody #2=#:G2
             (return-from f
               (progn
                 (if (> i 0)
                   (progn
                     (psetq i (the integer (1- i))
                            sum (the integer (+ sum i)))
                     (go #2#) ))
                 (format t \"~&SUM is ~a~%\" sum)
                 (return-from #1# sum) )))))    ; or, just sum
        (f x 0) )))

  and enable to execute pseudo recursive call deeper than deeper.

  > (fx 100000000)
  SUM is 5000000050000000
  5000000050000000
  > "
  ;; helper functions
  (labels ((valid-binding-p (binding)
             "check valid LET binding or not"
             (or (and (symbolp binding) binding)
                 (and (consp binding)
                      (symbolp (car binding))
                      (null (cddr binding)) )))
           ;;
           (separate-pairs (lst)
             "separate LET style variable bindings"
             (loop for elm in lst
                   for (var val) = (if (valid-binding-p elm)
                                     (if (symbolp elm) (list elm) elm)
                                     (error "invalid binding form: ~a" elm) )
                   collect var into var-acc
                   collect val into val-acc
                   finally (return (values var-acc val-acc)) ))
           ;;
           (declare-p (form)
             (and (consp form)
                  (symbolp (car form))
                  (eq (car form) 'cl:declare) ))
           ;;
           (separate-declarations (form)
             "separate declarations and a documentation from entire body.
              this helper function returns 3 lists with VALUES;
              list of documentations, list of declarations and list of forms."
             (if (atom form)
               (values nil nil form)
               (loop for elm in form with body-p = nil
                     ;; check documentations
                     if (and (not body-p) (stringp elm))
                       collect elm into acc-doc
                     ;; check declarations
                     else if (declare-p elm)
                       if body-p
                         do (error "invalid location for declarations: ~a" elm)
                       else
                         collect (cdr elm) into acc-decl
                       end
                     ;; collect body
                     else
                       collect elm into acc-form and do (setq body-p 1)
                     end
                     finally (return (values acc-doc acc-decl acc-form)) )))
             ;;
             #+clisp  ; optional; just for TCO manually
             (eliminate-tail-recursion (start-tag lambda-list tail-form)
               ;; leave form as it is when force-elimination not required
               (unless *local-function-force-eliminate-tail-call*
                 (return-from eliminate-tail-recursion tail-form) )
               ;; check and eliminate tail recursions
               (let ((form (macroexpand tail-form)))
                 (when form
                   (if (listp form)
                     (if (eq (car form) name)
                       ;; eliminate a tail recursive call
                       `(progn
                          (psetq ,@(mapcan (lambda (var val) `(,var ,val))
                                           lambda-list (cdr form) ))
                          (go ,start-tag) )
                       ;; check some sort of forms
                       (case (car form)
                         ((if)
                          ;; process conditional expr
                          `(if ,(cadr form)
                             ,@(mapcar (lambda (elm)
                                         (eliminate-tail-recursion
                                           start-tag lambda-list elm ))
                                       (cddr form) )))
                         ((let let* block tagbody progn catch the)
                          ;; process block code
                          `(,@(butlast form)
                             ,(eliminate-tail-recursion
                                start-tag lambda-list
                                (car (last form)) )))
                         ((flet labels) form) ; reserved
                         ((progn) form)       ; reserved
                         (otherwise form) ))  ; not tail recursive, maybe
                     ;; not a list
                     form )) )))
    ;; do parse local-function
    (multiple-value-bind (lambda-list init-params) (separate-pairs bindings)
      (let ((gs (mapcar (lambda (x) (gensym (symbol-name x))) lambda-list))
            (exit-val  (gensym "EXIT-VALUE-"))
            (block-tag (gensym "BLOCK-TAG-"))
            (start-tag (gensym "START-TAG-"))
            (nr-fn     (gensym "NO-RETURN-FN-")) )
        (multiple-value-bind (doc decls body) (separate-declarations body)
          ;; make customized macrolets
          `(macrolet ((no-return ((,nr-fn ,@gs))
                        "to be translated into GO expr with update"
                        (unless (eq ,nr-fn ',name)
                          (error
                            "not supported general TCO: jump from ~a into ~a"
                            ',name ,nr-fn ))
                        `(progn
                           (psetq ,@(mapcan ,(lambda (var val) `(,var ,val))
                                            ',lambda-list (list ,@gs) ))
                           (go ,',start-tag) ))
                      ;;
                      (global-exit-from-local-function (,exit-val)
                        "for global exit from LOCAL-FUNCTION execution"
                        `(return-from ,',block-tag ,,exit-val) ))
             ;; expand local-function
             ;; global block for a LOCAL-FUNCTION expr
             (block ,block-tag  ; for global exit from a local function
               (labels ((,name ,lambda-list
                          ;; allocate declarations and a documentation
                          (declare ,@(mapcan #'identity decls))
                          ,@doc
                          ;; allocate function body
                          (tagbody
                            ,start-tag  ; for no-return and tail recursion
                            (return-from ,name
                              (progn
                                ,@(butlast body)
                                ,(eliminate-tail-recursion
                                   start-tag lambda-list
                                   (car (last body)) ))) )))
                 ;; for debug
                 ,@(when *local-function-verbose-debug*
                     `((disassemble #',name) (terpri)) )
                 ;; execute local function
                 (,name ,@init-params) ))))))))

```