src/utilities.lisp, src/optparse.lisp: Move locatives to `utilities'.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 98d314a..d1755da 100644 (file)
--- 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)
@@ -713,18 +773,6 @@
            `((defun (setf ,from) (value object)
                (setf (,to object) 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)))))
-
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.
 
@@ -749,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 --------------------------------------------------