Very ragged work-in-progress.

[sod] / utilities.lisp

diff --git a/utilities.lisp b/utilities.lisp
index d61bb00..7e9e092 100644 (file)
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -28,6 +28,13 @@
 ;;;--------------------------------------------------------------------------
 ;;; List utilities.
 
+(defun mappend (function list &rest more-lists)
+  "Like a nondestructive MAPCAN.
+
+   Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
+   and return the result of appending all of the resulting lists."
+  (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+
 (define-condition inconsistent-merge-error (error)
   ((candidates :initarg :candidates
               :reader merge-error-candidates))
@@ -63,7 +70,9 @@
   ;; we can build the list up forwards, so as not to make the PICK function
   ;; interface be weird.  HEAD is a dummy cons cell inserted before the list,
   ;; which gives TAIL something to point to initially.  (If we had locatives,
-  ;; I'd have TAIL point to the thing holding the final NIL, but we haven't.)
+  ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
+  ;; instead, it points to the cons cell whose cdr holds the final NIL --
+  ;; which means that we need to invent a cons cell if the list is empty.)
   (do* ((head (cons nil nil))
         (tail head))
        ((null lists) (cdr head))
@@ -150,6 +159,31 @@
     (t nil)))
 
 ;;;--------------------------------------------------------------------------
+;;; Symbols.
+
+(defun symbolicate (&rest symbols)
+  "Return a symbol named after the concatenation of the names of the SYMBOLS.
+
+   The symbol is interned in the current *PACKAGE*.  Trad."
+  (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+
+;;;--------------------------------------------------------------------------
+;;; Object printing.
+
+(defmacro maybe-print-unreadable-object
+    ((object stream &rest args) &body body)
+  "Print helper for usually-unreadable objects.
+
+   If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
+   Otherwise just print using BODY."
+  (let ((func (gensym "PRINT")))
+    `(flet ((,func () ,@body))
+       (if *print-escape*
+          (print-unreadable-object (,object ,stream ,@args)
+            (,func))
+          (,func)))))
+
+;;;--------------------------------------------------------------------------
 ;;; Keyword arguments and lambda lists.
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -359,4 +393,19 @@
    OBJECT except where overridden by INITARGS."
   (apply #'copy-instance-using-class (class-of object) object initargs))
 
+(defmacro default-slot ((instance slot) &body value &environment env)
+  "If INSTANCE's SLOT is unbound, set it to VALUE.
+
+   Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
+   evaluated if it's needed."
+
+  (let* ((quotep (constantp slot env))
+        (instancevar (gensym "INSTANCE"))
+        (slotvar (if quotep slot (gensym "SLOT"))))
+    `(let ((,instancevar ,instance)
+          ,@(and (not quotep) `((,slotvar ,slot))))
+       (unless (slot-boundp ,instancevar ,slotvar)
+        (setf (slot-value ,instancevar ,slotvar)
+              (progn ,@value))))))
+
 ;;;----- That's all, folks --------------------------------------------------