X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/fe0f07ea19b36ce1abc1ec305d0203323cbf2316..ea87c989d51bfd4b64d2a802f87216dfce551a76:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index 73f85e7..ab1a47c 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. @@ -31,10 +31,12 @@ (:export #:unsigned-fixnum #:compile-time-defun #:show - #:stringify #:mappend #: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 #:until #: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 @@ -64,7 +66,7 @@ "Debugging tool: print the expression X and its values." (let ((tmp (gensym))) `(let ((,tmp (multiple-value-list ,x))) - (format t "~&") + (fresh-line) (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ") (format t "~S = ~@_~:I~:[#~;~:*~{~S~^ ~_~}~]" @@ -80,8 +82,14 @@ (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 @@ -119,11 +127,25 @@ (defun whitespace-char-p (ch) "Return whether CH is a whitespace character or not." (case ch - ((#\space #\tab #\newline #\return #\vt - #+cmu #\formfeed - #+clisp #\page) 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 @@ -149,6 +171,17 @@ (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)) @@ -162,7 +195,7 @@ (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)) (defmacro let*/gensyms (binds &body body) @@ -171,16 +204,16 @@ 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))))))) ;;;-------------------------------------------------------------------------- ;;; Some simple yet useful control structures. @@ -194,7 +227,7 @@ collect val into vals finally (return (values vars vals))) `(labels ((,name ,vars - ,@body)) + ,@body)) (,name ,@vals)))) (defmacro while (cond &body body) @@ -220,7 +253,7 @@ (list `(let ((,(or vary varx) ,argument) ,@(and vary `((,varx ,scrutinee)))) - ,@forms)) + ,@forms)) forms)))) clauses))))) @@ -239,8 +272,33 @@ "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 +;;; Capturing places as symbols. (defmacro %place-ref (getform setform newtmp) "Grim helper macro for with-places." @@ -260,29 +318,29 @@ (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)))))))) + (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)))))))) ;;;-------------------------------------------------------------------------- ;;; Update-in-place macros built using with-places. @@ -327,7 +385,7 @@ (get-setf-expansion place env) `(let* (,@(mapcar #'list valtmps valforms)) (make-loc (lambda () ,getform) - (lambda (,@newtmps) ,setform))))) + (lambda (,@newtmps) ,setform))))) (declaim (inline loc (setf loc)))