;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; macro-utilities.lisp --- Common utilities in macro writing
;;;; 
;;;; $Id$

(cl:in-package #:pmsf-lib)

;;;; %File Description:
;;;; 
;;;; This file contains a number of utility functions and macros which
;;;; are useful in writing macros.
;;;; 

(defmacro with-unique-names ((&rest bindings) &body body)
  "Executes a series of forms with each var bound to a fresh, uninterned
symbol.  The uninterned symbol is created as if by a call to gensym with
the string denoted by prefix -- or, if prefix is not supplied, the string
denoted by var -- as argument.
The variable bindings created are lexical unless special declarations are
specified.
The forms are evaluated in order, and the values of all but the last are
discarded (that is, the body is an implicit progn)."
  `(let ,(mapcar #'(lambda (binding)
                     (destructuring-bind (var prefix)
                         (if (consp binding) binding (list binding binding))
                       `(,var (gensym ,(string prefix)))))
                 bindings)
     ,@body))

(defmacro rebinding (bindings &body body)
  "Bind each var in bindings to a gensym, bind the gensym to
var's value via a let, return body's value wrapped in this let.
Evaluates a series of forms in the lexical environment that is
formed by adding the binding of each var to a fresh, uninterned
symbol, and the binding of that fresh, uninterned symbol to var's
original value, i.e., its value in the current lexical
environment.
The uninterned symbol is created as if by a call to gensym with the
string denoted by prefix -- or, if prefix is not supplied, the string
denoted by var -- as argument.
The forms are evaluated in order, and the values of all but the last
are discarded (that is, the body is an implicit progn)."
  (loop for binding in bindings
        for var = (car (if (consp binding) binding (list binding)))
        for name = (gensym)
        collect `(,name ,var) into renames
        collect ``(,,var ,,name) into temps
        finally (return `(let* ,renames
                           (with-unique-names ,bindings
                             `(let (,,@temps)
                                ,,@body))))))

(defun symbolicate (&rest pieces)
  (intern
   (apply #'concatenate 'string 
            (loop for thing in pieces
               collect (if (symbolp thing)
                           (symbol-name thing)
                           thing)))))

(defun symbolicate* (package &rest pieces)
  (intern
   (apply #'concatenate 'string 
            (loop for thing in pieces
               collect (if (symbolp thing)
                           (symbol-name thing)
                           thing)))
   package))

;;; Parse-Body
;;;
;;;    Parse out declarations and doc strings, *not* expanding macros.
;;;
;;; Taken from CMU CL, which is in the public domain
;;;
(defun parse-body (body &optional (doc-string-allowed t))
  "This function is to parse the declarations and doc-string out of the body of
  a defun-like form.  Body is the list of stuff which is to be parsed.
  Environment is ignored.  If Doc-String-Allowed is true, then a doc string
  will be parsed out of the body and returned.  If it is false then a string
  will terminate the search for declarations.  Three values are returned: the
  tail of Body after the declarations and doc strings, a list of declare forms,
  and the doc-string, or NIL if none."
  (let ((decls ())
        (doc nil))
    (do ((tail body (cdr tail)))
        ((endp tail)
         (values tail (nreverse decls) doc))
      (let ((form (car tail)))
        (cond ((and (stringp form) (cdr tail))
               (if doc-string-allowed
                   (setq doc form
                         ;; Only one doc string is allowed.
                         doc-string-allowed nil)
                   (return (values tail (nreverse decls) doc))))
              ((not (and (consp form) (symbolp (car form))))
               (return (values tail (nreverse decls) doc)))
              ((eq (car form) 'declare)
               (push form decls))
              (t
               (return (values tail (nreverse decls) doc))))))))

;;; Required-Argument
;;;
;;; Taken from CMU CL, which is in the public domain
;;;
(declaim (ftype (function () nil) required-argument))
(defun required-argument ()
  "This function can be used as the default value for keyword arguments that
  must be always be supplied.  Since it is known by the compiler to never
  return, it will avoid any compile-time type warnings that would result from a
  default value inconsistent with the declared type.  When this function is
  called, it signals an error indicating that a required keyword argument was
  not supplied.  This function is also useful for DEFSTRUCT slot defaults
  corresponding to required arguments."
  (error "A required keyword argument was not supplied."))