X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/b2c12b4eaf6e5c43791d95080a243c35f97ee488..ea87c989d51bfd4b64d2a802f87216dfce551a76:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 646eb7e..ab1a47c 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -31,7 +31,8 @@
   (:export #:unsigned-fixnum
 	   #:compile-time-defun
 	   #:show
-	   #:stringify #:mappend #:listify #:fix-pair #:pairify
+	   #:stringify #:functionify #:mappend
+	   #:listify #:fix-pair #:pairify
 	   #:parse-body #:with-parsed-body
 	   #:whitespace-char-p
 	   #:slot-uninitialized
@@ -65,7 +66,7 @@
   "Debugging tool: print the expression X and its values."
   (let ((tmp (gensym)))
     `(let ((,tmp (multiple-value-list ,x)))
-       (format t "~&")
+       (fresh-line)
        (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
 	 (format t
 		 "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
@@ -83,6 +84,13 @@
     (symbol (symbol-name str))
     (t (princ-to-string str))))
 
+(defun functionify (func)
+  "Convert the function-designator FUNC to a function."
+  (declare (type (or function symbol) func))
+  (etypecase func
+    (function func)
+    (symbol (symbol-function func))))
+
 (defun mappend (function list &rest more-lists)
   "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
    a list.  Return the concatenation of all the resulting lists.  Like
@@ -127,6 +135,17 @@
        t)
     (t nil)))
 
+(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))))
+
 (declaim (ftype (function nil ()) slot-unitialized))
 (defun slot-uninitialized ()
   "A function which signals an error.  Can be used as an initializer form in
@@ -176,7 +195,7 @@
 (defmacro with-gensyms (syms &body body)
   "Everyone's favourite macro helper."
   `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
-                   (listify syms)))
+		   (listify syms)))
      ,@body))
 
 (defmacro let*/gensyms (binds &body body)
@@ -185,16 +204,16 @@
    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)))))))
+	     (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)))))))
+	`(progn ,@body)
+	(car (more (mapcar #'pairify (listify binds)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Some simple yet useful control structures.
@@ -208,7 +227,7 @@
 	    collect val into vals
 	    finally (return (values vars vals)))
     `(labels ((,name ,vars
-	        ,@body))
+		,@body))
        (,name ,@vals))))
 
 (defmacro while (cond &body body)
@@ -234,7 +253,7 @@
 			       (list `(let ((,(or vary varx) ,argument)
 					    ,@(and vary
 						   `((,varx ,scrutinee))))
-				        ,@forms))
+					,@forms))
 			       forms))))
 		   clauses)))))
 
@@ -279,7 +298,7 @@
     (doit specs)))
 
 ;;;--------------------------------------------------------------------------
-;;; with-places
+;;; Capturing places as symbols.
 
 (defmacro %place-ref (getform setform newtmp)
   "Grim helper macro for with-places."
@@ -299,29 +318,29 @@
   (if (null places)
       `(progn ,@body)
       (let*/gensyms (environment)
-        (labels
-            ((more (places)
-               (let ((place (car places)))
-                 (with-gensyms (tmp valtmps valforms
-                                    newtmps setform getform)
-                   `((let ((,tmp ,(cadr place))
-                           (,(car place)
-                            (gensym ,(symbol-name (car place)))))
-                       (multiple-value-bind
-                           (,valtmps ,valforms
-                            ,newtmps ,setform ,getform)
-                           (get-setf-expansion ,tmp
-                                               ,environment)
-                         (list 'let*
-                               (mapcar #'list ,valtmps ,valforms)
-                               `(symbol-macrolet ((,,(car place)
-                                                   (%place-ref ,,getform
-                                                               ,,setform
-                                                               ,,newtmps)))
-                                  ,,@(if (cdr places)
-                                         (more (cdr places))
-                                         body))))))))))
-          (car (more (mapcar #'pairify (listify places))))))))
+	(labels
+	    ((more (places)
+	       (let ((place (car places)))
+		 (with-gensyms (tmp valtmps valforms
+				    newtmps setform getform)
+		   `((let ((,tmp ,(cadr place))
+			   (,(car place)
+			    (gensym ,(symbol-name (car place)))))
+		       (multiple-value-bind
+			   (,valtmps ,valforms
+			    ,newtmps ,setform ,getform)
+			   (get-setf-expansion ,tmp
+					       ,environment)
+			 (list 'let*
+			       (mapcar #'list ,valtmps ,valforms)
+			       `(symbol-macrolet ((,,(car place)
+						   (%place-ref ,,getform
+							       ,,setform
+							       ,,newtmps)))
+				  ,,@(if (cdr places)
+					 (more (cdr places))
+					 body))))))))))
+	  (car (more (mapcar #'pairify (listify places))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Update-in-place macros built using with-places.
@@ -366,7 +385,7 @@
       (get-setf-expansion place env)
     `(let* (,@(mapcar #'list valtmps valforms))
        (make-loc (lambda () ,getform)
-                 (lambda (,@newtmps) ,setform)))))
+		 (lambda (,@newtmps) ,setform)))))
 
 (declaim (inline loc (setf loc)))