X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/861345b43569790e39df152c6b495b14e7dab360..2c13c1cd713e033763786de1ce9fc66565abb5df:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index 3111832..8ba9a24 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -23,42 +23,76 @@ ;;; 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 #: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)) + #: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." + process." `(eval-when (:compile-toplevel :load-toplevel) (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~:[#~;~:*~{~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))))) + +(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)))) @@ -67,15 +101,17 @@ converted to their print representations." ((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))) @@ -83,15 +119,46 @@ where Y defaults to A if not specified." (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)) (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)))))))) + +#-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)))) @@ -100,9 +167,9 @@ structure definitions without doom ensuing." (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)) @@ -115,19 +182,81 @@ gensyms will be bound to the corresponding VALUE." `(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)) + +;;;-------------------------------------------------------------------------- +;;; 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) @@ -155,38 +284,71 @@ reading or setting the value of the corresponding PLACE." 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))