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