;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; 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)
form))))
(export 'once-only)
-(defmacro once-only (binds &body body)
+(defmacro once-only ((&rest binds) &body body)
"Macro helper for preventing repeated evaluation.
The syntax is actually hairier than shown:
"If COND, evaluate BODY as a progn with `it' bound to the value of COND."
`(let ((it ,cond)) (when it ,@body)))
+(export 'aand)
+(defmacro aand (&rest forms)
+ "Like `and', but anaphoric.
+
+ Each FORM except the first is evaluated with `it' bound to the value of
+ the previous one. If there are no forms, then the result it `t'; if there
+ is exactly one, then wrapping it in `aand' is pointless."
+ (labels ((doit (first rest)
+ (if (null rest)
+ first
+ `(let ((it ,first))
+ (if it ,(doit (car rest) (cdr rest)) nil)))))
+ (if (null forms)
+ 't
+ (doit (car forms) (cdr forms)))))
+
(export 'acond)
(defmacro acond (&body clauses &environment env)
"Like COND, but with `it' bound to the value of the condition.
(export 'mappend)
(defun mappend (function list &rest more-lists)
- "Like a nondestructive MAPCAN.
+ "Like a nondestructive `mapcan'.
Map FUNCTION over the the corresponding elements of LIST and 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 '(inconsistent-merge-error merge-error-candidates))
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+ "Moderately efficient shortest-paths-from-root computation.
+
+ The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC
+ accepts a VERTEX as its only argument, and returns a list of conses (V .
+ C) for each of the VERTEX's neighbours, indicating that there is an edge
+ from VERTEX to V, with cost C.
+
+ The return value is a list of entries (COST . REV-PATH) for each vertex
+ reachable from the ROOT; the COST is the total cost of the shortest path,
+ and REV-PATH is the path from the ROOT, in reverse order -- so the first
+ element is the vertex itself and the last element is the ROOT.
+
+ The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+ produce its output list. The computation as a whole takes O(N^2) time,
+ where N is the number of vertices in the graph, assuming there is at most
+ one edge between any pair of vertices."
+
+ ;; This is a listish version of Dijkstra's shortest-path algorithm. It
+ ;; could be made more efficient by using a fancy priority queue rather than
+ ;; a linear search for finding the nearest live element (see below), but it
+ ;; still runs pretty well.
+
+ (let ((map (make-hash-table))
+ (dead nil)
+ (live (list (list 0 root))))
+ (setf (gethash root map) (cons :live (car live)))
+ (loop
+ ;; The dead list contains a record, in output format (COST . PATH), for
+ ;; each vertex whose shortest path has been finally decided. The live
+ ;; list contains a record for the vertices of current interest, also in
+ ;; output format; the COST for a live record shows the best cost for a
+ ;; path using only dead vertices.
+ ;;
+ ;; Each time through here, we pull an item off the live list and
+ ;; push it onto the dead list, so we do at most N iterations total.
+
+ ;; If there are no more live items, then we're done; the remaining
+ ;; vertices, if any, are unreachable from the ROOT.
+ (when (null live) (return))
+
+ ;; Find the closest live vertex to the root. The linear scan through
+ ;; the live list costs at most N time.
+ (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+ (best-cost (car best))
+ (best-path (cdr best))
+ (best-vertex (car best-path)))
+
+ ;; Remove the chosen vertex from the LIVE list, and add the
+ ;; appropriate record to the dead list. We must have the shortest
+ ;; path to this vertex now: we have the shortest path using currently
+ ;; dead vertices; any other path must use at least one live vertex,
+ ;; and, by construction, the path through any such vertex must be
+ ;; further than the path we already have.
+ ;;
+ ;; Removal from the live list uses a linear scan which costs N time.
+ (setf live (delete best live))
+ (push best dead)
+ (setf (car (gethash best-vertex map)) :dead)
+
+ ;; Work through the chosen vertex's neighbours, adding each of them
+ ;; to the live list if they're not already there. If a neighbour is
+ ;; already live, and we find a shorter path to it through our chosen
+ ;; vertex, then update the neighbour's record.
+ ;;
+ ;; The chosen vertex obviously has at most N neighbours. There's no
+ ;; more looping in here, so performance is as claimed.
+ (dolist (neigh (funcall neighbours-func best-vertex))
+ (let* ((neigh-vertex (car neigh))
+ (neigh-cost (+ best-cost (cdr neigh)))
+ (neigh-record (gethash neigh-vertex map)))
+ (cond ((null neigh-record)
+ ;; If the neighbour isn't known, then now's the time to
+ ;; make a fresh live record for it.
+ (let ((new-record (list* :live neigh-cost
+ neigh-vertex best-path)))
+ (push (cdr new-record) live)
+ (setf (gethash neigh-vertex map) new-record)))
+ ((and (eq (car neigh-record) :live)
+ (< neigh-cost (cadr neigh-record)))
+ ;; If the neighbour is live, and we've found a better path
+ ;; to it, then update its record.
+ (setf (cadr neigh-record) neigh-cost
+ (cdddr neigh-record) best-path)))))))
+ dead))
+
+(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 among ~A."
- (merge-error-candidates condition)))))
+ (format stream "Merge inconsistency: failed to decide between ~
+ ~{~#[~;~A~;~A and ~A~:;~
+ ~@{~A, ~#[~;and ~A~]~}~]~}"
+ (mapcar (merge-error-present-function condition)
+ (merge-error-candidates condition))))))
(export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
"Return a merge of the given LISTS.
The resulting list contains the items of the given LISTS, with duplicates
the input LISTS in the sense that if A precedes B in some input list then
A will also precede B in the output list. If the lists aren't consistent
(e.g., some list contains A followed by B, and another contains B followed
- by A) then an error of type `inconsistent-merge-error' is signalled.
+ by A) then an error of type `inconsistent-merge-error' is signalled. The
+ offending items are filtered for presentation through the PRESENT function
+ before being attached to the condition, so as to produce a more useful
+ diagnostic message.
Item equality is determined by TEST.
candidates list if and only if an occurrence of A appears in an earlier
input list than any occurrence of item B. (This completely determines the
order of the candidates: it is not possible that two candidates appear in
- the same input list would resolve the ambiguity between them.) If PICK is
- omitted then the item chosen is the one appearing in the earliest of the
- input lists: i.e., effectively, the default PICK function is
+ the same input list, since that would resolve the ambiguity between them.)
+ If PICK is omitted then the item chosen is the one appearing in the
+ earliest of the input lists: i.e., effectively, the default PICK function
+ is
(lambda (candidates output-so-far)
(declare (ignore output-so-far))
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates candidates))
+ :candidates candidates
+ :present present))
((null (cdr leasts))
(car leasts))
(pick
(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)
,@body))))
+(export 'partial-order-minima)
+(defun partial-order-minima (items order)
+ "Return a list of minimal items according to the non-strict partial ORDER.
+
+ The ORDER function describes the partial order: (funcall ORDER X Y) should
+ return true if X precedes or is equal to Y in the order."
+ (reduce (lambda (tops this)
+ (let ((new nil) (keep t))
+ (dolist (top tops)
+ (cond ((funcall order top this)
+ (setf keep nil)
+ (push top new))
+ ((not (funcall order this top))
+ (push top new))))
+ (nreverse (if keep (cons this new) new))))
+ items
+ :initial-value nil))
+
+(export 'find-duplicates)
+(defun find-duplicates (report sequence &key (key #'identity) (test #'eql))
+ "Call REPORT on each pair of duplicate items in SEQUENCE.
+
+ Duplicates are determined according to the KEY and TEST funcitons."
+ (when (symbolp test) (setf test (symbol-function test)))
+ (cond ((zerop (length sequence)) nil)
+ ((or (eq test #'eq)
+ (eq test #'eql)
+ (eq test #'equal)
+ (eq test #'equalp))
+ (let ((seen (make-hash-table :test test)))
+ (map nil (lambda (item)
+ (let ((k (funcall key item)))
+ (multiple-value-bind (previous matchp)
+ (gethash k seen)
+ (if matchp (funcall report item previous)
+ (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))
+ ((vectorp sequence)
+ (dotimes (i (length sequence))
+ (let* ((item (aref sequence i))
+ (pos (position (funcall key item) sequence
+ :key key :test test :start (1+ i))))
+ (when pos (funcall report item (aref sequence pos))))))
+ (t
+ (error 'type-error :datum sequence :expected-type 'sequence))))
+
;;;--------------------------------------------------------------------------
;;; Strings and characters.
;;; 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
(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.
+
+(export 'defvar-unbound)
+(defmacro defvar-unbound (var doc)
+ "Make VAR a special variable with documentation DOC, but leave it unbound."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,var)
+ (setf (documentation ',var 'variable) ',doc)
+ ',var))
;;;--------------------------------------------------------------------------
;;; Symbols.
(,print))
(,print)))))
+(export 'print-ugly-stuff)
+(defun print-ugly-stuff (stream func)
+ "Print not-pretty things to the stream underlying STREAM.
+
+ The Lisp pretty-printing machinery, notably `pprint-logical-block', may
+ interpose additional streams between its body and the original target
+ stream. This makes it difficult to make use of the underlying stream's
+ special features, whatever they might be."
+
+ ;; This is unpleasant. Hacky hacky.
+ #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream)
+ (let ((target (sb-pretty::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ #+cmu '(if (typep stream 'pp:pretty-stream)
+ (let ((target (pp::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ '(funcall func stream)))
+
;;;--------------------------------------------------------------------------
;;; Iteration macros.
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))
(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))
`(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.
(setf (,to object) value))))))
;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+ &key allow-pointless-arguments)
+ "Return the condition designated by DATUM and ARGUMENTS.
+
+ DATUM and ARGUMENTS together are a `condition designator' of (some
+ supertype of) DEFAULT-TYPE; return the condition so designated."
+ (typecase datum
+ (condition
+ (unless (or allow-pointless-arguments (null arguments))
+ (error "Argument list provided with specific condition"))
+ datum)
+ (symbol
+ (apply #'make-condition datum arguments))
+ ((or string function)
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error "Unexpected condition designator datum ~S" datum))))
+
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+ ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+ "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+ Find an active restart designated by RESTART; if CONDITION is not nil,
+ then restrict the search to restarts associated with CONDITION, and
+ restarts not associated with any condition. If no such restart is found
+ then signal an error of type `control-error'; otherwise invoke the restart
+ with the given ARGUMENTS."
+ (apply #'invoke-restart
+ (or (find-restart restart condition)
+ (error 'simple-control-error
+ :format-control "~:[Restart ~S is not active~;~
+ No active `~(~A~)' restart~]~
+ ~@[ for condition ~S~]"
+ :format-arguments (list (symbolp restart)
+ restart
+ 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.
(export 'default-slot)
(,classvar (,instance ,class) (,slotvar (eql ',slot)))
,@docs ,@decls
(declare (ignore ,classvar))
- (setf (slot-value ,instance ',slot) (progn ,@body))))))
+ (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff