X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/dea4d05507e59ab779ed4bb209e05971d87e260c..e8abb2862e1a3b5f5a296d4fc00fe1b8e3200b4b:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index 15f9091..d1755da 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -195,6 +195,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) @@ -213,7 +273,7 @@ `(let ((it ,cond)) (when it ,@body))) (export 'acond) -(defmacro acond (&rest clauses &environment env) +(defmacro acond (&body clauses &environment env) "Like COND, but with `it' bound to the value of the condition. Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is @@ -271,6 +331,30 @@ ;;;-------------------------------------------------------------------------- ;;; MOP hacks (not terribly demanding). +(export 'instance-initargs) +(defgeneric instance-initargs (instance) + (:documentation + "Return a plausble list of initargs for INSTANCE. + + The idea is that you can make a copy of INSTANCE by invoking + + (apply #'make-instance (class-of INSTANCE) + (instance-initargs INSTANCE)) + + The default implementation works by inspecting the slot definitions and + extracting suitable initargs, so this will only succeed if enough slots + actually have initargs specified that `initialize-instance' can fill in + the rest correctly. + + The list returned is freshly consed, and you can destroy it if you like.") + (:method ((instance standard-object)) + (mapcan (lambda (slot) + (aif (slot-definition-initargs slot) + (list (car it) + (slot-value instance (slot-definition-name slot))) + nil)) + (class-slots (class-of instance))))) + (export '(copy-instance copy-instance-using-class)) (defgeneric copy-instance-using-class (class instance &rest initargs) (:documentation @@ -289,6 +373,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. @@ -354,7 +441,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. @@ -578,7 +665,10 @@ "Composition of functions. Functions are applied left-to-right. This is the reverse order of the usual mathematical notation, but I find - it easier to read. It's also slightly easier to work with in programs." + it easier to read. It's also slightly easier to work with in programs. + That is, (compose F1 F2 ... Fn) is what a category theorist might write as + F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn." + (labels ((compose1 (func-a func-b) (lambda (&rest args) (multiple-value-call func-b (apply func-a args))))) @@ -591,7 +681,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)))) ;;;-------------------------------------------------------------------------- @@ -602,7 +692,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)) @@ -664,6 +754,26 @@ ,(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. (export 'default-slot) @@ -687,4 +797,16 @@ (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'." + (with-gensyms (classvar slotvar) + `(defmethod slot-unbound + (,classvar (,instance ,class) (,slotvar (eql ',slot))) + (declare (ignore ,classvar)) + (setf (slot-value ,instance ',slot) (progn ,@body))))) + ;;;----- That's all, folks --------------------------------------------------