(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)
(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;
(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)))
(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))
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.
(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'."
(,kind ,scrutinee
,@(mapcar (lambda (clause)
(destructuring-bind
- (cases (&optional var) &rest forms)
+ (cases (&optional varx vary) &rest forms)
clause
`(,cases
- ,@(if var
- (list `(let ((,var ,argument)) ,@forms))
+ ,@(if varx
+ (list `(let ((,(or vary varx) ,argument)
+ ,@(and vary
+ `((,varx ,scrutinee))))
+ ,@forms))
forms))))
clauses)))))
(defmacro case2 (vform &body clauses)
"VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
- The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard
- `case' clause has the form (CASES FORMS...). The `case2' form evaluates
- the VFORM, and compares the SCRUTINEE to the various CASES, in order, just
- like `case'. If there is a match, then the corresponding FORMs are
- evaluated with VAR (if specified) bound to the value of ARGUMENT."
+ The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+ standard `case' clause has the form (CASES FORMS...). The `case2' form
+ evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+ order, just like `case'. If there is a match, then the corresponding
+ FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+ the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
+ ARGVAR is less optional than SCRUVAR."
(do-case2-like 'case vform clauses))
(defmacro ecase2 (vform &body clauses)
~mdw / lisp / blobdiff