X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/b3bc37457df55c92cabc8aeeb42bc67d3fb8af12..f36fbd9c42e8c151fc55de3efa1cb0520ba20927:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index 6b235f5..95b79de 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -13,12 +13,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,33 +28,52 @@ (defpackage #:mdw.base (:use #:common-lisp) - (:export #:compile-time-defun + (:export #:unsigned-fixnum + #:compile-time-defun #:show - #:stringify #:listify #:fix-pair #:pairify #:parse-body + #:stringify #:functionify #:mappend + #:listify #:fix-pair #:pairify + #:parse-body #:with-parsed-body #:whitespace-char-p #:slot-uninitialized - #:nlet #:while #:case2 #:ecase2 + #: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)) + #: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." - `(eval-when (:compile-toplevel :load-toplevel) + `(eval-when (:compile-toplevel :load-toplevel :execute) (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))) + (fresh-line) + (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; @@ -63,8 +82,20 @@ (typecase str (string str) (symbol (symbol-name str)) - (t (with-output-to-string (s) - (princ str s))))) + (t (princ-to-string str)))) + +(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)))) + +(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)." @@ -96,33 +127,67 @@ (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))) +(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)))) + (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) +(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 `@,'." - (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))))) + 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)))))))) + +(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)) + +#-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. @@ -167,9 +232,11 @@ (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))) + +(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'." @@ -205,6 +272,31 @@ "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))) + ;;;-------------------------------------------------------------------------- ;;; with-places