From 7769f8fdb8694fe33ebb6198978d96e22e05c027 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 22 Oct 2015 00:46:28 +0100 Subject: [PATCH] mdw-base.lisp: Move `with-places' to earlier in the file. --- mdw-base.lisp | 144 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 72 insertions(+), 72 deletions(-) diff --git a/mdw-base.lisp b/mdw-base.lisp index 6cdcccf..4bed97d 100644 --- a/mdw-base.lisp +++ b/mdw-base.lisp @@ -219,6 +219,78 @@ (car (more (mapcar #'pairify (listify binds))))))) ;;;-------------------------------------------------------------------------- +;;; Capturing places as symbols. + +(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)) + +(export 'with-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)))) + +(export 'with-places/gensyms) +(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)))) + +;;;-------------------------------------------------------------------------- ;;; Some simple yet useful control structures. (export 'nlet) @@ -307,78 +379,6 @@ (doit specs))) ;;;-------------------------------------------------------------------------- -;;; Capturing places as symbols. - -(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)) - -(export 'with-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)))) - -(export 'with-places/gensyms) -(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. (export 'update-place) -- 2.11.0