X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bf090e021a5c20da452a4841cdfb8eb78e29544e..cac85e0be5833902081c903f75e348b949294fb9:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 5c061bb..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) @@ -313,6 +374,9 @@ except where overridden by INITARGS." (apply #'copy-instance-using-class (class-of object) object initargs)) +(export '(generic-function-methods method-specializers + eql-specializer eql-specializer-object)) + ;;;-------------------------------------------------------------------------- ;;; List utilities. @@ -378,7 +442,7 @@ the input LISTS in the sense that if A precedes B in some input list then A will also precede B in the output list. If the lists aren't consistent (e.g., some list contains A followed by B, and another contains B followed - by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled. + by A) then an error of type `inconsistent-merge-error' is signalled. Item equality is determined by TEST. @@ -618,7 +682,7 @@ (defun symbolicate (&rest symbols) "Return a symbol named after the concatenation of the names of the SYMBOLS. - The symbol is interned in the current *PACKAGE*. Trad." + The symbol is interned in the current `*package*'. Trad." (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) ;;;-------------------------------------------------------------------------- @@ -629,7 +693,7 @@ ((object stream &rest args) &body body) "Print helper for usually-unreadable objects. - If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY. + If `*print-escape*' is set then print OBJECT unreadably using BODY. Otherwise just print using BODY." (with-gensyms (print) `(flet ((,print () ,@body)) @@ -658,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)))) @@ -688,7 +755,27 @@ (list (if ,end ,(loopguts t t end) - ,(loopguts indexvar t nil)))))))))) + ,(loopguts indexvar t nil))))))))))) + +;;;-------------------------------------------------------------------------- +;;; Structure accessor hacks. + +(export 'define-access-wrapper) +(defmacro define-access-wrapper (from to &key read-only) + "Make (FROM THING) work like (TO THING). + + If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like + (setf (TO THING) VALUE). + + This is mostly useful for structure slot accessors where the slot has to + be given an unpleasant name to avoid it being an external symbol." + `(progn + (declaim (inline ,from ,@(and (not read-only) `((setf ,from))))) + (defun ,from (object) + (,to object)) + ,@(and (not read-only) + `((defun (setf ,from) (value object) + (setf (,to object) value)))))) ;;;-------------------------------------------------------------------------- ;;; CLOS hacking. @@ -714,4 +801,18 @@ (setf (slot-value ,instance ,slot) (progn ,@value))))) +(export 'define-on-demand-slot) +(defmacro define-on-demand-slot (class slot (instance) &body body) + "Defines a slot which computes its initial value on demand. + + Sets up the named SLOT of CLASS to establish its value as the implicit + progn BODY, by defining an appropriate method on `slot-unbound'." + (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 --------------------------------------------------