X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/ad18ddfca6c8a13c604759c0759017e3cd6280d7..813da880d2d77f04ea623f426d543d298528f967:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index 0290ea9..aa14f27 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -1,7 +1,5 @@ ;;; -*-lisp-*- ;;; -;;; $Id$ -;;; ;;; Basic definitions ;;; ;;; (c) 2005 Mark Wooding @@ -28,20 +26,6 @@ (defpackage #:mdw.base (:use #:common-lisp) - (:export #:unsigned-fixnum - #:compile-time-defun - #:show - #: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 - #:update-place #:update-place-after - #:incf-after #:decf-after - #:fixnump) #+cmu (:import-from #:extensions #:fixnump)) (in-package #:mdw.base) @@ -49,6 +33,7 @@ ;;;-------------------------------------------------------------------------- ;;; Useful types. +(export 'unsigned-fixnum) (deftype unsigned-fixnum () "Unsigned fixnums; useful as array indices and suchlike." `(mod ,most-positive-fixnum)) @@ -56,12 +41,14 @@ ;;;-------------------------------------------------------------------------- ;;; 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 :execute) (defun ,name ,args ,@body))) +(export 'show) (defmacro show (x) "Debugging tool: print the expression X and its values." (let ((tmp (gensym))) @@ -75,6 +62,7 @@ (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 @@ -84,6 +72,7 @@ (symbol (symbol-name str)) (t (princ-to-string str)))) +(export 'functionify) (defun functionify (func) "Convert the function-designator FUNC to a function." (declare (type (or function symbol) func)) @@ -91,12 +80,14 @@ (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))) @@ -110,6 +101,7 @@ ((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 @@ -120,10 +112,12 @@ 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 @@ -135,6 +129,7 @@ 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." @@ -146,12 +141,14 @@ (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 @@ -171,6 +168,7 @@ (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 @@ -182,6 +180,7 @@ ,@(if docp nil `((declare (ignore ,docvar)))) ,@body)) +(export 'fixnump) #-cmu (progn (declaim (inline fixnump)) @@ -192,12 +191,23 @@ ;;;-------------------------------------------------------------------------- ;;; 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))) ,@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 @@ -216,88 +226,6 @@ (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))) - -;;;-------------------------------------------------------------------------- ;;; Capturing places as symbols. (defmacro %place-ref (getform setform newtmp) @@ -309,6 +237,7 @@ "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. @@ -335,6 +264,7 @@ (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'. @@ -368,13 +298,94 @@ ,@body)))) ;;;-------------------------------------------------------------------------- +;;; Some simple yet useful control structures. + +(export 'nlet) +(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)))) + +(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))) + +(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))))) + +(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 ([[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)) + +(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. +(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)))) +(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) @@ -383,10 +394,12 @@ (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)) @@ -394,11 +407,13 @@ ;;;-------------------------------------------------------------------------- ;;; 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 @@ -412,16 +427,16 @@ (make-loc (lambda () ,getform) (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