GopherProxy

	tutility.lisp - clic - Clic is an command line interactive client for gopher wr…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tutility.lisp (29896B)
	---
	1 ;;;; -------------------------------------------------------------------…
	2 ;;;; General Purpose Utilities for ASDF
	3
	4 (uiop/package:define-package :uiop/utility
	5 (:use :uiop/common-lisp :uiop/package)
	6 ;; import and reexport a few things defined in :uiop/common-lisp
	7 (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
	8 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
	9 (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
	10 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
	11 (:export
	12 ;; magic helper to define debugging functions:
	13 #:uiop-debug #:load-uiop-debug-utility #:uiop-debug-utility
	14 #:with-upgradability ;; (un)defining functions in an upgrade-friendly…
	15 #:defun* #:defgeneric*
	16 #:nest #:if-let ;; basic flow control
	17 #:parse-body ;; macro definition helper
	18 #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
	19 #:remove-plist-keys #:remove-plist-key ;; plists
	20 #:emptyp ;; sequences
	21 #:+non-base-chars-exist-p+ ;; characters
	22 #:+max-character-type-index+ #:character-type-index #:+character-type…
	23 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strca…
	24 #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+cr…
	25 #:string-prefix-p #:string-enclosed-p #:string-suffix-p
	26 #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
	27 #:coerce-class ;; CLOS
	28 #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps
	29 #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp
	30 #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-tim…
	31 #:list-to-hash-set #:ensure-gethash ;; hash-table
	32 #:ensure-function #:access-at #:access-at-count ;; functions
	33 #:call-function #:call-functions #:register-hook-function
	34 #:lexicographic< #:lexicographic<= ;; version
	35 #:simple-style-warning #:style-warn ;; simple style warnings
	36 #:match-condition-p #:match-any-condition-p ;; conditions
	37 #:call-with-muffled-conditions #:with-muffled-conditions
	38 #:not-implemented-error #:parameter-error))
	39 (in-package :uiop/utility)
	40
	41 ;;;; Defining functions in a way compatible with hot-upgrade:
	42 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefini…
	43 ;; thus replacing the function without warning or error
	44 ;; even if the signature and/or generic-ness of the function has changed.
	45 ;; For a generic function, this invalidates any previous DEFMETHOD.
	46 (eval-when (:load-toplevel :compile-toplevel :execute)
	47 (macrolet
	48 ((defdef (def* def)
	49 `(defmacro ,def* (name formals &rest rest)
	50 (destructuring-bind (name &key (supersede t))
	51 (if (or (atom name) (eq (car name) 'setf))
	52 (list name :supersede nil)
	53 name)
	54 (declare (ignorable supersede))
	55 `(progn
	56 ;; We usually try to do it only for the functions that …
	57 ;; which happens in asdf/upgrade - however, for ECL, we…
	58 ,@(when supersede
	59 `((fmakunbound ',name)))
	60 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails f…
	61 `((declaim (notinline ,name))))
	62 (,',def ,name ,formals ,@rest))))))
	63 (defdef defgeneric* defgeneric)
	64 (defdef defun* defun))
	65 (defmacro with-upgradability ((&optional) &body body)
	66 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFG…
	67 to also declare the functions NOTINLINE and to accept a wrapping the fun…
	68 specification into a list with keyword argument SUPERSEDE (which default…
	69 is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UN…
	70 to supersede any previous definition."
	71 `(eval-when (:compile-toplevel :load-toplevel :execute)
	72 ,@(loop :for form :in body :collect
	73 (if (consp form)
	74 (destructuring-bind (car . cdr) form
	75 (case car
	76 ((defun) `(defun* ,@cdr))
	77 ((defgeneric) `(defgeneric* ,@cdr))
	78 (otherwise form)))
	79 form)))))
	80
	81 ;;; Magic debugging help. See contrib/debug.lisp
	82 (with-upgradability ()
	83 (defvar uiop-debug-utility
	84 '(or (ignore-errors
	85 (probe-file (symbol-call :asdf :system-relative-pathname :uio…
	86 (probe-file (symbol-call :uiop/pathname :subpathname
	87 (user-homedir-pathname) "common-lisp/asdf/uiop/contri…
	88 "form that evaluates to the pathname to your favorite debugging util…
	89
	90 (defmacro uiop-debug (&rest keys)
	91 `(eval-when (:compile-toplevel :load-toplevel :execute)
	92 (load-uiop-debug-utility ,@keys)))
	93
	94 (defun load-uiop-debug-utility (&key package utility-file)
	95 (let* ((package (if package (find-package package) package))
	96 (keyword (read-from-string
	97 (format nil ":DBG-~:@(~A~)" (package-name package…
	98 (unless (member keyword features)
	99 (let* ((utility-file (or utility-file uiop-debug-utility))
	100 (file (ignore-errors (probe-file (eval utility-file)))))
	101 (if file (load file)
	102 (error "Failed to locate debug utility file: ~S" utility-f…
	103
	104 ;;; Flow control
	105 (with-upgradability ()
	106 (defmacro nest (&rest things)
	107 "Macro to keep code nesting and indentation under control." ;; Thank…
	108 (reduce #'(lambda (outer inner) `(,@outer ,inner))
	109 things :from-end t))
	110
	111 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; f…
	112 ;; bindings can be (var form) or ((var1 form1) ...)
	113 (let* ((binding-list (if (and (consp bindings) (symbolp (car binding…
	114 (list bindings)
	115 bindings))
	116 (variables (mapcar #'car binding-list)))
	117 `(let ,binding-list
	118 (if (and ,@variables)
	119 ,then-form
	120 ,else-form)))))
	121
	122 ;;; Macro definition helper
	123 (with-upgradability ()
	124 (defun parse-body (body &key documentation whole) ;; from alexandria
	125 "Parses BODY into (values remaining-forms declarations doc-string).
	126 Documentation strings are recognized only if DOCUMENTATION is true.
	127 Syntax errors in body are signalled and WHOLE is used in the signal
	128 arguments when given."
	129 (let ((doc nil)
	130 (decls nil)
	131 (current nil))
	132 (tagbody
	133 :declarations
	134 (setf current (car body))
	135 (when (and documentation (stringp current) (cdr body))
	136 (if doc
	137 (error "Too many documentation strings in ~S." (or whole …
	138 (setf doc (pop body)))
	139 (go :declarations))
	140 (when (and (listp current) (eql (first current) 'declare))
	141 (push (pop body) decls)
	142 (go :declarations)))
	143 (values body (nreverse decls) doc))))
	144
	145
	146 ;;; List manipulation
	147 (with-upgradability ()
	148 (defmacro while-collecting ((&rest collectors) &body body)
	149 "COLLECTORS should be a list of names for collections. A collector
	150 defines a function that, when applied to an argument inside BODY, will
	151 add its argument to the corresponding collection. Returns multiple valu…
	152 a list for each collection, in order.
	153 E.g.,
	154 $while-collecting \(foo bar$
	155 $dolist \(x '\(\(a 1$ $b 2$ $c 3$\)\)
	156 $foo \(first x$\)
	157 $bar \(second x$\)\)\)
	158 Returns two values: $A B C$ and $1 2 3$."
	159 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collecto…
	160 (initial-values (mapcar (constantly nil) collectors)))
	161 `(let ,(mapcar #'list vars initial-values)
	162 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) …
	163 ,@body
	164 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
	165
	166 (define-modify-macro appendf (&rest args)
	167 append "Append onto list") ;; only to be used on short lists.
	168
	169 (defun length=n-p (x n) ;is it that (= (length x) n) ?
	170 (check-type n (integer 0 *))
	171 (loop
	172 :for l = x :then (cdr l)
	173 :for i :downfrom n :do
	174 (cond
	175 ((zerop i) (return (null l)))
	176 ((not (consp l)) (return nil)))))
	177
	178 (defun ensure-list (x)
	179 (if (listp x) x (list x))))
	180
	181
	182 ;;; Remove a key from a plist, i.e. for keyword argument cleanup
	183 (with-upgradability ()
	184 (defun remove-plist-key (key plist)
	185 "Remove a single key from a plist"
	186 (loop* :for (k v) :on plist :by #'cddr
	187 :unless (eq k key)
	188 :append (list k v)))
	189
	190 (defun remove-plist-keys (keys plist)
	191 "Remove a list of keys from a plist"
	192 (loop* :for (k v) :on plist :by #'cddr
	193 :unless (member k keys)
	194 :append (list k v))))
	195
	196
	197 ;;; Sequences
	198 (with-upgradability ()
	199 (defun emptyp (x)
	200 "Predicate that is true for an empty sequence"
	201 (or (null x) (and (vectorp x) (zerop (length x))))))
	202
	203
	204 ;;; Characters
	205 (with-upgradability ()
	206 ;; base-char != character on ECL, LW, SBCL, Genera.
	207 ;; NB: We assume a total order on character types.
	208 ;; If that's not true... this code will need to be updated.
	209 (defparameter +character-types+ ;; assuming a simple hierarchy
	210 #.(coerce (loop* :for (type next) :on
	211 '(;; In SCL, all characters seem to be 16-bit base-…
	212 ;; Yet somehow character fails to be a subtype of…
	213 #-scl base-char
	214 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
	215 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = C…
	216 #+lispworks7+ lw:bmp-char
	217 #+lispworks lw:simple-char
	218 character)
	219 :unless (and next (subtypep next type))
	220 :collect type) 'vector))
	221 (defparameter +max-character-type-index+ (1- (length +character-types+…
	222 (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index…
	223 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *featu…
	224
	225 (with-upgradability ()
	226 (defun character-type-index (x)
	227 (declare (ignorable x))
	228 #.(case +max-character-type-index+
	229 (0 0)
	230 (1 '(etypecase x
	231 (character (if (typep x 'base-char) 0 1))
	232 (symbol (if (subtypep x 'base-char) 0 1))))
	233 (otherwise
	234 '(or (position-if (etypecase x
	235 (character #'(lambda (type) (typep x type)))
	236 (symbol #'(lambda (type) (subtypep x type))…
	237 +character-types+)
	238 (error "Not a character or character type: ~S" x))))))
	239
	240
	241 ;;; Strings
	242 (with-upgradability ()
	243 (defun base-string-p (string)
	244 "Does the STRING only contain BASE-CHARs?"
	245 (declare (ignorable string))
	246 (and #+non-base-chars-exist-p (eq 'base-char (array-element-type str…
	247
	248 (defun strings-common-element-type (strings)
	249 "What least subtype of CHARACTER can contain all the elements of all…
	250 (declare (ignorable strings))
	251 #.(if +non-base-chars-exist-p+
	252 `(aref +character-types+
	253 (loop :with index = 0 :for s :in strings :do
	254 (flet ((consider (i)
	255 (cond ((= i ,+max-character-type-index+) (return …
	256 ,@(when (> +max-character-type-index+ 1) `(…
	257 (cond
	258 ((emptyp s)) ;; NIL or empty string
	259 ((characterp s) (consider (character-type-index s)))
	260 ((stringp s) (let ((string-type-index
	261 (character-type-index (array-elem…
	262 (unless (>= index string-type-index)
	263 (loop :for c :across s :for i = (char…
	264 :do (consider i)
	265 ,@(when (> +max-character-type-…
	266 `((when (= i string-type-in…
	267 (t (error "Invalid string designator ~S for ~S" s 'str…
	268 :finally (return index)))
	269 ''character))
	270
	271 (defun reduce/strcat (strings &key key start end)
	272 "Reduce a list as if by STRCAT, accepting KEY START and END keywords…
	273 NIL is interpreted as an empty string. A character is interpreted as a s…
	274 (when (or start end) (setf strings (subseq strings start end)))
	275 (when key (setf strings (mapcar key strings)))
	276 (loop :with output = (make-string (loop :for s :in strings
	277 :sum (if (characterp s) 1 (l…
	278 :element-type (strings-common-elem…
	279 :with pos = 0
	280 :for input :in strings
	281 :do (etypecase input
	282 (null)
	283 (character (setf (char output pos) input) (incf pos))
	284 (string (replace output input :start1 pos) (incf pos (le…
	285 :finally (return output)))
	286
	287 (defun strcat (&rest strings)
	288 "Concatenate strings.
	289 NIL is interpreted as an empty string, a character as a string of length…
	290 (reduce/strcat strings))
	291
	292 (defun first-char (s)
	293 "Return the first character of a non-empty string S, or NIL"
	294 (and (stringp s) (plusp (length s)) (char s 0)))
	295
	296 (defun last-char (s)
	297 "Return the last character of a non-empty string S, or NIL"
	298 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
	299
	300 (defun split-string (string &key max (separator '(#\Space #\Tab)))
	301 "Split STRING into a list of components separated by
	302 any of the characters in the sequence SEPARATOR.
	303 If MAX is specified, then no more than max(1,MAX) components will be ret…
	304 starting the separation from the end, e.g. when called with arguments
	305 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \…
	306 (block ()
	307 (let ((list nil) (words 0) (end (length string)))
	308 (when (zerop end) (return nil))
	309 (flet ((separatorp (char) (find char separator))
	310 (done () (return (cons (subseq string 0 end) list))))
	311 (loop
	312 :for start = (if (and max (>= words (1- max)))
	313 (done)
	314 (position-if #'separatorp string :end end :…
	315 :do (when (null start) (done))
	316 (push (subseq string (1+ start) end) list)
	317 (incf words)
	318 (setf end start))))))
	319
	320 (defun string-prefix-p (prefix string)
	321 "Does STRING begin with PREFIX?"
	322 (let* ((x (string prefix))
	323 (y (string string))
	324 (lx (length x))
	325 (ly (length y)))
	326 (and (<= lx ly) (string= x y :end2 lx))))
	327
	328 (defun string-suffix-p (string suffix)
	329 "Does STRING end with SUFFIX?"
	330 (let* ((x (string string))
	331 (y (string suffix))
	332 (lx (length x))
	333 (ly (length y)))
	334 (and (<= ly lx) (string= x y :start1 (- lx ly)))))
	335
	336 (defun string-enclosed-p (prefix string suffix)
	337 "Does STRING begin with PREFIX and end with SUFFIX?"
	338 (and (string-prefix-p prefix string)
	339 (string-suffix-p string suffix)))
	340
	341 (defvar +cr+ (coerce #(#\Return) 'string))
	342 (defvar +lf+ (coerce #(#\Linefeed) 'string))
	343 (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
	344
	345 (defun stripln (x)
	346 "Strip a string X from any ending CR, LF or CRLF.
	347 Return two values, the stripped string and the ending that was stripped,
	348 or the original value and NIL if no stripping took place.
	349 Since our STRCAT accepts NIL as empty string designator,
	350 the two results passed to STRCAT always reconstitute the original string"
	351 (check-type x string)
	352 (block nil
	353 (flet ((c (end) (when (string-suffix-p x end)
	354 (return (values (subseq x 0 (- (length x) (lengt…
	355 (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
	356
	357 (defun standard-case-symbol-name (name-designator)
	358 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it…
	359 if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING o…
	360 platform such as Allegro with modern syntax."
	361 (check-type name-designator (or string symbol))
	362 (cond
	363 ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mo…
	364 (string name-designator))
	365 ;; Should we be doing something on CLISP?
	366 (t (string-upcase name-designator))))
	367
	368 (defun find-standard-case-symbol (name-designator package-designator &…
	369 "Find a symbol designated by NAME-DESIGNATOR in a package designated…
	370 where STANDARD-CASE-SYMBOL-NAME is used to transform them if these desig…
	371 If optional ERROR argument is NIL, return NIL instead of an error when t…
	372 (find-symbol* (standard-case-symbol-name name-designator)
	373 (etypecase package-designator
	374 ((or package symbol) package-designator)
	375 (string (standard-case-symbol-name package-designato…
	376 error)))
	377
	378 ;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity
	379 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
	380 (deftype timestamp () '(or real boolean)))
	381 (with-upgradability ()
	382 (defun timestamp< (x y)
	383 (etypecase x
	384 ((eql t) (not (eql y t)))
	385 (real (etypecase y
	386 ((eql t) nil)
	387 (real (< x y))
	388 (null t)))
	389 (null nil)))
	390 (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :…
	391 (defun timestamp*< (&rest list) (timestamps< list))
	392 (defun timestamp<= (x y) (not (timestamp< y x)))
	393 (defun earlier-timestamp (x y) (if (timestamp< x y) x y))
	394 (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :ini…
	395 (defun earliest-timestamp (&rest list) (timestamps-earliest list))
	396 (defun later-timestamp (x y) (if (timestamp< x y) y x))
	397 (defun timestamps-latest (list) (reduce 'later-timestamp list :initial…
	398 (defun latest-timestamp (&rest list) (timestamps-latest list))
	399 (define-modify-macro latest-timestamp-f (&rest timestamps) latest-time…
	400
	401
	402 ;;; Function designators
	403 (with-upgradability ()
	404 (defun ensure-function (fun &key (package :cl))
	405 "Coerce the object FUN into a function.
	406
	407 If FUN is a FUNCTION, return it.
	408 If the FUN is a non-sequence literal constant, return constantly that,
	409 i.e. for a boolean keyword character number or pathname.
	410 Otherwise if FUN is a non-literally constant symbol, return its FDEFINIT…
	411 If FUN is a CONS, return the function that applies its CAR
	412 to the appended list of the rest of its CDR and the arguments,
	413 unless the CAR is LAMBDA, in which case the expression is evaluated.
	414 If FUN is a string, READ a form from it in the specified PACKAGE (defaul…
	415 and EVAL that in a (FUNCTION ...) context."
	416 (etypecase fun
	417 (function fun)
	418 ((or boolean keyword character number pathname) (constantly fun))
	419 (hash-table #'(lambda (x) (gethash x fun)))
	420 (symbol (fdefinition fun))
	421 (cons (if (eq 'lambda (car fun))
	422 (eval fun)
	423 #'(lambda (&rest args) (apply (car fun) (append (cdr fun…
	424 (string (eval `(function ,(with-standard-io-syntax
	425 (let ((package (find-package package…
	426 (read-from-string fun))))))))
	427
	428 (defun access-at (object at)
	429 "Given an OBJECT and an AT specifier, list of successive accessors,
	430 call each accessor on the result of the previous calls.
	431 An accessor may be an integer, meaning a call to ELT,
	432 a keyword, meaning a call to GETF,
	433 NIL, meaning identity,
	434 a function or other symbol, meaning itself,
	435 or a list of a function designator and arguments, interpreted as per ENS…
	436 As a degenerate case, the AT specifier may be an atom of a single such a…
	437 instead of a list."
	438 (flet ((access (object accessor)
	439 (etypecase accessor
	440 (function (funcall accessor object))
	441 (integer (elt object accessor))
	442 (keyword (getf object accessor))
	443 (null object)
	444 (symbol (funcall accessor object))
	445 (cons (funcall (ensure-function accessor) object)))))
	446 (if (listp at)
	447 (dolist (accessor at object)
	448 (setf object (access object accessor)))
	449 (access object at))))
	450
	451 (defun access-at-count (at)
	452 "From an AT specification, extract a COUNT of maximum number
	453 of sub-objects to read as per ACCESS-AT"
	454 (cond
	455 ((integerp at)
	456 (1+ at))
	457 ((and (consp at) (integerp (first at)))
	458 (1+ (first at)))))
	459
	460 (defun call-function (function-spec &rest arguments)
	461 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTIO…
	462 with the given ARGUMENTS"
	463 (apply (ensure-function function-spec) arguments))
	464
	465 (defun call-functions (function-specs)
	466 "For each function in the list FUNCTION-SPECS, in order, call the fu…
	467 (map () 'call-function function-specs))
	468
	469 (defun register-hook-function (variable hook &optional call-now-p)
	470 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto t…
	471 When CALL-NOW-P is true, also call the function immediately."
	472 (pushnew hook (symbol-value variable) :test 'equal)
	473 (when call-now-p (call-function hook))))
	474
	475
	476 ;;; CLOS
	477 (with-upgradability ()
	478 (defun coerce-class (class &key (package :cl) (super t) (error 'error))
	479 "Coerce CLASS to a class that is subclass of SUPER if specified,
	480 or invoke ERROR handler as per CALL-FUNCTION.
	481
	482 A keyword designates the name a symbol, which when found in either PACKA…
	483 -- for backward compatibility, PACKAGE is also accepted for now, but t…
	484 A string is read as a symbol while in PACKAGE, the symbol designates a c…
	485
	486 A class object designates itself.
	487 NIL designates itself (no class).
	488 A symbol otherwise designates a class by name."
	489 (let* ((normalized
	490 (typecase class
	491 (keyword (or (find-symbol* class package nil)
	492 (find-symbol* class package nil)))
	493 (string (symbol-call :uiop :safe-read-from-string class :p…
	494 (t class)))
	495 (found
	496 (etypecase normalized
	497 ((or standard-class built-in-class) normalized)
	498 ((or null keyword) nil)
	499 (symbol (find-class normalized nil nil))))
	500 (super-class
	501 (etypecase super
	502 ((or standard-class built-in-class) super)
	503 ((or null keyword) nil)
	504 (symbol (find-class super nil nil)))))
	505 #+allegro (when found (mop:finalize-inheritance found))
	506 (or (and found
	507 (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::…
	508 found)
	509 (call-function error "Can't coerce ~S to a ~:[class~;subclass …
	510
	511
	512 ;;; Hash-tables
	513 (with-upgradability ()
	514 (defun ensure-gethash (key table default)
	515 "Lookup the TABLE for a KEY as by GETHASH, but if not present,
	516 call the (possibly constant) function designated by DEFAULT as per CALL-…
	517 set the corresponding entry to the result in the table.
	518 Return two values: the entry after its optional computation, and whether…
	519 (multiple-value-bind (value foundp) (gethash key table)
	520 (values
	521 (if foundp
	522 value
	523 (setf (gethash key table) (call-function default)))
	524 foundp)))
	525
	526 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
	527 "Convert a LIST into hash-table that has the same elements when view…
	528 up to the given equality TEST"
	529 (dolist (x list h) (setf (gethash x h) t))))
	530
	531
	532 ;;; Lexicographic comparison of lists of numbers
	533 (with-upgradability ()
	534 (defun lexicographic< (element< x y)
	535 "Lexicographically compare two lists of using the function element< …
	536 element< is a strict total order; the resulting order on X and Y will al…
	537 (cond ((null y) nil)
	538 ((null x) t)
	539 ((funcall element< (car x) (car y)) t)
	540 ((funcall element< (car y) (car x)) nil)
	541 (t (lexicographic< element< (cdr x) (cdr y)))))
	542
	543 (defun lexicographic<= (element< x y)
	544 "Lexicographically compare two lists of using the function element< …
	545 element< is a strict total order; the resulting order on X and Y will be…
	546 (not (lexicographic< element< y x))))
	547
	548
	549 ;;; Simple style warnings
	550 (with-upgradability ()
	551 (define-condition simple-style-warning
	552 #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition styl…
	553 ())
	554
	555 (defun style-warn (datum &rest arguments)
	556 (etypecase datum
	557 (string (warn (make-condition 'simple-style-warning :format-contro…
	558 (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datu…
	559 (style-warning (apply 'warn datum arguments)))))
	560
	561
	562 ;;; Condition control
	563
	564 (with-upgradability ()
	565 (defparameter +simple-condition-format-control-slot+
	566 #+abcl 'system::format-control
	567 #+allegro 'excl::format-control
	568 #+(or clasp ecl mkcl) 'si::format-control
	569 #+clisp 'system::$format-control
	570 #+clozure 'ccl::format-control
	571 #+(or cmucl scl) 'conditions::format-control
	572 #+(or gcl lispworks) 'conditions::format-string
	573 #+sbcl 'sb-kernel:format-control
	574 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl …
	575 "Name of the slot for FORMAT-CONTROL in simple-condition")
	576
	577 (defun match-condition-p (x condition)
	578 "Compare received CONDITION to some pattern X:
	579 a symbol naming a condition class,
	580 a simple vector of length 2, arguments to find-symbol* with result as ab…
	581 or a string describing the format-control of a simple-condition."
	582 (etypecase x
	583 (symbol (typep condition x))
	584 ((simple-vector 2)
	585 (ignore-errors (typep condition (find-symbol* (svref x 0) (svref …
	586 (function (funcall x condition))
	587 (string (and (typep condition 'simple-condition)
	588 ;; On SBCL, it's always set and the check triggers a …
	589 #+(or allegro clozure cmucl lispworks scl)
	590 (slot-boundp condition +simple-condition-format-contr…
	591 (ignore-errors (equal (simple-condition-format-contro…
	592
	593 (defun match-any-condition-p (condition conditions)
	594 "match CONDITION against any of the patterns of CONDITIONS supplied"
	595 (loop :for x :in conditions :thereis (match-condition-p x condition)…
	596
	597 (defun call-with-muffled-conditions (thunk conditions)
	598 "calls the THUNK in a context where the CONDITIONS are muffled"
	599 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c condi…
	600 (muffle-warning c)))))
	601 (funcall thunk)))
	602
	603 (defmacro with-muffled-conditions ((conditions) &body body)
	604 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
	605 `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
	606
	607 ;;; Conditions
	608
	609 (with-upgradability ()
	610 (define-condition not-implemented-error (error)
	611 ((functionality :initarg :functionality)
	612 (format-control :initarg :format-control)
	613 (format-arguments :initarg :format-arguments))
	614 (:report (lambda (condition stream)
	615 (format stream "Not (currently) implemented on ~A: ~S~@[ …
	616 (nth-value 1 (symbol-call :uiop :implementation-t…
	617 (slot-value condition 'functionality)
	618 (slot-value condition 'format-control)
	619 (slot-value condition 'format-arguments)))))
	620
	621 (defun not-implemented-error (functionality &optional format-control &…
	622 "Signal an error because some FUNCTIONALITY is not implemented in th…
	623 of the software on the current platform; it may or may not be implemente…
	624 of version of the software and of the underlying platform. Optionally, r…
	625 message."
	626 (error 'not-implemented-error
	627 :functionality functionality
	628 :format-control format-control
	629 :format-arguments format-arguments))
	630
	631 (define-condition parameter-error (error)
	632 ((functionality :initarg :functionality)
	633 (format-control :initarg :format-control)
	634 (format-arguments :initarg :format-arguments))
	635 (:report (lambda (condition stream)
	636 (apply 'format stream
	637 (slot-value condition 'format-control)
	638 (slot-value condition 'functionality)
	639 (slot-value condition 'format-arguments)))))
	640
	641 ;; Note that functionality MUST be passed as the second argument to pa…
	642 ;; the format-control. If you want it to not appear in first position …
	643 ;; ~* and ~:* to adjust parameter order.
	644 (defun parameter-error (format-control functionality &rest format-argu…
	645 "Signal an error because some FUNCTIONALITY or its specific implemen…
	646 platform does not accept a given parameter or combination of parameters.…
	647 message, that takes the functionality as its first argument (that can be…
	648 (error 'parameter-error
	649 :functionality functionality
	650 :format-control format-control
	651 :format-arguments format-arguments)))
	652