X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/64cbfb65118395be4d6628a2ba9d5b2bd95663e0..refs/heads/mdw/progfmt:/src/utilities.lisp diff --git a/src/utilities.lisp b/src/utilities.lisp index b02fdf4..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. @@ -526,17 +570,21 @@ (cdddr neigh-record) best-path))))))) dead)) -(export '(inconsistent-merge-error merge-error-candidates)) +(export '(inconsistent-merge-error + merge-error-candidates merge-error-present-function)) (define-condition inconsistent-merge-error (error) ((candidates :initarg :candidates - :reader merge-error-candidates)) + :reader merge-error-candidates) + (present :initarg :present :initform #'identity + :reader merge-error-present-function)) (:documentation "Reports an inconsistency in the arguments passed to `merge-lists'.") (:report (lambda (condition stream) (format stream "Merge inconsistency: failed to decide between ~ ~{~#[~;~A~;~A and ~A~:;~ ~@{~A, ~#[~;and ~A~]~}~]~}" - (merge-error-candidates condition))))) + (mapcar (merge-error-present-function condition) + (merge-error-candidates condition)))))) (export 'merge-lists) (defun merge-lists (lists &key pick (test #'eql) (present #'identity)) @@ -593,7 +641,8 @@ candidates)) (winner (cond ((null leasts) (error 'inconsistent-merge-error - :candidates (mapcar present candidates))) + :candidates candidates + :present present)) ((null (cdr leasts)) (car leasts)) (pick @@ -646,16 +695,17 @@ (symbol-name name) "-"))) cat-names)) (items-var (gensym "ITEMS-"))) - `(let ((,items-var ,items) - ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) - (dolist (,itemvar ,items-var) - (let* ,bind - (cond ,@(mapcar (lambda (cat-match-form cat-var) - `(,cat-match-form - (push ,itemvar ,cat-var))) - cat-match-forms cat-vars) - ,@(and (not (member t cat-match-forms)) - `((t (error "Failed to categorize ~A" ,itemvar))))))) + `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) + (let ((,items-var ,items)) + (dolist (,itemvar ,items-var) + (let* ,bind + (cond ,@(mapcar (lambda (cat-match-form cat-var) + `(,cat-match-form + (push ,itemvar ,cat-var))) + cat-match-forms cat-vars) + ,@(and (not (member t cat-match-forms)) + `((t (error "Failed to categorize ~A" + ,itemvar)))))))) (let ,(mapcar (lambda (name var) `(,name (nreverse ,var))) cat-names cat-vars) @@ -699,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)))) @@ -837,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 @@ -848,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. @@ -928,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)) @@ -938,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)) @@ -953,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. @@ -1033,6 +1087,61 @@ condition))) arguments)) +(export '(enclosing-condition enclosed-condition)) +(define-condition enclosing-condition (condition) + ((%enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) + (:documentation + "A condition which encloses another condition + + This is useful if one wants to attach additional information to an + existing condition. The enclosed condition can be obtained using the + `enclosed-condition' function.") + (:report (lambda (condition stream) + (princ (enclosed-condition condition) stream)))) + +(export 'information) +(define-condition information (condition) + ()) + +(export 'simple-information) +(define-condition simple-information (simple-condition information) + ()) + +(export 'info) +(defun info (datum &rest arguments) + "Report some useful diagnostic information. + + Establish a simple restart named `noted', and signal the condition of type + `information' designated by DATUM and ARGUMENTS. Return non-nil if the + restart was invoked, otherwise nil." + (restart-case + (signal (designated-condition 'simple-information datum arguments)) + (noted () :report "Noted." t))) + +(export 'noted) +(defun noted (&optional condition) + "Invoke the `noted' restart, possibly associated with the given CONDITION." + (invoke-associated-restart 'noted condition)) + +(export 'promiscuous-cerror) +(defun promiscuous-cerror (continue-string datum &rest arguments) + "Like standard `cerror', but robust against sneaky changes of conditions. + + It seems that `cerror' (well, at least the version in SBCL) is careful + to limit its restart to the specific condition it signalled. But that's + annoying, because `sod-parser:with-default-error-location' substitutes + different conditions carrying the error-location information." + (restart-case (apply #'error datum arguments) + (continue () + :report (lambda (stream) + (apply #'format stream continue-string datum arguments)) + nil))) + +(export 'cerror*) +(defun cerror* (datum &rest arguments) + (apply #'promiscuous-cerror "Continue" datum arguments)) + ;;;-------------------------------------------------------------------------- ;;; CLOS hacking.