+;;; 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))))
+
+;;;--------------------------------------------------------------------------
~mdw / sod / blobdiff