+(export 'defconstant*)
+(defmacro defconstant* (name value &key doc test)
+ "Define a constant, like `defconstant'. The TEST is an equality test used
+ to decide whether to override the current definition, if any."
+ (let ((temp (gensym)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((,temp ,value))
+ (unless (and (boundp ',name)
+ (funcall ,(or test ''eql) (symbol-value ',name) ,temp))
+ (defconstant ,name ,value ,@(and doc (list doc))))
+ ',name))))
+
+(export 'slot-uninitialized)
+(declaim (ftype (function nil ()) slot-unitialized))
+(defun slot-uninitialized ()
+ "A function which signals an error. Can be used as an initializer form in
+ structure definitions without doom ensuing."
+ (error "No initializer for slot."))
+
+(export 'parse-body)
+(compile-time-defun parse-body (body &key (allow-docstring-p t))
+ "Given a BODY (a list of forms), parses it into three sections: a
+ docstring, a list of declarations (forms beginning with the symbol
+ `declare') and the body forms. The result is returned as three lists
+ (even the docstring), suitable for interpolation into a backquoted list
+ using `@,'. If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at
+ all."
+ (let ((doc nil) (decls nil))
+ (do ((forms body (cdr forms))) (nil)
+ (let ((form (and forms (car forms))))
+ (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms))
+ (setf doc form))
+ ((and (consp form)
+ (eq (car form) 'declare))
+ (setf decls (append decls (cdr form))))
+ (t (return (values (and doc (list doc))
+ (and decls (list (cons 'declare decls)))
+ forms))))))))
+
+(export 'with-parsed-body)
+(defmacro with-parsed-body
+ ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body)
+ "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR
+ to the body, DECLVAR to the declarations, and DOCVAR to (a list
+ containing) the docstring, and evaluate BODY."
+ `(multiple-value-bind
+ (,docvar ,declvar ,bodyvar)
+ (parse-body ,form :allow-docstring-p ,docp)
+ ,@(if docp nil `((declare (ignore ,docvar))))
+ ,@body))
+
+(export 'fixnump)
+#-cmu
+(progn
+ (declaim (inline fixnump))
+ (defun fixnump (object)
+ "Answer non-nil if OBJECT is a fixnum, or nil if it isn't."
+ (typep object 'fixnum)))
+
+;;;--------------------------------------------------------------------------
+;;; Generating symbols.
+
+(export 'with-gensyms)
+(defmacro with-gensyms (syms &body body)
+ "Everyone's favourite macro helper."
+ `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
+ (listify syms)))
+ ,@body))
+
+(export 'let*/gensyms)
+(defmacro let*/gensyms (binds &body body)
+ "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE
+ defaults to VAR. The result is that BODY is evaluated in a context where
+ each VAR is bound to a gensym, and in the final expansion, each of those
+ gensyms will be bound to the corresponding VALUE."
+ (labels ((more (binds)
+ (let ((tmp (gensym "TMP")) (bind (car binds)))
+ `((let ((,tmp ,(cadr bind))
+ (,(car bind) (gensym ,(symbol-name (car bind)))))
+ `(let ((,,(car bind) ,,tmp))
+ ,,@(if (cdr binds)
+ (more (cdr binds))
+ body)))))))
+ (if (null binds)
+ `(progn ,@body)
+ (car (more (mapcar #'pairify (listify binds)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(export 'nlet)