;;; 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
#:show
- #:stringify #:listify #:fix-pair #:pairify
+ #:stringify #: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))
+ #:locp #:locf #:ref #:with-locatives
+ #:update-place #:update-place-after
+ #:incf-after #:decf-after))
(in-package #:mdw.base)
+;;;--------------------------------------------------------------------------
+;;; 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."
(symbol (symbol-name str))
(t (with-output-to-string (s)
(princ str s)))))
+
(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 -> 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)))
((#\space #\tab #\newline #\return #\vt #\formfeed) t)
(t nil)))
-(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))
- ,@body))
-
(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."))
+(compile-time-defun parse-body (body)
+ "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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Generating symbols.
+
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
`(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))
+ ,@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 var) &rest forms)
+ clause
+ `(,cases
+ ,@(if var
+ (list `(let ((,var ,argument)) ,@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."
+ (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))
+
+;;;--------------------------------------------------------------------------
+;;; 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
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
`(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
~mdw / lisp / blobdiff