utility.lisp 29.1 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities for ASDF

4 5
(uiop/package:define-package :uiop/utility
  (: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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
8
   #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
9
  (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
16
   #:nest #:if-let ;; basic flow control
17
   #:parse-body ;; macro definition helper
18 19
   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
   #: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 29
   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
   #:earlier-stamp #:stamps-earliest #:earliest-stamp
30
   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-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 37
   #:match-condition-p #:match-any-condition-p ;; conditions
   #:call-with-muffled-conditions #:with-muffled-conditions
38
   #:not-implemented-error #:parameter-error))
39
(in-package :uiop/utility)
40

41 42 43 44 45
;;;; Defining functions in a way compatible with hot-upgrade:
;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
;; thus replacing the function without warning or error
;; even if the signature and/or generic-ness of the function has changed.
;; For a generic function, this invalidates any previous DEFMETHOD.
46
(eval-when (:load-toplevel :compile-toplevel :execute)
47 48 49 50 51 52 53 54 55 56
  (macrolet
      ((defdef (def* def)
         `(defmacro ,def* (name formals &rest rest)
            (destructuring-bind (name &key (supersede t))
                (if (or (atom name) (eq (car name) 'setf))
                    (list name :supersede nil)
                    name)
              (declare (ignorable supersede))
              `(progn
                 ;; We usually try to do it only for the functions that need it,
57
                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
58 59
                 ,@(when supersede
                     `((fmakunbound ',name)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
60
                 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
61 62 63
                     `((declaim (notinline ,name))))
                 (,',def ,name ,formals ,@rest))))))
    (defdef defgeneric* defgeneric)
64 65
    (defdef defun* defun))
  (defmacro with-upgradability ((&optional) &body body)
66 67 68 69 70
    "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
to also declare the functions NOTINLINE and to accept a wrapping the function name
specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
to supersede any previous definition."
71 72 73 74 75 76
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       ,@(loop :for form :in body :collect
               (if (consp form)
                   (destructuring-bind (car . cdr) form
                     (case car
                       ((defun) `(defun* ,@cdr))
77
                       ((defgeneric) `(defgeneric* ,@cdr))
78 79
                       (otherwise form)))
                   form)))))
80 81

;;; Magic debugging help. See contrib/debug.lisp
82
(with-upgradability ()
83
  (defvar *uiop-debug-utility*
84
    '(or (ignore-errors
85 86 87
           (probe-file (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")))
      (probe-file (symbol-call :uiop/pathname :subpathname
                   (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")))
88 89
    "form that evaluates to the pathname to your favorite debugging utilities")

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 96 97 98
    (let* ((*package* (if package (find-package package) *package*))
           (keyword (read-from-string
                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
      (unless (member keyword *features*)
99
        (let* ((utility-file (or utility-file *uiop-debug-utility*))
100 101
               (file (ignore-errors (probe-file (eval utility-file)))))
          (if file (load file)
102
              (error "Failed to locate debug utility file: ~S" utility-file)))))))
103

104
;;; Flow control
105
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
106 107 108 109 110
  (defmacro nest (&rest things)
    "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
    (reduce #'(lambda (outer inner) `(,@outer ,inner))
            things :from-end t))

111 112 113 114 115 116 117 118 119 120
  (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
    ;; bindings can be (var form) or ((var1 form1) ...)
    (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
                             (list bindings)
                             bindings))
           (variables (mapcar #'car binding-list)))
      `(let ,binding-list
         (if (and ,@variables)
             ,then-form
             ,else-form)))))
121

122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
;;; Macro definition helper
(with-upgradability ()
  (defun parse-body (body &key documentation whole) ;; from alexandria
    "Parses BODY into (values remaining-forms declarations doc-string).
Documentation strings are recognized only if DOCUMENTATION is true.
Syntax errors in body are signalled and WHOLE is used in the signal
arguments when given."
    (let ((doc nil)
          (decls nil)
          (current nil))
      (tagbody
       :declarations
         (setf current (car body))
         (when (and documentation (stringp current) (cdr body))
           (if doc
               (error "Too many documentation strings in ~S." (or whole body))
               (setf doc (pop body)))
           (go :declarations))
         (when (and (listp current) (eql (first current) 'declare))
           (push (pop body) decls)
           (go :declarations)))
      (values body (nreverse decls) doc))))


146
;;; List manipulation
147 148 149
(with-upgradability ()
  (defmacro while-collecting ((&rest collectors) &body body)
    "COLLECTORS should be a list of names for collections.  A collector
150 151 152 153 154 155 156 157 158
defines a function that, when applied to an argument inside BODY, will
add its argument to the corresponding collection.  Returns multiple values,
a list for each collection, in order.
   E.g.,
\(while-collecting \(foo bar\)
           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
             \(foo \(first x\)\)
             \(bar \(second x\)\)\)\)
Returns two values: \(A B C\) and \(1 2 3\)."
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
    (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
          (initial-values (mapcar (constantly nil) collectors)))
      `(let ,(mapcar #'list vars initial-values)
         (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
           ,@body
           (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))

  (define-modify-macro appendf (&rest args)
    append "Append onto list") ;; only to be used on short lists.

  (defun length=n-p (x n) ;is it that (= (length x) n) ?
    (check-type n (integer 0 *))
    (loop
      :for l = x :then (cdr l)
      :for i :downfrom n :do
        (cond
          ((zerop i) (return (null l)))
176 177 178 179 180
          ((not (consp l)) (return nil)))))

  (defun ensure-list (x)
    (if (listp x) x (list x))))

181

182
;;; Remove a key from a plist, i.e. for keyword argument cleanup
183 184 185 186 187 188
(with-upgradability ()
  (defun remove-plist-key (key plist)
    "Remove a single key from a plist"
    (loop* :for (k v) :on plist :by #'cddr
           :unless (eq k key)
           :append (list k v)))
189

190 191 192 193 194
  (defun remove-plist-keys (keys plist)
    "Remove a list of keys from a plist"
    (loop* :for (k v) :on plist :by #'cddr
           :unless (member k keys)
           :append (list k v))))
195 196


197
;;; Sequences
198 199 200 201
(with-upgradability ()
  (defun emptyp (x)
    "Predicate that is true for an empty sequence"
    (or (null x) (and (vectorp x) (zerop (length x))))))
202

203

204
;;; Characters
205
(with-upgradability ()
206 207 208
  ;; base-char != character on ECL, LW, SBCL, Genera.
  ;; NB: We assume a total order on character types.
  ;; If that's not true... this code will need to be updated.
209
  (defparameter +character-types+ ;; assuming a simple hierarchy
210 211 212 213 214 215
    #.(coerce (loop* :for (type next) :on
                     '(;; In SCL, all characters seem to be 16-bit base-char
                       ;; Yet somehow character fails to be a subtype of base-char
                       #-scl base-char
                       ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
                       ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
Elias Pipping's avatar
Elias Pipping committed
216
                       #+lispworks7+ lw:bmp-char
217
                       #+lispworks lw:simple-char
218 219 220 221 222 223
                       character)
                     :unless (and next (subtypep next type))
                     :collect type) 'vector))
  (defparameter +max-character-type-index+ (1- (length +character-types+)))
  (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
224 225 226 227 228 229 230 231 232 233 234

(with-upgradability ()
  (defun character-type-index (x)
    (declare (ignorable x))
    #.(case +max-character-type-index+
        (0 0)
        (1 '(etypecase x
             (character (if (typep x 'base-char) 0 1))
             (symbol (if (subtypep x 'base-char) 0 1))))
        (otherwise
         '(or (position-if (etypecase x
235
                             (character #'(lambda (type) (typep x type)))
236 237 238 239
                             (symbol #'(lambda (type) (subtypep x type))))
               +character-types+)
           (error "Not a character or character type: ~S" x))))))

240

241
;;; Strings
242
(with-upgradability ()
243
  (defun base-string-p (string)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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 string))))
247 248

  (defun strings-common-element-type (strings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
249
    "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
250
    (declare (ignorable strings))
251 252 253
    #.(if +non-base-chars-exist-p+
          `(aref +character-types+
            (loop :with index = 0 :for s :in strings :do
254 255 256 257 258 259 260 261 262 263 264 265 266 267
              (flet ((consider (i)
                       (cond ((= i ,+max-character-type-index+) (return i))
                             ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
                (cond
                  ((emptyp s)) ;; NIL or empty string
                  ((characterp s) (consider (character-type-index s)))
                  ((stringp s) (let ((string-type-index
                                       (character-type-index (array-element-type s))))
                                 (unless (>= index string-type-index)
                                   (loop :for c :across s :for i = (character-type-index c)
                                         :do (consider i)
                                         ,@(when (> +max-character-type-index+ 1)
                                             `((when (= i string-type-index) (return))))))))
                  (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
268 269
                  :finally (return index)))
          ''character))
270 271

  (defun reduce/strcat (strings &key key start end)
272 273
    "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
NIL is interpreted as an empty string. A character is interpreted as a string of length one."
274 275
    (when (or start end) (setf strings (subseq strings start end)))
    (when key (setf strings (mapcar key strings)))
276 277
    (loop :with output = (make-string (loop :for s :in strings
                                            :sum (if (characterp s) 1 (length s)))
278
                                      :element-type (strings-common-element-type strings))
279
          :with pos = 0
280
          :for input :in strings
281 282 283 284
          :do (etypecase input
                (null)
                (character (setf (char output pos) input) (incf pos))
                (string (replace output input :start1 pos) (incf pos (length input))))
285 286
          :finally (return output)))

287
  (defun strcat (&rest strings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
288 289
    "Concatenate strings.
NIL is interpreted as an empty string, a character as a string of length one."
290
    (reduce/strcat strings))
291

292
  (defun first-char (s)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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 301
  (defun split-string (string &key max (separator '(#\Space #\Tab)))
    "Split STRING into a list of components separated by
302 303 304 305
any of the characters in the sequence SEPARATOR.
If MAX is specified, then no more than max(1,MAX) components will be returned,
starting the separation from the end, e.g. when called with arguments
 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
306 307
    (block ()
      (let ((list nil) (words 0) (end (length string)))
308
        (when (zerop end) (return nil))
309 310 311 312 313
        (flet ((separatorp (char) (find char separator))
               (done () (return (cons (subseq string 0 end) list))))
          (loop
            :for start = (if (and max (>= words (1- max)))
                             (done)
314 315 316 317 318
                             (position-if #'separatorp string :end end :from-end t))
            :do (when (null start) (done))
                (push (subseq string (1+ start) end) list)
                (incf words)
                (setf end start))))))
319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338

  (defun string-prefix-p (prefix string)
    "Does STRING begin with PREFIX?"
    (let* ((x (string prefix))
           (y (string string))
           (lx (length x))
           (ly (length y)))
      (and (<= lx ly) (string= x y :end2 lx))))

  (defun string-suffix-p (string suffix)
    "Does STRING end with SUFFIX?"
    (let* ((x (string string))
           (y (string suffix))
           (lx (length x))
           (ly (length y)))
      (and (<= ly lx) (string= x y :start1 (- lx ly)))))

  (defun string-enclosed-p (prefix string suffix)
    "Does STRING begin with PREFIX and end with SUFFIX?"
    (and (string-prefix-p prefix string)
339
         (string-suffix-p string suffix)))
340

341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
  (defvar +cr+ (coerce #(#\Return) 'string))
  (defvar +lf+ (coerce #(#\Linefeed) 'string))
  (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))

  (defun stripln (x)
    "Strip a string X from any ending CR, LF or CRLF.
Return two values, the stripped string and the ending that was stripped,
or the original value and NIL if no stripping took place.
Since our STRCAT accepts NIL as empty string designator,
the two results passed to STRCAT always reconstitute the original string"
    (check-type x string)
    (block nil
      (flet ((c (end) (when (string-suffix-p x end)
                        (return (values (subseq x 0 (- (length x) (length end))) end)))))
        (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))

357
  (defun standard-case-symbol-name (name-designator)
358 359 360 361
    "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
platform such as Allegro with modern syntax."
    (check-type name-designator (or string symbol))
362
    (cond
363 364
      ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
       (string name-designator))
365 366 367 368
      ;; Should we be doing something on CLISP?
      (t (string-upcase name-designator))))

  (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
369 370
    "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
371
If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
372 373
    (find-symbol* (standard-case-symbol-name name-designator)
                  (etypecase package-designator
374 375
                    ((or package symbol) package-designator)
                    (string (standard-case-symbol-name package-designator)))
376
                  error)))
377

378
;;; stamps: a REAL or a boolean where T=-infinity, NIL=+infinity
379 380
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
  (deftype stamp () '(or real boolean)))
381 382 383
(with-upgradability ()
  (defun stamp< (x y)
    (etypecase x
384
      ((eql t) (not (eql y t)))
385
      (real (etypecase y
386 387 388 389
              ((eql t) nil)
              (real (< x y))
              (null t)))
      (null nil)))
390 391 392 393
  (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
  (defun stamp*< (&rest list) (stamps< list))
  (defun stamp<= (x y) (not (stamp< y x)))
  (defun earlier-stamp (x y) (if (stamp< x y) x y))
394
  (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value nil))
395 396
  (defun earliest-stamp (&rest list) (stamps-earliest list))
  (defun later-stamp (x y) (if (stamp< x y) y x))
397
  (defun stamps-latest (list) (reduce 'later-stamp list :initial-value t))
398 399
  (defun latest-stamp (&rest list) (stamps-latest list))
  (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
400

401

402
;;; Function designators
403 404 405
(with-upgradability ()
  (defun ensure-function (fun &key (package :cl))
    "Coerce the object FUN into a function.
406 407 408 409 410 411

If FUN is a FUNCTION, return it.
If the FUN is a non-sequence literal constant, return constantly that,
i.e. for a boolean keyword character number or pathname.
Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
If FUN is a CONS, return the function that applies its CAR
412 413
to the appended list of the rest of its CDR and the arguments,
unless the CAR is LAMBDA, in which case the expression is evaluated.
414 415
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
416 417 418
    (etypecase fun
      (function fun)
      ((or boolean keyword character number pathname) (constantly fun))
419
      (hash-table #'(lambda (x) (gethash x fun)))
420
      (symbol (fdefinition fun))
421 422 423
      (cons (if (eq 'lambda (car fun))
                (eval fun)
                #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
424 425 426 427 428 429
      (string (eval `(function ,(with-standard-io-syntax
                                  (let ((*package* (find-package package)))
                                    (read-from-string fun))))))))

  (defun access-at (object at)
    "Given an OBJECT and an AT specifier, list of successive accessors,
430 431
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
432 433 434 435 436
a keyword, meaning a call to GETF,
NIL, meaning identity,
a function or other symbol, meaning itself,
or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
As a degenerate case, the AT specifier may be an atom of a single such accessor
437
instead of a list."
438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
    (flet ((access (object accessor)
             (etypecase accessor
               (function (funcall accessor object))
               (integer (elt object accessor))
               (keyword (getf object accessor))
               (null object)
               (symbol (funcall accessor object))
               (cons (funcall (ensure-function accessor) object)))))
      (if (listp at)
          (dolist (accessor at object)
            (setf object (access object accessor)))
          (access object at))))

  (defun access-at-count (at)
    "From an AT specification, extract a COUNT of maximum number
453
of sub-objects to read as per ACCESS-AT"
454 455 456 457 458
    (cond
      ((integerp at)
       (1+ at))
      ((and (consp at) (integerp (first at)))
       (1+ (first at)))))
459

460
  (defun call-function (function-spec &rest arguments)
461 462
    "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
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 function as per CALL-FUNCTION"
467
    (map () 'call-function function-specs))
468

469
  (defun register-hook-function (variable hook &optional call-now-p)
470 471 472
    "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
When CALL-NOW-P is true, also call the function immediately."
    (pushnew hook (symbol-value variable) :test 'equal)
473
    (when call-now-p (call-function hook))))
474

475

476 477 478 479 480 481 482 483 484 485 486 487 488 489
;;; CLOS
(with-upgradability ()
  (defun coerce-class (class &key (package :cl) (super t) (error 'error))
    "Coerce CLASS to a class that is subclass of SUPER if specified,
or invoke ERROR handler as per CALL-FUNCTION.

A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
A string is read as a symbol while in PACKAGE, the symbol designates a class.

A class object designates itself.
NIL designates itself (no class).
A symbol otherwise designates a class by name."
    (let* ((normalized
490
            (typecase class
491 492 493 494 495
              (keyword (or (find-symbol* class package nil)
                           (find-symbol* class *package* nil)))
              (string (symbol-call :uiop :safe-read-from-string class :package package))
              (t class)))
           (found
496 497 498 499 500 501 502 503 504 505
            (etypecase normalized
              ((or standard-class built-in-class) normalized)
              ((or null keyword) nil)
              (symbol (find-class normalized nil nil))))
           (super-class
            (etypecase super
              ((or standard-class built-in-class) super)
              ((or null keyword) nil)
              (symbol (find-class super nil nil)))))
      #+allegro (when found (mop:finalize-inheritance found))
506
      (or (and found
507
               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
508
               found)
509
          (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
510 511


512 513 514
;;; Hash-tables
(with-upgradability ()
  (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-FUNCTION,
517 518
set the corresponding entry to the result in the table.
Return two values: the entry after its optional computation, and whether it was found"
519
    (multiple-value-bind (value foundp) (gethash key table)
520 521 522 523 524
      (values
       (if foundp
           value
           (setf (gethash key table) (call-function default)))
       foundp)))
525 526 527 528 529 530 531

  (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
    "Convert a LIST into hash-table that has the same elements when viewed as a set,
up to the given equality TEST"
    (dolist (x list h) (setf (gethash x h) t))))


532
;;; Lexicographic comparison of lists of numbers
533
(with-upgradability ()
534 535 536
  (defun lexicographic< (element< x y)
    "Lexicographically compare two lists of using the function element< to compare elements.
element< is a strict total order; the resulting order on X and Y will also be strict."
537 538
    (cond ((null y) nil)
          ((null x) t)
539 540 541 542 543 544 545
          ((funcall element< (car x) (car y)) t)
          ((funcall element< (car y) (car x)) nil)
          (t (lexicographic< element< (cdr x) (cdr y)))))

  (defun lexicographic<= (element< x y)
    "Lexicographically compare two lists of using the function element< to compare elements.
element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
546 547 548 549 550 551 552 553 554 555 556 557 558 559
    (not (lexicographic< element< y x))))


;;; Simple style warnings
(with-upgradability ()
  (define-condition simple-style-warning
      #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
    ())

  (defun style-warn (datum &rest arguments)
    (etypecase datum
      (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments)))
      (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
      (style-warning (apply 'warn datum arguments)))))
560

561 562 563

;;; Condition control

564 565 566 567
(with-upgradability ()
  (defparameter +simple-condition-format-control-slot+
    #+abcl 'system::format-control
    #+allegro 'excl::format-control
568
    #+(or clasp ecl mkcl) 'si::format-control
569 570
    #+clisp 'system::$format-control
    #+clozure 'ccl::format-control
571
    #+(or cmucl scl) 'conditions::format-control
572 573
    #+(or gcl lispworks) 'conditions::format-string
    #+sbcl 'sb-kernel:format-control
574
    #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
575 576 577 578
    "Name of the slot for FORMAT-CONTROL in simple-condition")

  (defun match-condition-p (x condition)
    "Compare received CONDITION to some pattern X:
579 580 581
a symbol naming a condition class,
a simple vector of length 2, arguments to find-symbol* with result as above,
or a string describing the format-control of a simple-condition."
582 583
    (etypecase x
      (symbol (typep condition x))
584 585
      ((simple-vector 2)
       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
586 587 588
      (function (funcall x condition))
      (string (and (typep condition 'simple-condition)
                   ;; On SBCL, it's always set and the check triggers a warning
589
                   #+(or allegro clozure cmucl lispworks scl)
590 591 592 593 594 595 596 597
                   (slot-boundp condition +simple-condition-format-control-slot+)
                   (ignore-errors (equal (simple-condition-format-control condition) x))))))

  (defun match-any-condition-p (condition conditions)
    "match CONDITION against any of the patterns of CONDITIONS supplied"
    (loop :for x :in conditions :thereis (match-condition-p x condition)))

  (defun call-with-muffled-conditions (thunk conditions)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
598
    "calls the THUNK in a context where the CONDITIONS are muffled"
599 600 601 602
    (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
                                      (muffle-warning c)))))
      (funcall thunk)))

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 608 609 610 611 612 613 614
;;; Conditions

(with-upgradability ()
  (define-condition not-implemented-error (error)
    ((functionality :initarg :functionality)
     (format-control :initarg :format-control)
     (format-arguments :initarg :format-arguments))
    (:report (lambda (condition stream)
615 616
               (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
                       (nth-value 1 (symbol-call :uiop :implementation-type))
617 618 619 620 621
                       (slot-value condition 'functionality)
                       (slot-value condition 'format-control)
                       (slot-value condition 'format-arguments)))))

  (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
622 623 624 625
    "Signal an error because some FUNCTIONALITY is not implemented in the current version
of the software on the current platform; it may or may not be implemented in different combinations
of version of the software and of the underlying platform. Optionally, report a formatted error
message."
626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644
    (error 'not-implemented-error
           :functionality functionality
           :format-control format-control
           :format-arguments format-arguments))

  (define-condition parameter-error (error)
    ((functionality :initarg :functionality)
     (format-control :initarg :format-control)
     (format-arguments :initarg :format-arguments))
    (:report (lambda (condition stream)
               (apply 'format stream
                       (slot-value condition 'format-control)
                       (slot-value condition 'functionality)
                       (slot-value condition 'format-arguments)))))

  ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
  ;; the format-control. If you want it to not appear in first position in actual message, use
  ;; ~* and ~:* to adjust parameter order.
  (defun parameter-error (format-control functionality &rest format-arguments)
645 646 647
    "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
platform does not accept a given parameter or combination of parameters. Report a formatted error
message, that takes the functionality as its first argument (that can be skipped with ~*)."
648 649 650 651 652
    (error 'parameter-error
           :functionality functionality
           :format-control format-control
           :format-arguments format-arguments)))