X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/141283ff3851f6ada772db21a496026fd8fdd76e..cac85e0be5833902081c903f75e348b949294fb9:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 1093f68..3c33be2 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -175,19 +175,20 @@ (,bodyfunc)))))))) (export 'parse-body) -(defun parse-body (body) +(defun parse-body (body &key (docp t) (declp t)) "Parse the BODY into a docstring, declarations and the body forms. These are returned as three lists, so that they can be spliced into a macro expansion easily. The declarations are consolidated into a single - `declare' form." + `declare' form. If DOCP is nil then a docstring is not permitted; if + DECLP is nil, then declarations are not permitted." (let ((decls nil) (doc nil)) (loop (cond ((null body) (return)) - ((and (consp (car body)) (eq (caar body) 'declare)) + ((and declp (consp (car body)) (eq (caar body) 'declare)) (setf decls (append decls (cdr (pop body))))) - ((and (stringp (car body)) (not doc) (cdr body)) + ((and docp (stringp (car body)) (not doc) (cdr body)) (setf doc (pop body))) (t (return)))) (values (and doc (list doc)) @@ -195,6 +196,66 @@ body))) ;;;-------------------------------------------------------------------------- +;;; Locatives. + +(export '(loc locp)) +(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) + "Locative data type. See `locf' and `ref'." + (reader nil :type function) + (writer nil :type function)) + +(export 'locf) +(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 cheesy because it uses + closures rather than actually taking the address of something. Also, + unlike Zetalisp, we don't overload `car' to do our dirty work." + (multiple-value-bind + (valtmps valforms newtmps setform getform) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list valtmps valforms)) + (make-loc (lambda () ,getform) + (lambda (,@newtmps) ,setform))))) + +(export 'ref) +(declaim (inline ref (setf ref))) +(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)) + +(export 'with-locatives) +(defmacro with-locatives (locs &body body) + "Evaluate BODY with implicit locatives. + + 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 + defaults to SYM. As an abbreviation for a common case, LOCS may be a + symbol instead of a list. + + The BODY is evaluated in an environment where each SYM is a symbol macro + which expands to (ref LOC-EXPR) -- or, in fact, something similar which + doesn't break if LOC-EXPR has side-effects. Thus, references, including + `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. + Useful for covering over where something uses a locative." + (setf locs (mapcar (lambda (item) + (cond ((atom item) (list item item)) + ((null (cdr item)) (list (car item) (car item))) + (t item))) + (if (listp locs) locs (list locs)))) + (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) + (ll (mapcar #'cadr locs)) + (ss (mapcar #'car locs))) + `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) + (symbol-macrolet (,@(mapcar (lambda (sym tmp) + `(,sym (ref ,tmp))) ss tt)) + ,@body)))) + +;;;-------------------------------------------------------------------------- ;;; Anaphorics. (export 'it) @@ -661,29 +722,32 @@ (once-only (:environment env seq start end) (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-")) - - (flet ((loopguts (indexp listp endvar) - ;; Build a DO-loop to do what we want. - (let* ((do-vars nil) - (end-condition (if endvar - `(>= ,ivar ,endvar) - `(endp ,seq))) - (item (if listp - `(car ,seq) - `(aref ,seq ,ivar))) - (body-call `(,bodyfunc ,item))) - (when listp - (push `(,seq (nthcdr ,start ,seq) (cdr ,seq)) - do-vars)) - (when indexp - (push `(,ivar ,start (1+ ,ivar)) do-vars)) - (when indexvar - (setf body-call (append body-call (list ivar)))) - `(do ,do-vars (,end-condition) ,body-call)))) - - `(block nil - (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) - (tagbody ,@body))) + (multiple-value-bind (docs decls body) (parse-body body :docp nil) + (declare (ignore docs)) + + (flet ((loopguts (indexp listp endvar) + ;; Build a DO-loop to do what we want. + (let* ((do-vars nil) + (end-condition (if endvar + `(>= ,ivar ,endvar) + `(endp ,seq))) + (item (if listp + `(car ,seq) + `(aref ,seq ,ivar))) + (body-call `(,bodyfunc ,item))) + (when listp + (push `(,seq (nthcdr ,start ,seq) (cdr ,seq)) + do-vars)) + (when indexp + (push `(,ivar ,start (1+ ,ivar)) do-vars)) + (when indexvar + (setf body-call (append body-call (list ivar)))) + `(do ,do-vars (,end-condition) ,body-call)))) + + `(block nil + (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) + ,@decls + (tagbody ,@body))) (etypecase ,seq (vector (let ((,endvar (or ,end (length ,seq)))) @@ -691,7 +755,7 @@ (list (if ,end ,(loopguts t t end) - ,(loopguts indexvar t nil)))))))))) + ,(loopguts indexvar t nil))))))))))) ;;;-------------------------------------------------------------------------- ;;; Structure accessor hacks. @@ -743,10 +807,12 @@ Sets up the named SLOT of CLASS to establish its value as the implicit progn BODY, by defining an appropriate method on `slot-unbound'." - (with-gensyms (classvar slotvar) - `(defmethod slot-unbound - (,classvar (,instance ,class) (,slotvar (eql ',slot))) - (declare (ignore ,classvar)) - (setf (slot-value ,instance ',slot) (progn ,@body))))) + (multiple-value-bind (docs decls body) (parse-body body) + (with-gensyms (classvar slotvar) + `(defmethod slot-unbound + (,classvar (,instance ,class) (,slotvar (eql ',slot))) + ,@docs ,@decls + (declare (ignore ,classvar)) + (setf (slot-value ,instance ',slot) (progn ,@body)))))) ;;;----- That's all, folks --------------------------------------------------