X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/c884ec24084f0c2ad184ba2372fb78f501cdc165..refs/heads/mdw/progfmt:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index bdcdf80..9ff9daf 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -23,17 +23,29 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
-(cl:defpackage #:sod-utilities
-  (:use #:common-lisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (handler-bind ((warning #'muffle-warning))
+    (cl:defpackage #:sod-utilities
+      (:use #:common-lisp
 
-	;; MOP from somewhere.
-	#+sbcl #:sb-mop
-	#+(or cmu clisp) #:mop
-	#+ecl #:clos))
+	    ;; MOP from somewhere.
+	    #+sbcl #:sb-mop
+	    #+(or cmu clisp) #:mop
+	    #+ecl #:clos))))
 
 (cl:in-package #:sod-utilities)
 
 ;;;--------------------------------------------------------------------------
+;;; Common symbols.
+;;;
+;;; Sometimes, logically independent packages will want to use the same
+;;; symbol, and these uses (by careful design) don't conflict with each
+;;; other.  If we export the symbols here, then the necessary sharing will
+;;; happen automatically.
+
+(export 'int)				; used by c-types and optparse
+
+;;;--------------------------------------------------------------------------
 ;;; Macro hacks.
 
 (export 'with-gensyms)
@@ -198,8 +210,10 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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))
@@ -216,8 +230,8 @@
       (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)))
@@ -390,6 +404,17 @@
    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))
 
@@ -439,6 +464,25 @@
    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.
@@ -705,18 +749,18 @@
 			      (setf (gethash k seen) item)))))
 		sequence)))
 	((listp sequence)
-	 (mapl (lambda (tail)
-		 (let* ((item (car tail))
-			(rest (cdr tail))
-			(match (member (funcall key item) rest
-				       :test test :key key)))
-		   (when match (funcall report item (car match)))))
-	       sequence))
+	 (do ((tail sequence (cdr tail))
+	      (i 0 (1+ i)))
+	     ((endp tail))
+	     (let* ((item (car tail))
+		    (match (find (funcall key item) sequence
+				 :test test :key key :end i)))
+	       (when match (funcall report item match)))))
 	((vectorp sequence)
 	 (dotimes (i (length sequence))
 	   (let* ((item (aref sequence i))
 		  (pos (position (funcall key item) sequence
-				 :key key :test test :start (1+ i))))
+				 :key key :test test :end i)))
 	     (when pos (funcall report item (aref sequence pos))))))
 	(t
 	 (error 'type-error :datum sequence :expected-type 'sequence))))
@@ -843,7 +887,7 @@
 ;;; Functions.
 
 (export 'compose)
-(defun compose (function &rest more-functions)
+(defun compose (&rest functions)
   "Composition of functions.  Functions are applied left-to-right.
 
    This is the reverse order of the usual mathematical notation, but I find
@@ -854,7 +898,9 @@
   (labels ((compose1 (func-a func-b)
 	     (lambda (&rest args)
 	       (multiple-value-call func-b (apply func-a args)))))
-    (reduce #'compose1 more-functions :initial-value function)))
+    (if (null functions) #'values
+	(reduce #'compose1 (cdr functions)
+		:initial-value (car functions)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Variables.
@@ -934,8 +980,9 @@
    The loop is surrounded by an anonymous BLOCK and the loop body forms an
    implicit TAGBODY, as is usual.  There is no result-form, however."
 
-  (once-only (:environment env seq start end)
-    (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
+  (once-only (:environment env start end)
+    (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-")
+		   (endvar "END-") (bodyfunc "BODY-"))
       (multiple-value-bind (docs decls body) (parse-body body :docp nil)
 	(declare (ignore docs))
 
@@ -944,13 +991,13 @@
 		 (let* ((do-vars nil)
 			(end-condition (if endvar
 					   `(>= ,ivar ,endvar)
-					   `(endp ,seq)))
+					   `(endp ,seqvar)))
 			(item (if listp
-				  `(car ,seq)
-				  `(aref ,seq ,ivar)))
+				  `(car ,seqvar)
+				  `(aref ,seqvar ,ivar)))
 			(body-call `(,bodyfunc ,item)))
 		   (when listp
-		     (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+		     (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar))
 			   do-vars))
 		   (when indexp
 		     (push `(,ivar ,start (1+ ,ivar)) do-vars))
@@ -959,17 +1006,18 @@
 		   `(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))))
-		    ,(loopguts t nil endvar)))
-		 (list
-		  (if ,end
-		      ,(loopguts t t end)
-		      ,(loopguts indexvar t nil)))))))))))
+	     (let ((,seqvar ,seq))
+	       (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+			,@decls
+			(tagbody ,@body)))
+		 (etypecase ,seqvar
+		   (vector
+		    (let ((,endvar (or ,end (length ,seqvar))))
+		      ,(loopguts t nil endvar)))
+		   (list
+		    (if ,end
+			,(loopguts t t end)
+			,(loopguts indexvar t nil))))))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Structure accessor hacks.