utility.lisp 29.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 #: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
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
26
   #:coerce-class ;; CLOS
27
28
   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
   #:earlier-stamp #:stamps-earliest #:earliest-stamp
29
   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-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
34
   #:lexicographic< #:lexicographic<= ;; version
   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p
35
36
   #:match-condition-p #:match-any-condition-p ;; conditions
   #:call-with-muffled-conditions #:with-muffled-conditions
37
   #:not-implemented-error #:parameter-error))
38
(in-package :uiop/utility)
39

40
41
42
43
44
;;;; 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.
45
(eval-when (:load-toplevel :compile-toplevel :execute)
46
47
48
49
50
51
52
53
54
55
  (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,
56
                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
57
58
                 ,@(when supersede
                     `((fmakunbound ',name)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
59
                 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl
60
61
62
                     `((declaim (notinline ,name))))
                 (,',def ,name ,formals ,@rest))))))
    (defdef defgeneric* defgeneric)
63
64
    (defdef defun* defun))
  (defmacro with-upgradability ((&optional) &body body)
65
66
67
68
69
    "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."
70
71
72
73
74
75
    `(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))
76
                       ((defgeneric) `(defgeneric* ,@cdr))
77
78
                       (otherwise form)))
                   form)))))
79
80

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

88
  (defmacro uiop-debug (&rest keys)
89
    `(eval-when (:compile-toplevel :load-toplevel :execute)
90
       (load-uiop-debug-utility ,@keys)))
91

92
  (defun load-uiop-debug-utility (&key package utility-file)
93
94
95
96
    (let* ((*package* (if package (find-package package) *package*))
           (keyword (read-from-string
                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
      (unless (member keyword *features*)
97
        (let* ((utility-file (or utility-file *uiop-debug-utility*))
98
99
               (file (ignore-errors (probe-file (eval utility-file)))))
          (if file (load file)
100
              (error "Failed to locate debug utility file: ~S" utility-file)))))))
101

102
;;; Flow control
103
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
104
105
106
107
108
  (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))

109
110
111
112
113
114
115
116
117
118
  (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)))))
119
120

;;; List manipulation
121
122
123
(with-upgradability ()
  (defmacro while-collecting ((&rest collectors) &body body)
    "COLLECTORS should be a list of names for collections.  A collector
124
125
126
127
128
129
130
131
132
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\)."
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
    (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)))
150
151
152
153
154
          ((not (consp l)) (return nil)))))

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

155

156
;;; remove a key from a plist, i.e. for keyword argument cleanup
157
158
159
160
161
162
(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)))
163

164
165
166
167
168
  (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))))
169
170


171
;;; Sequences
172
173
174
175
(with-upgradability ()
  (defun emptyp (x)
    "Predicate that is true for an empty sequence"
    (or (null x) (and (vectorp x) (zerop (length x))))))
176

177

178
;;; Characters
179
(with-upgradability ()
180
181
182
  ;; 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.
183
  (defparameter +character-types+ ;; assuming a simple hierarchy
184
185
186
187
188
189
    #.(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
190
                       #+lispworks7+ lw:bmp-char
191
                       #+lispworks lw:simple-char
192
193
194
195
196
197
                       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*)))
198
199
200
201
202
203
204
205
206
207
208

(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
209
                             (character #'(lambda (type) (typep x type)))
210
211
212
213
                             (symbol #'(lambda (type) (subtypep x type))))
               +character-types+)
           (error "Not a character or character type: ~S" x))))))

214

215
;;; Strings
216
(with-upgradability ()
217
  (defun base-string-p (string)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
218
    "Does the STRING only contain BASE-CHARs?"
219
    (declare (ignorable string))
220
    (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
221
222

  (defun strings-common-element-type (strings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
223
    "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
224
    (declare (ignorable strings))
225
226
227
    #.(if +non-base-chars-exist-p+
          `(aref +character-types+
            (loop :with index = 0 :for s :in strings :do
228
229
230
231
232
233
234
235
236
237
238
239
240
241
              (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))))
242
243
                  :finally (return index)))
          ''character))
244
245

  (defun reduce/strcat (strings &key key start end)
246
247
    "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."
248
249
    (when (or start end) (setf strings (subseq strings start end)))
    (when key (setf strings (mapcar key strings)))
250
251
    (loop :with output = (make-string (loop :for s :in strings
                                            :sum (if (characterp s) 1 (length s)))
252
                                      :element-type (strings-common-element-type strings))
253
          :with pos = 0
254
          :for input :in strings
255
256
257
258
          :do (etypecase input
                (null)
                (character (setf (char output pos) input) (incf pos))
                (string (replace output input :start1 pos) (incf pos (length input))))
259
260
          :finally (return output)))

261
  (defun strcat (&rest strings)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
262
263
    "Concatenate strings.
NIL is interpreted as an empty string, a character as a string of length one."
264
    (reduce/strcat strings))
265

266
  (defun first-char (s)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
267
    "Return the first character of a non-empty string S, or NIL"
268
    (and (stringp s) (plusp (length s)) (char s 0)))
269

270
  (defun last-char (s)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
271
    "Return the last character of a non-empty string S, or NIL"
272
    (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
273

274
275
  (defun split-string (string &key max (separator '(#\Space #\Tab)))
    "Split STRING into a list of components separated by
276
277
278
279
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\")."
280
281
    (block ()
      (let ((list nil) (words 0) (end (length string)))
282
        (when (zerop end) (return nil))
283
284
285
286
287
        (flet ((separatorp (char) (find char separator))
               (done () (return (cons (subseq string 0 end) list))))
          (loop
            :for start = (if (and max (>= words (1- max)))
                             (done)
288
289
290
291
292
                             (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))))))
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

  (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)
313
         (string-suffix-p string suffix)))
314

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
  (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)))))

331
  (defun standard-case-symbol-name (name-designator)
332
333
334
335
    "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))
336
    (cond
337
338
      ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
       (string name-designator))
339
340
341
342
      ;; Should we be doing something on CLISP?
      (t (string-upcase name-designator))))

  (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
343
344
    "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.
345
If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
346
347
    (find-symbol* (standard-case-symbol-name name-designator)
                  (etypecase package-designator
348
349
                    ((or package symbol) package-designator)
                    (string (standard-case-symbol-name package-designator)))
350
                  error)))
351

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
352
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
353
354
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
  (deftype stamp () '(or real boolean)))
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
(with-upgradability ()
  (defun stamp< (x y)
    (etypecase x
      (null (and y t))
      ((eql t) nil)
      (real (etypecase y
              (null nil)
              ((eql t) t)
              (real (< x y))))))
  (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))
  (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
  (defun earliest-stamp (&rest list) (stamps-earliest list))
  (defun later-stamp (x y) (if (stamp< x y) y x))
  (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
  (defun latest-stamp (&rest list) (stamps-latest list))
  (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
374

375

376
;;; Function designators
377
378
379
(with-upgradability ()
  (defun ensure-function (fun &key (package :cl))
    "Coerce the object FUN into a function.
380
381
382
383
384
385

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
386
387
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.
388
389
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
390
391
392
    (etypecase fun
      (function fun)
      ((or boolean keyword character number pathname) (constantly fun))
393
      (hash-table #'(lambda (x) (gethash x fun)))
394
      (symbol (fdefinition fun))
395
396
397
      (cons (if (eq 'lambda (car fun))
                (eval fun)
                #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
398
399
400
401
402
403
      (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,
404
405
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
406
407
408
409
410
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
411
instead of a list."
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
    (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
427
of sub-objects to read as per ACCESS-AT"
428
429
430
431
432
    (cond
      ((integerp at)
       (1+ at))
      ((and (consp at) (integerp (first at)))
       (1+ (first at)))))
433

434
  (defun call-function (function-spec &rest arguments)
435
436
    "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
with the given ARGUMENTS"
437
    (apply (ensure-function function-spec) arguments))
438

439
  (defun call-functions (function-specs)
440
    "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
441
    (map () 'call-function function-specs))
442

443
  (defun register-hook-function (variable hook &optional call-now-p)
444
445
446
    "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)
447
    (when call-now-p (call-function hook))))
448

449

450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
;;; 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
             (typecase class
              (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
             (etypecase normalized
               ((or standard-class built-in-class) normalized)
               ((or null keyword) nil)
               (symbol (find-class normalized nil nil)))))
      (or (and found
               (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super))
               found)
477
          (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
478
479


480
481
482
;;; Hash-tables
(with-upgradability ()
  (defun ensure-gethash (key table default)
483
    "Lookup the TABLE for a KEY as by GETHASH, but if not present,
484
call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
485
486
set the corresponding entry to the result in the table.
Return two values: the entry after its optional computation, and whether it was found"
487
    (multiple-value-bind (value foundp) (gethash key table)
488
489
490
491
492
      (values
       (if foundp
           value
           (setf (gethash key table) (call-function default)))
       foundp)))
493
494
495
496
497
498
499

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


500
;;; Version handling
501
502
(with-upgradability ()
  (defun unparse-version (version-list)
503
    "From a parsed version (a list of natural numbers), compute the version string"
504
    (format nil "~{~D~^.~}" version-list))
505

506
  (defun parse-version (version-string &optional on-error)
507
    "Parse a VERSION-STRING as a series of natural numbers separated by dots.
508
509
510
511
512
513
514
Return a (non-null) list of integers if the string is valid;
otherwise return NIL.

When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
with format arguments explaining why the version is invalid.
ON-ERROR is also called if the version is not canonical
in that it doesn't print back to itself, but the list is returned anyway."
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
    (block nil
      (unless (stringp version-string)
        (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
        (return))
      (unless (loop :for prev = nil :then c :for c :across version-string
                    :always (or (digit-char-p c)
                                (and (eql c #\.) prev (not (eql prev #\.))))
                    :finally (return (and c (digit-char-p c))))
        (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
                       'parse-version version-string)
        (return))
      (let* ((version-list
               (mapcar #'parse-integer (split-string version-string :separator ".")))
             (normalized-version (unparse-version version-list)))
        (unless (equal version-string normalized-version)
          (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
        version-list)))

533
534
535
  (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."
536
537
    (cond ((null y) nil)
          ((null x) t)
538
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."
    (not (lexicographic< element< y x)))
546
547

  (defun version< (version1 version2)
548
    "Compare two version strings"
549
550
551
552
553
    (let ((v1 (parse-version version1 nil))
          (v2 (parse-version version2 nil)))
      (lexicographic< '< v1 v2)))

  (defun version<= (version1 version2)
554
    "Compare two version strings"
555
556
557
558
    (not (version< version2 version1)))

  (defun version-compatible-p (provided-version required-version)
    "Is the provided version a compatible substitution for the required-version?
559
560
561
If major versions differ, it's not compatible.
If they are equal, then any later version is compatible,
with later being determined by a lexicographical comparison of minor numbers."
562
563
564
    (let ((x (parse-version provided-version nil))
          (y (parse-version required-version nil)))
      (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
565

566
567
568

;;; Condition control

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

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

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

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