utility.lisp 18.4 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
   #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
19
   #:emptyp ;; sequences
20
   #:strcat #:first-char #:last-char #:split-string ;; strings
21
   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
22
   #:find-class* ;; CLOS
23 24
   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
   #:earlier-stamp #:stamps-earliest #:earliest-stamp
25 26
   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
   #:list-to-hash-set ;; hash-table
27
   #:ensure-function #:access-at #:access-at-count ;; functions
28
   #:call-function #:call-functions #:register-hook-function
29 30
   #:match-condition-p #:match-any-condition-p ;; conditions
   #:call-with-muffled-conditions #:with-muffled-conditions
31 32
   #:lexicographic< #:lexicographic<=
   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
33
(in-package :uiop/utility)
34

35 36 37 38 39
;;;; 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.
40 41 42
(eval-when (:load-toplevel :compile-toplevel :execute)
  (defun undefine-function (function-spec)
    (cond
43
      ((symbolp function-spec)
44
       #+clisp
45 46 47 48 49
       (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))
50 51
      ((and (consp function-spec) (eq (car function-spec) 'setf)
            (consp (cdr function-spec)) (null (cddr function-spec)))
52
       #-gcl2.6 (fmakunbound function-spec))
53 54
      (t (error "bad function spec ~S" function-spec))))
  (defun undefine-functions (function-spec-list)
55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
    (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)
77 78 79 80 81 82 83 84 85 86 87 88 89
    (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)))))
90 91

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

99
  (defmacro uiop-debug (&rest keys)
100
    `(eval-when (:compile-toplevel :load-toplevel :execute)
101
       (load-uiop-debug-utility ,@keys)))
102

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


114
;;; Flow control
115 116 117 118 119 120 121 122 123 124 125
(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)))))
126 127

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

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

167 168 169 170 171
  (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))))
172 173


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

180

181
;;; Strings
182 183 184
(with-upgradability ()
  (defun strcat (&rest strings)
    (apply 'concatenate 'string strings))
185

186 187
  (defun first-char (s)
    (and (stringp s) (plusp (length s)) (char s 0)))
188

189 190
  (defun last-char (s)
    (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
191

192 193
  (defun split-string (string &key max (separator '(#\Space #\Tab)))
    "Split STRING into a list of components separated by
194 195 196 197
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\")."
198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
    (block ()
      (let ((list nil) (words 0) (end (length string)))
        (flet ((separatorp (char) (find char separator))
               (done () (return (cons (subseq string 0 end) list))))
          (loop
            :for start = (if (and max (>= words (1- max)))
                             (done)
                             (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))))))

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

233 234

;;; CLOS
235 236 237 238 239 240
(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)))))
241

242 243

;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
244 245
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
  (deftype stamp () '(or real boolean)))
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
(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))
265

266

267
;;; Hash-tables
268 269 270
(with-upgradability ()
  (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
    (dolist (x list h) (setf (gethash x h) t))))
271

272

273
;;; Function designators
274 275 276
(with-upgradability ()
  (defun ensure-function (fun &key (package :cl))
    "Coerce the object FUN into a function.
277 278 279 280 281 282 283 284 285

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
to the appended list of the rest of its CDR and the arguments.
If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
and EVAL that in a (FUNCTION ...) context."
286 287 288 289 290 291 292 293 294 295 296
    (etypecase fun
      (function fun)
      ((or boolean keyword character number pathname) (constantly fun))
      ((or function symbol) fun)
      (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
      (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,
297 298
call each accessor on the result of the previous calls.
An accessor may be an integer, meaning a call to ELT,
299 300 301 302 303
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
304
instead of a list."
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319
    (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
320
   of sub-objects to read as per ACCESS-AT"
321 322 323 324 325
    (cond
      ((integerp at)
       (1+ at))
      ((and (consp at) (integerp (first at)))
       (1+ (first at)))))
326

327 328
  (defun call-function (function-spec &rest arguments)
    (apply (ensure-function function-spec) arguments))
329

330 331
  (defun call-functions (function-specs)
    (map () 'call-function function-specs))
332

333 334 335
  (defun register-hook-function (variable hook &optional call-now-p)
    (pushnew hook (symbol-value variable))
    (when call-now-p (call-function hook))))
336

337 338

;;; Version handling
339 340 341
(with-upgradability ()
  (defun unparse-version (version-list)
    (format nil "~{~D~^.~}" version-list))
342

343 344
  (defun parse-version (version-string &optional on-error)
    "Parse a VERSION-STRING as a series of natural integers separated by dots.
345 346 347 348 349 350 351
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."
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389
    (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?
390 391 392
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."
393 394 395
    (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))))))
396

397 398 399

;;; Condition control

400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
(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:
415 416 417
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."
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
    (etypecase x
      (symbol (typep condition x))
      ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
      (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)))

437 438
  (defmacro with-muffled-conditions ((conditions) &body body)
    `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
439

440