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

4
5
6
7
(uiop/package:define-package :uiop/utility
  (:nicknames :asdf/utility)
  (:recycle :uiop/utility :asdf/utility :asdf)
  (:use :uiop/common-lisp :uiop/package)
8
  ;; import and reexport a few things defined in :asdf/common-lisp
9
  (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
10
   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
11
  (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
12
   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
13
  (:export
14
   ;; magic helper to define debugging functions:
15
   #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
16
   #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
17
   #:if-let ;; basic flow control
18
19
   #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
   #:remove-plist-keys #:remove-plist-key ;; plists
20
   #:emptyp ;; sequences
21
22
23
   #:+non-base-chars-exist-p+ ;; characters
   #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
   #:first-char #:last-char #:split-string
24
   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
25
   #:find-class* ;; CLOS
26
27
   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
   #:earlier-stamp #:stamps-earliest #:earliest-stamp
28
29
   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
   #:list-to-hash-set ;; hash-table
30
   #:ensure-function #:access-at #:access-at-count ;; functions
31
   #:call-function #:call-functions #:register-hook-function
32
33
   #:match-condition-p #:match-any-condition-p ;; conditions
   #:call-with-muffled-conditions #:with-muffled-conditions
34
35
   #:lexicographic< #:lexicographic<=
   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
36
(in-package :uiop/utility)
37

38
39
40
41
42
;;;; 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.
43
44
45
(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun undefine-function (function-spec)
    (cond
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
46
      ((symbolp function-spec)
47
       #+clisp
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
48
49
50
51
52
       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
         (when (typep f 'clos:standard-generic-function)
           (loop :for m :in (clos:generic-function-methods f)
                 :do (remove-method f m))))
       (fmakunbound function-spec))
53
54
      ((and (consp function-spec) (eq (car function-spec) 'setf)
            (consp (cdr function-spec)) (null (cddr function-spec)))
55
       #-gcl2.6 (fmakunbound function-spec))
56
57
      (t (error "bad function spec ~S" function-spec))))
  (defun undefine-functions (function-spec-list)
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
    (map () 'undefine-function function-spec-list))
  (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
                 ;; undefining the previous function is the portable way
                 ;; of overriding any incompatible previous gf, except on CLISP.
                 ;; We usually try to do it only for the functions that need it,
                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
                 ;; (which causes issues in clisp)
                 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
                     `((undefine-function ',name)))
                 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
                 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
                     `((declaim (notinline ,name))))
                 (,',def ,name ,formals ,@rest))))))
    (defdef defgeneric* defgeneric)
80
81
82
83
84
85
86
87
88
89
90
91
92
    (defdef defun* defun))
  (defmacro with-upgradability ((&optional) &body body)
    `(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))
                       ((defgeneric)
                        (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
                          `(defgeneric* ,@cdr)))
                       (otherwise form)))
                   form)))))
93
94

;;; Magic debugging help. See contrib/debug.lisp
95
(with-upgradability ()
96
  (defvar *uiop-debug-utility*
97
    '(or (ignore-errors
98
99
          (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
      (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
100
101
    "form that evaluates to the pathname to your favorite debugging utilities")

102
  (defmacro uiop-debug (&rest keys)
103
    `(eval-when (:compile-toplevel :load-toplevel :execute)
104
       (load-uiop-debug-utility ,@keys)))
105

106
  (defun load-uiop-debug-utility (&key package utility-file)
107
108
109
110
    (let* ((*package* (if package (find-package package) *package*))
           (keyword (read-from-string
                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
      (unless (member keyword *features*)
111
        (let* ((utility-file (or utility-file *uiop-debug-utility*))
112
113
114
               (file (ignore-errors (probe-file (eval utility-file)))))
          (if file (load file)
              (error "Failed to locate debug utility file: ~S" utility-file)))))))
115
116


117
;;; Flow control
118
119
120
121
122
123
124
125
126
127
128
(with-upgradability ()
  (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)))))
129
130

;;; List manipulation
131
132
133
(with-upgradability ()
  (defmacro while-collecting ((&rest collectors) &body body)
    "COLLECTORS should be a list of names for collections.  A collector
134
135
136
137
138
139
140
141
142
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\)."
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
    (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)))
160
161
162
163
164
          ((not (consp l)) (return nil)))))

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

165

166
;;; remove a key from a plist, i.e. for keyword argument cleanup
167
168
169
170
171
172
(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)))
173

174
175
176
177
178
  (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))))
179
180


181
;;; Sequences
182
183
184
185
(with-upgradability ()
  (defun emptyp (x)
    "Predicate that is true for an empty sequence"
    (or (null x) (and (vectorp x) (zerop (length x))))))
186

187

188
189
;;; Characters
(with-upgradability ()
190
191
  (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
  (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
192
193


194
;;; Strings
195
(with-upgradability ()
196
197
  (defun base-string-p (string)
    (declare (ignorable string))
198
    (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
199
200

  (defun strings-common-element-type (strings)
201
    (declare (ignorable strings))
202
203
    #-non-base-chars-exist-p 'character
    #+non-base-chars-exist-p
204
    (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
205
        'base-char 'character))
206
207

  (defun reduce/strcat (strings &key key start end)
208
209
    "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."
210
211
    (when (or start end) (setf strings (subseq strings start end)))
    (when key (setf strings (mapcar key strings)))
212
    (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
213
                                      :element-type (strings-common-element-type strings))
214
          :with pos = 0
215
          :for input :in strings
216
217
218
219
          :do (etypecase input
                (null)
                (character (setf (char output pos) input) (incf pos))
                (string (replace output input :start1 pos) (incf pos (length input))))
220
221
          :finally (return output)))

222
  (defun strcat (&rest strings)
223
    (reduce/strcat strings))
224

225
226
  (defun first-char (s)
    (and (stringp s) (plusp (length s)) (char s 0)))
227

228
229
  (defun last-char (s)
    (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
230

231
232
  (defun split-string (string &key max (separator '(#\Space #\Tab)))
    "Split STRING into a list of components separated by
233
234
235
236
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\")."
237
238
    (block ()
      (let ((list nil) (words 0) (end (length string)))
239
        (when (zerop end) (return nil))
240
241
242
243
244
        (flet ((separatorp (char) (find char separator))
               (done () (return (cons (subseq string 0 end) list))))
          (loop
            :for start = (if (and max (>= words (1- max)))
                             (done)
245
246
247
248
249
                             (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))))))
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

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

272
273

;;; CLOS
274
275
276
277
278
279
(with-upgradability ()
  (defun find-class* (x &optional (errorp t) environment)
    (etypecase x
      ((or standard-class built-in-class) x)
      #+gcl2.6 (keyword nil)
      (symbol (find-class x errorp environment)))))
280

281
282

;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
283
284
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
  (deftype stamp () '(or real boolean)))
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
(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))
304

305

306
;;; Hash-tables
307
308
309
(with-upgradability ()
  (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
    (dolist (x list h) (setf (gethash x h) t))))
310

311

312
;;; Function designators
313
314
315
(with-upgradability ()
  (defun ensure-function (fun &key (package :cl))
    "Coerce the object FUN into a function.
316
317
318
319
320
321

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
322
323
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.
324
325
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
326
327
328
329
    (etypecase fun
      (function fun)
      ((or boolean keyword character number pathname) (constantly fun))
      ((or function symbol) fun)
330
331
332
      (cons (if (eq 'lambda (car fun))
                (eval fun)
                #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
333
334
335
336
337
338
      (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,
339
340
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
341
342
343
344
345
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
346
instead of a list."
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
    (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
362
   of sub-objects to read as per ACCESS-AT"
363
364
365
366
367
    (cond
      ((integerp at)
       (1+ at))
      ((and (consp at) (integerp (first at)))
       (1+ (first at)))))
368

369
370
  (defun call-function (function-spec &rest arguments)
    (apply (ensure-function function-spec) arguments))
371

372
373
  (defun call-functions (function-specs)
    (map () 'call-function function-specs))
374

375
376
377
  (defun register-hook-function (variable hook &optional call-now-p)
    (pushnew hook (symbol-value variable))
    (when call-now-p (call-function hook))))
378

379
380

;;; Version handling
381
382
383
(with-upgradability ()
  (defun unparse-version (version-list)
    (format nil "~{~D~^.~}" version-list))
384

385
386
  (defun parse-version (version-string &optional on-error)
    "Parse a VERSION-STRING as a series of natural integers separated by dots.
387
388
389
390
391
392
393
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."
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
    (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)))

  (defun lexicographic< (< x y)
    (cond ((null y) nil)
          ((null x) t)
          ((funcall < (car x) (car y)) t)
          ((funcall < (car y) (car x)) nil)
          (t (lexicographic< < (cdr x) (cdr y)))))

  (defun lexicographic<= (< x y)
    (not (lexicographic< < y x)))

  (defun version< (version1 version2)
    (let ((v1 (parse-version version1 nil))
          (v2 (parse-version version2 nil)))
      (lexicographic< '< v1 v2)))

  (defun version<= (version1 version2)
    (not (version< version2 version1)))

  (defun version-compatible-p (provided-version required-version)
    "Is the provided version a compatible substitution for the required-version?
432
433
434
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."
435
436
437
    (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))))))
438

439
440
441

;;; Condition control

442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
(with-upgradability ()
  (defparameter +simple-condition-format-control-slot+
    #+abcl 'system::format-control
    #+allegro 'excl::format-control
    #+clisp 'system::$format-control
    #+clozure 'ccl::format-control
    #+(or cmu scl) 'conditions::format-control
    #+ecl 'si::format-control
    #+(or gcl lispworks) 'conditions::format-string
    #+sbcl 'sb-kernel:format-control
    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
    "Name of the slot for FORMAT-CONTROL in simple-condition")

  (defun match-condition-p (x condition)
    "Compare received CONDITION to some pattern X:
457
458
459
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."
460
461
    (etypecase x
      (symbol (typep condition x))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
462
463
      ((simple-vector 2)
       (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
      (function (funcall x condition))
      (string (and (typep condition 'simple-condition)
                   ;; On SBCL, it's always set and the check triggers a warning
                   #+(or allegro clozure cmu lispworks scl)
                   (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)
    (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
                                      (muffle-warning c)))))
      (funcall thunk)))

480
481
  (defmacro with-muffled-conditions ((conditions) &body body)
    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
482

483