X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/560e118666d0a7c41a43e2d86e2f38e3b931ef14..813da880d2d77f04ea623f426d543d298528f967:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index bbe7662..aa14f27 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Basic definitions ;;; ;;; (c) 2005 Mark Wooding @@ -13,12 +11,12 @@ ;;; 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. @@ -28,44 +26,68 @@ (defpackage #:mdw.base (:use #:common-lisp) - (:export #:compile-time-defun - #:show - #:stringify #:listify #:fix-pair #:pairify - #:whitespace-char-p - #:slot-uninitialized - #:nlet #:while #:case2 #:ecase2 - #:with-gensyms #:let*/gensyms #:with-places - #:locp #:locf #:ref #:with-locatives - #:update-place #:update-place-after - #:incf-after #:decf-after)) + #+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) + process." + `(eval-when (:compile-toplevel :load-toplevel :execute) (defun ,name ,args ,@body))) +(export 'show) (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~:[#~;~:*~{~S~^ ~_~}~]" + ',x + ,tmp)) + (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 -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)))) + +(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))) @@ -79,61 +101,206 @@ converted to their print representations." ((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 - (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)) +(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." + 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 + `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)))))))) + +(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)) + (defun fixnump (object) + "Answer non-nil if OBJECT is a fixnum, or nil if it isn't." + (typep object 'fixnum))) + ;;;-------------------------------------------------------------------------- ;;; 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." + 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) @@ -143,14 +310,18 @@ gensyms will be bound to the corresponding VALUE." 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)) - ,@body)) + `(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))) (compile-time-defun do-case2-like (kind vform clauses) "Helper function for `case2' and `ecase2'." @@ -160,92 +331,75 @@ gensyms will be bound to the corresponding VALUE." (,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))))) +(export 'case2) (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)) +(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)) @@ -253,43 +407,46 @@ reading or setting the value of the corresponding PLACE." ;;;-------------------------------------------------------------------------- ;;; 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 -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))) + (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 -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))