From: Mark Wooding Date: Thu, 20 Apr 2006 11:03:09 +0000 (+0100) Subject: General tidying and prettifying. X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/lisp/commitdiff_plain/02866e072a8ac99b5e639fe79b4a7c6df5f11fdc?ds=sidebyside;hp=e09b6d1d4ad8756be39b092f1fe72f771cb2296c General tidying and prettifying. --- diff --git a/mdw-base.lisp b/mdw-base.lisp index 21948fa..4d67b7a 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -23,6 +23,9 @@ ;;; 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 @@ -36,6 +39,9 @@ (defpackage #:mdw.base #:incf-after #:decf-after)) (in-package #:mdw.base) +;;;-------------------------------------------------------------------------- +;;; 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." @@ -58,9 +64,11 @@ (defun stringify (str) (symbol (symbol-name str)) (t (with-output-to-string (s) (princ str s))))) + (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)))) @@ -69,6 +77,7 @@ (compile-time-defun do-fix-pair (x y defaultp) ((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 @@ -78,6 +87,7 @@ (compile-time-defun fix-pair (x &optional (y nil defaultp)) 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))) @@ -112,6 +122,9 @@ (defun slot-uninitialized () structure definitions without doom ensuing." (error "No initializer for slot.")) +;;;-------------------------------------------------------------------------- +;;; Generating symbols. + (defmacro with-gensyms (syms &body body) "Everyone's favourite macro helper." `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) @@ -135,13 +148,18 @@ (defmacro let*/gensyms (binds &body body) `(progn ,@body) (car (more (mapcar #'pairify (listify binds))))))) +;;;-------------------------------------------------------------------------- +;;; 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 @@ -175,29 +193,38 @@ (defmacro with-places ((&key environment) places &body body) 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)))) + (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 @@ -210,13 +237,17 @@ (defmacro locf (place &environment 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 diff --git a/optparse.lisp b/optparse.lisp index 7819b70..a09c188 100644 --- a/optparse.lisp +++ b/optparse.lisp @@ -23,6 +23,9 @@ ;;; along with this program; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +;;;-------------------------------------------------------------------------- +;;; Packages. + (defpackage #:mdw.optparse (:use #:common-lisp #:mdw.base #:mdw.sys-base #:mdw.str) (:export #:exit #:*program-name* #:*command-line-strings* @@ -45,6 +48,7 @@ (defpackage #:mdw.optparse (in-package #:mdw.optparse) +;;;-------------------------------------------------------------------------- ;;; Standard error-reporting functions. (defun moan (msg &rest args) @@ -55,6 +59,7 @@ (defun die (&rest args) (apply #'moan args) (exit 1)) +;;;-------------------------------------------------------------------------- ;;; The main option parser. (defstruct (option (:predicate optionp) @@ -411,6 +416,7 @@ (defmacro with-unix-error-reporting ((&key) &body body) (error (,cond) (die "~A" ,cond))))) +;;;-------------------------------------------------------------------------- ;;; Standard option handlers. (defmacro defopthandler (name (var &optional (arg (gensym))) @@ -663,6 +669,7 @@ (defmacro options (&rest optlist) (parse-option-form form))) optlist))) +;;;-------------------------------------------------------------------------- ;;; Support stuff for help and usage messages (defun print-text (string