;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Basic definitions
;;;
;;; (c) 2005 Mark Wooding
;;;--------------------------------------------------------------------------
;;; Generating symbols.
+(export 'symbolicate)
+(defun symbolicate (&rest names)
+ "Return a symbol constructued by concatenating the NAMES.
+
+ The NAMES are coerced to strings, using the `string' function, so they may
+ be strings, characters, or symbols. The resulting symbol is interned in
+ the current `*package*'."
+ (intern (apply #'concatenate 'string (mapcar #'string names))))
+
(export 'with-gensyms)
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
(do-case2-like 'ecase vform clauses))
(export 'setf-default)
-(defmacro setf-default (&rest specs &environment env)
+(defmacro setf-default (&rest specs)
"Like setf, but only sets places which are currently nil.
The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE
is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
default is /not/ stored. The result is the (new) value of the last
PLACE."
- (labels ((doit (specs)
- (cond ((null specs) nil)
- ((null (cdr specs))
- (error "Odd number of arguments for SETF-DEFAULT."))
- (t
- (let ((place (car specs))
- (default (cadr specs))
- (rest (cddr specs)))
- (multiple-value-bind
- (vars vals store-vals writer reader)
- (get-setf-expansion place env)
- `(let* ,(mapcar #'list vars vals)
- (or ,reader
- (multiple-value-bind ,store-vals ,default
- ,writer))
- ,@(and rest (list (doit rest))))))))))
- (doit specs)))
+ `(progn ,@(do ((list nil)
+ (specs specs (cddr specs)))
+ ((endp specs) (nreverse list))
+ (unless (cdr specs)
+ (error "Odd number of arguments for `setf-default'."))
+ (push (with-places/gensyms ((place (car specs)))
+ `(or ,place (setf ,place ,(cadr specs))))
+ list))))
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.