X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/7769f8fdb8694fe33ebb6198978d96e22e05c027..813da880d2d77f04ea623f426d543d298528f967:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 4bed97d..aa14f27 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
-;;; $Id$
-;;;
 ;;; Basic definitions
 ;;;
 ;;; (c) 2005 Mark Wooding
@@ -193,6 +191,15 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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."
@@ -335,7 +342,7 @@
 			       forms))))
 		   clauses)))))
 
-(export 'caase2)
+(export 'case2)
 (defmacro case2 (vform &body clauses)
   "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
    The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
@@ -353,30 +360,21 @@
   (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.