;;; 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.
;;;--------------------------------------------------------------------------
;;; 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))
(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)))
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))
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.
(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)
(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))))
;;; 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.
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.
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.
~mdw / sod / blobdiff