Various: Try porting the code to CLisp.

[lisp] / mdw-base.lisp

diff --git a/mdw-base.lisp b/mdw-base.lisp
index 269b398..8ba9a24 100644 (file)
--- a/mdw-base.lisp
+++ b/mdw-base.lisp
@@ -28,19 +28,30 @@
 
 (defpackage #:mdw.base
   (:use #:common-lisp)
-  (:export #:compile-time-defun
+  (:export #:unsigned-fixnum
+          #: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
+          #:nlet #:while #:until #: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)
 
 ;;;--------------------------------------------------------------------------
+;;; Useful types.
+
+(deftype unsigned-fixnum ()
+  "Unsigned fixnums; useful as array indices and suchlike."
+  `(mod ,most-positive-fixnum))
+
+;;;--------------------------------------------------------------------------
 ;;; Some simple macros to get things going.
 
 (defmacro compile-time-defun (name args &body body)
@@ -50,11 +61,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 +83,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)))
@@ -96,7 +119,9 @@
 (defun whitespace-char-p (ch)
   "Return whether CH is a whitespace character or not."
   (case ch
-    ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+    ((#\space #\tab #\newline #\return #\vt
+             #+cmu #\formfeed
+             #+clisp #\page) t)
     (t nil)))
 
 (declaim (ftype (function nil ()) slot-unitialized))
@@ -124,6 +149,13 @@
                                 (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.
 
@@ -167,9 +199,11 @@
 
 (defmacro while (cond &body body)
   "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
-  `(loop
-     (unless ,cond (return))
-     ,@body))
+  `(loop (unless ,cond (return)) (progn ,@body)))
+
+(defmacro until (cond &body body)
+  "If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
+  `(loop (when ,cond (return)) (progn ,@body)))
 
 (compile-time-defun do-case2-like (kind vform clauses)
   "Helper function for `case2' and `ecase2'."