utility.lisp 30.6 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 #: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 #: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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
15
   #:nest #:if-let ;; basic flow control
16
   #:parse-body ;; macro definition helper
17
18
   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
   #:remove-plist-keys #:remove-plist-key ;; plists
19
   #:emptyp ;; sequences
20
   #:+non-base-chars-exist-p+ ;; characters
21
   #:+max-character-type-index+ #:character-type-index #:+character-types+
22
   #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
23
   #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
24
   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
25
   #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
26
   #:coerce-class ;; CLOS
27
28
29
   #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps
   #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp
   #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f
30
   #:list-to-hash-set #:ensure-gethash ;; hash-table
31
   #:ensure-function #:access-at #:access-at-count ;; functions
32
   #:call-function #:call-functions #:register-hook-function
33
   #:lexicographic< #:lexicographic<= ;; version
34
   #:simple-style-warning #:style-warn ;; simple style warnings
35
36
   #:match-condition-p #:match-any-condition-p ;; conditions
   #:call-with-muffled-conditions #:with-muffled-conditions
37
38
39
   #:not-implemented-error #:parameter-error
   #:symbol-test-to-feature-expression
   #:boolean-to-feature-expression))
40
(in-package :uiop/utility)
41

42
;;;; Defining functions in a way compatible with hot-upgrade:
43
44
45
46
;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE,
;;   so that new definitions are always seen by all callers, even those up the stack.
;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state
;;   (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file.
47
48
;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it,
;;   at least if that function is used by ASDF while performing the plan to load ASDF.
49
50
51
52
53
54
55
56
;; - THOU SHALT change the name of a function whenever thou makest an incompatible change.
;; - For instance, when the meanings of NIL and T for timestamps was inverted,
;;   functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc.,
;;   because the change other caused a huge incompatibility during upgrade.
;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc.,
;;   even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND.
;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that
;;   all the methods required for ASDF to successfully continue compiling itself
57
58
;;   shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC.
;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND.
59
60
61
62
;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC,
;;   in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN).
;; - Any time you change a signature, please keep a comment specifying the first release after the change;
;;   put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND.
63
(eval-when (:load-toplevel :compile-toplevel :execute)
64
65
66
67
68
69
  (defun ensure-function-notinline (definition &aux (name (second definition)))
    (assert (member (first definition) '(defun defgeneric)))
    `(progn
       ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
          `(declaim (notinline ,name)))
       ,definition))
70
  (defmacro with-upgradability ((&optional) &body body)
71
72
73
74
75
    "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."
76
77
78
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       ,@(loop :for form :in body :collect
               (if (consp form)
79
                   (case (first form)
80
                     ((defun defgeneric) (ensure-function-notinline form))
81
                     (otherwise form))
82
                   form)))))
83
84

;;; Magic debugging help. See contrib/debug.lisp
85
(with-upgradability ()
86
  (defvar *uiop-debug-utility*
87
    '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp")
88
89
    "form that evaluates to the pathname to your favorite debugging utilities")

90
  (defmacro uiop-debug (&rest keys)
91
    "Load the UIOP debug utility at compile-time as well as runtime"
92
    `(eval-when (:compile-toplevel :load-toplevel :execute)
93
       (load-uiop-debug-utility ,@keys)))
94

95
  (defun load-uiop-debug-utility (&key package utility-file)
96
97
    "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*).
Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)."
98
99
100
101
    (let* ((*package* (if package (find-package package) *package*))
           (keyword (read-from-string
                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
      (unless (member keyword *features*)
102
        (let* ((utility-file (or utility-file *uiop-debug-utility*))
103
104
               (file (ignore-errors (probe-file (eval utility-file)))))
          (if file (load file)
105
              (error "Failed to locate debug utility file: ~S" utility-file)))))))
106

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

114
115
116
117
118
119
120
121
122
123
  (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)))))
124

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
;;; 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))))


149
;;; List manipulation
150
151
152
(with-upgradability ()
  (defmacro while-collecting ((&rest collectors) &body body)
    "COLLECTORS should be a list of names for collections.  A collector
153
154
155
156
157
158
159
160
161
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\)."
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
    (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)))
179
180
181
182
183
          ((not (consp l)) (return nil)))))

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

184

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

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


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

206

207
;;; Characters
208
(with-upgradability ()
209
210
211
  ;; 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.
212
  (defparameter +character-types+ ;; assuming a simple hierarchy
213
214
215
216
217
218
219
220
221
222
223
    #.(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
                      #+lispworks7+ lw:bmp-char
                      #+lispworks lw:simple-char
                      character)
                    :unless (and next (subtypep next type))
                      :collect type) 'vector))
224
225
226
  (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*)))
227
228
229
230
231
232
233
234
235
236
237

(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
238
                             (character #'(lambda (type) (typep x type)))
239
240
241
242
                             (symbol #'(lambda (type) (subtypep x type))))
               +character-types+)
           (error "Not a character or character type: ~S" x))))))

243

244
;;; Strings
245
(with-upgradability ()
246
  (defun base-string-p (string)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
247
    "Does the STRING only contain BASE-CHARs?"
248
    (declare (ignorable string))
249
    (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
250
251

  (defun strings-common-element-type (strings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
252
    "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
253
    (declare (ignorable strings))
254
255
256
    #.(if +non-base-chars-exist-p+
          `(aref +character-types+
            (loop :with index = 0 :for s :in strings :do
257
258
259
260
261
262
263
264
265
266
267
268
269
270
              (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))))
271
272
                  :finally (return index)))
          ''character))
273
274

  (defun reduce/strcat (strings &key key start end)
275
276
    "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."
277
278
    (when (or start end) (setf strings (subseq strings start end)))
    (when key (setf strings (mapcar key strings)))
279
280
    (loop :with output = (make-string (loop :for s :in strings
                                            :sum (if (characterp s) 1 (length s)))
281
                                      :element-type (strings-common-element-type strings))
282
          :with pos = 0
283
          :for input :in strings
284
285
286
287
          :do (etypecase input
                (null)
                (character (setf (char output pos) input) (incf pos))
                (string (replace output input :start1 pos) (incf pos (length input))))
288
289
          :finally (return output)))

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

295
  (defun first-char (s)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
296
    "Return the first character of a non-empty string S, or NIL"
297
    (and (stringp s) (plusp (length s)) (char s 0)))
298

299
  (defun last-char (s)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
300
    "Return the last character of a non-empty string S, or NIL"
301
    (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
302

303
304
  (defun split-string (string &key max (separator '(#\Space #\Tab)))
    "Split STRING into a list of components separated by
305
306
307
308
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\")."
309
310
    (block ()
      (let ((list nil) (words 0) (end (length string)))
311
        (when (zerop end) (return nil))
312
313
314
315
316
        (flet ((separatorp (char) (find char separator))
               (done () (return (cons (subseq string 0 end) list))))
          (loop
            :for start = (if (and max (>= words (1- max)))
                             (done)
317
318
319
320
321
                             (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))))))
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341

  (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)
342
         (string-suffix-p string suffix)))
343

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
  (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)))))

360
  (defun standard-case-symbol-name (name-designator)
361
362
363
364
    "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))
365
    (cond
366
367
      ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
       (string name-designator))
368
369
370
371
      ;; Should we be doing something on CLISP?
      (t (string-upcase name-designator))))

  (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
372
373
    "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.
374
If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
375
376
    (find-symbol* (standard-case-symbol-name name-designator)
                  (etypecase package-designator
377
378
                    ((or package symbol) package-designator)
                    (string (standard-case-symbol-name package-designator)))
379
                  error)))
380

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

404

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

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
415
416
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.
417
418
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
419
420
421
    (etypecase fun
      (function fun)
      ((or boolean keyword character number pathname) (constantly fun))
422
      (hash-table #'(lambda (x) (gethash x fun)))
423
      (symbol (fdefinition fun))
424
425
426
      (cons (if (eq 'lambda (car fun))
                (eval fun)
                #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
427
428
429
430
431
432
      (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,
433
434
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
435
436
437
438
439
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
440
instead of a list."
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
    (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
456
of sub-objects to read as per ACCESS-AT"
457
458
459
460
461
    (cond
      ((integerp at)
       (1+ at))
      ((and (consp at) (integerp (first at)))
       (1+ (first at)))))
462

463
  (defun call-function (function-spec &rest arguments)
464
465
    "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
with the given ARGUMENTS"
466
    (apply (ensure-function function-spec) arguments))
467

468
  (defun call-functions (function-specs)
469
    "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
470
    (map () 'call-function function-specs))
471

472
  (defun register-hook-function (variable hook &optional call-now-p)
473
474
475
    "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)
476
    (when call-now-p (call-function hook))))
477

478

479
480
481
482
483
484
485
486
487
488
489
490
491
492
;;; 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
493
            (typecase class
494
495
496
497
498
              (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
499
500
501
502
503
504
505
506
507
508
            (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))
509
      (or (and found
510
               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
511
               found)
512
          (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
513
514


515
516
517
;;; Hash-tables
(with-upgradability ()
  (defun ensure-gethash (key table default)
518
    "Lookup the TABLE for a KEY as by GETHASH, but if not present,
519
call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
520
521
set the corresponding entry to the result in the table.
Return two values: the entry after its optional computation, and whether it was found"
522
    (multiple-value-bind (value foundp) (gethash key table)
523
524
525
526
527
      (values
       (if foundp
           value
           (setf (gethash key table) (call-function default)))
       foundp)))
528
529
530
531
532
533
534

  (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))))


535
;;; Lexicographic comparison of lists of numbers
536
(with-upgradability ()
537
538
539
  (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."
540
541
    (cond ((null y) nil)
          ((null x) t)
542
543
544
545
546
547
548
          ((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."
549
550
551
552
553
554
555
556
557
558
559
560
561
562
    (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)))))
563

564
565
566

;;; Condition control

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

  (defun match-condition-p (x condition)
    "Compare received CONDITION to some pattern X:
582
583
584
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."
585
586
    (etypecase x
      (symbol (typep condition x))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
587
588
      ((simple-vector 2)
       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
589
590
591
      (function (funcall x condition))
      (string (and (typep condition 'simple-condition)
                   ;; On SBCL, it's always set and the check triggers a warning
592
                   #+(or allegro clozure cmucl lispworks scl)
593
594
595
596
597
598
599
600
                   (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
601
    "calls the THUNK in a context where the CONDITIONS are muffled"
602
603
604
605
    (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
                                      (muffle-warning c)))))
      (funcall thunk)))

606
  (defmacro with-muffled-conditions ((conditions) &body body)
607
    "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
608
    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
609

610
611
612
613
614
615
616
617
;;; 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)
618
619
               (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
                       (nth-value 1 (symbol-call :uiop :implementation-type))
620
621
622
623
624
                       (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)
625
626
627
628
    "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."
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
    (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)
648
649
650
    "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 ~*)."
651
652
653
654
655
    (error 'parameter-error
           :functionality functionality
           :format-control format-control
           :format-arguments format-arguments)))

656
657
658
659
660
661
662
663
664
665
666
667
(with-upgradability ()
  (defun boolean-to-feature-expression (value)
    "Converts a boolean VALUE to a form suitable for testing with #+."
    (if value
        '(:and)
        '(:or)))

  (defun symbol-test-to-feature-expression (name package)
    "Check if a symbol with a given NAME exists in PACKAGE and returns a
form suitable for testing with #+."
    (boolean-to-feature-expression
     (find-symbol* name package nil))))