;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Basic definitions
;;;
;;; (c) 2005 Mark Wooding
;;; 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.
(defpackage #:mdw.base
(:use #:common-lisp)
- (:export #:compile-time-defun
- #:show
- #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
- #:whitespace-char-p
- #:slot-uninitialized
- #: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
- #:fixnump)
#+cmu (:import-from #:extensions #:fixnump))
(in-package #:mdw.base)
;;;--------------------------------------------------------------------------
+;;; Useful types.
+
+(export 'unsigned-fixnum)
+(deftype unsigned-fixnum ()
+ "Unsigned fixnums; useful as array indices and suchlike."
+ `(mod ,most-positive-fixnum))
+
+;;;--------------------------------------------------------------------------
;;; Some simple macros to get things going.
+(export 'compile-time-defun)
(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)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,name ,args ,@body)))
+(export 'show)
(defmacro show (x)
"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~^ ~_~}~]"
(terpri)
(values-list ,tmp))))
+(export 'stringify)
(defun stringify (str)
"Return a string representation of STR. Strings are returned unchanged;
symbols are converted to their names (unqualified!). Other objects are
(typecase str
(string str)
(symbol (symbol-name str))
- (t (with-output-to-string (s)
- (princ str s)))))
+ (t (princ-to-string str))))
+
+(export 'functionify)
+(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))))
+(export 'mappend)
(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)))
+(export 'listify)
(compile-time-defun listify (x)
"If X is a (possibly empty) list, return X; otherwise return (list X)."
(if (listp x) x (list x)))
((cddr x) (error "Too many elements for a pair."))
(t (values (car x) (cadr x))))))
+(export 'fix-pair)
(compile-time-defun fix-pair (x &optional (y nil defaultp))
"Return two values extracted from X. It works as follows:
(A) -> A, Y
where Y defaults to A if not specified."
(do-fix-pair x y defaultp))
+(export 'pairify)
(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)))
+(export 'whitespace-char-p)
(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)))
+(export 'defconstant*)
+(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))))
+
+(export 'slot-uninitialized)
(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."
(error "No initializer for slot."))
+(export 'parse-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
(and decls (list (cons 'declare decls)))
forms))))))))
+(export 'with-parsed-body)
+(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))
+
+(export 'fixnump)
#-cmu
(progn
(declaim (inline fixnump))
;;;--------------------------------------------------------------------------
;;; Generating symbols.
+(export 'symbolicate)
+(defun symbolicate (&rest names)
+ "Return a symbol constructued by concatenating the NAMES.
+
+ The NAMES are coerced to strings, using the `string' function, so they may
+ be strings, characters, or symbols. The resulting symbol is interned in
+ the current `*package*'."
+ (intern (apply #'concatenate 'string (mapcar #'string names))))
+
+(export 'with-gensyms)
(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))
+(export 'let*/gensyms)
(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."
(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)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Capturing places as symbols.
+
+(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))
+
+(export 'with-places)
+(defmacro with-places (clauses &body body &environment env)
+ "Define symbols which refer to `setf'-able places.
+
+ The syntax is similar to `let'. The CLAUSES are a list of (NAME PLACE)
+ pairs. Each NAME is defined as a symbol-macro referring to the
+ corresponding PLACE: a mention of the NAME within the BODY forms extracts
+ the current value(s) of the PLACE, while a `setf' (or `setq', because
+ symbol macros are strange like that) of a NAME updates the value(s) in the
+ PLACE. The returned values are those of the BODY, evaluated as an
+ implicit `progn'."
+
+ (let ((temp-binds nil)
+ (macro-binds nil))
+ (dolist (clause clauses)
+ (destructuring-bind (name place) clause
+ (multiple-value-bind (valtmps valforms newtmps setform getform)
+ (get-setf-expansion place env)
+ (setf temp-binds
+ (nconc (nreverse (mapcar #'list valtmps valforms))
+ temp-binds))
+ (push `(,name (%place-ref ,getform ,setform ,newtmps))
+ macro-binds))))
+ `(let (,@(nreverse temp-binds))
+ (symbol-macrolet (,@(nreverse macro-binds))
+ ,@body))))
+
+(export 'with-places/gensyms)
+(defmacro with-places/gensyms (clauses &body body)
+ "A kind of a cross between `with-places' and `let*/gensyms'.
+
+ This is a hairy helper for writing `setf'-like macros. The CLAUSES are a
+ list of (NAME [PLACE]) pairs, where the PLACE defaults to NAME, and a
+ bare NAME may be written in place of the singleton list (NAME). The
+ PLACEs are evaluated.
+
+ The BODY forms are evaluated as an implicit `progn', with each NAME bound
+ to a gensym, to produce a Lisp form, called the `kernel'. The result of
+ the `with-places/gensyms' macro is then itself a Lisp form, called the
+ `result'.
+
+ The effect of evaluating the `result' form is to evaluate the `kernel'
+ form with each of the gensyms stands for the value(s) stored in the
+ corresponding PLACE; a `setf' (or `setq') of one of the gensyms updates
+ the value(s) in the corresponding PLACE. The values returned by the
+ `result' form are the values returned by the `kernel'."
+
+ (let* ((clauses (mapcar #'pairify clauses))
+ (names (mapcar #'car clauses))
+ (places (mapcar #'cadr clauses))
+ (gensyms (mapcar (lambda (name) (gensym (symbol-name name)))
+ names)))
+ ``(with-places (,,@(mapcar (lambda (gensym place)
+ ``(,',gensym ,,place))
+ gensyms places))
+ ,(let (,@(mapcar (lambda (name gensym)
+ `(,name ',gensym))
+ names gensyms))
+ ,@body))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
+(export 'nlet)
(defmacro nlet (name binds &body body)
"Scheme's named let."
(multiple-value-bind (vars vals)
collect val into vals
finally (return (values vars vals)))
`(labels ((,name ,vars
- ,@body))
+ ,@body))
(,name ,@vals))))
+(export 'while)
(defmacro while (cond &body body)
"If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
`(loop (unless ,cond (return)) (progn ,@body)))
+(export 'until)
(defmacro until (cond &body body)
"If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
`(loop (when ,cond (return)) (progn ,@body)))
(list `(let ((,(or vary varx) ,argument)
,@(and vary
`((,varx ,scrutinee))))
- ,@forms))
+ ,@forms))
forms))))
clauses)))))
+(export 'caase2)
(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
ARGVAR is less optional than SCRUVAR."
(do-case2-like 'case vform clauses))
+(export 'ecase2)
(defmacro ecase2 (vform &body clauses)
"Like `case2', but signals an error if no clause matches the SCRUTINEE."
(do-case2-like 'ecase vform clauses))
-;;;--------------------------------------------------------------------------
-;;; 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."
- (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))))))))
+(export 'setf-default)
+(defmacro setf-default (&rest specs)
+ "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."
+ `(progn ,@(do ((list nil)
+ (specs specs (cddr specs)))
+ ((endp specs) (nreverse list))
+ (unless (cdr specs)
+ (error "Odd number of arguments for `setf-default'."))
+ (push (with-places/gensyms ((place (car specs)))
+ `(or ,place (setf ,place ,(cadr specs))))
+ list))))
;;;--------------------------------------------------------------------------
;;; 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))))
+(export 'update-place)
+(defmacro update-place (op place &rest args)
+ "Update PLACE with (OP PLACE . ARGS), returning the new value."
+ (with-places/gensyms (place)
+ `(setf ,place (,op ,place ,@args))))
-(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)
+(export 'update-place-after)
+(defmacro update-place-after (op place &rest args)
+ "Update PLACE with (OP PLACE . ARGS), returning the old value."
+ (with-places/gensyms (place)
(with-gensyms (x)
`(let ((,x ,place))
- (setf ,place (,op ,x ,arg))
+ (setf ,place (,op ,x ,@args))
,x))))
+(export 'incf-after)
(defmacro incf-after (place &optional (by 1))
"Increment PLACE by BY, returning the old value."
`(update-place-after + ,place ,by))
+(export 'decf-after)
(defmacro decf-after (place &optional (by 1))
"Decrement PLACE by BY, returning the old value."
`(update-place-after - ,place ,by))
;;;--------------------------------------------------------------------------
;;; Locatives.
+(export 'locp)
(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))
+ (reader (slot-uninitialized) :type function :read-only t)
+ (writer (slot-uninitialized) :type function :read-only t))
+(export 'locf)
(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
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
-
-(declaim (inline loc (setf loc)))
+ (lambda (,@newtmps) ,setform)))))
+(export 'ref)
+(declaim (inline ref (setf ref)))
(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))
+(export 'with-locatives)
(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
~mdw / lisp / blobdiff