+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
+ (lambda (x y)
+ (funcall fun y x)))
+
+;;; like CL:ASSERT, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT
+;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a
+;;; significant amount of code when you multiply them by 400, so
+;;; replacing them with this should reduce the size of the system
+;;; by enough to be worthwhile.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(let ((*package* (find-package :keyword)))
+ (format nil "~S" expr)))))
+(defun %failed-aver (expr-as-string)
+ (error "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+;;; Return the numeric value of a type bound, i.e. an interval bound
+;;; more or less in the format of bounds in ANSI's type specifiers,
+;;; where a bare numeric value is a closed bound and a list of a
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+ (if (consp x)
+ (destructuring-bind (result) x result)
+ x))
+
+;;; some commonly-occuring CONSTANTLY forms
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
+\f
+;;;; utilities for two-VALUES predicates
+
+;;; sort of like ANY and EVERY, except:
+;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
+;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
+;;; as SUBTYPEP does.)
+;;; * THING is just an atom, and we apply OP (an arity-2 function)
+;;; successively to THING and each element of LIST.
+(defun any/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (values nil certain?))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
+(defun every/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))