X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/blobdiff_plain/b2c12b4eaf6e5c43791d95080a243c35f97ee488..171bb403b78e6868ee77250681b7c5adb0c85bd9:/mdw-base.lisp diff --git a/mdw-base.lisp b/mdw-base.lisp index 646eb7e..a5b154b 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -31,7 +31,8 @@ (:export #:unsigned-fixnum #:compile-time-defun #:show - #:stringify #:mappend #:listify #:fix-pair #:pairify + #:stringify #:functionify #:mappend + #:listify #:fix-pair #:pairify #:parse-body #:with-parsed-body #:whitespace-char-p #:slot-uninitialized @@ -65,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~^ ~_~}~]" @@ -83,6 +84,13 @@ (symbol (symbol-name str)) (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 @@ -127,6 +135,17 @@ 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 @@ -176,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) @@ -185,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. @@ -208,7 +227,7 @@ collect val into vals finally (return (values vars vals))) `(labels ((,name ,vars - ,@body)) + ,@body)) (,name ,@vals)))) (defmacro while (cond &body body) @@ -234,7 +253,7 @@ (list `(let ((,(or vary varx) ,argument) ,@(and vary `((,varx ,scrutinee)))) - ,@forms)) + ,@forms)) forms)))) clauses))))) @@ -279,7 +298,7 @@ (doit specs))) ;;;-------------------------------------------------------------------------- -;;; with-places +;;; Capturing places as symbols. (defmacro %place-ref (getform setform newtmp) "Grim helper macro for with-places." @@ -290,53 +309,78 @@ "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)))))))) +(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)))) + +(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)))) ;;;-------------------------------------------------------------------------- ;;; 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 (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) +(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)))) (defmacro incf-after (place &optional (by 1)) @@ -366,7 +410,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)))