;;; nlet.el --- schemes 'named let' for emacs.
;;
;; ~/share/emacs/jhg/nlet.el ---
;;
;; $Id: nlet.el,v 1.11 2011/11/26 22:34:42 harley Exp $
;;

;; Author:    harley@panix.com
;; Licence:   GPL v2 (or later)
;; Url:       http://www.mahalito.net/~harley/elisp/nlet.el
;; Version:   $Revision: 1.11 $
;; Package-Requires:

;;; Commentary:
;;
;; Wrote this to have scheme's "named let" (r5rs 4.2.4) in elisp.

;;; History:
;; Written for fun.

;;; Code:

(defvar nlet:check-arg-cnt t)

(defmacro nlet (name vars &rest body)
  "(nlet NAME VARS BODY) -- Schemes 'named let' for emacs."
  (declare (indent defun))
  (if (not (symbolp name))
    (error "nlet requires the name tobe a symbol."))
  (nlet:expand name vars body))
;; (nlet nil nil nil)
;; (nlet 1 nil nil)

(defun nlet:expand (name var-exps sexps)
  "Expand the nlet macro with NAME VAR-EXPS SEXPS."
  ;; written as a defun for ease of debugging.
  (let ((tag-loop (gensym "nlet-loop-"))
        (tag-exit (gensym "nlet-exit-"))
        (vars (mapcar 'car var-exps)))
    `(let ,var-exps
       (catch ',tag-exit
         (while t ;; keep doing the loop
           (catch ',tag-loop
             (throw ',tag-exit ;; terminate when the progn returns a value
                    (progn
                      ,@(nlet:add-throw name tag-loop vars sexps)))))))))

(defun nlet:add-throw (name tag vars sexp)
  "Walk the body of an nlet form and rewrite calls to NAME.
Calls to the loop are rewritten into a series of setqs followed
by a throw to the loop catch which the 'while' will run again.
Argument TAG the tag to thow to.
Argument VARS list of vars.
Argument SEXP the body forms."
  ;; This needs to be a defun so we can recurse.
  ;; Maybe it could be a "label" function of nlet:expand?...
  (cond
   ((null name) ;; dont bother when no name.
    sexp)
   ((and (listp sexp) (equal 'quote (car sexp))) ;; quoted form
    sexp)
   ((and (listp sexp) (equal name (car sexp))) ;; a call to our name...
    ;; ...replace call to name with setq/throw
    `(progn
       ,@(let ((vlst vars) (elst (cdr sexp)) (slst nil))
           (when nlet:check-arg-cnt ;; enforce matching arg counts?
             (if (not (= (length vlst) (length elst)))
               (error "nlet: form: '%s' vars: '%s'  args: '%s'"
                      sexp vlst elst)))
           (while vlst
             (setq slst (cons `(setq ,(car vlst) ,(car elst)) slst))
             (setq vlst (cdr vlst)
                   elst (cdr elst)))
           (nreverse slst))
       (throw ',tag nil)))
   ((listp sexp) ;; some list of forms
    (mapcar '(lambda (e) (nlet:add-throw name tag vars e)) sexp))
   (t ;; everything else
    sexp)))

;; For testing...
(defun nlet:run-tests ()
  "Run some simple tests of nlet."
  ;; simple
  (assert (equal 1 (nlet a ((x 1)) 'a x)))
  (assert (equal 2 (nlet nil nil 2)))
  ;; bigger
  (let ((cnt 1000)
        (a   'unset))
    (assert
     (equal
      'end
      (nlet foo ((a 10) (b 0))
        (when (<= 0 a)
          (message "a=%s b=%s cnt=%s" a b cnt)
          '(foo 1 2 3) ;; shouldnt be expanded
          (setq cnt (1+ cnt))
          (foo (- a 1) (1+ b)))
        'end)))
    (assert (equal cnt   1011))
    (assert (equal a   'unset)))
  t)
;; (nlet:run-tests)

;; throws an error
;; (jhg-macroexpand (nlet foo ((a 1) (b 2)) (foo) (foo 11 22 33)))

(provide 'nlet)

;;; nlet.el ends here