119 lines
4.9 KiB
Common Lisp
119 lines
4.9 KiB
Common Lisp
;;;; 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."))
|