;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;; *********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
;;; *********************************************************************

(in-package "SI")


#+ecl-min
(defmacro handler-bind (bindings &body body)
  `(progn ,@body))


;;;; The Collect macro:

;;; Collect-Normal-Expander  --  Internal
;;;
;;;    This function does the real work of macroexpansion for normal
;;; collection macros.  N-Value is the name of the variable which
;;; holds the current value.  Fun is the function which does
;;; collection.  Forms is the list of forms whose values we are
;;; supposed to collect.
;;;
(defun collect-normal-expander (n-value fun forms)
  `(progn
    ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
    ,n-value))

;;; Collect-List-Expander  --  Internal
;;;
;;;    This function deals with the list collection case.  N-Tail is
;;; the pointer to the current tail of the list, which is NIL if the
;;; list is empty.
;;;
(defun collect-list-expander (n-value n-tail forms)
  (let ((n-res (gensym)))
    `(progn
      ,@(mapcar #'(lambda (form)
                    `(let ((,n-res (cons ,form nil)))
                       (cond (,n-tail
                              (rplacd ,n-tail ,n-res)
                              (setq ,n-tail ,n-res))
                             (t
                              (setq ,n-tail ,n-res  ,n-value ,n-res)))))
                forms)
      ,n-value)))


;;; Collect  --  Public
;;;
;;;    The ultimate collection macro...
;;;
(defmacro collect (collections &body body)
  "Collect ({(Name [Initial-Value] [Function])}*) {Form}*

Collect some values somehow.  Each of the collections specifies a
bunch of things which collected during the evaluation of the body of
the form.  The name of the collection is used to define a local macro,
a la MACROLET.  Within the body, this macro will evaluate each of its
arguments and collect the result, returning the current value after
the collection is done.  The body is evaluated as a PROGN; to get the
final values when you are done, just call the collection macro with no
arguments.

Initial-Value is the value that the collection starts out with, which
defaults to NIL.  Function is the function which does the collection.
It is a function which will accept two arguments: the value to be
collected and the current collection.  The result of the function is
made the new value for the collection.  As a totally magical
special-case, the Function may be Collect, which tells us to build a
list in forward order; this is the default.  If an Initial-Value is
supplied for Collect, the stuff will be rplacd'd onto the end.  Note
that Function may be anything that can appear in the functional
position, including macros and lambdas.

Bare symbols in `specs' are equivalent to:

(symbol nil 'collect)

Example:

  (collect (a b)
    (a 3)
    (a 4)
    (b 5)
    (list (a) (b)))
  ; => ((3 4) (5))
"

  (let (macros binds)
    (dolist (spec collections)
      (cond ((atom spec)
             (setq spec (list spec)))
            ((not (<= 1 (length spec) 3))
             (error "Malformed collection specifier: ~S." spec)))
      (let ((n-value (gensym))
            (name (first spec))
            (default (second spec))
            (kind (or (third spec) 'collect)))
        (push `(,n-value ,default) binds)
        (if (eq kind 'collect)
            (let ((n-tail (gensym)))
              (if default
                  (push `(,n-tail (last ,n-value)) binds)
                  (push n-tail binds))
              (push `(,name (&rest args)
                            (collect-list-expander ',n-value ',n-tail args))
                    macros))
            (push `(,name (&rest args)
                          (collect-normal-expander ',n-value ',kind args))
                  macros))))
    `(macrolet ,macros (let* ,(nreverse binds) ,@body))))


;;;; The Once-Only macro:

;;; Once-Only  --  Interface
;;;
;;;    Once-Only is a utility useful in writing source transforms and
;;;    macros.  It provides an easy way to wrap a let around some code
;;;    to ensure that some forms are only evaluated once.
;;;
(defmacro once-only (specs &body body)
  "Once-Only ({(Var Value-Expression)}*) Form*

Create a Let* which evaluates each Value-Expression, binding a
temporary variable to the result, and wrapping the Let* around the
result of the evaluation of Body.  Within the body, each Var is bound
to the corresponding temporary variable.

Bare symbols in `specs' are equivalent to:

  (symbol symbol)

Example:

  (defmacro cons1 (x)
    (once-only (x) `(cons ,x ,x)))
  (let ((y 0))
    (cons1 (incf y)))
  ; => (1 . 1)
"
  (labels ((frob (specs body)
             (if (null specs)
                 `(progn ,@body)
                 (let ((spec (first specs)))
                   (cond ((atom spec)
                          (setq spec (list spec spec)))
                         ((/= (length spec) 2)
                          (error "Malformed Once-Only binding spec: ~S." spec)))
                   (let ((name (first spec))
                         (exp-temp (gensym)))
                     `(let ((,exp-temp ,(second spec))
                            (,name (gensym "OO-")))
                        `(let ((,,name ,,exp-temp))
                           ,,(frob (rest specs) body))))))))
    (frob specs body)))


;;; Automate an idiom often found in macros:
;;;   (LET ((FOO (GENSYM "FOO"))
;;;         (MAX-INDEX (GENSYM "MAX-INDEX-")))
;;;     ...)
;;;
;;; "Good notation eliminates thought." -- Eric Siggia
;;;
;;; Incidentally, this is essentially the same operator which
;;; _On Lisp_ calls WITH-GENSYMS.
(defmacro with-unique-names (symbols &body body)
  "Binds each variable named by a symbol in `symbols' to a unique
symbol around `body'."
  `(let* ,(mapcar (lambda (symbol)
                    (let* ((symbol-name (symbol-name symbol))
                           (stem symbol-name))
                      `(,symbol (gensym ,stem))))
                  symbols)
     ,@body))

(defmacro with-gensyms (symbols &body body)
  "Alias for `with-unique-names'."
  `(with-unique-names ,symbols ,@body))


(defmacro with-clean-symbols (symbols &body body)
  "Rewrites the given forms replacing the given symbols with uninterned
ones, which is useful for creating hygienic macros."
  `(progn ,@(sublis
             (mapcar #'(lambda (s)
                         (cons s (make-symbol (symbol-name s))))
                     symbols)
             body)))


;;; Curbed from alexandria
(defmacro if-let (bindings &body (then-form &optional else-form))
  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
                           (list bindings)
                           bindings))
         (variables (mapcar #'car binding-list)))
    `(let ,binding-list
       (if (and ,@variables)
           ,then-form
           ,else-form))))

(defmacro when-let (bindings &body forms)
  `(if-let ,bindings
     (progn ,@forms)))

(defmacro when-let* (bindings &body body)
  (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
                          (list bindings)
                          bindings)))
    (labels ((bind (bindings body)
               (if bindings
                   `((let (,(car bindings))
                       (when ,(caar bindings)
                         ,@(bind (cdr bindings) body))))
                   body)))
      `(let (,(car binding-list))
         (when ,(caar binding-list)
           ,@(bind (cdr binding-list) body))))))
