dep.lisp (%dep-value): Force the dep before registering a dependents.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 4bed97d..aa14f27 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -1,7 +1,5 @@
 ;;; -*-lisp-*-
 ;;;
 ;;; -*-lisp-*-
 ;;;

-;;; $Id$
-;;;

 ;;; Basic definitions
 ;;;
 ;;; (c) 2005 Mark Wooding
 ;;; Basic definitions
 ;;;
 ;;; (c) 2005 Mark Wooding


@@ -193,6 +191,15 @@
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.
 
 ;;;--------------------------------------------------------------------------
 ;;; 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."
 (export 'with-gensyms)
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."


@@ -335,7 +342,7 @@
                               forms))))
                   clauses)))))
 
                               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
 (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)
   (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."
   "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.
 
 ;;;--------------------------------------------------------------------------
 ;;; Update-in-place macros built using with-places.