X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/9a3cb4610ab59001fd44c13dcdc6ea206acf0e50..refs/heads/mdw/progfmt:/src/utilities.lisp?ds=inline

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 1670f55..9ff9daf 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -210,8 +210,10 @@ (defun parse-body (body &key (docp t) (declp t))
 ;;;--------------------------------------------------------------------------
 ;;; Locatives.
 
-(export '(loc locp))
-(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
+(export '(locative locativep))
+(defstruct (locative (:predicate locativep)
+		     (:constructor make-locative (reader writer))
+		     (:conc-name loc-))
   "Locative data type.  See `locf' and `ref'."
   (reader nil :type function)
   (writer nil :type function))
@@ -228,8 +230,8 @@ (defmacro locf (place &environment env)
       (valtmps valforms newtmps setform getform)
       (get-setf-expansion place env)
     `(let* (,@(mapcar #'list valtmps valforms))
-       (make-loc (lambda () ,getform)
-		 (lambda (,@newtmps) ,setform)))))
+       (make-locative (lambda () ,getform)
+		      (lambda (,@newtmps) ,setform)))))
 
 (export 'ref)
 (declaim (inline ref (setf ref)))
@@ -402,6 +404,17 @@ (defun copy-instance (object &rest initargs)
    except where overridden by INITARGS."
   (apply #'copy-instance-using-class (class-of object) object initargs))
 
+(export 'find-eql-specialized-method)
+(defun find-eql-specialized-method (function arg object)
+  "Return a method defined on FUNCTION whose ARGth argument is
+   `eql'-specialized on OBJECT."
+  (find-if (lambda (method)
+	     (let ((spec (nth arg (method-specializers method))))
+	       (and spec
+		    (typep spec 'eql-specializer)
+		    (eq (eql-specializer-object spec) object))))
+	   (generic-function-methods function)))
+
 (export '(generic-function-methods method-specializers
 	  eql-specializer eql-specializer-object))
 
@@ -451,6 +464,25 @@ (defun mappend (function list &rest more-lists)
    and return the result of appending all of the resulting lists."
   (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
 
+(export 'cross-product)
+(defun cross-product (&rest pieces)
+  "Return the cross product of the PIECES.
+
+   Each arguments may be a list, or a (non-nil) atom, which is equivalent to
+   a singleton list containing just that atom.  Return a list of all possible
+   lists which can be constructed by taking one item from each argument list
+   in turn, in an arbitrary order."
+  (reduce (lambda (piece tails)
+	    (mapcan (lambda (tail)
+		      (mapcar (lambda (head)
+				(cons head tail))
+			      (if (listp piece) piece
+				  (list piece))))
+		    tails))
+	  pieces
+	  :from-end t
+	  :initial-value '(nil)))
+
 (export 'distinguished-point-shortest-paths)
 (defun distinguished-point-shortest-paths (root neighbours-func)
   "Moderately efficient shortest-paths-from-root computation.