Initial CL parser/generator implementation

lib/macro-utilities.lisp

@@ -0,0 +1,118 @@
+;;;; 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."))