;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
-;;;
+;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
-;;;
+;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;;--------------------------------------------------------------------------
+;;; Package things.
+
(defpackage #:mdw.base
(:use #:common-lisp)
- (:export #:compile-time-defun
+ (:export #:unsigned-fixnum
+ #:compile-time-defun
#:show
- #:stringify #:listify #:fix-pair #:pairify
+ #:stringify #:functionify #:mappend
+ #:listify #:fix-pair #:pairify
+ #:parse-body #:with-parsed-body
#:whitespace-char-p
#:slot-uninitialized
+ #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
#:with-gensyms #:let*/gensyms #:with-places
- #:locp #:locf #:ref #:with-locatives))
+ #:locp #:locf #:ref #:with-locatives
+ #:update-place #:update-place-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)
"Define a function which can be used by macros during the compilation
-process."
- `(eval-when (:compile-toplevel :load-toplevel)
+ process."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))
+ (fresh-line)
+ (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;
-symbols are converted to their names (unqualified!). Other objects are
-converted to their print representations."
+ symbols are converted to their names (unqualified!). Other objects are
+ converted to their print representations."
(typecase str
(string str)
(symbol (symbol-name str))
- (t (with-output-to-string (s)
- (princ str s)))))
+ (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
+ 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)))
+
(compile-time-defun do-fix-pair (x y defaultp)
"Helper function for fix-pair and pairify."
(flet ((singleton (x) (values x (if defaultp y x))))
((atom (cdr x)) (values (car x) (cdr x)))
((cddr x) (error "Too many elements for a pair."))
(t (values (car x) (cadr x))))))
+
(compile-time-defun fix-pair (x &optional (y nil defaultp))
"Return two values extracted from X. It works as follows:
- (A) -> A, Y
- (A B) -> A, B
- (A B . C) -> error
- (A . B) -> A, B
- A -> A, Y
-where Y defaults to A if not specified."
+ (A) -> A, Y
+ (A B) -> A, B
+ (A B . C) -> error
+ (A . B) -> A, B
+ A -> A, Y
+ where Y defaults to A if not specified."
(do-fix-pair x y defaultp))
+
(compile-time-defun pairify (x &optional (y nil defaultp))
"As for fix-pair, but returns a list instead of two values."
(multiple-value-call #'list (do-fix-pair x y defaultp)))
(defun whitespace-char-p (ch)
"Return whether CH is a whitespace character or not."
(case ch
- ((#\space #\tab #\newline #\return #\vt #\formfeed) t)
+ (#.(loop for i below char-code-limit
+ for ch = (code-char i)
+ unless (with-input-from-string (in (string ch))
+ (peek-char t in nil))
+ collect ch)
+ 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
-structure definitions without doom ensuing."
+ structure definitions without doom ensuing."
(error "No initializer for slot."))
+(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 `@,'. 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))))))))
+
+(defmacro with-parsed-body
+ ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body)
+ "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR
+ to the body, DECLVAR to the declarations, and DOCVAR to (a list
+ containing) the docstring, and evaluate BODY."
+ `(multiple-value-bind
+ (,docvar ,declvar ,bodyvar)
+ (parse-body ,form :allow-docstring-p ,docp)
+ ,@(if docp nil `((declare (ignore ,docvar))))
+ ,@body))
+
+#-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 with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
(defmacro let*/gensyms (binds &body body)
"A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE
-defaults to VAR. The result is that BODY is evaluated in a context where
-each VAR is bound to a gensym, and in the final expansion, each of those
-gensyms will be bound to the corresponding VALUE."
+ defaults to VAR. The result is that BODY is evaluated in a context where
+ 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))
`(progn ,@body)
(car (more (mapcar #'pairify (listify binds)))))))
+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(defmacro nlet (name binds &body body)
+ "Scheme's named let."
+ (multiple-value-bind (vars vals)
+ (loop for bind in binds
+ for (var val) = (pairify bind nil)
+ collect var into vars
+ collect val into vals
+ finally (return (values vars vals)))
+ `(labels ((,name ,vars
+ ,@body))
+ (,name ,@vals))))
+
+(defmacro while (cond &body body)
+ "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
+ `(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'."
+ (with-gensyms (scrutinee argument)
+ `(multiple-value-bind (,scrutinee ,argument) ,vform
+ (declare (ignorable ,argument))
+ (,kind ,scrutinee
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind
+ (cases (&optional varx vary) &rest forms)
+ clause
+ `(,cases
+ ,@(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 ([[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)
+ "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+ (do-case2-like 'ecase vform clauses))
+
+(defmacro setf-default (&rest specs &environment env)
+ "Like setf, but only sets places which are currently nil.
+
+ The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE
+ is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
+ default is /not/ stored. The result is the (new) value of the last
+ PLACE."
+ (labels ((doit (specs)
+ (cond ((null specs) nil)
+ ((null (cdr specs))
+ (error "Odd number of arguments for SETF-DEFAULT."))
+ (t
+ (let ((place (car specs))
+ (default (cadr specs))
+ (rest (cddr specs)))
+ (multiple-value-bind
+ (vars vals store-vals writer reader)
+ (get-setf-expansion place env)
+ `(let* ,(mapcar #'list vars vals)
+ (or ,reader
+ (multiple-value-bind ,store-vals ,default
+ ,writer))
+ ,@(and rest (list (doit rest))))))))))
+ (doit specs)))
+
+;;;--------------------------------------------------------------------------
+;;; with-places
+
(defmacro %place-ref (getform setform newtmp)
"Grim helper macro for with-places."
(declare (ignore setform newtmp))
getform)
+
(define-setf-expander %place-ref (getform setform newtmp)
"Grim helper macro for with-places."
(values nil nil newtmp setform getform))
+
(defmacro with-places ((&key environment) places &body body)
"A hairy helper, for writing setf-like macros. PLACES is a list of binding
-pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY is
-evaluated in a context where each VAR is bound to a gensym, and in the final
-expansion, each of those gensyms will be bound to a symbol-macro capable of
-reading or setting the value of the corresponding PLACE."
+ pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY
+ is evaluated in a context where each VAR is bound to a gensym, and in the
+ final expansion, each of those gensyms will be bound to a symbol-macro
+ capable of reading or setting the value of the corresponding PLACE."
(if (null places)
`(progn ,@body)
(let*/gensyms (environment)
body))))))))))
(car (more (mapcar #'pairify (listify places))))))))
+;;;--------------------------------------------------------------------------
+;;; Update-in-place macros built using with-places.
+
+(defmacro update-place (op place arg &environment env)
+ "Update PLACE with the value of OP PLACE ARG, returning the new value."
+ (with-places (:environment env) (place)
+ `(setf ,place (,op ,place ,arg))))
+
+(defmacro update-place-after (op place arg &environment env)
+ "Update PLACE with the value of OP PLACE ARG, returning the old value."
+ (with-places (:environment env) (place)
+ (with-gensyms (x)
+ `(let ((,x ,place))
+ (setf ,place (,op ,x ,arg))
+ ,x))))
+
+(defmacro incf-after (place &optional (by 1))
+ "Increment PLACE by BY, returning the old value."
+ `(update-place-after + ,place ,by))
+
+(defmacro decf-after (place &optional (by 1))
+ "Decrement PLACE by BY, returning the old value."
+ `(update-place-after - ,place ,by))
+
+;;;--------------------------------------------------------------------------
+;;; Locatives.
+
(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
"Locative data type. See `locf' and `ref'."
(reader (slot-uninitialized) :type function)
(writer (slot-uninitialized) :type function))
+
(defmacro locf (place &environment env)
"Slightly cheesy locatives. (locf PLACE) returns an object which, using
-the `ref' function, can be used to read or set the value of PLACE. It's
-cheesy because it uses closures rather than actually taking the address of
-something. Also, unlike Zetalisp, we don't overload `car' to do our dirty
-work."
+ the `ref' function, can be used to read or set the value of PLACE. It's
+ cheesy because it uses closures rather than actually taking the address of
+ something. Also, unlike Zetalisp, we don't overload `car' to do our dirty
+ work."
(multiple-value-bind
(valtmps valforms newtmps setform getform)
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
(lambda (,@newtmps) ,setform)))))
+
(declaim (inline loc (setf loc)))
+
(defun ref (loc)
"Fetch the value referred to by a locative."
(funcall (loc-reader loc)))
+
(defun (setf ref) (new loc)
"Store a new value in the place referred to by a locative."
(funcall (loc-writer loc) new))
+
(defmacro with-locatives (locs &body body)
"LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
-symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
-defaults to SYM. As an abbreviation for a common case, LOCS may be a symbol
-instead of a list. The BODY is evaluated in an environment where each SYM is
-a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, something
-similar which doesn't break if LOC-EXPR has side-effects. Thus, references,
-including `setf' forms, fetch or modify the thing referred to by the
-LOC-EXPR. Useful for covering over where something uses a locative."
+ symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
+ defaults to SYM. As an abbreviation for a common case, LOCS may be a
+ symbol instead of a list. The BODY is evaluated in an environment where
+ each SYM is a symbol macro which expands to (ref LOC-EXPR) -- or, in fact,
+ something similar which doesn't break if LOC-EXPR has side-effects. Thus,
+ references, including `setf' forms, fetch or modify the thing referred to
+ by the LOC-EXPR. Useful for covering over where something uses a
+ locative."
(setf locs (mapcar #'pairify (listify locs)))
(let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
(ll (mapcar #'cadr locs))
~mdw / lisp / blobdiff