X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/b3bc37457df55c92cabc8aeeb42bc67d3fb8af12..05c1e7c3367de14f38e81e9ecdc0a36904dbc13e:/mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 6b235f5..37a3068 100644
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -30,14 +30,17 @@
   (:use #:common-lisp)
   (:export #:compile-time-defun
 	   #:show
-	   #:stringify #:listify #:fix-pair #:pairify #:parse-body
+	   #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
 	   #:whitespace-char-p
 	   #:slot-uninitialized
 	   #:nlet #:while #:case2 #:ecase2
 	   #:with-gensyms #:let*/gensyms #:with-places
 	   #:locp #:locf #:ref #:with-locatives
 	   #:update-place #:update-place-after
-	   #:incf-after #:decf-after))
+	   #:incf-after #:decf-after
+	   #:fixnump)
+  #+cmu (:import-from #:extensions #:fixnump))
+
 (in-package #:mdw.base)
 
 ;;;--------------------------------------------------------------------------
@@ -50,11 +53,17 @@
      (defun ,name ,args ,@body)))
 
 (defmacro show (x)
-  "Debugging tool: print the expression X and its value."
+  "Debugging tool: print the expression X and its values."
   (let ((tmp (gensym)))
-    `(let ((,tmp ,x))
-       (format t "~&~S: ~S~%" ',x ,tmp)
-       ,tmp)))
+    `(let ((,tmp (multiple-value-list ,x)))
+       (format t "~&")
+       (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
+	 (format t
+		 "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
+		 ',x
+		 ,tmp))
+       (terpri)
+       (values-list ,tmp))))
 
 (defun stringify (str)
   "Return a string representation of STR.  Strings are returned unchanged;
@@ -66,6 +75,12 @@
     (t (with-output-to-string (s)
 	 (princ str s)))))
 
+(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
+   mapcan, but nondestructive."
+  (apply #'append (apply #'mapcar function list more-lists)))
+
 (compile-time-defun listify (x)
   "If X is a (possibly empty) list, return X; otherwise return (list X)."
   (if (listp x) x (list x)))
@@ -105,24 +120,31 @@
    structure definitions without doom ensuing."
   (error "No initializer for slot."))
 
-(compile-time-defun parse-body (body)
+(compile-time-defun parse-body (body &key (allow-docstring-p t))
   "Given a BODY (a list of forms), parses it into three sections: a
    docstring, a list of declarations (forms beginning with the symbol
    `declare') and the body forms.  The result is returned as three lists
    (even the docstring), suitable for interpolation into a backquoted list
-   using `@,'."
-  (multiple-value-bind
-      (doc body)
-      (if (and (consp body)
-	       (stringp (car body)))
-	  (values (list (car body)) (cdr body))
-	  (values nil body))
-    (loop for forms on body
-	  for form = (car forms)
-	  while (and (consp form)
-		     (eq (car form) 'declare))
-	  collect form into decls
-	  finally (return (values doc decls forms)))))
+   using `@,'.  If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at
+   all."
+  (let ((doc nil) (decls nil))
+    (do ((forms body (cdr forms))) (nil)
+      (let ((form (and forms (car forms))))
+	(cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms))
+	       (setf doc form))
+	      ((and (consp form)
+		    (eq (car form) 'declare))
+	       (setf decls (append decls (cdr form))))
+	      (t (return (values (and doc (list doc))
+				 (and decls (list (cons 'declare decls)))
+				 forms))))))))
+
+#-cmu
+(progn
+  (declaim (inline fixnump))
+  (defun fixnump (object)
+    "Answer non-nil if OBJECT is a fixnum, or nil if it isn't."
+    (typep object 'fixnum)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Generating symbols.