| 50 | | (cl:in-package :common-lisp-user) |
| 51 | | #+genera (in-package :future-common-lisp-user) |
| | 50 | (in-package :cl-user) |
| | 51 | |
| | 52 | #+abcl |
| | 53 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 54 | (documentation 'car 'function)) ;; workaround (SETF DOCUMENTATION) autoloader bug |
| | 55 | |
| | 56 | #+cmu |
| | 57 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 58 | (declaim (optimize (speed 1) (safety 3) (debug 3))) |
| | 59 | (setf ext:*gc-verbose* nil)) |
| | 60 | |
| | 61 | #+(or abcl clisp cmu) |
| | 62 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 63 | (unless (member :asdf2.27 *features*) |
| | 64 | (let* ((existing-version |
| | 65 | (when (find-package :asdf) |
| | 66 | (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) |
| | 67 | (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf)))) |
| | 68 | (etypecase ver |
| | 69 | (string ver) |
| | 70 | (cons (format nil "~{~D~^.~}" ver)) |
| | 71 | (null "1.0")))))) |
| | 72 | (away (format nil "~A-~A" :asdf existing-version))) |
| | 73 | (when existing-version |
| | 74 | (rename-package :asdf away) |
| | 75 | (when *load-verbose* |
| | 76 | (format t "; Renamed package ~A away to ~A~%" :asdf away)))))) |
| | 77 | |
| | 78 | ;;;; --------------------------------------------------------------------------- |
| | 79 | ;;;; Handle ASDF package upgrade, including implementation-dependent magic. |
| | 80 | ;; |
| | 81 | ;; See https://bugs.launchpad.net/asdf/+bug/485687 |
| | 82 | ;; |
| | 83 | ;; CAUTION: we must handle the first few packages specially for hot-upgrade. |
| | 84 | ;; asdf/package will be frozen as of 2.27 |
| | 85 | ;; to forever export the same exact symbols. |
| | 86 | ;; Any other symbol must be import-from'ed |
| | 87 | ;; and reexported in a different package |
| | 88 | ;; (alternatively the package may be dropped & replaced by one with a new name). |
| | 89 | |
| | 90 | (defpackage :asdf/package |
| | 91 | (:use :common-lisp) |
| | 92 | (:export |
| | 93 | #:find-package* #:find-symbol* #:symbol-call |
| | 94 | #:intern* #:unintern* #:export* #:make-symbol* |
| | 95 | #:symbol-shadowing-p #:home-package-p #:rehome-symbol |
| | 96 | #:symbol-package-name #:standard-common-lisp-symbol-p |
| | 97 | #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol |
| | 98 | #:nuke-symbol-in-package #:nuke-symbol |
| | 99 | #:ensure-package-unused #:delete-package* |
| | 100 | #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names |
| | 101 | #:package-definition-form #:parse-define-package-form |
| | 102 | #:ensure-package #:define-package)) |
| | 103 | |
| | 104 | (in-package :asdf/package) |
| | 105 | |
| | 106 | ;;;; General purpose package utilities |
| | 107 | |
| | 108 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 109 | (defun find-package* (package-designator &optional (error t)) |
| | 110 | (let ((package (find-package package-designator))) |
| | 111 | (cond |
| | 112 | (package package) |
| | 113 | (error (error "No package named ~S" (string package-designator))) |
| | 114 | (t nil)))) |
| | 115 | (defun find-symbol* (name package-designator &optional (error t)) |
| | 116 | "Find a symbol in a package of given string'ified NAME; |
| | 117 | unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax |
| | 118 | by letting you supply a symbol or keyword for the name; |
| | 119 | also works well when the package is not present. |
| | 120 | If optional ERROR argument is NIL, return NIL instead of an error |
| | 121 | when the symbol is not found." |
| | 122 | (block nil |
| | 123 | (let ((package (find-package* package-designator error))) |
| | 124 | (when package ;; package error handled by find-package* already |
| | 125 | (multiple-value-bind (symbol status) (find-symbol (string name) package) |
| | 126 | (cond |
| | 127 | (status (return (values symbol status))) |
| | 128 | (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) |
| | 129 | (values nil nil)))) |
| | 130 | (defun symbol-call (package name &rest args) |
| | 131 | "Call a function associated with symbol of given name in given package, |
| | 132 | with given ARGS. Useful when the call is read before the package is loaded, |
| | 133 | or when loading the package is optional." |
| | 134 | (apply (find-symbol* name package) args)) |
| | 135 | (defun intern* (name package-designator &optional (error t)) |
| | 136 | (intern (string name) (find-package* package-designator error))) |
| | 137 | (defun export* (name package-designator) |
| | 138 | (let* ((package (find-package* package-designator)) |
| | 139 | (symbol (intern* name package))) |
| | 140 | (export (or symbol (list symbol)) package))) |
| | 141 | (defun make-symbol* (name) |
| | 142 | (etypecase name |
| | 143 | (string (make-symbol name)) |
| | 144 | (symbol (copy-symbol name)))) |
| | 145 | (defun unintern* (name package-designator &optional (error t)) |
| | 146 | (block nil |
| | 147 | (let ((package (find-package* package-designator error))) |
| | 148 | (when package |
| | 149 | (multiple-value-bind (symbol status) (find-symbol* name package error) |
| | 150 | (cond |
| | 151 | (status (unintern symbol package) |
| | 152 | (return (values symbol status))) |
| | 153 | (error (error "symbol ~A not present in package ~A" |
| | 154 | (string symbol) (package-name package)))))) |
| | 155 | (values nil nil)))) |
| | 156 | (defun symbol-shadowing-p (symbol package) |
| | 157 | (and (member symbol (package-shadowing-symbols package)) t)) |
| | 158 | (defun home-package-p (symbol package) |
| | 159 | (and package (let ((sp (symbol-package symbol))) |
| | 160 | (and sp (let ((pp (find-package* package))) |
| | 161 | (and pp (eq sp pp)))))))) |
| | 162 | |
| | 163 | |
| | 164 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 165 | (defun symbol-package-name (symbol) |
| | 166 | (let ((package (symbol-package symbol))) |
| | 167 | (and package (package-name package)))) |
| | 168 | (defun standard-common-lisp-symbol-p (symbol) |
| | 169 | (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) |
| | 170 | (and (eq sym symbol) (eq status :external)))) |
| | 171 | (defun reify-package (package &optional package-context) |
| | 172 | (if (eq package package-context) t |
| | 173 | (etypecase package |
| | 174 | (null nil) |
| | 175 | ((eql (find-package :cl)) :cl) |
| | 176 | (package (package-name package))))) |
| | 177 | (defun unreify-package (package &optional package-context) |
| | 178 | (etypecase package |
| | 179 | (null nil) |
| | 180 | ((eql t) package-context) |
| | 181 | ((or symbol string) (find-package package)))) |
| | 182 | (defun reify-symbol (symbol &optional package-context) |
| | 183 | (etypecase symbol |
| | 184 | ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) |
| | 185 | (symbol (vector (symbol-name symbol) |
| | 186 | (reify-package (symbol-package symbol) package-context))))) |
| | 187 | (defun unreify-symbol (symbol &optional package-context) |
| | 188 | (etypecase symbol |
| | 189 | (symbol symbol) |
| | 190 | ((simple-vector 2) |
| | 191 | (let* ((symbol-name (svref symbol 0)) |
| | 192 | (package-foo (svref symbol 1)) |
| | 193 | (package (unreify-package package-foo package-context))) |
| | 194 | (if package (intern* symbol-name package) |
| | 195 | (make-symbol* symbol-name))))))) |
| | 196 | |
| | 197 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 198 | (defvar *all-package-happiness* '()) |
| | 199 | (defvar *all-package-fishiness* (list t)) |
| | 200 | (defvar *package-fishiness* '()) |
| | 201 | (defun flush-fishy () |
| | 202 | (when *package-fishiness* |
| | 203 | (if (null (rest *package-fishiness*)) |
| | 204 | (push (first *package-fishiness*) *all-package-happiness*) |
| | 205 | (push (nreverse *package-fishiness*) *all-package-fishiness*)) |
| | 206 | (setf *package-fishiness* nil))) |
| | 207 | (defun record-fishy (info) |
| | 208 | ;;(format t "~&FISHY: ~S~%" info) |
| | 209 | (push info *package-fishiness*)) |
| | 210 | (defmacro when-package-fishiness (&body body) |
| | 211 | `(when *all-package-fishiness* ,@body)) |
| | 212 | (defmacro note-package-fishiness (&rest info) |
| | 213 | `(when-package-fishiness (record-fishy (list ,@info))))) |
| | 214 | |
| | 215 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 216 | #+(or clisp clozure) |
| | 217 | (defun get-setf-function-symbol (symbol) |
| | 218 | #+clisp (let ((sym (get symbol 'system::setf-function))) |
| | 219 | (if sym (values sym :setf-function) |
| | 220 | (let ((sym (get symbol 'system::setf-expander))) |
| | 221 | (if sym (values sym :setf-expander) |
| | 222 | (values nil nil))))) |
| | 223 | #+clozure (gethash symbol ccl::%setf-function-names%)) |
| | 224 | #+(or clisp clozure) |
| | 225 | (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) |
| | 226 | #+clisp (assert (member kind '(:setf-function :setf-expander))) |
| | 227 | #+clozure (assert (eq kind t)) |
| | 228 | #+clisp |
| | 229 | (cond |
| | 230 | ((null new-setf-symbol) |
| | 231 | (remprop symbol 'system::setf-function) |
| | 232 | (remprop symbol 'system::setf-expander)) |
| | 233 | ((eq kind :setf-function) |
| | 234 | (setf (get symbol 'system::setf-function) new-setf-symbol)) |
| | 235 | ((eq kind :setf-expander) |
| | 236 | (setf (get symbol 'system::setf-expander) new-setf-symbol)) |
| | 237 | (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" |
| | 238 | kind symbol new-setf-symbol))) |
| | 239 | #+clozure |
| | 240 | (progn |
| | 241 | (gethash symbol ccl::%setf-function-names%) new-setf-symbol |
| | 242 | (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) |
| | 243 | #+(or clisp clozure) |
| | 244 | (defun create-setf-function-symbol (symbol) |
| | 245 | #+clisp (system::setf-symbol symbol) |
| | 246 | #+clozure (ccl::construct-setf-function-name symbol)) |
| | 247 | (defun set-dummy-symbol (symbol reason other-symbol) |
| | 248 | (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) |
| | 249 | (defun make-dummy-symbol (symbol) |
| | 250 | (let ((dummy (copy-symbol symbol))) |
| | 251 | (set-dummy-symbol dummy 'replacing symbol) |
| | 252 | (set-dummy-symbol symbol 'replaced-by dummy) |
| | 253 | dummy)) |
| | 254 | (defun dummy-symbol (symbol) |
| | 255 | (get symbol 'dummy-symbol)) |
| | 256 | (defun get-dummy-symbol (symbol) |
| | 257 | (let ((existing (dummy-symbol symbol))) |
| | 258 | (if existing (values (cdr existing) (car existing)) |
| | 259 | (make-dummy-symbol symbol)))) |
| | 260 | (defun nuke-symbol-in-package (symbol package-designator) |
| | 261 | (let ((package (find-package* package-designator)) |
| | 262 | (name (symbol-name symbol))) |
| | 263 | (multiple-value-bind (sym stat) (find-symbol name package) |
| | 264 | (when (and (member stat '(:internal :external)) (eq symbol sym)) |
| | 265 | (if (symbol-shadowing-p symbol package) |
| | 266 | (shadowing-import (get-dummy-symbol symbol) package) |
| | 267 | (unintern symbol package)))))) |
| | 268 | (defun nuke-symbol (symbol &optional (packages (list-all-packages))) |
| | 269 | #+(or clisp clozure) |
| | 270 | (multiple-value-bind (setf-symbol kind) |
| | 271 | (get-setf-function-symbol symbol) |
| | 272 | (when kind (nuke-symbol setf-symbol))) |
| | 273 | (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) |
| | 274 | (defun rehome-symbol (symbol package-designator) |
| | 275 | "Changes the home package of a symbol, also leaving it present in its old home if any" |
| | 276 | (let* ((name (symbol-name symbol)) |
| | 277 | (package (find-package* package-designator)) |
| | 278 | (old-package (symbol-package symbol)) |
| | 279 | (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) |
| | 280 | (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) |
| | 281 | (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) |
| | 282 | (unless (eq package old-package) |
| | 283 | (let ((overwritten-symbol-shadowing-p |
| | 284 | (and overwritten-symbol-status |
| | 285 | (symbol-shadowing-p overwritten-symbol package)))) |
| | 286 | (note-package-fishiness |
| | 287 | :rehome-symbol name (package-name old-package) |
| | 288 | (package-name package) old-status (and shadowing t) |
| | 289 | overwritten-symbol-status overwritten-symbol-shadowing-p) |
| | 290 | (when old-package |
| | 291 | (if shadowing |
| | 292 | (shadowing-import shadowing old-package)) |
| | 293 | (unintern symbol old-package)) |
| | 294 | (cond |
| | 295 | (overwritten-symbol-shadowing-p |
| | 296 | (shadowing-import symbol package)) |
| | 297 | (t |
| | 298 | (when overwritten-symbol-status |
| | 299 | (unintern overwritten-symbol package)) |
| | 300 | (import symbol package))) |
| | 301 | (if shadowing |
| | 302 | (shadowing-import symbol old-package) |
| | 303 | (import symbol old-package)) |
| | 304 | #+(or clisp clozure) |
| | 305 | (multiple-value-bind (setf-symbol kind) |
| | 306 | (get-setf-function-symbol symbol) |
| | 307 | (when kind |
| | 308 | (let* ((setf-function (fdefinition setf-symbol)) |
| | 309 | (new-setf-symbol (create-setf-function-symbol symbol))) |
| | 310 | (note-package-fishiness |
| | 311 | :setf-function |
| | 312 | name (package-name package) |
| | 313 | (symbol-name setf-symbol) (symbol-package-name setf-symbol) |
| | 314 | (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) |
| | 315 | (when (symbol-package setf-symbol) |
| | 316 | (unintern setf-symbol (symbol-package setf-symbol))) |
| | 317 | (setf (fdefinition new-setf-symbol) setf-function) |
| | 318 | (set-setf-function-symbol new-setf-symbol symbol kind)))) |
| | 319 | #+(or clisp clozure) |
| | 320 | (multiple-value-bind (overwritten-setf foundp) |
| | 321 | (get-setf-function-symbol overwritten-symbol) |
| | 322 | (when foundp |
| | 323 | (unintern overwritten-setf))) |
| | 324 | (when (eq old-status :external) |
| | 325 | (export* symbol old-package)) |
| | 326 | (when (eq overwritten-symbol-status :external) |
| | 327 | (export* symbol package)))) |
| | 328 | (values overwritten-symbol overwritten-symbol-status)))) |
| | 329 | (defun ensure-package-unused (package) |
| | 330 | (loop :for p :in (package-used-by-list package) :do |
| | 331 | (unuse-package package p))) |
| | 332 | (defun delete-package* (package &key nuke) |
| | 333 | (let ((p (find-package package))) |
| | 334 | (when p |
| | 335 | (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) |
| | 336 | (ensure-package-unused p) |
| | 337 | (delete-package package)))) |
| | 338 | (defun package-names (package) |
| | 339 | (cons (package-name package) (package-nicknames package))) |
| | 340 | (defun packages-from-names (names) |
| | 341 | (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) |
| | 342 | (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) |
| | 343 | separator |
| | 344 | (index (random most-positive-fixnum))) |
| | 345 | (loop :for i :from index |
| | 346 | :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) |
| | 347 | :thereis (and (not (find-package n)) n))) |
| | 348 | (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) |
| | 349 | (let ((new-name |
| | 350 | (apply 'fresh-package-name |
| | 351 | :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) |
| | 352 | (record-fishy (list :rename-away (package-names p) new-name)) |
| | 353 | (rename-package p new-name)))) |
| | 354 | |
| | 355 | |
| | 356 | ;;; Communicable representation of symbol and package information |
| | 357 | |
| | 358 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 359 | (defun package-definition-form (package-designator |
| | 360 | &key (nicknamesp t) (usep t) |
| | 361 | (shadowp t) (shadowing-import-p t) |
| | 362 | (exportp t) (importp t) internp (error t)) |
| | 363 | (let* ((package (or (find-package* package-designator error) |
| | 364 | (return-from package-definition-form nil))) |
| | 365 | (name (package-name package)) |
| | 366 | (nicknames (package-nicknames package)) |
| | 367 | (use (mapcar #'package-name (package-use-list package))) |
| | 368 | (shadow ()) |
| | 369 | (shadowing-import (make-hash-table :test 'equal)) |
| | 370 | (import (make-hash-table :test 'equal)) |
| | 371 | (export ()) |
| | 372 | (intern ())) |
| | 373 | (when package |
| | 374 | (loop :for sym :being :the :symbols :in package |
| | 375 | :for status = (nth-value 1 (find-symbol* sym package)) :do |
| | 376 | (ecase status |
| | 377 | ((nil :inherited)) |
| | 378 | ((:internal :external) |
| | 379 | (let* ((name (symbol-name sym)) |
| | 380 | (external (eq status :external)) |
| | 381 | (home (symbol-package sym)) |
| | 382 | (home-name (package-name home)) |
| | 383 | (imported (not (eq home package))) |
| | 384 | (shadowing (symbol-shadowing-p sym package))) |
| | 385 | (cond |
| | 386 | ((and shadowing imported) |
| | 387 | (push name (gethash home-name shadowing-import))) |
| | 388 | (shadowing |
| | 389 | (push name shadow)) |
| | 390 | (imported |
| | 391 | (push name (gethash home-name import)))) |
| | 392 | (cond |
| | 393 | (external |
| | 394 | (push name export)) |
| | 395 | (imported) |
| | 396 | (t (push name intern))))))) |
| | 397 | (labels ((sort-names (names) |
| | 398 | (sort names #'string<)) |
| | 399 | (table-keys (table) |
| | 400 | (loop :for k :being :the :hash-keys :of table :collect k)) |
| | 401 | (when-relevant (key value) |
| | 402 | (when value (list (cons key value)))) |
| | 403 | (import-options (key table) |
| | 404 | (loop :for i :in (sort-names (table-keys table)) |
| | 405 | :collect `(,key ,i ,@(sort-names (gethash i table)))))) |
| | 406 | `(defpackage ,name |
| | 407 | ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) |
| | 408 | (:use ,@(and usep (sort-names use))) |
| | 409 | ,@(when-relevant :shadow (and shadowp (sort-names shadow))) |
| | 410 | ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) |
| | 411 | ,@(import-options :import-from (and importp import)) |
| | 412 | ,@(when-relevant :export (and exportp (sort-names export))) |
| | 413 | ,@(when-relevant :intern (and internp (sort-names intern))))))))) |
| | 414 | |
| | 415 | |
| | 416 | ;;; ensure-package, define-package |
| | 417 | |
| | 418 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 419 | (defun ensure-package (name &key |
| | 420 | nicknames documentation use |
| | 421 | shadow shadowing-import-from |
| | 422 | import-from export intern |
| | 423 | recycle mix reexport |
| | 424 | unintern) |
| | 425 | (declare (ignorable documentation)) |
| | 426 | (macrolet ((when-fishy (&body body) `(when-package-fishiness ,@body)) |
| | 427 | (fishy (&rest info) `(note-package-fishiness ,@info))) |
| | 428 | (let* ((package-name (string name)) |
| | 429 | (nicknames (mapcar #'string nicknames)) |
| | 430 | (names (cons package-name nicknames)) |
| | 431 | (previous (packages-from-names names)) |
| | 432 | (discarded (cdr previous)) |
| | 433 | (to-delete ()) |
| | 434 | (package (or (first previous) (make-package package-name :nicknames nicknames))) |
| | 435 | (recycle (packages-from-names recycle)) |
| | 436 | (use (mapcar 'find-package* use)) |
| | 437 | (mix (mapcar 'find-package* mix)) |
| | 438 | (reexport (mapcar 'find-package* reexport)) |
| | 439 | (shadow (mapcar 'string shadow)) |
| | 440 | (export (mapcar 'string export)) |
| | 441 | (intern (mapcar 'string intern)) |
| | 442 | (unintern (mapcar 'string unintern)) |
| | 443 | (shadowed (make-hash-table :test 'equal)) ; string to bool |
| | 444 | (imported (make-hash-table :test 'equal)) ; string to bool |
| | 445 | (exported (make-hash-table :test 'equal)) ; string to bool |
| | 446 | ;; string to list home package and use package: |
| | 447 | (inherited (make-hash-table :test 'equal))) |
| | 448 | (when-fishy (record-fishy package-name)) |
| | 449 | (labels |
| | 450 | ((ensure-shadowing-import (name p) |
| | 451 | (let ((import-me (find-symbol* name p))) |
| | 452 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 453 | (cond |
| | 454 | ((gethash name shadowed) |
| | 455 | (unless (eq import-me existing) |
| | 456 | (error "Conflicting shadowings for ~A" name))) |
| | 457 | (t |
| | 458 | (setf (gethash name shadowed) t) |
| | 459 | (setf (gethash name imported) t) |
| | 460 | (unless (or (null status) |
| | 461 | (and (member status '(:internal :external)) |
| | 462 | (eq existing import-me) |
| | 463 | (symbol-shadowing-p existing package))) |
| | 464 | (fishy :shadowing-import |
| | 465 | name (package-name p) (symbol-package-name import-me) |
| | 466 | (and status (symbol-package-name existing)) status)) |
| | 467 | (shadowing-import import-me package)))))) |
| | 468 | (ensure-import (sym p) |
| | 469 | (let* ((name (string sym)) |
| | 470 | (import-me (find-symbol* name p))) |
| | 471 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 472 | (cond |
| | 473 | ((gethash name imported) |
| | 474 | (unless (eq import-me existing) |
| | 475 | (error "Can't import ~S from both ~S and ~S" |
| | 476 | name (package-name (symbol-package existing)) (package-name p)))) |
| | 477 | ((gethash name shadowed) |
| | 478 | (error "Can't both shadow ~S and import it from ~S" name (package-name p))) |
| | 479 | (t |
| | 480 | (setf (gethash name imported) t) |
| | 481 | (unless (and status (eq import-me existing)) |
| | 482 | (when status |
| | 483 | (fishy :import name (package-name p) (symbol-package-name import-me) |
| | 484 | (and status (symbol-package-name existing)) status) |
| | 485 | (unintern* existing package)) |
| | 486 | (import import-me package))))))) |
| | 487 | (ensure-mix (name symbol p) |
| | 488 | (unless (gethash name shadowed) |
| | 489 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 490 | (let* ((sp (symbol-package symbol)) |
| | 491 | (im (gethash name imported)) |
| | 492 | (in (gethash name inherited))) |
| | 493 | (cond |
| | 494 | ((or (null status) |
| | 495 | (and status (eq symbol existing)) |
| | 496 | (and in (eq sp (first in)))) |
| | 497 | (ensure-inherited name symbol p t)) |
| | 498 | (in |
| | 499 | (remhash name inherited) |
| | 500 | (ensure-shadowing-import name (second in))) |
| | 501 | (im |
| | 502 | (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S" |
| | 503 | existing symbol (package-name package))) |
| | 504 | (t |
| | 505 | (ensure-inherited name symbol p t))))))) |
| | 506 | (ensure-inherited (name symbol p mix) |
| | 507 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 508 | (let* ((sp (symbol-package symbol)) |
| | 509 | (in (gethash name inherited)) |
| | 510 | (xp (and status (symbol-package existing)))) |
| | 511 | (when (null sp) |
| | 512 | (fishy :import-uninterned name (package-name p) mix) |
| | 513 | (import symbol p) |
| | 514 | (setf sp (package-name p))) |
| | 515 | (cond |
| | 516 | ((gethash name shadowed)) |
| | 517 | (in |
| | 518 | (unless (equal sp (first in)) |
| | 519 | (if mix |
| | 520 | (ensure-shadowing-import name (second in)) |
| | 521 | (error "Can't inherit ~S from ~S, it is inherited from ~S" |
| | 522 | name (package-name sp) (package-name (first in)))))) |
| | 523 | ((gethash name imported) |
| | 524 | (unless (eq symbol existing) |
| | 525 | (error "Can't inherit ~S from ~S, it is imported from ~S" |
| | 526 | name (package-name sp) (package-name xp)))) |
| | 527 | (t |
| | 528 | (setf (gethash name inherited) (list sp p)) |
| | 529 | (when (and status (not (eq sp xp))) |
| | 530 | (let ((shadowing (symbol-shadowing-p existing package))) |
| | 531 | (fishy :inherited name (package-name p) (package-name sp) |
| | 532 | (package-name xp)) |
| | 533 | (if shadowing (ensure-shadowing-import name p) |
| | 534 | (unintern* existing package))))))))) |
| | 535 | (recycle-symbol (name) |
| | 536 | (when (gethash name exported) ;; don't bother recycling private symbols |
| | 537 | (let (recycled foundp) |
| | 538 | (dolist (r recycle (values recycled foundp)) |
| | 539 | (multiple-value-bind (symbol status) (find-symbol name r) |
| | 540 | (when (and status (home-package-p symbol r)) |
| | 541 | (cond |
| | 542 | (foundp |
| | 543 | ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. |
| | 544 | (fishy :recycled-duplicate name (package-name foundp) (package-name r))) |
| | 545 | (t |
| | 546 | (setf recycled symbol foundp r))))))))) |
| | 547 | (symbol-recycled-p (sym) |
| | 548 | (member (symbol-package sym) recycle)) |
| | 549 | (ensure-symbol (name &optional intern) |
| | 550 | (unless (or (gethash name shadowed) |
| | 551 | (gethash name imported) |
| | 552 | (gethash name inherited)) |
| | 553 | (multiple-value-bind (existing status) |
| | 554 | (find-symbol name package) |
| | 555 | (multiple-value-bind (recycled previous) (recycle-symbol name) |
| | 556 | (cond |
| | 557 | ((and status (eq existing recycled) (eq previous package))) |
| | 558 | (previous |
| | 559 | (rehome-symbol recycled package)) |
| | 560 | ((and status (eq package (symbol-package existing)))) |
| | 561 | (t |
| | 562 | (when status |
| | 563 | (fishy :ensure-symbol name |
| | 564 | (reify-package (symbol-package existing) package) |
| | 565 | status intern) |
| | 566 | (unintern existing)) |
| | 567 | (when intern |
| | 568 | (intern* name package)))))))) |
| | 569 | (ensure-export (name p) |
| | 570 | (multiple-value-bind (symbol status) (find-symbol* name p) |
| | 571 | (unless (eq status :external) |
| | 572 | (ensure-exported name symbol p)))) |
| | 573 | (ensure-exported (name sym p) |
| | 574 | (dolist (u (package-used-by-list p)) |
| | 575 | (ensure-exported-to-user name sym u)) |
| | 576 | (export* sym p)) |
| | 577 | (ensure-exported-to-user (name sym u) |
| | 578 | (multiple-value-bind (usym ustat) (find-symbol name u) |
| | 579 | (unless (and ustat (eq sym usym)) |
| | 580 | (let ((accessible |
| | 581 | (or (null ustat) |
| | 582 | (let ((shadowing (symbol-shadowing-p usym u)) |
| | 583 | (recycled (symbol-recycled-p usym))) |
| | 584 | (unless (and shadowing (not recycled)) |
| | 585 | (fishy :ensure-export name (symbol-package-name sym) |
| | 586 | (package-name u) |
| | 587 | (and ustat (symbol-package-name usym)) ustat shadowing) |
| | 588 | (if (or (eq ustat :inherited) shadowing) |
| | 589 | (shadowing-import sym u) |
| | 590 | (unintern usym u)) |
| | 591 | t))))) |
| | 592 | (when (and accessible (eq ustat :external)) |
| | 593 | (ensure-exported name sym u))))))) |
| | 594 | #-(or gcl genera) (setf (documentation package t) documentation) #+gcl documentation |
| | 595 | (loop :for p :in (set-difference (package-use-list package) (append mix use)) |
| | 596 | :do (fishy :use (package-names p)) (unuse-package p package)) |
| | 597 | (loop :for p :in discarded |
| | 598 | :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) |
| | 599 | (package-names p)) |
| | 600 | :do (fishy :nickname (package-names p)) |
| | 601 | (cond (n (rename-package p (first n) (rest n))) |
| | 602 | (t (rename-package-away p) |
| | 603 | (push p to-delete)))) |
| | 604 | (rename-package package package-name nicknames) |
| | 605 | (dolist (name unintern) |
| | 606 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 607 | (when status |
| | 608 | (unless (eq status :inherited) |
| | 609 | (fishy :unintern name (symbol-package-name existing) status) |
| | 610 | (unintern* name package nil))))) |
| | 611 | (dolist (name export) |
| | 612 | (setf (gethash name exported) t)) |
| | 613 | (dolist (p reexport) |
| | 614 | (do-external-symbols (sym p) |
| | 615 | (setf (gethash (string sym) exported) t))) |
| | 616 | (do-external-symbols (sym package) |
| | 617 | (let ((name (symbol-name sym))) |
| | 618 | (unless (gethash name exported) |
| | 619 | (fishy :over-exported name (symbol-package-name sym)) |
| | 620 | (unexport sym package)))) |
| | 621 | (dolist (name shadow) |
| | 622 | (setf (gethash name shadowed) t) |
| | 623 | (multiple-value-bind (existing status) (find-symbol name package) |
| | 624 | (multiple-value-bind (recycled previous) (recycle-symbol name) |
| | 625 | (let ((shadowing (and status (symbol-shadowing-p existing package)))) |
| | 626 | (cond |
| | 627 | ((eq previous package)) |
| | 628 | (previous |
| | 629 | (rehome-symbol recycled package)) |
| | 630 | ((or (member status '(nil :inherited)) |
| | 631 | (home-package-p existing package))) |
| | 632 | (t |
| | 633 | (let ((dummy (make-symbol name))) |
| | 634 | (fishy :shadow-imported name (symbol-package-name existing) status shadowing) |
| | 635 | (shadowing-import dummy package) |
| | 636 | (import dummy package))))))) |
| | 637 | (shadow name package)) |
| | 638 | (loop :for (p . syms) :in shadowing-import-from |
| | 639 | :for pp = (find-package* p) :do |
| | 640 | (dolist (sym syms) (ensure-shadowing-import (string sym) pp))) |
| | 641 | (dolist (p mix) |
| | 642 | (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p))) |
| | 643 | (loop :for (p . syms) :in import-from :do |
| | 644 | (dolist (sym syms) (ensure-import sym p))) |
| | 645 | (dolist (p (append use mix)) |
| | 646 | (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil)) |
| | 647 | (use-package p package)) |
| | 648 | (loop :for name :being :the :hash-keys :of exported :do |
| | 649 | (ensure-symbol name t) |
| | 650 | (ensure-export name package)) |
| | 651 | (dolist (name intern) |
| | 652 | (ensure-symbol name t)) |
| | 653 | (do-symbols (sym package) |
| | 654 | (ensure-symbol (symbol-name sym))) |
| | 655 | (map () 'delete-package* to-delete) |
| | 656 | (flush-fishy) |
| | 657 | package))))) |
| | 658 | |
| | 659 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 660 | (defun parse-define-package-form (package clauses) |
| | 661 | (loop |
| | 662 | :with use-p = nil :with recycle-p = nil |
| | 663 | :with documentation = nil |
| | 664 | :for (kw . args) :in clauses |
| | 665 | :when (eq kw :nicknames) :append args :into nicknames :else |
| | 666 | :when (eq kw :documentation) |
| | 667 | :do (cond |
| | 668 | (documentation (error "define-package: can't define documentation twice")) |
| | 669 | ((or (atom args) (cdr args)) (error "define-package: bad documentation")) |
| | 670 | (t (setf documentation (car args)))) :else |
| | 671 | :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else |
| | 672 | :when (eq kw :shadow) :append args :into shadow :else |
| | 673 | :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else |
| | 674 | :when (eq kw :import-from) :collect args :into import-from :else |
| | 675 | :when (eq kw :export) :append args :into export :else |
| | 676 | :when (eq kw :intern) :append args :into intern :else |
| | 677 | :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else |
| | 678 | :when (eq kw :mix) :append args :into mix :else |
| | 679 | :when (eq kw :reexport) :append args :into reexport :else |
| | 680 | :when (eq kw :unintern) :append args :into unintern :else |
| | 681 | :do (error "unrecognized define-package keyword ~S" kw) |
| | 682 | :finally (return `(,package |
| | 683 | :nicknames ,nicknames :documentation ,documentation |
| | 684 | :use ,(if use-p use '(:common-lisp)) |
| | 685 | :shadow ,shadow :shadowing-import-from ,shadowing-import-from |
| | 686 | :import-from ,import-from :export ,export :intern ,intern |
| | 687 | :recycle ,(if recycle-p recycle (cons package nicknames)) |
| | 688 | :mix ,mix :reexport ,reexport :unintern ,unintern))))) |
| | 689 | |
| | 690 | (defmacro define-package (package &rest clauses) |
| | 691 | (let ((ensure-form |
| | 692 | `(apply 'ensure-package ',(parse-define-package-form package clauses)))) |
| | 693 | `(progn |
| | 694 | #+clisp |
| | 695 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| | 696 | ,ensure-form) |
| | 697 | #+(or clisp ecl gcl) (defpackage ,package (:use)) |
| | 698 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| | 699 | ,ensure-form)))) |
| | 700 | |
| | 701 | ;;;; Final tricks to keep various implementations happy. |
| | 702 | ;; We want most such tricks in common-lisp.lisp, |
| | 703 | ;; but these need to be done before the define-package form there, |
| | 704 | ;; that we nevertheless want to be the very first form. |
| | 705 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| | 706 | #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. |
| | 707 | (setf excl::*autoload-package-name-alist* |
| | 708 | (remove "asdf" excl::*autoload-package-name-alist* |
| | 709 | :test 'equalp :key 'car)) |
| | 710 | |
| | 711 | #+gcl |
| | 712 | ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, |
| | 713 | ;; but can run ASDF 2.011. GCL 2.6 has even more issues. |
| | 714 | (cond |
| | 715 | ((or (< system::*gcl-major-version* 2) |
| | 716 | (and (= system::*gcl-major-version* 2) |
| | 717 | (< system::*gcl-minor-version* 6))) |
| | 718 | (error "GCL 2.6 or later required to use ASDF")) |
| | 719 | ((and (= system::*gcl-major-version* 2) |
| | 720 | (= system::*gcl-minor-version* 6)) |
| | 721 | (pushnew 'ignorable pcl::*variable-declarations-without-argument*) |
| | 722 | (pushnew :gcl2.6 *features*)) |
| | 723 | (t |
| | 724 | (pushnew :gcl2.7 *features*)))) |
| | 725 | ;;;; ------------------------------------------------------------------------- |
| | 726 | ;;;; Handle compatibility with multiple implementations. |
| | 727 | ;;; This file is for papering over the deficiencies and peculiarities |
| | 728 | ;;; of various Common Lisp implementations. |
| | 729 | ;;; For implementation-specific access to the system, see os.lisp instead. |
| | 730 | ;;; A few functions are defined here, but actually exported from utility; |
| | 731 | ;;; from this package only common-lisp symbols are exported. |
| | 732 | |
| | 733 | (asdf/package:define-package :asdf/common-lisp |
| | 734 | (:nicknames :asdf/cl) |
| | 735 | (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package) |
| | 736 | (:reexport :common-lisp) |
| | 737 | (:recycle :asdf/common-lisp :asdf) |
| | 738 | #+allegro (:intern #:*acl-warn-save*) |
| | 739 | #+cormanlisp |
| | 740 | (:export |
| | 741 | #:logical-pathname #:translate-logical-pathname |
| | 742 | #:make-broadcast-stream #:file-namestring) |
| | 743 | #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!) |
| | 744 | #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*) |
| | 745 | #+genera (:shadowing-import-from :scl #:boolean) |
| | 746 | #+genera (:export #:boolean #:ensure-directories-exist) |
| | 747 | #+mcl (:shadow #:user-homedir-pathname)) |
| | 748 | (in-package :asdf/common-lisp) |
| 85 | | ;;; This would belong amongst implementation-dependent tweaks above, |
| 86 | | ;;; except that the defun has to be in package asdf. |
| 87 | | #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) |
| 88 | | #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) |
| 89 | | #+mkcl (require :cmp) |
| 90 | | #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics |
| 91 | | |
| 92 | | ;;; Package setup, step 2. |
| 93 | | (defvar *asdf-version* nil) |
| 94 | | (defvar *upgraded-p* nil) |
| 95 | | (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. |
| 96 | | (defun find-symbol* (s p) |
| 97 | | (find-symbol (string s) p)) |
| 98 | | ;; Strip out formatting that is not supported on Genera. |
| 99 | | ;; Has to be inside the eval-when to make Lispworks happy (!) |
| 100 | | (defun strcat (&rest strings) |
| 101 | | (apply 'concatenate 'string strings)) |
| 102 | | (defmacro compatfmt (format) |
| 103 | | #-(or gcl genera) format |
| 104 | | #+(or gcl genera) |
| 105 | | (loop :for (unsupported . replacement) :in |
| 106 | | (append |
| 107 | | '(("~3i~_" . "")) |
| 108 | | #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do |
| 109 | | (loop :for found = (search unsupported format) :while found :do |
| 110 | | (setf format (strcat (subseq format 0 found) replacement |
| 111 | | (subseq format (+ found (length unsupported))))))) |
| 112 | | format) |
| 113 | | (let* (;; For bug reporting sanity, please always bump this version when you modify this file. |
| 114 | | ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version |
| 115 | | ;; can help you do these changes in synch (look at the source for documentation). |
| 116 | | ;; Relying on its automation, the version is now redundantly present on top of this file. |
| 117 | | ;; "2.345" would be an official release |
| 118 | | ;; "2.345.6" would be a development version in the official upstream |
| 119 | | ;; "2.345.0.7" would be your seventh local modification of official release 2.345 |
| 120 | | ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 |
| 121 | | (asdf-version "2.26.6") |
| 122 | | (existing-asdf (find-class 'component nil)) |
| 123 | | (existing-version *asdf-version*) |
| 124 | | (already-there (equal asdf-version existing-version))) |
| 125 | | (unless (and existing-asdf already-there) |
| 126 | | (when (and existing-asdf *asdf-verbose*) |
| 127 | | (format *trace-output* |
| 128 | | (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") |
| 129 | | existing-version asdf-version)) |
| 130 | | (labels |
| 131 | | ((present-symbol-p (symbol package) |
| 132 | | (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) |
| 133 | | (present-symbols (package) |
| 134 | | ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera |
| 135 | | (let (l) |
| 136 | | (do-symbols (s package) |
| 137 | | (when (present-symbol-p s package) (push s l))) |
| 138 | | (reverse l))) |
| 139 | | (unlink-package (package) |
| 140 | | (let ((u (find-package package))) |
| 141 | | (when u |
| 142 | | (ensure-unintern u (present-symbols u)) |
| 143 | | (loop :for p :in (package-used-by-list u) :do |
| 144 | | (unuse-package u p)) |
| 145 | | (delete-package u)))) |
| 146 | | (ensure-exists (name nicknames use) |
| 147 | | (let ((previous |
| 148 | | (remove-duplicates |
| 149 | | (mapcar #'find-package (cons name nicknames)) |
| 150 | | :from-end t))) |
| 151 | | ;; do away with packages with conflicting (nick)names |
| 152 | | (map () #'unlink-package (cdr previous)) |
| 153 | | ;; reuse previous package with same name |
| 154 | | (let ((p (car previous))) |
| 155 | | (cond |
| 156 | | (p |
| 157 | | (rename-package p name nicknames) |
| 158 | | (ensure-use p use) |
| 159 | | p) |
| 160 | | (t |
| 161 | | (make-package name :nicknames nicknames :use use)))))) |
| 162 | | (intern* (symbol package) |
| 163 | | (intern (string symbol) package)) |
| 164 | | (remove-symbol (symbol package) |
| 165 | | (let ((sym (find-symbol* symbol package))) |
| 166 | | (when sym |
| 167 | | #-cormanlisp (unexport sym package) |
| 168 | | (unintern sym package) |
| 169 | | sym))) |
| 170 | | (ensure-unintern (package symbols) |
| 171 | | (loop :with packages = (list-all-packages) |
| 172 | | :for sym :in symbols |
| 173 | | :for removed = (remove-symbol sym package) |
| 174 | | :when removed :do |
| 175 | | (loop :for p :in packages :do |
| 176 | | (when (eq removed (find-symbol* sym p)) |
| 177 | | (unintern removed p))))) |
| 178 | | (ensure-shadow (package symbols) |
| 179 | | (shadow symbols package)) |
| 180 | | (ensure-use (package use) |
| 181 | | (dolist (used (package-use-list package)) |
| 182 | | (unless (member (package-name used) use :test 'string=) |
| 183 | | (unuse-package used) |
| 184 | | (do-external-symbols (sym used) |
| 185 | | (when (eq sym (find-symbol* sym package)) |
| 186 | | (remove-symbol sym package))))) |
| 187 | | (dolist (used (reverse use)) |
| 188 | | (do-external-symbols (sym used) |
| 189 | | (unless (eq sym (find-symbol* sym package)) |
| 190 | | (remove-symbol sym package))) |
| 191 | | (use-package used package))) |
| 192 | | (ensure-fmakunbound (package symbols) |
| 193 | | (loop :for name :in symbols |
| 194 | | :for sym = (find-symbol* name package) |
| 195 | | :when sym :do (fmakunbound sym))) |
| 196 | | (ensure-export (package export) |
| 197 | | (let ((formerly-exported-symbols nil) |
| 198 | | (bothly-exported-symbols nil) |
| 199 | | (newly-exported-symbols nil)) |
| 200 | | (do-external-symbols (sym package) |
| 201 | | (if (member sym export :test 'string-equal) |
| 202 | | (push sym bothly-exported-symbols) |
| 203 | | (push sym formerly-exported-symbols))) |
| 204 | | (loop :for sym :in export :do |
| 205 | | (unless (member sym bothly-exported-symbols :test 'equal) |
| 206 | | (push sym newly-exported-symbols))) |
| 207 | | (loop :for user :in (package-used-by-list package) |
| 208 | | :for shadowing = (package-shadowing-symbols user) :do |
| 209 | | (loop :for new :in newly-exported-symbols |
| 210 | | :for old = (find-symbol* new user) |
| 211 | | :when (and old (not (member old shadowing))) |
| 212 | | :do (unintern old user))) |
| 213 | | (loop :for x :in newly-exported-symbols :do |
| 214 | | (export (intern* x package))))) |
| 215 | | (ensure-package (name &key nicknames use unintern |
| 216 | | shadow export redefined-functions) |
| 217 | | (let* ((p (ensure-exists name nicknames use))) |
| 218 | | (ensure-unintern p unintern) |
| 219 | | (ensure-shadow p shadow) |
| 220 | | (ensure-export p export) |
| 221 | | (ensure-fmakunbound p redefined-functions) |
| 222 | | p))) |
| 223 | | (macrolet |
| 224 | | ((pkgdcl (name &key nicknames use export |
| 225 | | redefined-functions unintern shadow) |
| 226 | | `(ensure-package |
| 227 | | ',name :nicknames ',nicknames :use ',use :export ',export |
| 228 | | :shadow ',shadow |
| 229 | | :unintern ',unintern |
| 230 | | :redefined-functions ',redefined-functions))) |
| 231 | | (pkgdcl |
| 232 | | :asdf |
| 233 | | :use (:common-lisp) |
| 234 | | :redefined-functions |
| 235 | | (#:perform #:explain #:output-files #:operation-done-p |
| 236 | | #:perform-with-restarts #:component-relative-pathname |
| 237 | | #:system-source-file #:operate #:find-component #:find-system |
| 238 | | #:apply-output-translations #:translate-pathname* #:resolve-location |
| 239 | | #:system-relative-pathname |
| 240 | | #:inherit-source-registry #:process-source-registry |
| 241 | | #:process-source-registry-directive |
| 242 | | #:compile-file* #:source-file-type) |
| 243 | | :unintern |
| 244 | | (#:*asdf-revision* #:around #:asdf-method-combination |
| 245 | | #:split #:make-collector #:do-dep #:do-one-dep |
| 246 | | #:resolve-relative-location-component #:resolve-absolute-location-component |
| 247 | | #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function |
| 248 | | :export |
| 249 | | (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command |
| 250 | | #:system-definition-pathname #:with-system-definitions |
| 251 | | #:search-for-system-definition #:find-component #:component-find-path |
| 252 | | #:compile-system #:load-system #:load-systems |
| 253 | | #:require-system #:test-system #:clear-system |
| 254 | | #:operation #:compile-op #:load-op #:load-source-op #:test-op |
| 255 | | #:feature #:version #:version-satisfies |
| 256 | | #:upgrade-asdf |
| 257 | | #:implementation-identifier #:implementation-type #:hostname |
| 258 | | #:input-files #:output-files #:output-file #:perform |
| 259 | | #:operation-done-p #:explain |
| 260 | | |
| 261 | | #:component #:source-file |
| 262 | | #:c-source-file #:cl-source-file #:java-source-file |
| 263 | | #:cl-source-file.cl #:cl-source-file.lsp |
| 264 | | #:static-file |
| 265 | | #:doc-file |
| 266 | | #:html-file |
| 267 | | #:text-file |
| 268 | | #:source-file-type |
| 269 | | #:module ; components |
| 270 | | #:system |
| 271 | | #:unix-dso |
| 272 | | |
| 273 | | #:module-components ; component accessors |
| 274 | | #:module-components-by-name |
| 275 | | #:component-pathname |
| 276 | | #:component-relative-pathname |
| 277 | | #:component-name |
| 278 | | #:component-version |
| 279 | | #:component-parent |
| 280 | | #:component-property |
| 281 | | #:component-system |
| 282 | | #:component-depends-on |
| 283 | | #:component-encoding |
| 284 | | #:component-external-format |
| 285 | | |
| 286 | | #:system-description |
| 287 | | #:system-long-description |
| 288 | | #:system-author |
| 289 | | #:system-maintainer |
| 290 | | #:system-license |
| 291 | | #:system-licence |
| 292 | | #:system-source-file |
| 293 | | #:system-source-directory |
| 294 | | #:system-relative-pathname |
| 295 | | #:map-systems |
| 296 | | |
| 297 | | #:operation-description |
| 298 | | #:operation-on-warnings |
| 299 | | #:operation-on-failure |
| 300 | | #:component-visited-p |
| 301 | | |
| 302 | | #:*system-definition-search-functions* ; variables |
| 303 | | #:*central-registry* |
| 304 | | #:*compile-file-warnings-behaviour* |
| 305 | | #:*compile-file-failure-behaviour* |
| 306 | | #:*resolve-symlinks* |
| 307 | | #:*load-system-operation* |
| 308 | | #:*asdf-verbose* |
| 309 | | #:*verbose-out* |
| 310 | | |
| 311 | | #:asdf-version |
| 312 | | |
| 313 | | #:operation-error #:compile-failed #:compile-warned #:compile-error |
| 314 | | #:error-name |
| 315 | | #:error-pathname |
| 316 | | #:load-system-definition-error |
| 317 | | #:error-component #:error-operation |
| 318 | | #:system-definition-error |
| 319 | | #:missing-component |
| 320 | | #:missing-component-of-version |
| 321 | | #:missing-dependency |
| 322 | | #:missing-dependency-of-version |
| 323 | | #:circular-dependency ; errors |
| 324 | | #:duplicate-names |
| 325 | | |
| 326 | | #:try-recompiling |
| 327 | | #:retry |
| 328 | | #:accept ; restarts |
| 329 | | #:coerce-entry-to-directory |
| 330 | | #:remove-entry-from-registry |
| 331 | | |
| 332 | | #:*encoding-detection-hook* |
| 333 | | #:*encoding-external-format-hook* |
| 334 | | #:*default-encoding* |
| 335 | | #:*utf-8-external-format* |
| 336 | | |
| 337 | | #:clear-configuration |
| 338 | | #:*output-translations-parameter* |
| 339 | | #:initialize-output-translations |
| 340 | | #:disable-output-translations |
| 341 | | #:clear-output-translations |
| 342 | | #:ensure-output-translations |
| 343 | | #:apply-output-translations |
| 344 | | #:compile-file* |
| 345 | | #:compile-file-pathname* |
| 346 | | #:enable-asdf-binary-locations-compatibility |
| 347 | | #:*default-source-registries* |
| 348 | | #:*source-registry-parameter* |
| 349 | | #:initialize-source-registry |
| 350 | | #:compute-source-registry |
| 351 | | #:clear-source-registry |
| 352 | | #:ensure-source-registry |
| 353 | | #:process-source-registry |
| 354 | | #:system-registered-p #:registered-systems #:loaded-systems |
| 355 | | #:resolve-location |
| 356 | | #:asdf-message |
| 357 | | #:user-output-translations-pathname |
| 358 | | #:system-output-translations-pathname |
| 359 | | #:user-output-translations-directory-pathname |
| 360 | | #:system-output-translations-directory-pathname |
| 361 | | #:user-source-registry |
| 362 | | #:system-source-registry |
| 363 | | #:user-source-registry-directory |
| 364 | | #:system-source-registry-directory |
| 365 | | |
| 366 | | ;; Utilities: please use asdf-utils instead |
| 367 | | #| |
| 368 | | ;; #:aif #:it |
| 369 | | ;; #:appendf #:orf |
| 370 | | #:length=n-p |
| 371 | | #:remove-keys #:remove-keyword |
| 372 | | #:first-char #:last-char #:string-suffix-p |
| 373 | | #:coerce-name |
| 374 | | #:directory-pathname-p #:ensure-directory-pathname |
| 375 | | #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root |
| 376 | | #:getenv #:getenv-pathname #:getenv-pathnames |
| 377 | | #:getenv-absolute-directory #:getenv-absolute-directories |
| 378 | | #:probe-file* |
| 379 | | #:find-symbol* #:strcat |
| 380 | | #:make-pathname-component-logical #:make-pathname-logical |
| 381 | | #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname* |
| 382 | | #:pathname-directory-pathname #:pathname-parent-directory-pathname |
| 383 | | #:read-file-forms |
| 384 | | #:resolve-symlinks #:truenamize |
| 385 | | #:split-string |
| 386 | | #:component-name-to-pathname-components |
| 387 | | #:split-name-type |
| 388 | | #:subdirectories #:directory-files |
| 389 | | #:while-collecting |
| 390 | | #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* |
| 391 | | #:*wild-path* #:wilden |
| 392 | | #:directorize-pathname-host-device|# |
| 393 | | ))) |
| 394 | | #+genera (import 'scl:boolean :asdf) |
| 395 | | (setf *asdf-version* asdf-version |
| 396 | | *upgraded-p* (if existing-version |
| 397 | | (cons existing-version *upgraded-p*) |
| 398 | | *upgraded-p*)))))) |
| 399 | | |
| 400 | | ;;;; ------------------------------------------------------------------------- |
| 401 | | ;;;; User-visible parameters |
| 402 | | ;;;; |
| 403 | | (defvar *resolve-symlinks* t |
| 404 | | "Determine whether or not ASDF resolves symlinks when defining systems. |
| 405 | | |
| 406 | | Defaults to T.") |
| 407 | | |
| 408 | | (defvar *compile-file-warnings-behaviour* |
| 409 | | (or #+clisp :ignore :warn) |
| 410 | | "How should ASDF react if it encounters a warning when compiling a file? |
| 411 | | Valid values are :error, :warn, and :ignore.") |
| 412 | | |
| 413 | | (defvar *compile-file-failure-behaviour* |
| 414 | | (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) |
| 415 | | "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) |
| 416 | | when compiling a file? Valid values are :error, :warn, and :ignore. |
| 417 | | Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") |
| 418 | | |
| 419 | | (defvar *verbose-out* nil) |
| 420 | | |
| 421 | | (defparameter +asdf-methods+ |
| 422 | | '(perform-with-restarts perform explain output-files operation-done-p)) |
| 423 | | |
| 424 | | (defvar *load-system-operation* 'load-op |
| 425 | | "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. |
| 426 | | You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, |
| 427 | | or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") |
| 428 | | |
| 429 | | (defvar *compile-op-compile-file-function* 'compile-file* |
| 430 | | "Function used to compile lisp files.") |
| 431 | | |
| 432 | | |
| 433 | | |
| 434 | | #+allegro |
| 435 | | (eval-when (:compile-toplevel :execute) |
| 522 | | (defmacro aif (test then &optional else) |
| 523 | | "Anaphoric version of IF, On Lisp style" |
| 524 | | `(let ((it ,test)) (if it ,then ,else))) |
| 525 | | |
| 526 | | (defun* pathname-directory-pathname (pathname) |
| 527 | | "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, |
| 528 | | and NIL NAME, TYPE and VERSION components" |
| 529 | | (when pathname |
| 530 | | (make-pathname :name nil :type nil :version nil :defaults pathname))) |
| | 1010 | (define-modify-macro appendf (&rest args) |
| | 1011 | append "Append onto list") ;; only to be used on short lists. |
| | 1012 | |
| | 1013 | (defun* length=n-p (x n) ;is it that (= (length x) n) ? |
| | 1014 | (check-type n (integer 0 *)) |
| | 1015 | (loop |
| | 1016 | :for l = x :then (cdr l) |
| | 1017 | :for i :downfrom n :do |
| | 1018 | (cond |
| | 1019 | ((zerop i) (return (null l))) |
| | 1020 | ((not (consp l)) (return nil))))) |
| | 1021 | |
| | 1022 | ;;; remove a key from a plist, i.e. for keyword argument cleanup |
| | 1023 | (defun* remove-plist-key (key plist) |
| | 1024 | "Remove a single key from a plist" |
| | 1025 | (loop* :for (k v) :on plist :by #'cddr |
| | 1026 | :unless (eq k key) |
| | 1027 | :append (list k v))) |
| | 1028 | |
| | 1029 | (defun* remove-plist-keys (keys plist) |
| | 1030 | "Remove a list of keys from a plist" |
| | 1031 | (loop* :for (k v) :on plist :by #'cddr |
| | 1032 | :unless (member k keys) |
| | 1033 | :append (list k v))) |
| | 1034 | |
| | 1035 | |
| | 1036 | ;;; Sequences |
| | 1037 | (defun* emptyp (x) |
| | 1038 | "Predicate that is true for an empty sequence" |
| | 1039 | (or (null x) (and (vectorp x) (zerop (length x))))) |
| | 1040 | |
| | 1041 | |
| | 1042 | ;;; Strings |
| | 1043 | |
| | 1044 | (defun* first-char (s) |
| | 1045 | (and (stringp s) (plusp (length s)) (char s 0))) |
| | 1046 | |
| | 1047 | (defun* last-char (s) |
| | 1048 | (and (stringp s) (plusp (length s)) (char s (1- (length s))))) |
| | 1049 | |
| | 1050 | (defun* split-string (string &key max (separator '(#\Space #\Tab))) |
| | 1051 | "Split STRING into a list of components separated by |
| | 1052 | any of the characters in the sequence SEPARATOR. |
| | 1053 | If MAX is specified, then no more than max(1,MAX) components will be returned, |
| | 1054 | starting the separation from the end, e.g. when called with arguments |
| | 1055 | \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." |
| | 1056 | (block () |
| | 1057 | (let ((list nil) (words 0) (end (length string))) |
| | 1058 | (flet ((separatorp (char) (find char separator)) |
| | 1059 | (done () (return (cons (subseq string 0 end) list)))) |
| | 1060 | (loop |
| | 1061 | :for start = (if (and max (>= words (1- max))) |
| | 1062 | (done) |
| | 1063 | (position-if #'separatorp string :end end :from-end t)) :do |
| | 1064 | (when (null start) |
| | 1065 | (done)) |
| | 1066 | (push (subseq string (1+ start) end) list) |
| | 1067 | (incf words) |
| | 1068 | (setf end start)))))) |
| | 1069 | |
| | 1070 | (defun* string-prefix-p (prefix string) |
| | 1071 | "Does STRING begin with PREFIX?" |
| | 1072 | (let* ((x (string prefix)) |
| | 1073 | (y (string string)) |
| | 1074 | (lx (length x)) |
| | 1075 | (ly (length y))) |
| | 1076 | (and (<= lx ly) (string= x y :end2 lx)))) |
| | 1077 | |
| | 1078 | (defun* string-suffix-p (string suffix) |
| | 1079 | "Does STRING end with SUFFIX?" |
| | 1080 | (let* ((x (string string)) |
| | 1081 | (y (string suffix)) |
| | 1082 | (lx (length x)) |
| | 1083 | (ly (length y))) |
| | 1084 | (and (<= ly lx) (string= x y :start1 (- lx ly))))) |
| | 1085 | |
| | 1086 | (defun* string-enclosed-p (prefix string suffix) |
| | 1087 | "Does STRING begin with PREFIX and end with SUFFIX?" |
| | 1088 | (and (string-prefix-p prefix string) |
| | 1089 | (string-suffix-p string suffix))) |
| | 1090 | |
| | 1091 | |
| | 1092 | ;;; CLOS |
| | 1093 | (defun* find-class* (x &optional (errorp t) environment) |
| | 1094 | (etypecase x |
| | 1095 | ((or standard-class built-in-class) x) |
| | 1096 | #+gcl2.6 (keyword nil) |
| | 1097 | (symbol (find-class x errorp environment)))) |
| | 1098 | |
| | 1099 | |
| | 1100 | ;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity |
| | 1101 | (deftype stamp () '(or real boolean)) |
| | 1102 | (defun* stamp< (x y) |
| | 1103 | (etypecase x |
| | 1104 | (null (and y t)) |
| | 1105 | ((eql t) nil) |
| | 1106 | (real (etypecase y |
| | 1107 | (null nil) |
| | 1108 | ((eql t) t) |
| | 1109 | (real (< x y)))))) |
| | 1110 | (defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) |
| | 1111 | (defun* stamp*< (&rest list) (stamps< list)) |
| | 1112 | (defun* stamp<= (x y) (not (stamp< y x))) |
| | 1113 | (defun* earlier-stamp (x y) (if (stamp< x y) x y)) |
| | 1114 | (defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) |
| | 1115 | (defun* earliest-stamp (&rest list) (stamps-earliest list)) |
| | 1116 | (defun* later-stamp (x y) (if (stamp< x y) y x)) |
| | 1117 | (defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) |
| | 1118 | (defun* latest-stamp (&rest list) (stamps-latest list)) |
| | 1119 | (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp) |
| | 1120 | |
| | 1121 | |
| | 1122 | ;;; Hash-tables |
| | 1123 | (defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) |
| | 1124 | (dolist (x list h) (setf (gethash x h) t))) |
| | 1125 | |
| | 1126 | |
| | 1127 | ;;; Function designators |
| | 1128 | (defun* ensure-function (fun &key (package :cl)) |
| | 1129 | "Coerce the object FUN into a function. |
| | 1130 | |
| | 1131 | If FUN is a FUNCTION, return it. |
| | 1132 | If the FUN is a non-sequence literal constant, return constantly that, |
| | 1133 | i.e. for a boolean keyword character number or pathname. |
| | 1134 | Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. |
| | 1135 | If FUN is a CONS, return the function that applies its CAR |
| | 1136 | to the appended list of the rest of its CDR and the arguments. |
| | 1137 | If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) |
| | 1138 | and EVAL that in a (FUNCTION ...) context." |
| | 1139 | (etypecase fun |
| | 1140 | (function fun) |
| | 1141 | ((or boolean keyword character number pathname) (constantly fun)) |
| | 1142 | ((or function symbol) fun) |
| | 1143 | (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))) |
| | 1144 | (string (eval `(function ,(with-standard-io-syntax |
| | 1145 | (let ((*package* (find-package package))) |
| | 1146 | (read-from-string fun)))))))) |
| | 1147 | |
| | 1148 | (defun* access-at (object at) |
| | 1149 | "Given an OBJECT and an AT specifier, list of successive accessors, |
| | 1150 | call each accessor on the result of the previous calls. |
| | 1151 | An accessor may be an integer, meaning a call to ELT, |
| | 1152 | a keyword, meaning a call to GETF, |
| | 1153 | NIL, meaning identity, |
| | 1154 | a function or other symbol, meaning itself, |
| | 1155 | or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. |
| | 1156 | As a degenerate case, the AT specifier may be an atom of a single such accessor |
| | 1157 | instead of a list." |
| | 1158 | (flet ((access (object accessor) |
| | 1159 | (etypecase accessor |
| | 1160 | (function (funcall accessor object)) |
| | 1161 | (integer (elt object accessor)) |
| | 1162 | (keyword (getf object accessor)) |
| | 1163 | (null object) |
| | 1164 | (symbol (funcall accessor object)) |
| | 1165 | (cons (funcall (ensure-function accessor) object))))) |
| | 1166 | (if (listp at) |
| | 1167 | (dolist (accessor at object) |
| | 1168 | (setf object (access object accessor))) |
| | 1169 | (access object at)))) |
| | 1170 | |
| | 1171 | (defun* access-at-count (at) |
| | 1172 | "From an AT specification, extract a COUNT of maximum number |
| | 1173 | of sub-objects to read as per ACCESS-AT" |
| | 1174 | (cond |
| | 1175 | ((integerp at) |
| | 1176 | (1+ at)) |
| | 1177 | ((and (consp at) (integerp (first at))) |
| | 1178 | (1+ (first at))))) |
| | 1179 | |
| | 1180 | (defun* call-function (function-spec &rest arguments) |
| | 1181 | (apply (ensure-function function-spec) arguments)) |
| | 1182 | |
| | 1183 | (defun* call-functions (function-specs) |
| | 1184 | (map () 'call-function function-specs)) |
| | 1185 | |
| | 1186 | (defun* register-hook-function (variable hook &optional (call-now-p t)) |
| | 1187 | (pushnew hook (symbol-value variable)) |
| | 1188 | (when call-now-p (call-function hook))) |
| | 1189 | |
| | 1190 | |
| | 1191 | ;;; Version handling |
| | 1192 | (defun* unparse-version (version-list) |
| | 1193 | (format nil "~{~D~^.~}" version-list)) |
| | 1194 | |
| | 1195 | (defun* parse-version (version-string &optional on-error) |
| | 1196 | "Parse a VERSION-STRING as a series of natural integers separated by dots. |
| | 1197 | Return a (non-null) list of integers if the string is valid; |
| | 1198 | otherwise return NIL. |
| | 1199 | |
| | 1200 | When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, |
| | 1201 | with format arguments explaining why the version is invalid. |
| | 1202 | ON-ERROR is also called if the version is not canonical |
| | 1203 | in that it doesn't print back to itself, but the list is returned anyway." |
| | 1204 | (block nil |
| | 1205 | (unless (stringp version-string) |
| | 1206 | (call-function on-error "~S: ~S is not a string" 'parse-version version-string) |
| | 1207 | (return)) |
| | 1208 | (unless (loop :for prev = nil :then c :for c :across version-string |
| | 1209 | :always (or (digit-char-p c) |
| | 1210 | (and (eql c #\.) prev (not (eql prev #\.)))) |
| | 1211 | :finally (return (and c (digit-char-p c)))) |
| | 1212 | (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" |
| | 1213 | 'parse-version version-string) |
| | 1214 | (return)) |
| | 1215 | (let* ((version-list |
| | 1216 | (mapcar #'parse-integer (split-string version-string :separator "."))) |
| | 1217 | (normalized-version (unparse-version version-list))) |
| | 1218 | (unless (equal version-string normalized-version) |
| | 1219 | (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) |
| | 1220 | version-list))) |
| | 1221 | |
| | 1222 | |
| | 1223 | (defun* version-compatible-p (provided-version required-version) |
| | 1224 | "Is the provided version a compatible substitution for the required-version? |
| | 1225 | If major versions differ, it's not compatible. |
| | 1226 | If they are equal, then any later version is compatible, |
| | 1227 | with later being determined by a lexicographical comparison of minor numbers." |
| | 1228 | (let ((x (parse-version provided-version 'warn)) |
| | 1229 | (y (parse-version required-version 'warn))) |
| | 1230 | (labels ((bigger (x y) |
| | 1231 | (cond ((not y) t) |
| | 1232 | ((not x) nil) |
| | 1233 | ((> (car x) (car y)) t) |
| | 1234 | ((= (car x) (car y)) |
| | 1235 | (bigger (cdr x) (cdr y)))))) |
| | 1236 | (and x y (= (car x) (car y)) |
| | 1237 | (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) |
| | 1238 | |
| | 1239 | |
| | 1240 | ;;; Condition control |
| | 1241 | |
| | 1242 | (defvar *uninteresting-conditions* nil |
| | 1243 | "Uninteresting conditions, as per MATCH-CONDITION-P") |
| | 1244 | |
| | 1245 | (defparameter +simple-condition-format-control-slot+ |
| | 1246 | #+abcl 'system::format-control |
| | 1247 | #+allegro 'excl::format-control |
| | 1248 | #+clisp 'system::$format-control |
| | 1249 | #+clozure 'ccl::format-control |
| | 1250 | #+ecl 'si::format-control |
| | 1251 | #+(or cmu scl) 'conditions::format-control |
| | 1252 | #+(or gcl lispworks) 'conditions::format-string |
| | 1253 | #+sbcl 'sb-kernel:format-control |
| | 1254 | #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil |
| | 1255 | "Name of the slot for FORMAT-CONTROL in simple-condition") |
| | 1256 | |
| | 1257 | (defun* match-condition-p (x condition) |
| | 1258 | "Compare received CONDITION to some pattern X: |
| | 1259 | a symbol naming a condition class, |
| | 1260 | a simple vector of length 2, arguments to find-symbol* with result as above, |
| | 1261 | or a string describing the format-control of a simple-condition." |
| | 1262 | (etypecase x |
| | 1263 | (symbol (typep condition x)) |
| | 1264 | ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil))) |
| | 1265 | (function (funcall x condition)) |
| | 1266 | (string (and (typep condition 'simple-condition) |
| | 1267 | ;; On SBCL, it's always set and the check triggers a warning |
| | 1268 | #+(or allegro clozure cmu lispworks scl) |
| | 1269 | (slot-boundp condition +simple-condition-format-control-slot+) |
| | 1270 | (ignore-errors (equal (simple-condition-format-control condition) x)))))) |
| | 1271 | |
| | 1272 | (defun* match-any-condition-p (condition conditions) |
| | 1273 | "match CONDITION against any of the patterns of CONDITIONS supplied" |
| | 1274 | (loop :for x :in conditions :thereis (match-condition-p x condition))) |
| | 1275 | |
| | 1276 | (defun* call-with-muffled-conditions (thunk conditions) |
| | 1277 | (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) |
| | 1278 | (muffle-warning c))))) |
| | 1279 | (funcall thunk))) |
| | 1280 | |
| | 1281 | (defmacro with-muffled-uninteresting-conditions ((conditions) &body body) |
| | 1282 | `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions)) |
| | 1283 | |
| | 1284 | ;;;; ------------------------------------------------------------------------- |
| | 1285 | ;;;; Portability layer around Common Lisp pathnames |
| | 1286 | |
| | 1287 | (asdf/package:define-package :asdf/pathname |
| | 1288 | (:recycle :asdf/pathname :asdf) |
| | 1289 | (:use :asdf/common-lisp :asdf/package :asdf/utility) |
| | 1290 | (:export |
| | 1291 | #:*resolve-symlinks* |
| | 1292 | ;; Making and merging pathnames, portably |
| | 1293 | #:normalize-pathname-directory-component #:denormalize-pathname-directory-component |
| | 1294 | #:pathname-equal |
| | 1295 | #:merge-pathname-directory-components #:make-pathname* #:*unspecific-pathname-type* |
| | 1296 | #:make-pathname-component-logical #:make-pathname-logical |
| | 1297 | #:merge-pathnames* |
| | 1298 | ;; Directories |
| | 1299 | #:pathname-directory-pathname #:pathname-parent-directory-pathname |
| | 1300 | #:directory-pathname-p #:ensure-directory-pathname #:file-pathname-p |
| | 1301 | ;; Absolute vs relative pathnames |
| | 1302 | #:ensure-pathname-absolute |
| | 1303 | #:relativize-directory-component #:relativize-pathname-directory |
| | 1304 | ;; Parsing filenames and lists thereof |
| | 1305 | #:component-name-to-pathname-components |
| | 1306 | #:split-name-type #:parse-unix-namestring #:unix-namestring |
| | 1307 | #:split-unix-namestring-directory-components |
| | 1308 | #:subpathname #:subpathname* #:subpathp |
| | 1309 | ;; Resolving symlinks somewhat |
| | 1310 | #:truenamize #:resolve-symlinks #:resolve-symlinks* |
| | 1311 | ;; Wildcard pathnames |
| | 1312 | #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden |
| | 1313 | ;; Pathname host and its root |
| | 1314 | #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p |
| | 1315 | #:pathname-root #:directory-separator-for-host |
| | 1316 | #:directorize-pathname-host-device |
| | 1317 | ;; defaults |
| | 1318 | #:nil-pathname #:with-pathname-defaults |
| | 1319 | ;; probe filesystem |
| | 1320 | #:truename* #:probe-file* #:safe-file-write-date |
| | 1321 | #:subdirectories #:directory-files #:directory* |
| | 1322 | #:filter-logical-directory-results #:collect-sub*directories |
| | 1323 | ;; Simple filesystem operations |
| | 1324 | #:ensure-all-directories-exist |
| | 1325 | #:rename-file-overwriting-target |
| | 1326 | #:delete-file-if-exists |
| | 1327 | ;; Translate a pathname |
| | 1328 | #:translate-pathname* |
| | 1329 | ;; temporary |
| | 1330 | #:add-pathname-suffix #:tmpize-pathname |
| | 1331 | #:call-with-staging-pathname #:with-staging-pathname |
| | 1332 | ;; physical pathnames |
| | 1333 | #:logical-pathname-p #:physical-pathname-p #:sane-physical-pathname #:root-pathname |
| | 1334 | ;; Windows shortcut support |
| | 1335 | #:read-null-terminated-string #:read-little-endian |
| | 1336 | #:parse-file-location-info #:parse-windows-shortcut |
| | 1337 | ;; Checking constraints |
| | 1338 | #:ensure-pathname |
| | 1339 | #:absolutize-pathnames |
| | 1340 | ;; Output translations |
| | 1341 | #:*output-translation-function*)) |
| | 1342 | |
| | 1343 | (in-package :asdf/pathname) |
| | 1344 | |
| | 1345 | ;;; User-visible parameters |
| | 1346 | (defvar *resolve-symlinks* t |
| | 1347 | "Determine whether or not ASDF resolves symlinks when defining systems. |
| | 1348 | |
| | 1349 | Defaults to T.") |
| | 1350 | |
| | 1351 | |
| | 1352 | ;;; Normalizing pathnames across implementations |
| 792 | | (make-pathname :directory (append (or (pathname-directory pathspec) |
| 793 | | (list :relative)) |
| 794 | | (list (file-namestring pathspec))) |
| 795 | | :name nil :type nil :version nil |
| 796 | | :defaults pathspec)))) |
| 797 | | |
| 798 | | #+genera |
| 799 | | (unless (fboundp 'ensure-directories-exist) |
| 800 | | (defun* ensure-directories-exist (path) |
| 801 | | (fs:create-directories-recursively (pathname path)))) |
| 802 | | |
| 803 | | (defun* absolute-pathname-p (pathspec) |
| 804 | | (and (typep pathspec '(or pathname string)) |
| 805 | | (eq :absolute (car (pathname-directory (pathname pathspec)))))) |
| 806 | | |
| 807 | | (defun* coerce-pathname (name &key type defaults) |
| 808 | | "coerce NAME into a PATHNAME. |
| 809 | | When given a string, portably decompose it into a relative pathname: |
| 810 | | #\\/ separates subdirectories. The last #\\/-separated string is as follows: |
| 811 | | if TYPE is NIL, its last #\\. if any separates name and type from from type; |
| 812 | | if TYPE is a string, it is the type, and the whole string is the name; |
| 813 | | if TYPE is :DIRECTORY, the string is a directory component; |
| 814 | | if the string is empty, it's a directory. |
| 815 | | Any directory named .. is read as :BACK. |
| 816 | | Host, device and version components are taken from DEFAULTS." |
| 817 | | ;; The defaults are required notably because they provide the default host |
| 818 | | ;; to the below make-pathname, which may crucially matter to people using |
| 819 | | ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. |
| 820 | | ;; NOTE that the host and device slots will be taken from the defaults, |
| 821 | | ;; but that should only matter if you later merge relative pathnames with |
| 822 | | ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* |
| 823 | | (etypecase name |
| 824 | | ((or null pathname) |
| 825 | | name) |
| 826 | | (symbol |
| 827 | | (coerce-pathname (string-downcase name) :type type :defaults defaults)) |
| 828 | | (string |
| 829 | | (multiple-value-bind (relative path filename) |
| 830 | | (component-name-to-pathname-components name :force-directory (eq type :directory) |
| 831 | | :force-relative t) |
| 832 | | (multiple-value-bind (name type) |
| | 1605 | (make-pathname* :directory (append (or (normalize-pathname-directory-component |
| | 1606 | (pathname-directory pathspec)) |
| | 1607 | (list :relative)) |
| | 1608 | (list (file-namestring pathspec))) |
| | 1609 | :name nil :type nil :version nil :defaults pathspec)))) |
| | 1610 | |
| | 1611 | |
| | 1612 | ;;; Wildcard pathnames |
| | 1613 | (defparameter *wild* (or #+cormanlisp "*" :wild)) |
| | 1614 | (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) |
| | 1615 | (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) |
| | 1616 | (defparameter *wild-file* |
| | 1617 | (make-pathname :directory nil :name *wild* :type *wild* |
| | 1618 | :version (or #-(or allegro abcl xcl) *wild*))) |
| | 1619 | (defparameter *wild-directory* |
| | 1620 | (make-pathname* :directory `(:relative ,*wild-directory-component*) |
| | 1621 | :name nil :type nil :version nil)) |
| | 1622 | (defparameter *wild-inferiors* |
| | 1623 | (make-pathname* :directory `(:relative ,*wild-inferiors-component*) |
| | 1624 | :name nil :type nil :version nil)) |
| | 1625 | (defparameter *wild-path* |
| | 1626 | (merge-pathnames* *wild-file* *wild-inferiors*)) |
| | 1627 | |
| | 1628 | (defun* wilden (path) |
| | 1629 | (merge-pathnames* *wild-path* path)) |
| | 1630 | |
| | 1631 | |
| | 1632 | ;;; Probing the filesystem |
| | 1633 | (defun* nil-pathname (&optional (defaults *default-pathname-defaults*)) |
| | 1634 | ;; 19.2.2.2.1 says a NIL host can mean a default host; |
| | 1635 | ;; see also "valid physical pathname host" in the CLHS glossary, that suggests |
| | 1636 | ;; strings and lists of strings or :unspecific |
| | 1637 | ;; But CMUCL decides to die on NIL. |
| | 1638 | (make-pathname* :directory nil :name nil :type nil :version nil :device nil |
| | 1639 | :host (or #+cmu lisp::*unix-host*) |
| | 1640 | ;; the default shouldn't matter, but we really want something physical |
| | 1641 | :defaults defaults)) |
| | 1642 | |
| | 1643 | (defmacro with-pathname-defaults ((&optional defaults) &body body) |
| | 1644 | `(let ((*default-pathname-defaults* ,(or defaults '(nil-pathname)))) ,@body)) |
| | 1645 | |
| | 1646 | (defun* truename* (p) |
| | 1647 | ;; avoids both logical-pathname merging and physical resolution issues |
| | 1648 | (and p (ignore-errors (with-pathname-defaults () (truename p))))) |
| | 1649 | |
| | 1650 | (defun* probe-file* (p &key truename) |
| | 1651 | "when given a pathname P (designated by a string as per PARSE-NAMESTRING), |
| | 1652 | probes the filesystem for a file or directory with given pathname. |
| | 1653 | If it exists, return its truename is ENSURE-PATHNAME is true, |
| | 1654 | or the original (parsed) pathname if it is false (the default)." |
| | 1655 | (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations |
| | 1656 | (etypecase p |
| | 1657 | (null nil) |
| | 1658 | (string (probe-file* (parse-namestring p) :truename truename)) |
| | 1659 | (pathname (unless (wild-pathname-p p) |
| | 1660 | (let ((foundtrue |
| | 1661 | #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) |
| | 1662 | '(probe-file p) |
| | 1663 | #+clisp (if-let (it (find-symbol* '#:probe-pathname :ext nil)) |
| | 1664 | `(ignore-errors (,it p))) |
| | 1665 | #+gcl2.6 |
| | 1666 | '(or (probe-file p) |
| | 1667 | (and (directory-pathname-p p) |
| | 1668 | (ignore-errors |
| | 1669 | (ensure-directory-pathname |
| | 1670 | (truename* (subpathname |
| | 1671 | (ensure-directory-pathname p) ".")))))) |
| | 1672 | '(truename* p)))) |
| | 1673 | (cond |
| | 1674 | (truename foundtrue) |
| | 1675 | (foundtrue p) |
| | 1676 | (t nil)))))))) |
| | 1677 | |
| | 1678 | (defun* safe-file-write-date (pathname) |
| | 1679 | ;; If FILE-WRITE-DATE returns NIL, it's possible that |
| | 1680 | ;; the user or some other agent has deleted an input file. |
| | 1681 | ;; Also, generated files will not exist at the time planning is done |
| | 1682 | ;; and calls compute-action-stamp which calls safe-file-write-date. |
| | 1683 | ;; So it is very possible that we can't get a valid file-write-date, |
| | 1684 | ;; and we can survive and we will continue the planning |
| | 1685 | ;; as if the file were very old. |
| | 1686 | ;; (or should we treat the case in a different, special way?) |
| | 1687 | (and (probe-file* pathname) (ignore-errors (file-write-date pathname)))) |
| | 1688 | |
| | 1689 | (defun* directory* (pathname-spec &rest keys &key &allow-other-keys) |
| | 1690 | (apply 'directory pathname-spec |
| | 1691 | (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) |
| | 1692 | #+clozure '(:follow-links nil) |
| | 1693 | #+clisp '(:circle t :if-does-not-exist :ignore) |
| | 1694 | #+(or cmu scl) '(:follow-links nil :truenamep nil) |
| | 1695 | #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) |
| | 1696 | '(:resolve-symlinks nil)))))) |
| | 1697 | |
| | 1698 | (defun* filter-logical-directory-results (directory entries merger) |
| | 1699 | (if (logical-pathname-p directory) |
| | 1700 | ;; Try hard to not resolve logical-pathname into physical pathnames; |
| | 1701 | ;; otherwise logical-pathname users/lovers will be disappointed. |
| | 1702 | ;; If directory* could use some implementation-dependent magic, |
| | 1703 | ;; we will have logical pathnames already; otherwise, |
| | 1704 | ;; we only keep pathnames for which specifying the name and |
| | 1705 | ;; translating the LPN commute. |
| | 1706 | (loop :for f :in entries |
| | 1707 | :for p = (or (and (logical-pathname-p f) f) |
| | 1708 | (let* ((u (ignore-errors (funcall merger f)))) |
| | 1709 | ;; The first u avoids a cumbersome (truename u) error. |
| | 1710 | ;; At this point f should already be a truename, |
| | 1711 | ;; but isn't quite in CLISP, for it doesn't have :version :newest |
| | 1712 | (and u (equal (truename* u) (truename* f)) u))) |
| | 1713 | :when p :collect p) |
| | 1714 | entries)) |
| | 1715 | |
| | 1716 | (defun* directory-files (directory &optional (pattern *wild-file*)) |
| | 1717 | (let ((dir (pathname directory))) |
| | 1718 | (when (logical-pathname-p dir) |
| | 1719 | ;; Because of the filtering we do below, |
| | 1720 | ;; logical pathnames have restrictions on wild patterns. |
| | 1721 | ;; Not that the results are very portable when you use these patterns on physical pathnames. |
| | 1722 | (when (wild-pathname-p dir) |
| | 1723 | (error "Invalid wild pattern in logical directory ~S" directory)) |
| | 1724 | (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) |
| | 1725 | (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) |
| | 1726 | (setf pattern (make-pathname-logical pattern (pathname-host dir)))) |
| | 1727 | (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) |
| | 1728 | (filter-logical-directory-results |
| | 1729 | directory entries |
| | 1730 | #'(lambda (f) |
| | 1731 | (make-pathname :defaults dir |
| | 1732 | :name (make-pathname-component-logical (pathname-name f)) |
| | 1733 | :type (make-pathname-component-logical (pathname-type f)) |
| | 1734 | :version (make-pathname-component-logical (pathname-version f)))))))) |
| | 1735 | |
| | 1736 | (defun* subdirectories (directory) |
| | 1737 | (let* ((directory (ensure-directory-pathname directory)) |
| | 1738 | #-(or abcl cormanlisp genera xcl) |
| | 1739 | (wild (merge-pathnames* |
| | 1740 | #-(or abcl allegro cmu lispworks sbcl scl xcl) |
| | 1741 | *wild-directory* |
| | 1742 | #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" |
| | 1743 | directory)) |
| | 1744 | (dirs |
| | 1745 | #-(or abcl cormanlisp genera xcl) |
| | 1746 | (ignore-errors |
| | 1747 | (directory* wild . #.(or #+clozure '(:directories t :files nil) |
| | 1748 | #+mcl '(:directories t)))) |
| | 1749 | #+(or abcl xcl) (system:list-directory directory) |
| | 1750 | #+cormanlisp (cl::directory-subdirs directory) |
| | 1751 | #+genera (fs:directory-list directory)) |
| | 1752 | #+(or abcl allegro cmu genera lispworks sbcl scl xcl) |
| | 1753 | (dirs (loop :for x :in dirs |
| | 1754 | :for d = #+(or abcl xcl) (extensions:probe-directory x) |
| | 1755 | #+allegro (excl:probe-directory x) |
| | 1756 | #+(or cmu sbcl scl) (directory-pathname-p x) |
| | 1757 | #+genera (getf (cdr x) :directory) |
| | 1758 | #+lispworks (lw:file-directory-p x) |
| | 1759 | :when d :collect #+(or abcl allegro xcl) d |
| | 1760 | #+genera (ensure-directory-pathname (first x)) |
| | 1761 | #+(or cmu lispworks sbcl scl) x))) |
| | 1762 | (filter-logical-directory-results |
| | 1763 | directory dirs |
| | 1764 | (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) |
| | 1765 | '(:absolute)))) ; because allegro returns NIL for #p"FOO:" |
| | 1766 | #'(lambda (d) |
| | 1767 | (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) |
| | 1768 | (and (consp dir) (consp (cdr dir)) |
| | 1769 | (make-pathname |
| | 1770 | :defaults directory :name nil :type nil :version nil |
| | 1771 | :directory (append prefix (make-pathname-component-logical (last dir))))))))))) |
| | 1772 | |
| | 1773 | (defun* collect-sub*directories (directory collectp recursep collector) |
| | 1774 | (when (funcall collectp directory) |
| | 1775 | (funcall collector directory)) |
| | 1776 | (dolist (subdir (subdirectories directory)) |
| | 1777 | (when (funcall recursep subdir) |
| | 1778 | (collect-sub*directories subdir collectp recursep collector)))) |
| | 1779 | |
| | 1780 | |
| | 1781 | ;;; Parsing filenames and lists thereof |
| | 1782 | (defun* split-unix-namestring-directory-components |
| | 1783 | (unix-namestring &key ensure-directory dot-dot) |
| | 1784 | "Splits the path string UNIX-NAMESTRING, returning four values: |
| | 1785 | A flag that is either :absolute or :relative, indicating |
| | 1786 | how the rest of the values are to be interpreted. |
| | 1787 | A directory path --- a list of strings and keywords, suitable for |
| | 1788 | use with MAKE-PATHNAME when prepended with the flag value. |
| | 1789 | Directory components with an empty name or the name . are removed. |
| | 1790 | Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). |
| | 1791 | A last-component, either a file-namestring including type extension, |
| | 1792 | or NIL in the case of a directory pathname. |
| | 1793 | A flag that is true iff the unix-style-pathname was just |
| | 1794 | a file-namestring without / path specification. |
| | 1795 | ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: |
| | 1796 | the third return value will be NIL, and final component of the namestring |
| | 1797 | will be treated as part of the directory path. |
| | 1798 | |
| | 1799 | An empty string is thus read as meaning a pathname object with all fields nil. |
| | 1800 | |
| | 1801 | Note that : characters will NOT be interpreted as host specification. |
| | 1802 | Absolute pathnames are only appropriate on Unix-style systems. |
| | 1803 | |
| | 1804 | The intention of this function is to support structured component names, |
| | 1805 | e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." |
| | 1806 | (check-type unix-namestring string) |
| | 1807 | (check-type dot-dot (member nil :back :up)) |
| | 1808 | (if (and (not (find #\/ unix-namestring)) (not ensure-directory) |
| | 1809 | (plusp (length unix-namestring))) |
| | 1810 | (values :relative () unix-namestring t) |
| | 1811 | (let* ((components (split-string unix-namestring :separator "/")) |
| | 1812 | (last-comp (car (last components)))) |
| | 1813 | (multiple-value-bind (relative components) |
| | 1814 | (if (equal (first components) "") |
| | 1815 | (if (equal (first-char unix-namestring) #\/) |
| | 1816 | (values :absolute (cdr components)) |
| | 1817 | (values :relative nil)) |
| | 1818 | (values :relative components)) |
| | 1819 | (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) |
| | 1820 | components)) |
| | 1821 | (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) |
| | 1822 | (cond |
| | 1823 | ((equal last-comp "") |
| | 1824 | (values relative components nil nil)) ; "" already removed from components |
| | 1825 | (ensure-directory |
| | 1826 | (values relative components nil nil)) |
| | 1827 | (t |
| | 1828 | (values relative (butlast components) last-comp nil))))))) |
| | 1829 | |
| | 1830 | (defun* split-name-type (filename) |
| | 1831 | "Split a filename into two values NAME and TYPE that are returned. |
| | 1832 | We assume filename has no directory component. |
| | 1833 | The last . if any separates name and type from from type, |
| | 1834 | except that if there is only one . and it is in first position, |
| | 1835 | the whole filename is the NAME with an empty type. |
| | 1836 | NAME is always a string. |
| | 1837 | For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." |
| | 1838 | (check-type filename string) |
| | 1839 | (assert (plusp (length filename))) |
| | 1840 | (destructuring-bind (name &optional (type *unspecific-pathname-type*)) |
| | 1841 | (split-string filename :max 2 :separator ".") |
| | 1842 | (if (equal name "") |
| | 1843 | (values filename *unspecific-pathname-type*) |
| | 1844 | (values name type)))) |
| | 1845 | |
| | 1846 | (defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory |
| | 1847 | &allow-other-keys) |
| | 1848 | "Coerce NAME into a PATHNAME using standard Unix syntax. |
| | 1849 | |
| | 1850 | Unix syntax is used whether or not the underlying system is Unix; |
| | 1851 | on such non-Unix systems it is only usable but for relative pathnames; |
| | 1852 | but especially to manipulate relative pathnames portably, it is of crucial |
| | 1853 | to possess a portable pathname syntax independent of the underlying OS. |
| | 1854 | This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. |
| | 1855 | |
| | 1856 | When given a PATHNAME object, just return it untouched. |
| | 1857 | When given NIL, just return NIL. |
| | 1858 | When given a non-null SYMBOL, first downcase its name and treat it as a string. |
| | 1859 | When given a STRING, portably decompose it into a pathname as below. |
| | 1860 | |
| | 1861 | #\\/ separates directory components. |
| | 1862 | |
| | 1863 | The last #\\/-separated substring is interpreted as follows: |
| | 1864 | 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, |
| | 1865 | the string is made the last directory component, and NAME and TYPE are NIL. |
| | 1866 | if the string is empty, it's the empty pathname with all slots NIL. |
| | 1867 | 2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE |
| | 1868 | are separated by SPLIT-NAME-TYPE. |
| | 1869 | 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. |
| | 1870 | |
| | 1871 | Directory components with an empty name the name . are removed. |
| | 1872 | Any directory named .. is read as DOT-DOT, |
| | 1873 | which must be one of :BACK or :UP and defaults to :BACK. |
| | 1874 | |
| | 1875 | HOST, DEVICE and VERSION components are taken from DEFAULTS, |
| | 1876 | which itself defaults to (ROOT-PATHNAME), also used if DEFAULTS in NIL. |
| | 1877 | No host or device can be specified in the string itself, |
| | 1878 | which makes it unsuitable for absolute pathnames outside Unix. |
| | 1879 | |
| | 1880 | For relative pathnames, these components (and hence the defaults) won't matter |
| | 1881 | if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, |
| | 1882 | which is an important reason to always use MERGE-PATHNAMES*. |
| | 1883 | |
| | 1884 | Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME |
| | 1885 | with those keys, removing TYPE DEFAULTS and DOT-DOT. |
| | 1886 | When you're manipulating pathnames that are supposed to make sense portably |
| | 1887 | even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T |
| | 1888 | to throw an error if the pathname is absolute" |
| | 1889 | (block nil |
| | 1890 | (check-type type (or null string (eql :directory))) |
| | 1891 | (when ensure-directory |
| | 1892 | (setf type :directory)) |
| | 1893 | (etypecase name |
| | 1894 | ((or null pathname) (return name)) |
| | 1895 | (symbol |
| | 1896 | (setf name (string-downcase name))) |
| | 1897 | (string)) |
| | 1898 | (multiple-value-bind (relative path filename file-only) |
| | 1899 | (split-unix-namestring-directory-components |
| | 1900 | name :dot-dot dot-dot :ensure-directory (eq type :directory)) |
| | 1901 | (multiple-value-bind (name type) |
| | 1902 | (cond |
| | 1903 | ((or (eq type :directory) (null filename)) |
| | 1904 | (values nil nil)) |
| | 1905 | (type |
| | 1906 | (values filename type)) |
| | 1907 | (t |
| | 1908 | (split-name-type filename))) |
| | 1909 | (apply 'ensure-pathname |
| | 1910 | (make-pathname* |
| | 1911 | :directory (unless file-only (cons relative path)) |
| | 1912 | :name name :type type |
| | 1913 | :defaults (or defaults (nil-pathname))) |
| | 1914 | (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) |
| | 1915 | |
| | 1916 | (defun* unix-namestring (pathname) |
| | 1917 | "Given a non-wild PATHNAME, return a Unix-style namestring for it. |
| | 1918 | If the PATHNAME is NIL or a STRING, return it unchanged. |
| | 1919 | |
| | 1920 | This only considers the DIRECTORY, NAME and TYPE components of the pathname. |
| | 1921 | This is a portable solution for representing relative pathnames, |
| | 1922 | But unless you are running on a Unix system, it is not a general solution |
| | 1923 | to representing native pathnames. |
| | 1924 | |
| | 1925 | An error is signaled if the argument is not NULL, a STRING or a PATHNAME, |
| | 1926 | or if it is a PATHNAME but some of its components are not recognized." |
| | 1927 | (etypecase pathname |
| | 1928 | ((or null string) pathname) |
| | 1929 | (pathname |
| | 1930 | (with-output-to-string (s) |
| | 1931 | (flet ((err () (error "Not a valid unix-namestring ~S" pathname))) |
| | 1932 | (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) |
| | 1933 | (name (pathname-name pathname)) |
| | 1934 | (type (pathname-type pathname)) |
| | 1935 | (type (and (not (eq type :unspecific)) type))) |
| 1025 | | ;;;; ------------------------------------------------------------------------- |
| 1026 | | ;;;; ASDF Interface, in terms of generic functions. |
| 1027 | | (defgeneric* find-system (system &optional error-p)) |
| 1028 | | (defgeneric* perform-with-restarts (operation component)) |
| 1029 | | (defgeneric* perform (operation component)) |
| 1030 | | (defgeneric* operation-done-p (operation component)) |
| 1031 | | (defgeneric* mark-operation-done (operation component)) |
| 1032 | | (defgeneric* explain (operation component)) |
| 1033 | | (defgeneric* output-files (operation component)) |
| 1034 | | (defgeneric* input-files (operation component)) |
| 1035 | | (defgeneric* component-operation-time (operation component)) |
| 1036 | | (defgeneric* operation-description (operation component) |
| 1037 | | (:documentation "returns a phrase that describes performing this operation |
| 1038 | | on this component, e.g. \"loading /a/b/c\". |
| 1039 | | You can put together sentences using this phrase.")) |
| 1040 | | |
| 1041 | | (defgeneric* system-source-file (system) |
| 1042 | | (:documentation "Return the source file in which system is defined.")) |
| 1043 | | |
| 1044 | | (defgeneric* component-system (component) |
| 1045 | | (:documentation "Find the top-level system containing COMPONENT")) |
| 1046 | | |
| 1047 | | (defgeneric* component-pathname (component) |
| 1048 | | (:documentation "Extracts the pathname applicable for a particular component.")) |
| 1049 | | |
| 1050 | | (defgeneric* component-relative-pathname (component) |
| 1051 | | (:documentation "Returns a pathname for the component argument intended to be |
| 1052 | | interpreted relative to the pathname of that component's parent. |
| 1053 | | Despite the function's name, the return value may be an absolute |
| 1054 | | pathname, because an absolute pathname may be interpreted relative to |
| 1055 | | another pathname in a degenerate way.")) |
| 1056 | | |
| 1057 | | (defgeneric* component-property (component property)) |
| 1058 | | |
| 1059 | | (defgeneric* (setf component-property) (new-value component property)) |
| 1060 | | |
| 1061 | | (defgeneric* component-external-format (component)) |
| 1062 | | |
| 1063 | | (defgeneric* component-encoding (component)) |
| 1064 | | |
| 1065 | | (eval-when (#-gcl :compile-toplevel :load-toplevel :execute) |
| 1066 | | (defgeneric* (setf module-components-by-name) (new-value module))) |
| 1067 | | |
| 1068 | | (defgeneric* version-satisfies (component version)) |
| 1069 | | |
| 1070 | | (defgeneric* find-component (base path) |
| 1071 | | (:documentation "Finds the component with PATH starting from BASE module; |
| 1072 | | if BASE is nil, then the component is assumed to be a system.")) |
| 1073 | | |
| 1074 | | (defgeneric* source-file-type (component system)) |
| 1075 | | |
| 1076 | | (defgeneric* operation-ancestor (operation) |
| 1077 | | (:documentation |
| 1078 | | "Recursively chase the operation's parent pointer until we get to |
| 1079 | | the head of the tree")) |
| 1080 | | |
| 1081 | | (defgeneric* component-visited-p (operation component) |
| 1082 | | (:documentation "Returns the value stored by a call to |
| 1083 | | VISIT-COMPONENT, if that has been called, otherwise NIL. |
| 1084 | | This value stored will be a cons cell, the first element |
| 1085 | | of which is a computed key, so not interesting. The |
| 1086 | | CDR wil be the DATA value stored by VISIT-COMPONENT; recover |
| 1087 | | it as (cdr (component-visited-p op c)). |
| 1088 | | In the current form of ASDF, the DATA value retrieved is |
| 1089 | | effectively a boolean, indicating whether some operations are |
| 1090 | | to be performed in order to do OPERATION X COMPONENT. If the |
| 1091 | | data value is NIL, the combination had been explored, but no |
| 1092 | | operations needed to be performed.")) |
| 1093 | | |
| 1094 | | (defgeneric* visit-component (operation component data) |
| 1095 | | (:documentation "Record DATA as being associated with OPERATION |
| 1096 | | and COMPONENT. This is a side-effecting function: the association |
| 1097 | | will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the |
| 1098 | | OPERATION\). |
| 1099 | | No evidence that DATA is ever interesting, beyond just being |
| 1100 | | non-NIL. Using the data field is probably very risky; if there is |
| 1101 | | already a record for OPERATION X COMPONENT, DATA will be quietly |
| 1102 | | discarded instead of recorded. |
| 1103 | | Starting with 2.006, TRAVERSE will store an integer in data, |
| 1104 | | so that nodes can be sorted in decreasing order of traversal.")) |
| 1105 | | |
| 1106 | | |
| 1107 | | (defgeneric* (setf visiting-component) (new-value operation component)) |
| 1108 | | |
| 1109 | | (defgeneric* component-visiting-p (operation component)) |
| 1110 | | |
| 1111 | | (defgeneric* component-depends-on (operation component) |
| 1112 | | (:documentation |
| 1113 | | "Returns a list of dependencies needed by the component to perform |
| 1114 | | the operation. A dependency has one of the following forms: |
| 1115 | | |
| 1116 | | (<operation> <component>*), where <operation> is a class |
| 1117 | | designator and each <component> is a component |
| 1118 | | designator, which means that the component depends on |
| 1119 | | <operation> having been performed on each <component>; or |
| 1120 | | |
| 1121 | | (FEATURE <feature>), which means that the component depends |
| 1122 | | on <feature>'s presence in *FEATURES*. |
| 1123 | | |
| 1124 | | Methods specialized on subclasses of existing component types |
| 1125 | | should usually append the results of CALL-NEXT-METHOD to the |
| 1126 | | list.")) |
| 1127 | | |
| 1128 | | (defgeneric* component-self-dependencies (operation component)) |
| 1129 | | |
| 1130 | | (defgeneric* traverse (operation component) |
| 1131 | | (:documentation |
| 1132 | | "Generate and return a plan for performing OPERATION on COMPONENT. |
| 1133 | | |
| 1134 | | The plan returned is a list of dotted-pairs. Each pair is the CONS |
| 1135 | | of ASDF operation object and a COMPONENT object. The pairs will be |
| 1136 | | processed in order by OPERATE.")) |
| 1137 | | |
| 1138 | | |
| 1139 | | ;;;; ------------------------------------------------------------------------- |
| 1140 | | ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 |
| 1141 | | (when *upgraded-p* |
| 1142 | | (when (find-class 'module nil) |
| 1143 | | (eval |
| 1144 | | '(defmethod update-instance-for-redefined-class :after |
| 1145 | | ((m module) added deleted plist &key) |
| 1146 | | (declare (ignorable deleted plist)) |
| 1147 | | (when *asdf-verbose* |
| 1148 | | (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") |
| 1149 | | m (asdf-version))) |
| 1150 | | (when (member 'components-by-name added) |
| 1151 | | (compute-module-components-by-name m)) |
| 1152 | | (when (typep m 'system) |
| 1153 | | (when (member 'source-file added) |
| 1154 | | (%set-system-source-file |
| 1155 | | (probe-asd (component-name m) (component-pathname m)) m) |
| 1156 | | (when (equal (component-name m) "asdf") |
| 1157 | | (setf (component-version m) *asdf-version*)))))))) |
| 1158 | | |
| 1159 | | ;;;; ------------------------------------------------------------------------- |
| 1160 | | ;;;; Classes, Conditions |
| 1161 | | |
| 1162 | | (define-condition system-definition-error (error) () |
| 1163 | | ;; [this use of :report should be redundant, but unfortunately it's not. |
| 1164 | | ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function |
| 1165 | | ;; over print-object; this is always conditions::%print-condition for |
| 1166 | | ;; condition objects, which in turn does inheritance of :report options at |
| 1167 | | ;; run-time. fortunately, inheritance means we only need this kludge here in |
| 1168 | | ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] |
| 1169 | | #+cmu (:report print-object)) |
| 1170 | | |
| 1171 | | (define-condition formatted-system-definition-error (system-definition-error) |
| 1172 | | ((format-control :initarg :format-control :reader format-control) |
| 1173 | | (format-arguments :initarg :format-arguments :reader format-arguments)) |
| 1174 | | (:report (lambda (c s) |
| 1175 | | (apply 'format s (format-control c) (format-arguments c))))) |
| 1176 | | |
| 1177 | | (define-condition load-system-definition-error (system-definition-error) |
| 1178 | | ((name :initarg :name :reader error-name) |
| 1179 | | (pathname :initarg :pathname :reader error-pathname) |
| 1180 | | (condition :initarg :condition :reader error-condition)) |
| 1181 | | (:report (lambda (c s) |
| 1182 | | (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") |
| 1183 | | (error-name c) (error-pathname c) (error-condition c))))) |
| 1184 | | |
| 1185 | | (define-condition circular-dependency (system-definition-error) |
| 1186 | | ((components :initarg :components :reader circular-dependency-components)) |
| 1187 | | (:report (lambda (c s) |
| 1188 | | (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") |
| 1189 | | (circular-dependency-components c))))) |
| 1190 | | |
| 1191 | | (define-condition duplicate-names (system-definition-error) |
| 1192 | | ((name :initarg :name :reader duplicate-names-name)) |
| 1193 | | (:report (lambda (c s) |
| 1194 | | (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") |
| 1195 | | (duplicate-names-name c))))) |
| 1196 | | |
| 1197 | | (define-condition missing-component (system-definition-error) |
| 1198 | | ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) |
| 1199 | | (parent :initform nil :reader missing-parent :initarg :parent))) |
| 1200 | | |
| 1201 | | (define-condition missing-component-of-version (missing-component) |
| 1202 | | ((version :initform nil :reader missing-version :initarg :version))) |
| 1203 | | |
| 1204 | | (define-condition missing-dependency (missing-component) |
| 1205 | | ((required-by :initarg :required-by :reader missing-required-by))) |
| 1206 | | |
| 1207 | | (define-condition missing-dependency-of-version (missing-dependency |
| 1208 | | missing-component-of-version) |
| 1209 | | ()) |
| 1210 | | |
| 1211 | | (define-condition operation-error (error) |
| 1212 | | ((component :reader error-component :initarg :component) |
| 1213 | | (operation :reader error-operation :initarg :operation)) |
| 1214 | | (:report (lambda (c s) |
| 1215 | | (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") |
| 1216 | | (type-of c) (error-operation c) (error-component c))))) |
| 1217 | | (define-condition compile-error (operation-error) ()) |
| 1218 | | (define-condition compile-failed (compile-error) ()) |
| 1219 | | (define-condition compile-warned (compile-error) ()) |
| 1220 | | |
| 1221 | | (define-condition invalid-configuration () |
| 1222 | | ((form :reader condition-form :initarg :form) |
| 1223 | | (location :reader condition-location :initarg :location) |
| 1224 | | (format :reader condition-format :initarg :format) |
| 1225 | | (arguments :reader condition-arguments :initarg :arguments :initform nil)) |
| 1226 | | (:report (lambda (c s) |
| 1227 | | (format s (compatfmt "~@<~? (will be skipped)~@:>") |
| 1228 | | (condition-format c) |
| 1229 | | (list* (condition-form c) (condition-location c) |
| 1230 | | (condition-arguments c)))))) |
| 1231 | | (define-condition invalid-source-registry (invalid-configuration warning) |
| 1232 | | ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) |
| 1233 | | (define-condition invalid-output-translation (invalid-configuration warning) |
| 1234 | | ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) |
| 1235 | | |
| 1236 | | (defclass component () |
| 1237 | | ((name :accessor component-name :initarg :name :type string :documentation |
| 1238 | | "Component name: designator for a string composed of portable pathname characters") |
| 1239 | | ;; We might want to constrain version with |
| 1240 | | ;; :type (and string (satisfies parse-version)) |
| 1241 | | ;; but we cannot until we fix all systems that don't use it correctly! |
| 1242 | | (version :accessor component-version :initarg :version) |
| 1243 | | (description :accessor component-description :initarg :description) |
| 1244 | | (long-description :accessor component-long-description :initarg :long-description) |
| 1245 | | ;; This one below is used by POIU - http://www.cliki.net/poiu |
| 1246 | | ;; a parallelizing extension of ASDF that compiles in multiple parallel |
| 1247 | | ;; slave processes (forked on demand) and loads in the master process. |
| 1248 | | ;; Maybe in the future ASDF may use it internally instead of in-order-to. |
| 1249 | | (load-dependencies :accessor component-load-dependencies :initform nil) |
| 1250 | | ;; In the ASDF object model, dependencies exist between *actions* |
| 1251 | | ;; (an action is a pair of operation and component). They are represented |
| 1252 | | ;; alists of operations to dependencies (other actions) in each component. |
| 1253 | | ;; There are two kinds of dependencies, each stored in its own slot: |
| 1254 | | ;; in-order-to and do-first dependencies. These two kinds are related to |
| 1255 | | ;; the fact that some actions modify the filesystem, |
| 1256 | | ;; whereas other actions modify the current image, and |
| 1257 | | ;; this implies a difference in how to interpret timestamps. |
| 1258 | | ;; in-order-to dependencies will trigger re-performing the action |
| 1259 | | ;; when the timestamp of some dependency |
| 1260 | | ;; makes the timestamp of current action out-of-date; |
| 1261 | | ;; do-first dependencies do not trigger such re-performing. |
| 1262 | | ;; Therefore, a FASL must be recompiled if it is obsoleted |
| 1263 | | ;; by any of its FASL dependencies (in-order-to); but |
| 1264 | | ;; it needn't be recompiled just because one of these dependencies |
| 1265 | | ;; hasn't yet been loaded in the current image (do-first). |
| 1266 | | ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! |
| 1267 | | ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. |
| 1268 | | ;; Maybe rename the slots in ASDF? But that's not very backwards compatible. |
| 1269 | | ;; See our ASDF 2 paper for more complete explanations. |
| 1270 | | (in-order-to :initform nil :initarg :in-order-to |
| 1271 | | :accessor component-in-order-to) |
| 1272 | | (do-first :initform nil :initarg :do-first |
| 1273 | | :accessor component-do-first) |
| 1274 | | ;; methods defined using the "inline" style inside a defsystem form: |
| 1275 | | ;; need to store them somewhere so we can delete them when the system |
| 1276 | | ;; is re-evaluated |
| 1277 | | (inline-methods :accessor component-inline-methods :initform nil) |
| 1278 | | (parent :initarg :parent :initform nil :reader component-parent) |
| 1279 | | ;; no direct accessor for pathname, we do this as a method to allow |
| 1280 | | ;; it to default in funky ways if not supplied |
| 1281 | | (relative-pathname :initarg :pathname) |
| 1282 | | ;; the absolute-pathname is computed based on relative-pathname... |
| 1283 | | (absolute-pathname) |
| 1284 | | (operation-times :initform (make-hash-table) |
| 1285 | | :accessor component-operation-times) |
| 1286 | | (around-compile :initarg :around-compile) |
| 1287 | | (%encoding :accessor %component-encoding :initform nil :initarg :encoding) |
| 1288 | | ;; XXX we should provide some atomic interface for updating the |
| 1289 | | ;; component properties |
| 1290 | | (properties :accessor component-properties :initarg :properties |
| 1291 | | :initform nil))) |
| 1292 | | |
| 1293 | | (defun* component-find-path (component) |
| 1294 | | (reverse |
| 1295 | | (loop :for c = component :then (component-parent c) |
| 1296 | | :while c :collect (component-name c)))) |
| 1297 | | |
| 1298 | | (defmethod print-object ((c component) stream) |
| 1299 | | (print-unreadable-object (c stream :type t :identity nil) |
| 1300 | | (format stream "~{~S~^ ~}" (component-find-path c)))) |
| 1301 | | |
| 1302 | | |
| 1303 | | ;;;; methods: conditions |
| 1304 | | |
| 1305 | | (defmethod print-object ((c missing-dependency) s) |
| 1306 | | (format s (compatfmt "~@<~A, required by ~A~@:>") |
| 1307 | | (call-next-method c nil) (missing-required-by c))) |
| 1308 | | |
| 1309 | | (defun* sysdef-error (format &rest arguments) |
| 1310 | | (error 'formatted-system-definition-error :format-control |
| 1311 | | format :format-arguments arguments)) |
| 1312 | | |
| 1313 | | ;;;; methods: components |
| 1314 | | |
| 1315 | | (defmethod print-object ((c missing-component) s) |
| 1316 | | (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") |
| 1317 | | (missing-requires c) |
| 1318 | | (when (missing-parent c) |
| 1319 | | (coerce-name (missing-parent c))))) |
| 1320 | | |
| 1321 | | (defmethod print-object ((c missing-component-of-version) s) |
| 1322 | | (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") |
| 1323 | | (missing-requires c) |
| 1324 | | (missing-version c) |
| 1325 | | (when (missing-parent c) |
| 1326 | | (coerce-name (missing-parent c))))) |
| 1327 | | |
| 1328 | | (defmethod component-system ((component component)) |
| 1329 | | (aif (component-parent component) |
| 1330 | | (component-system it) |
| 1331 | | component)) |
| 1332 | | |
| 1333 | | (defvar *default-component-class* 'cl-source-file) |
| 1334 | | |
| 1335 | | (defun* compute-module-components-by-name (module) |
| 1336 | | (let ((hash (make-hash-table :test 'equal))) |
| 1337 | | (setf (module-components-by-name module) hash) |
| 1338 | | (loop :for c :in (module-components module) |
| 1339 | | :for name = (component-name c) |
| 1340 | | :for previous = (gethash name (module-components-by-name module)) |
| 1341 | | :do |
| 1342 | | (when previous |
| 1343 | | (error 'duplicate-names :name name)) |
| 1344 | | :do (setf (gethash name (module-components-by-name module)) c)) |
| 1345 | | hash)) |
| 1346 | | |
| 1347 | | (defclass module (component) |
| 1348 | | ((components |
| 1349 | | :initform nil |
| 1350 | | :initarg :components |
| 1351 | | :accessor module-components) |
| 1352 | | (components-by-name |
| 1353 | | :accessor module-components-by-name) |
| 1354 | | ;; What to do if we can't satisfy a dependency of one of this module's |
| 1355 | | ;; components. This allows a limited form of conditional processing. |
| 1356 | | (if-component-dep-fails |
| 1357 | | :initform :fail |
| 1358 | | :initarg :if-component-dep-fails |
| 1359 | | :accessor module-if-component-dep-fails) |
| 1360 | | (default-component-class |
| 1361 | | :initform nil |
| 1362 | | :initarg :default-component-class |
| 1363 | | :accessor module-default-component-class))) |
| 1364 | | |
| 1365 | | (defun* component-parent-pathname (component) |
| 1366 | | ;; No default anymore (in particular, no *default-pathname-defaults*). |
| 1367 | | ;; If you force component to have a NULL pathname, you better arrange |
| 1368 | | ;; for any of its children to explicitly provide a proper absolute pathname |
| 1369 | | ;; wherever a pathname is actually wanted. |
| 1370 | | (let ((parent (component-parent component))) |
| 1371 | | (when parent |
| 1372 | | (component-pathname parent)))) |
| 1373 | | |
| 1374 | | (defmethod component-pathname ((component component)) |
| 1375 | | (if (slot-boundp component 'absolute-pathname) |
| 1376 | | (slot-value component 'absolute-pathname) |
| 1377 | | (let ((pathname |
| 1378 | | (merge-pathnames* |
| 1379 | | (component-relative-pathname component) |
| 1380 | | (pathname-directory-pathname (component-parent-pathname component))))) |
| 1381 | | (unless (or (null pathname) (absolute-pathname-p pathname)) |
| 1382 | | (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>") |
| 1383 | | pathname (component-find-path component))) |
| 1384 | | (setf (slot-value component 'absolute-pathname) pathname) |
| 1385 | | pathname))) |
| 1386 | | |
| 1387 | | (defmethod component-property ((c component) property) |
| 1388 | | (cdr (assoc property (slot-value c 'properties) :test #'equal))) |
| 1389 | | |
| 1390 | | (defmethod (setf component-property) (new-value (c component) property) |
| 1391 | | (let ((a (assoc property (slot-value c 'properties) :test #'equal))) |
| 1392 | | (if a |
| 1393 | | (setf (cdr a) new-value) |
| 1394 | | (setf (slot-value c 'properties) |
| 1395 | | (acons property new-value (slot-value c 'properties))))) |
| 1396 | | new-value) |
| 1397 | | |
| 1398 | | (defvar *default-encoding* :default |
| 1399 | | "Default encoding for source files. |
| 1400 | | The default value :default preserves the legacy behavior. |
| 1401 | | A future default might be :utf-8 or :autodetect |
| 1402 | | reading emacs-style -*- coding: utf-8 -*- specifications, |
| 1403 | | and falling back to utf-8 or latin1 if nothing is specified.") |
| 1404 | | |
| 1405 | | (defparameter *utf-8-external-format* |
| 1406 | | #+(and asdf-unicode (not clisp)) :utf-8 |
| 1407 | | #+(and asdf-unicode clisp) charset:utf-8 |
| 1408 | | #-asdf-unicode :default |
| 1409 | | "Default :external-format argument to pass to CL:OPEN and also |
| 1410 | | CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. |
| 1411 | | On modern implementations, this will decode UTF-8 code points as CL characters. |
| 1412 | | On legacy implementations, it may fall back on some 8-bit encoding, |
| 1413 | | with non-ASCII code points being read as several CL characters; |
| 1414 | | hopefully, if done consistently, that won't affect program behavior too much.") |
| 1415 | | |
| 1416 | | (defun* always-default-encoding (pathname) |
| 1417 | | (declare (ignore pathname)) |
| 1418 | | *default-encoding*) |
| 1419 | | |
| 1420 | | (defvar *encoding-detection-hook* #'always-default-encoding |
| 1421 | | "Hook for an extension to define a function to automatically detect a file's encoding") |
| 1422 | | |
| 1423 | | (defun* detect-encoding (pathname) |
| 1424 | | (funcall *encoding-detection-hook* pathname)) |
| 1425 | | |
| 1426 | | (defmethod component-encoding ((c component)) |
| 1427 | | (or (loop :for x = c :then (component-parent x) |
| 1428 | | :while x :thereis (%component-encoding x)) |
| 1429 | | (detect-encoding (component-pathname c)))) |
| 1430 | | |
| 1431 | | (defun* default-encoding-external-format (encoding) |
| 1432 | | (case encoding |
| 1433 | | (:default :default) ;; for backwards compatibility only. Explicit usage discouraged. |
| 1434 | | (:utf-8 *utf-8-external-format*) |
| 1435 | | (otherwise |
| 1436 | | (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding) |
| 1437 | | :default))) |
| 1438 | | |
| 1439 | | (defvar *encoding-external-format-hook* |
| 1440 | | #'default-encoding-external-format |
| 1441 | | "Hook for an extension to define a mapping between non-default encodings |
| 1442 | | and implementation-defined external-format's") |
| 1443 | | |
| 1444 | | (defun encoding-external-format (encoding) |
| 1445 | | (funcall *encoding-external-format-hook* encoding)) |
| 1446 | | |
| 1447 | | (defmethod component-external-format ((c component)) |
| 1448 | | (encoding-external-format (component-encoding c))) |
| 1449 | | |
| 1450 | | (defclass proto-system () ; slots to keep when resetting a system |
| 1451 | | ;; To preserve identity for all objects, we'd need keep the components slots |
| 1452 | | ;; but also to modify parse-component-form to reset the recycled objects. |
| 1453 | | ((name) #|(components) (components-by-names)|#)) |
| 1454 | | |
| 1455 | | (defclass system (module proto-system) |
| 1456 | | (;; description and long-description are now available for all component's, |
| 1457 | | ;; but now also inherited from component, but we add the legacy accessor |
| 1458 | | (description :accessor system-description :initarg :description) |
| 1459 | | (long-description :accessor system-long-description :initarg :long-description) |
| 1460 | | (author :accessor system-author :initarg :author) |
| 1461 | | (maintainer :accessor system-maintainer :initarg :maintainer) |
| 1462 | | (licence :accessor system-licence :initarg :licence |
| 1463 | | :accessor system-license :initarg :license) |
| 1464 | | (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL |
| 1465 | | (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) |
| 1466 | | |
| 1467 | | ;;;; ------------------------------------------------------------------------- |
| 1468 | | ;;;; version-satisfies |
| 1469 | | |
| 1470 | | (defmethod version-satisfies ((c component) version) |
| 1471 | | (unless (and version (slot-boundp c 'version)) |
| 1472 | | (when version |
| 1473 | | (warn "Requested version ~S but component ~S has no version" version c)) |
| 1474 | | (return-from version-satisfies t)) |
| 1475 | | (version-satisfies (component-version c) version)) |
| 1476 | | |
| 1477 | | (defun* asdf-version () |
| 1478 | | "Exported interface to the version of ASDF currently installed. A string. |
| 1479 | | You can compare this string with e.g.: |
| 1480 | | (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." |
| 1481 | | *asdf-version*) |
| 1482 | | |
| 1483 | | (defun* parse-version (string &optional on-error) |
| 1484 | | "Parse a version string as a series of natural integers separated by dots. |
| 1485 | | Return a (non-null) list of integers if the string is valid, NIL otherwise. |
| 1486 | | If on-error is error, warn, or designates a function of compatible signature, |
| 1487 | | the function is called with an explanation of what is wrong with the argument. |
| 1488 | | NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" |
| 1489 | | (and |
| 1490 | | (or (stringp string) |
| 1491 | | (when on-error |
| 1492 | | (funcall on-error "~S: ~S is not a string" |
| 1493 | | 'parse-version string)) nil) |
| 1494 | | (or (loop :for prev = nil :then c :for c :across string |
| 1495 | | :always (or (digit-char-p c) |
| 1496 | | (and (eql c #\.) prev (not (eql prev #\.)))) |
| 1497 | | :finally (return (and c (digit-char-p c)))) |
| 1498 | | (when on-error |
| 1499 | | (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" |
| 1500 | | 'parse-version string)) nil) |
| 1501 | | (mapcar #'parse-integer (split-string string :separator ".")))) |
| 1502 | | |
| 1503 | | (defmethod version-satisfies ((cver string) version) |
| 1504 | | (let ((x (parse-version cver 'warn)) |
| 1505 | | (y (parse-version version 'warn))) |
| 1506 | | (labels ((bigger (x y) |
| 1507 | | (cond ((not y) t) |
| 1508 | | ((not x) nil) |
| 1509 | | ((> (car x) (car y)) t) |
| 1510 | | ((= (car x) (car y)) |
| 1511 | | (bigger (cdr x) (cdr y)))))) |
| 1512 | | (and x y (= (car x) (car y)) |
| 1513 | | (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) |
| | 2036 | (defun* subpathp (maybe-subpath base-pathname) |
| | 2037 | (and (pathnamep maybe-subpath) (pathnamep base-pathname) |
| | 2038 | (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) |
| | 2039 | (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) |
| | 2040 | (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) |
| | 2041 | (with-pathname-defaults () |
| | 2042 | (let ((enough (enough-namestring maybe-subpath base-pathname))) |
| | 2043 | (and (relative-pathname-p enough) (pathname enough)))))) |
| | 2044 | |
| | 2045 | |
| | 2046 | ;;; Resolving symlinks somewhat |
| | 2047 | (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) |
| | 2048 | "Resolve as much of a pathname as possible" |
| | 2049 | (block nil |
| | 2050 | (when (typep pathname '(or null logical-pathname)) (return pathname)) |
| | 2051 | (let ((p (merge-pathnames* pathname defaults))) |
| | 2052 | (when (logical-pathname-p p) (return p)) |
| | 2053 | (let ((found (probe-file* p :truename t))) |
| | 2054 | (when found (return found))) |
| | 2055 | (unless (absolute-pathname-p p) |
| | 2056 | (let ((true-defaults (truename* defaults))) |
| | 2057 | (when true-defaults |
| | 2058 | (setf p (merge-pathnames pathname true-defaults))))) |
| | 2059 | (unless (absolute-pathname-p p) (return p)) |
| | 2060 | (let ((sofar (probe-file* (pathname-root p) :truename t))) |
| | 2061 | (unless sofar (return p)) |
| | 2062 | (flet ((solution (directories) |
| | 2063 | (merge-pathnames* |
| | 2064 | (make-pathname* :host nil :device nil |
| | 2065 | :directory `(:relative ,@directories) |
| | 2066 | :name (pathname-name p) |
| | 2067 | :type (pathname-type p) |
| | 2068 | :version (pathname-version p)) |
| | 2069 | sofar))) |
| | 2070 | (loop :with directory = (normalize-pathname-directory-component |
| | 2071 | (pathname-directory p)) |
| | 2072 | :for dir :in (cdr directory) |
| | 2073 | :for rest :on (cdr directory) |
| | 2074 | :for more = (probe-file* |
| | 2075 | (merge-pathnames* |
| | 2076 | (make-pathname* :directory `(:relative ,dir)) |
| | 2077 | sofar) :truename t) :do |
| | 2078 | (if more |
| | 2079 | (setf sofar more) |
| | 2080 | (return (solution rest))) |
| | 2081 | :finally |
| | 2082 | (return (solution nil)))))))) |
| | 2083 | |
| | 2084 | (defun* resolve-symlinks (path) |
| | 2085 | #-allegro (truenamize path) |
| | 2086 | #+allegro |
| | 2087 | (if (physical-pathname-p path) |
| | 2088 | (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) |
| | 2089 | path)) |
| | 2090 | |
| | 2091 | (defun* resolve-symlinks* (path) |
| | 2092 | (if *resolve-symlinks* |
| | 2093 | (and path (resolve-symlinks path)) |
| | 2094 | path)) |
| | 2095 | |
| | 2096 | |
| | 2097 | ;;; absolute vs relative |
| | 2098 | (defun* ensure-pathname-absolute (path &optional defaults (on-error 'error)) |
| | 2099 | (cond |
| | 2100 | ((absolute-pathname-p path)) |
| | 2101 | ((stringp path) (ensure-pathname-absolute (pathname path) defaults)) |
| | 2102 | ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) |
| | 2103 | ((absolute-pathname-p defaults) |
| | 2104 | (or (absolute-pathname-p (merge-pathnames* path defaults)) |
| | 2105 | (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" |
| | 2106 | path defaults))) |
| | 2107 | (t (call-function on-error |
| | 2108 | "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" |
| | 2109 | path defaults)))) |
| | 2110 | |
| | 2111 | (defun relativize-directory-component (directory-component) |
| | 2112 | (let ((directory (normalize-pathname-directory-component directory-component))) |
| | 2113 | (cond |
| | 2114 | ((stringp directory) |
| | 2115 | (list :relative directory)) |
| | 2116 | ((eq (car directory) :absolute) |
| | 2117 | (cons :relative (cdr directory))) |
| | 2118 | (t |
| | 2119 | directory)))) |
| | 2120 | |
| | 2121 | (defun* relativize-pathname-directory (pathspec) |
| | 2122 | (let ((p (pathname pathspec))) |
| | 2123 | (make-pathname* |
| | 2124 | :directory (relativize-directory-component (pathname-directory p)) |
| | 2125 | :defaults p))) |
| | 2126 | |
| | 2127 | |
| | 2128 | ;;; Simple filesystem operations |
| | 2129 | (defun* ensure-all-directories-exist (pathnames) |
| | 2130 | (dolist (pathname pathnames) |
| | 2131 | (ensure-directories-exist (translate-logical-pathname pathname)))) |
| | 2132 | |
| | 2133 | (defun* rename-file-overwriting-target (source target) |
| | 2134 | #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic |
| | 2135 | (posix:copy-file source target :method :rename) |
| | 2136 | #-clisp |
| | 2137 | (rename-file source target |
| | 2138 | #+clozure :if-exists #+clozure :rename-and-delete)) |
| | 2139 | |
| | 2140 | (defun* delete-file-if-exists (x) |
| | 2141 | (when (probe-file* x) |
| | 2142 | (delete-file x))) |
| | 2143 | |
| | 2144 | ;;; Translate a pathname |
| | 2145 | (defun* (translate-pathname*) (path absolute-source destination &optional root source) |
| | 2146 | (declare (ignore source)) |
| | 2147 | (cond |
| | 2148 | ((functionp destination) |
| | 2149 | (funcall destination path absolute-source)) |
| | 2150 | ((eq destination t) |
| | 2151 | path) |
| | 2152 | ((not (pathnamep destination)) |
| | 2153 | (error "Invalid destination")) |
| | 2154 | ((not (absolute-pathname-p destination)) |
| | 2155 | (translate-pathname path absolute-source (merge-pathnames* destination root))) |
| | 2156 | (root |
| | 2157 | (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) |
| | 2158 | (t |
| | 2159 | (translate-pathname path absolute-source destination)))) |
| | 2160 | |
| | 2161 | |
| | 2162 | ;;; Temporary pathnames |
| | 2163 | (defun* add-pathname-suffix (pathname suffix) |
| | 2164 | (make-pathname :name (strcat (pathname-name pathname) suffix) |
| | 2165 | :defaults pathname)) |
| | 2166 | |
| | 2167 | (defun* tmpize-pathname (x) |
| | 2168 | (add-pathname-suffix x "-ASDF-TMP")) |
| | 2169 | |
| | 2170 | (defun* call-with-staging-pathname (pathname fun) |
| | 2171 | "Calls fun with a staging pathname, and atomically |
| | 2172 | renames the staging pathname to the pathname in the end. |
| | 2173 | Note: this protects only against failure of the program, |
| | 2174 | not against concurrent attempts. |
| | 2175 | For the latter case, we ought pick random suffix and atomically open it." |
| | 2176 | (let* ((pathname (pathname pathname)) |
| | 2177 | (staging (tmpize-pathname pathname))) |
| | 2178 | (unwind-protect |
| | 2179 | (multiple-value-prog1 |
| | 2180 | (funcall fun staging) |
| | 2181 | (rename-file-overwriting-target staging pathname)) |
| | 2182 | (delete-file-if-exists staging)))) |
| | 2183 | |
| | 2184 | (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) |
| | 2185 | `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) |
| | 2186 | |
| | 2187 | ;;; Basic pathnames |
| | 2188 | (defun* sane-physical-pathname (&key defaults (keep t) fallback want-existing) |
| | 2189 | (flet ((sanitize (x) |
| | 2190 | (setf x (and x (ignore-errors (translate-logical-pathname x)))) |
| | 2191 | (when (pathnamep x) |
| | 2192 | (setf x |
| | 2193 | (ecase keep |
| | 2194 | ((t) x) |
| | 2195 | ((:directory) (pathname-directory-pathname x)) |
| | 2196 | ((:root) (pathname-root x)) |
| | 2197 | ((:host) (pathname-host-pathname x)) |
| | 2198 | ((nil) (nil-pathname x)))) |
| | 2199 | (when want-existing ;; CCL's probe-file will choke if d-p-d is logical |
| | 2200 | (setf x (probe-file* x))) |
| | 2201 | (and (physical-pathname-p x) x)))) |
| | 2202 | (or (sanitize defaults) |
| | 2203 | (when fallback |
| | 2204 | (or (sanitize (nil-pathname)) |
| | 2205 | (sanitize (ignore-errors (user-homedir-pathname))))) |
| | 2206 | (error "Could not find a sane a physical pathname~ |
| | 2207 | ~@[ from ~S~]~@[~:*~@[ or~*~] fallbacks~]" |
| | 2208 | defaults fallback)))) |
| | 2209 | |
| | 2210 | (defun* root-pathname () |
| | 2211 | "On a Unix system, this will presumably be the root pathname /. |
| | 2212 | Otherwise, this will be the root of some implementation-dependent filesystem host." |
| | 2213 | (sane-physical-pathname :keep :root :fallback t)) |
| | 2214 | |
| 1589 | | ;;;; ------------------------------------------------------------------------- |
| 1590 | | ;;;; Finding systems |
| 1591 | | |
| 1592 | | (defun* make-defined-systems-table () |
| 1593 | | (make-hash-table :test 'equal)) |
| 1594 | | |
| 1595 | | (defvar *defined-systems* (make-defined-systems-table) |
| 1596 | | "This is a hash table whose keys are strings, being the |
| 1597 | | names of the systems, and whose values are pairs, the first |
| 1598 | | element of which is a universal-time indicating when the |
| 1599 | | system definition was last updated, and the second element |
| 1600 | | of which is a system object.") |
| 1601 | | |
| 1602 | | (defun* coerce-name (name) |
| 1603 | | (typecase name |
| 1604 | | (component (component-name name)) |
| 1605 | | (symbol (string-downcase (symbol-name name))) |
| 1606 | | (string name) |
| 1607 | | (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) |
| 1608 | | |
| 1609 | | (defun* system-registered-p (name) |
| 1610 | | (gethash (coerce-name name) *defined-systems*)) |
| 1611 | | |
| 1612 | | (defun* registered-systems () |
| 1613 | | (loop :for (() . system) :being :the :hash-values :of *defined-systems* |
| 1614 | | :collect (coerce-name system))) |
| 1615 | | |
| 1616 | | (defun* register-system (system) |
| 1617 | | (check-type system system) |
| 1618 | | (let ((name (component-name system))) |
| 1619 | | (check-type name string) |
| 1620 | | (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) |
| 1621 | | (unless (eq system (cdr (gethash name *defined-systems*))) |
| 1622 | | (setf (gethash name *defined-systems*) |
| 1623 | | (cons (get-universal-time) system))))) |
| 1624 | | |
| 1625 | | (defun* clear-system (name) |
| 1626 | | "Clear the entry for a system in the database of systems previously loaded. |
| 1627 | | Note that this does NOT in any way cause the code of the system to be unloaded." |
| 1628 | | ;; There is no "unload" operation in Common Lisp, and |
| 1629 | | ;; a general such operation cannot be portably written, |
| 1630 | | ;; considering how much CL relies on side-effects to global data structures. |
| 1631 | | (remhash (coerce-name name) *defined-systems*)) |
| 1632 | | |
| 1633 | | (defun* map-systems (fn) |
| 1634 | | "Apply FN to each defined system. |
| 1635 | | |
| 1636 | | FN should be a function of one argument. It will be |
| 1637 | | called with an object of type asdf:system." |
| 1638 | | (loop :for (nil . system) :being :the hash-values :of *defined-systems* |
| 1639 | | :do (funcall fn system))) |
| 1640 | | |
| 1641 | | ;;; for the sake of keeping things reasonably neat, we adopt a |
| 1642 | | ;;; convention that functions in this list are prefixed SYSDEF- |
| 1643 | | |
| 1644 | | (defvar *system-definition-search-functions* '()) |
| 1645 | | |
| 1646 | | (setf *system-definition-search-functions* |
| 1647 | | (append |
| 1648 | | ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. |
| 1649 | | (remove 'contrib-sysdef-search *system-definition-search-functions*) |
| 1650 | | ;; Tuck our defaults at the end of the list if they were absent. |
| 1651 | | ;; This is imperfect, in case they were removed on purpose, |
| 1652 | | ;; but then it will be the responsibility of whoever does that |
| 1653 | | ;; to upgrade asdf before he does such a thing rather than after. |
| 1654 | | (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) |
| 1655 | | '(sysdef-central-registry-search |
| 1656 | | sysdef-source-registry-search |
| 1657 | | sysdef-find-asdf)))) |
| 1658 | | |
| 1659 | | (defun* search-for-system-definition (system) |
| 1660 | | (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) |
| 1661 | | (cons 'find-system-if-being-defined |
| 1662 | | *system-definition-search-functions*))) |
| 1663 | | |
| 1664 | | (defvar *central-registry* nil |
| 1665 | | "A list of 'system directory designators' ASDF uses to find systems. |
| 1666 | | |
| 1667 | | A 'system directory designator' is a pathname or an expression |
| 1668 | | which evaluates to a pathname. For example: |
| 1669 | | |
| 1670 | | (setf asdf:*central-registry* |
| 1671 | | (list '*default-pathname-defaults* |
| 1672 | | #p\"/home/me/cl/systems/\" |
| 1673 | | #p\"/usr/share/common-lisp/systems/\")) |
| 1674 | | |
| 1675 | | This is for backward compatibilily. |
| 1676 | | Going forward, we recommend new users should be using the source-registry. |
| 1677 | | ") |
| 1678 | | |
| 1679 | | (defun* featurep (x &optional (features *features*)) |
| 1680 | | (cond |
| 1681 | | ((atom x) |
| 1682 | | (and (member x features) t)) |
| 1683 | | ((eq :not (car x)) |
| 1684 | | (assert (null (cddr x))) |
| 1685 | | (not (featurep (cadr x) features))) |
| 1686 | | ((eq :or (car x)) |
| 1687 | | (some #'(lambda (x) (featurep x features)) (cdr x))) |
| 1688 | | ((eq :and (car x)) |
| 1689 | | (every #'(lambda (x) (featurep x features)) (cdr x))) |
| 1690 | | (t |
| 1691 | | (error "Malformed feature specification ~S" x)))) |
| 1692 | | |
| 1693 | | (defun* os-unix-p () |
| 1694 | | (featurep '(:or :unix :cygwin :darwin))) |
| 1695 | | |
| 1696 | | (defun* os-windows-p () |
| 1697 | | (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) |
| 1698 | | |
| 1699 | | (defun* probe-asd (name defaults) |
| | 2291 | |
| | 2292 | ;;; Check pathname constraints |
| | 2293 | |
| | 2294 | (defun* ensure-pathname |
| | 2295 | (pathname &key |
| | 2296 | on-error |
| | 2297 | defaults type dot-dot |
| | 2298 | want-pathname |
| | 2299 | want-logical want-physical ensure-physical |
| | 2300 | want-relative want-absolute ensure-absolute ensure-subpath |
| | 2301 | want-non-wild want-wild wilden |
| | 2302 | want-file want-directory ensure-directory |
| | 2303 | want-existing ensure-directories-exist |
| | 2304 | truename resolve-symlinks truenamize |
| | 2305 | &aux (p pathname)) ;; mutable working copy, preserve original |
| | 2306 | "Coerces its argument into a PATHNAME, |
| | 2307 | optionally doing some transformations and checking specified constraints. |
| | 2308 | |
| | 2309 | If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. |
| | 2310 | |
| | 2311 | If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING |
| | 2312 | reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE; |
| | 2313 | then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true, |
| | 2314 | and the all the checks and transformations are run. |
| | 2315 | |
| | 2316 | Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. |
| | 2317 | The boolean T is an alias for ERROR. |
| | 2318 | ERROR means that an error will be raised if the constraint is not satisfied. |
| | 2319 | CERROR means that an continuable error will be raised if the constraint is not satisfied. |
| | 2320 | IGNORE means just return NIL instead of the pathname. |
| | 2321 | |
| | 2322 | The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) |
| | 2323 | that will be called with the the following arguments: |
| | 2324 | a generic format string for ensure pathname, the pathname, |
| | 2325 | the keyword argument corresponding to the failed check or transformation, |
| | 2326 | a format string for the reason ENSURE-PATHNAME failed, |
| | 2327 | and a list with arguments to that format string. |
| | 2328 | If ON-ERROR is NIL, ERROR is used instead, which does the right thing. |
| | 2329 | You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). |
| | 2330 | |
| | 2331 | The transformations and constraint checks are done in this order, |
| | 2332 | which is also the order in the lambda-list: |
| | 2333 | |
| | 2334 | WANT-PATHNAME checks that pathname (after parsing if needed) is not null. |
| | 2335 | Otherwise, if the pathname is NIL, ensure-pathname returns NIL. |
| | 2336 | WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME |
| | 2337 | WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME |
| | 2338 | ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME |
| | 2339 | WANT-RELATIVE checks that pathname has a relative directory component |
| | 2340 | WANT-ABSOLUTE checks that pathname does have an absolute directory component |
| | 2341 | ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again |
| | 2342 | that the result absolute is an absolute pathname indeed. |
| | 2343 | ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. |
| | 2344 | WANT-FILE checks that pathname has a non-nil FILE component |
| | 2345 | WANT-DIRECTORY checks that pathname has nil FILE and TYPE components |
| | 2346 | ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret |
| | 2347 | any file and type components as being actually a last directory component. |
| | 2348 | WANT-NON-WILD checks that pathname is not a wild pathname |
| | 2349 | WANT-WILD checks that pathname is a wild pathname |
| | 2350 | WILDEN merges the pathname with **/*.*.* if it is not wild |
| | 2351 | WANT-EXISTING checks that a file (or directory) exists with that pathname. |
| | 2352 | ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. |
| | 2353 | TRUENAME replaces the pathname by its truename, or errors if not possible. |
| | 2354 | RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. |
| | 2355 | TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." |
| 1701 | | (when (directory-pathname-p defaults) |
| 1702 | | (let* ((file (probe-file* (subpathname defaults (strcat name ".asd"))))) |
| 1703 | | (when file |
| 1704 | | (return file))) |
| 1705 | | #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) |
| 1706 | | (when (os-windows-p) |
| 1707 | | (let ((shortcut |
| 1708 | | (make-pathname |
| 1709 | | :defaults defaults :version :newest :case :local |
| 1710 | | :name (strcat name ".asd") |
| 1711 | | :type "lnk"))) |
| 1712 | | (when (probe-file* shortcut) |
| 1713 | | (let ((target (parse-windows-shortcut shortcut))) |
| 1714 | | (when target |
| 1715 | | (return (pathname target)))))))))) |
| 1716 | | |
| 1717 | | (defun* sysdef-central-registry-search (system) |
| 1718 | | (let ((name (coerce-name system)) |
| 1719 | | (to-remove nil) |
| 1720 | | (to-replace nil)) |
| 1721 | | (block nil |
| 1722 | | (unwind-protect |
| 1723 | | (dolist (dir *central-registry*) |
| 1724 | | (let ((defaults (eval dir))) |
| 1725 | | (when defaults |
| 1726 | | (cond ((directory-pathname-p defaults) |
| 1727 | | (let ((file (probe-asd name defaults))) |
| 1728 | | (when file |
| 1729 | | (return file)))) |
| 1730 | | (t |
| 1731 | | (restart-case |
| 1732 | | (let* ((*print-circle* nil) |
| 1733 | | (message |
| 1734 | | (format nil |
| 1735 | | (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") |
| 1736 | | system dir defaults))) |
| 1737 | | (error message)) |
| 1738 | | (remove-entry-from-registry () |
| 1739 | | :report "Remove entry from *central-registry* and continue" |
| 1740 | | (push dir to-remove)) |
| 1741 | | (coerce-entry-to-directory () |
| 1742 | | :report (lambda (s) |
| 1743 | | (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") |
| 1744 | | (ensure-directory-pathname defaults) dir)) |
| 1745 | | (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) |
| 1746 | | ;; cleanup |
| 1747 | | (dolist (dir to-remove) |
| 1748 | | (setf *central-registry* (remove dir *central-registry*))) |
| 1749 | | (dolist (pair to-replace) |
| 1750 | | (let* ((current (car pair)) |
| 1751 | | (new (cdr pair)) |
| 1752 | | (position (position current *central-registry*))) |
| 1753 | | (setf *central-registry* |
| 1754 | | (append (subseq *central-registry* 0 position) |
| 1755 | | (list new) |
| 1756 | | (subseq *central-registry* (1+ position)))))))))) |
| 1757 | | |
| 1758 | | (defun* make-temporary-package () |
| 1759 | | (flet ((try (counter) |
| 1760 | | (ignore-errors |
| 1761 | | (make-package (format nil "~A~D" :asdf counter) |
| 1762 | | :use '(:cl :asdf))))) |
| 1763 | | (do* ((counter 0 (+ counter 1)) |
| 1764 | | (package (try counter) (try counter))) |
| 1765 | | (package package)))) |
| 1766 | | |
| 1767 | | (defun* safe-file-write-date (pathname) |
| 1768 | | ;; If FILE-WRITE-DATE returns NIL, it's possible that |
| 1769 | | ;; the user or some other agent has deleted an input file. |
| 1770 | | ;; Also, generated files will not exist at the time planning is done |
| 1771 | | ;; and calls operation-done-p which calls safe-file-write-date. |
| 1772 | | ;; So it is very possible that we can't get a valid file-write-date, |
| 1773 | | ;; and we can survive and we will continue the planning |
| 1774 | | ;; as if the file were very old. |
| 1775 | | ;; (or should we treat the case in a different, special way?) |
| 1776 | | (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) |
| 1777 | | (progn |
| 1778 | | (when (and pathname *asdf-verbose*) |
| 1779 | | (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>") |
| 1780 | | pathname)) |
| 1781 | | 0))) |
| 1782 | | |
| 1783 | | (defmethod find-system ((name null) &optional (error-p t)) |
| 1784 | | (declare (ignorable name)) |
| 1785 | | (when error-p |
| 1786 | | (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) |
| 1787 | | |
| 1788 | | (defmethod find-system (name &optional (error-p t)) |
| 1789 | | (find-system (coerce-name name) error-p)) |
| 1790 | | |
| 1791 | | (defvar *systems-being-defined* nil |
| 1792 | | "A hash-table of systems currently being defined keyed by name, or NIL") |
| 1793 | | (defvar *systems-being-operated* nil |
| 1794 | | "A boolean indicating that some systems are being operated on") |
| 1795 | | |
| 1796 | | (defun* find-system-if-being-defined (name) |
| 1797 | | (when *systems-being-defined* |
| 1798 | | (gethash (coerce-name name) *systems-being-defined*))) |
| 1799 | | |
| 1800 | | (defun* call-with-system-definitions (thunk) |
| 1801 | | (if *systems-being-defined* |
| 1802 | | (funcall thunk) |
| 1803 | | (let ((*systems-being-defined* (make-hash-table :test 'equal))) |
| 1804 | | (funcall thunk)))) |
| 1805 | | |
| 1806 | | (defmacro with-system-definitions ((&optional) &body body) |
| 1807 | | `(call-with-system-definitions #'(lambda () ,@body))) |
| 1808 | | |
| 1809 | | (defun* load-sysdef (name pathname) |
| 1810 | | ;; Tries to load system definition with canonical NAME from PATHNAME. |
| 1811 | | (with-system-definitions () |
| 1812 | | (let ((package (make-temporary-package))) |
| 1813 | | (unwind-protect |
| 1814 | | (handler-bind |
| 1815 | | ((error #'(lambda (condition) |
| 1816 | | (error 'load-system-definition-error |
| 1817 | | :name name :pathname pathname |
| 1818 | | :condition condition)))) |
| 1819 | | (let ((*package* package) |
| 1820 | | (*default-pathname-defaults* |
| 1821 | | ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. |
| 1822 | | (pathname-directory-pathname (translate-logical-pathname pathname))) |
| 1823 | | (external-format (encoding-external-format (detect-encoding pathname)))) |
| 1824 | | (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") |
| 1825 | | pathname package) |
| 1826 | | (load pathname :external-format external-format))) |
| 1827 | | (delete-package package))))) |
| 1828 | | |
| 1829 | | (defun* locate-system (name) |
| 1830 | | "Given a system NAME designator, try to locate where to load the system from. |
| 1831 | | Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME |
| 1832 | | FOUNDP is true when a system was found, |
| 1833 | | either a new unregistered one or a previously registered one. |
| 1834 | | FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is |
| 1835 | | PATHNAME when not null is a path from where to load the system, |
| 1836 | | either associated with FOUND-SYSTEM, or with the PREVIOUS system. |
| 1837 | | PREVIOUS when not null is a previously loaded SYSTEM object of same name. |
| 1838 | | PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." |
| 1839 | | (let* ((name (coerce-name name)) |
| 1840 | | (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk |
| 1841 | | (previous (cdr in-memory)) |
| 1842 | | (previous (and (typep previous 'system) previous)) |
| 1843 | | (previous-time (car in-memory)) |
| 1844 | | (found (search-for-system-definition name)) |
| 1845 | | (found-system (and (typep found 'system) found)) |
| 1846 | | (pathname (or (and (typep found '(or pathname string)) (pathname found)) |
| 1847 | | (and found-system (system-source-file found-system)) |
| 1848 | | (and previous (system-source-file previous)))) |
| 1849 | | (foundp (and (or found-system pathname previous) t))) |
| 1850 | | (check-type found (or null pathname system)) |
| 1851 | | (when foundp |
| 1852 | | (setf pathname (resolve-symlinks* pathname)) |
| 1853 | | (when (and pathname (not (absolute-pathname-p pathname))) |
| 1854 | | (setf pathname (ensure-pathname-absolute pathname)) |
| 1855 | | (when found-system |
| 1856 | | (%set-system-source-file pathname found-system))) |
| 1857 | | (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp |
| 1858 | | (system-source-file previous) pathname))) |
| 1859 | | (%set-system-source-file pathname previous) |
| 1860 | | (setf previous-time nil)) |
| 1861 | | (values foundp found-system pathname previous previous-time)))) |
| 1862 | | |
| 1863 | | (defmethod find-system ((name string) &optional (error-p t)) |
| 1864 | | (with-system-definitions () |
| 1865 | | (loop |
| 1866 | | (restart-case |
| 1867 | | (multiple-value-bind (foundp found-system pathname previous previous-time) |
| 1868 | | (locate-system name) |
| 1869 | | (declare (ignore foundp)) |
| 1870 | | (when (and found-system (not previous)) |
| 1871 | | (register-system found-system)) |
| 1872 | | (when (and pathname |
| 1873 | | (or (not previous-time) |
| 1874 | | ;; don't reload if it's already been loaded, |
| 1875 | | ;; or its filestamp is in the future which means some clock is skewed |
| 1876 | | ;; and trying to load might cause an infinite loop. |
| 1877 | | (< previous-time (safe-file-write-date pathname) (get-universal-time)))) |
| 1878 | | (load-sysdef name pathname)) |
| 1879 | | (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed |
| 1880 | | (return |
| 1881 | | (cond |
| 1882 | | (in-memory |
| 1883 | | (when pathname |
| 1884 | | (setf (car in-memory) (safe-file-write-date pathname))) |
| 1885 | | (cdr in-memory)) |
| 1886 | | (error-p |
| 1887 | | (error 'missing-component :requires name)))))) |
| 1888 | | (reinitialize-source-registry-and-retry () |
| 1889 | | :report (lambda (s) |
| 1890 | | (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) |
| 1891 | | (initialize-source-registry)))))) |
| 1892 | | |
| 1893 | | (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) |
| 1894 | | (setf fallback (coerce-name fallback) |
| 1895 | | requested (coerce-name requested)) |
| 1896 | | (when (equal requested fallback) |
| 1897 | | (let ((registered (cdr (gethash fallback *defined-systems*)))) |
| 1898 | | (or registered |
| 1899 | | (apply 'make-instance 'system |
| 1900 | | :name fallback :source-file source-file keys))))) |
| 1901 | | |
| 1902 | | (defun* sysdef-find-asdf (name) |
| 1903 | | ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. |
| 1904 | | (find-system-fallback name "asdf" :version *asdf-version*)) |
| 1905 | | |
| 1906 | | |
| 1907 | | ;;;; ------------------------------------------------------------------------- |
| 1908 | | ;;;; Finding components |
| 1909 | | |
| 1910 | | (defmethod find-component ((base string) path) |
| 1911 | | (let ((s (find-system base nil))) |
| 1912 | | (and s (find-component s path)))) |
| 1913 | | |
| 1914 | | (defmethod find-component ((base symbol) path) |
| 1915 | | (cond |
| 1916 | | (base (find-component (coerce-name base) path)) |
| 1917 | | (path (find-component path nil)) |
| 1918 | | (t nil))) |
| 1919 | | |
| 1920 | | (defmethod find-component ((base cons) path) |
| 1921 | | (find-component (car base) (cons (cdr base) path))) |
| 1922 | | |
| 1923 | | (defmethod find-component ((module module) (name string)) |
| 1924 | | (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! |
| 1925 | | (compute-module-components-by-name module)) |
| 1926 | | (values (gethash name (module-components-by-name module)))) |
| 1927 | | |
| 1928 | | (defmethod find-component ((component component) (name symbol)) |
| 1929 | | (if name |
| 1930 | | (find-component component (coerce-name name)) |
| 1931 | | component)) |
| 1932 | | |
| 1933 | | (defmethod find-component ((module module) (name cons)) |
| 1934 | | (find-component (find-component module (car name)) (cdr name))) |
| 1935 | | |
| 1936 | | |
| 1937 | | ;;; component subclasses |
| 1938 | | |
| 1939 | | (defclass source-file (component) |
| 1940 | | ((type :accessor source-file-explicit-type :initarg :type :initform nil))) |
| 1941 | | |
| 1942 | | (defclass cl-source-file (source-file) |
| 1943 | | ((type :initform "lisp"))) |
| 1944 | | (defclass cl-source-file.cl (cl-source-file) |
| 1945 | | ((type :initform "cl"))) |
| 1946 | | (defclass cl-source-file.lsp (cl-source-file) |
| 1947 | | ((type :initform "lsp"))) |
| 1948 | | (defclass c-source-file (source-file) |
| 1949 | | ((type :initform "c"))) |
| 1950 | | (defclass java-source-file (source-file) |
| 1951 | | ((type :initform "java"))) |
| 1952 | | (defclass static-file (source-file) ()) |
| 1953 | | (defclass doc-file (static-file) ()) |
| 1954 | | (defclass html-file (doc-file) |
| 1955 | | ((type :initform "html"))) |
| 1956 | | |
| 1957 | | (defmethod source-file-type ((component module) (s module)) |
| 1958 | | (declare (ignorable component s)) |
| 1959 | | :directory) |
| 1960 | | (defmethod source-file-type ((component source-file) (s module)) |
| 1961 | | (declare (ignorable s)) |
| 1962 | | (source-file-explicit-type component)) |
| 1963 | | |
| 1964 | | (defmethod component-relative-pathname ((component component)) |
| 1965 | | (coerce-pathname |
| 1966 | | (or (slot-value component 'relative-pathname) |
| 1967 | | (component-name component)) |
| 1968 | | :type (source-file-type component (component-system component)) |
| 1969 | | :defaults (component-parent-pathname component))) |
| 1970 | | |
| 1971 | | ;;;; ------------------------------------------------------------------------- |
| 1972 | | ;;;; Operations |
| 1973 | | |
| 1974 | | ;;; one of these is instantiated whenever #'operate is called |
| 1975 | | |
| 1976 | | (defclass operation () |
| 1977 | | (;; as of danb's 2003-03-16 commit e0d02781, :force can be: |
| 1978 | | ;; T to force the inside of the specified system, |
| 1979 | | ;; but not recurse to other systems we depend on. |
| 1980 | | ;; :ALL (or any other atom) to force all systems |
| 1981 | | ;; including other systems we depend on. |
| 1982 | | ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) |
| 1983 | | ;; to force systems named in a given list |
| 1984 | | ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 |
| 1985 | | (forced :initform nil :initarg :force :accessor operation-forced) |
| 1986 | | (forced-not :initform nil :initarg :force-not :accessor operation-forced-not) |
| 1987 | | (original-initargs :initform nil :initarg :original-initargs |
| 1988 | | :accessor operation-original-initargs) |
| 1989 | | (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) |
| 1990 | | (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) |
| 1991 | | (parent :initform nil :initarg :parent :accessor operation-parent))) |
| 1992 | | |
| 1993 | | (defmethod print-object ((o operation) stream) |
| 1994 | | (print-unreadable-object (o stream :type t :identity t) |
| 1995 | | (ignore-errors |
| 1996 | | (prin1 (operation-original-initargs o) stream)))) |
| 1997 | | |
| 1998 | | (defmethod shared-initialize :after ((operation operation) slot-names |
| 1999 | | &key force force-not |
| 2000 | | &allow-other-keys) |
| 2001 | | ;; the &allow-other-keys disables initarg validity checking |
| 2002 | | (declare (ignorable operation slot-names force force-not)) |
| 2003 | | (macrolet ((frob (x) ;; normalize forced and forced-not slots |
| 2004 | | `(when (consp (slot-value operation ',x)) |
| 2005 | | (setf (slot-value operation ',x) |
| 2006 | | (mapcar #'coerce-name (slot-value operation ',x)))))) |
| 2007 | | (frob forced) (frob forced-not)) |
| | 2357 | (flet ((report-error (keyword description &rest arguments) |
| | 2358 | (call-function (or on-error 'error) |
| | 2359 | "Invalid pathname ~S: ~*~?" |
| | 2360 | pathname keyword description arguments))) |
| | 2361 | (macrolet ((err (constraint &rest arguments) |
| | 2362 | `(report-error ',(intern* constraint :keyword) ,@arguments)) |
| | 2363 | (check (constraint condition &rest arguments) |
| | 2364 | `(when ,constraint |
| | 2365 | (unless ,condition (err ,constraint ,@arguments)))) |
| | 2366 | (transform (transform condition expr) |
| | 2367 | `(when ,transform |
| | 2368 | (,@(if condition `(when ,condition) '(progn)) |
| | 2369 | (setf p ,expr))))) |
| | 2370 | (etypecase p |
| | 2371 | ((or null pathname)) |
| | 2372 | (string |
| | 2373 | (setf p (parse-unix-namestring |
| | 2374 | p :defaults defaults :type type :dot-dot dot-dot |
| | 2375 | :ensure-directory ensure-directory :want-relative want-relative)))) |
| | 2376 | (check want-pathname (pathnamep p) "Expected a pathname, not NIL") |
| | 2377 | (unless (pathnamep p) (return nil)) |
| | 2378 | (check want-logical (logical-pathname-p p) "Expected a logical pathname") |
| | 2379 | (check want-physical (physical-pathname-p p) "Expected a physical pathname") |
| | 2380 | (transform ensure-physical () (translate-logical-pathname p)) |
| | 2381 | (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") |
| | 2382 | (check want-relative (relative-pathname-p p) "Expected a relative pathname") |
| | 2383 | (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") |
| | 2384 | (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults)) |
| | 2385 | (check ensure-absolute (absolute-pathname-p p) |
| | 2386 | "Could not make into an absolute pathname even after merging with ~S" defaults) |
| | 2387 | (check ensure-subpath (absolute-pathname-p defaults) |
| | 2388 | "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) |
| | 2389 | (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) |
| | 2390 | (check want-file (file-pathname-p p) "Expected a file pathname") |
| | 2391 | (check want-directory (directory-pathname-p p) "Expected a directory pathname") |
| | 2392 | (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) |
| | 2393 | (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") |
| | 2394 | (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") |
| | 2395 | (transform wilden (not (wild-pathname-p p)) (wilden p)) |
| | 2396 | (when want-existing |
| | 2397 | (let ((existing (probe-file* p :truename truename))) |
| | 2398 | (if existing |
| | 2399 | (when truename |
| | 2400 | (return existing)) |
| | 2401 | (err want-existing "Expected an existing pathname")))) |
| | 2402 | (when ensure-directories-exist (ensure-directories-exist p)) |
| | 2403 | (when truename |
| | 2404 | (let ((truename (truename* p))) |
| | 2405 | (if truename |
| | 2406 | (return truename) |
| | 2407 | (err truename "Can't get a truename for pathname")))) |
| | 2408 | (transform resolve-symlinks () (resolve-symlinks p)) |
| | 2409 | (transform truenamize () (truenamize p)) |
| | 2410 | p)))) |
| | 2411 | |
| | 2412 | |
| | 2413 | (defun absolutize-pathnames |
| | 2414 | (pathnames &key type (resolve-symlinks *resolve-symlinks*) truename) |
| | 2415 | "Given a list of PATHNAMES where each is in the context of the next ones, |
| | 2416 | try to resolve these pathnames into an absolute pathname; first gently, then harder." |
| | 2417 | (block nil |
| | 2418 | (labels ((resolve (x) |
| | 2419 | (or (when truename |
| | 2420 | (absolute-pathname-p (truename* x))) |
| | 2421 | (when resolve-symlinks |
| | 2422 | (absolute-pathname-p (resolve-symlinks x))) |
| | 2423 | (absolute-pathname-p x) |
| | 2424 | (unless resolve-symlinks |
| | 2425 | (absolute-pathname-p (resolve-symlinks x))) |
| | 2426 | (unless truename |
| | 2427 | (absolute-pathname-p (truename* x))) |
| | 2428 | (return nil))) |
| | 2429 | (tryone (x type rest) |
| | 2430 | (resolve (or (absolute-pathname-p x) |
| | 2431 | (subpathname (recurse rest :directory) x :type type)))) |
| | 2432 | (recurse (pathnames type) |
| | 2433 | (if (null pathnames) (return nil) |
| | 2434 | (tryone (first pathnames) type (rest pathnames))))) |
| | 2435 | (recurse pathnames type)))) |
| | 2436 | |
| | 2437 | |
| | 2438 | ;;; Hook for output translations |
| | 2439 | (defvar *output-translation-function* 'identity) |
| | 2440 | ;;;; --------------------------------------------------------------------------- |
| | 2441 | ;;;; Utilities related to streams |
| | 2442 | |
| | 2443 | (asdf/package:define-package :asdf/stream |
| | 2444 | (:recycle :asdf/stream) |
| | 2445 | (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname) |
| | 2446 | (:export |
| | 2447 | #:*default-stream-element-type* #:*stderr* #:setup-stderr |
| | 2448 | #:with-safe-io-syntax #:call-with-safe-io-syntax |
| | 2449 | #:with-output #:output-string #:with-input |
| | 2450 | #:with-input-file #:call-with-input-file |
| | 2451 | #:finish-outputs #:format! #:safe-format! |
| | 2452 | #:copy-stream-to-stream #:concatenate-files |
| | 2453 | #:copy-stream-to-stream-line-by-line |
| | 2454 | #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line |
| | 2455 | #:slurp-stream-forms #:slurp-stream-form |
| | 2456 | #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form |
| | 2457 | #:eval-input #:eval-thunk #:standard-eval-thunk |
| | 2458 | #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding |
| | 2459 | #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format |
| | 2460 | #:*default-encoding* #:*utf-8-external-format*)) |
| | 2461 | (in-package :asdf/stream) |
| | 2462 | |
| | 2463 | (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) |
| | 2464 | "default element-type for open (depends on the current CL implementation)") |
| | 2465 | |
| | 2466 | (defvar *stderr* *error-output* |
| | 2467 | "the original error output stream at startup") |
| | 2468 | |
| | 2469 | (defun setup-stderr () |
| | 2470 | (setf *stderr* |
| | 2471 | #+allegro excl::*stderr* |
| | 2472 | #+clozure ccl::*stderr* |
| | 2473 | #-(or allegro clozure) *error-output*)) |
| | 2474 | (setup-stderr) |
| | 2475 | |
| | 2476 | |
| | 2477 | ;;; Safe syntax |
| | 2478 | |
| | 2479 | (defvar *standard-readtable* (copy-readtable nil)) |
| | 2480 | |
| | 2481 | (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) |
| | 2482 | "Establish safe CL reader options around the evaluation of BODY" |
| | 2483 | `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) |
| | 2484 | |
| | 2485 | (defun* call-with-safe-io-syntax (thunk &key (package :cl)) |
| | 2486 | (with-standard-io-syntax () |
| | 2487 | (let ((*package* (find-package package)) |
| | 2488 | (*readtable* *standard-readtable*) |
| | 2489 | (*read-default-float-format* 'double-float) |
| | 2490 | (*print-readably* nil) |
| | 2491 | (*read-eval* nil)) |
| | 2492 | (funcall thunk)))) |
| | 2493 | |
| | 2494 | |
| | 2495 | ;;; Output to a stream or string, FORMAT-style |
| | 2496 | |
| | 2497 | (defun* call-with-output (output function) |
| | 2498 | "Calls FUNCTION with an actual stream argument, |
| | 2499 | behaving like FORMAT with respect to how stream designators are interpreted: |
| | 2500 | If OUTPUT is a stream, use it as the stream. |
| | 2501 | If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. |
| | 2502 | If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. |
| | 2503 | If OUTPUT is a string with a fill-pointer, use it as a string-output-stream. |
| | 2504 | Otherwise, signal an error." |
| | 2505 | (etypecase output |
| | 2506 | (null |
| | 2507 | (with-output-to-string (stream) (funcall function stream))) |
| | 2508 | ((eql t) |
| | 2509 | (funcall function *standard-output*)) |
| | 2510 | (stream |
| | 2511 | (funcall function output)) |
| | 2512 | (string |
| | 2513 | (assert (fill-pointer output)) |
| | 2514 | (with-output-to-string (stream output) (funcall function stream))))) |
| | 2515 | |
| | 2516 | (defmacro with-output ((output-var &optional (value output-var)) &body body) |
| | 2517 | "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) |
| | 2518 | as per FORMAT, and evaluate BODY within the scope of this binding." |
| | 2519 | `(call-with-output ,value #'(lambda (,output-var) ,@body))) |
| | 2520 | |
| | 2521 | (defun* output-string (string &optional output) |
| | 2522 | "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" |
| | 2523 | (if output |
| | 2524 | (with-output (output) (princ string output)) |
| | 2525 | string)) |
| | 2526 | |
| | 2527 | |
| | 2528 | ;;; Input helpers |
| | 2529 | |
| | 2530 | (defun* call-with-input (input function) |
| | 2531 | "Calls FUNCTION with an actual stream argument, interpreting |
| | 2532 | stream designators like READ, but also coercing strings to STRING-INPUT-STREAM. |
| | 2533 | If INPUT is a STREAM, use it as the stream. |
| | 2534 | If INPUT is NIL, use a *STANDARD-INPUT* as the stream. |
| | 2535 | If INPUT is T, use *TERMINAL-IO* as the stream. |
| | 2536 | As an extension, if INPUT is a string, use it as a string-input-stream. |
| | 2537 | Otherwise, signal an error." |
| | 2538 | (etypecase input |
| | 2539 | (null (funcall function *standard-input*)) |
| | 2540 | ((eql t) (funcall function *terminal-io*)) |
| | 2541 | (stream (funcall function input)) |
| | 2542 | (string (with-input-from-string (stream input) (funcall function stream))))) |
| | 2543 | |
| | 2544 | (defmacro with-input ((input-var &optional (value input-var)) &body body) |
| | 2545 | "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) |
| | 2546 | as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." |
| | 2547 | `(call-with-input ,value #'(lambda (,input-var) ,@body))) |
| | 2548 | |
| | 2549 | (defun* call-with-input-file (pathname thunk |
| | 2550 | &key |
| | 2551 | (element-type *default-stream-element-type*) |
| | 2552 | (external-format :default) |
| | 2553 | (if-does-not-exist :error)) |
| | 2554 | "Open FILE for input with given recognizes options, call THUNK with the resulting stream. |
| | 2555 | Other keys are accepted but discarded." |
| | 2556 | #+gcl2.6 (declare (ignore external-format)) |
| | 2557 | (with-open-file (s pathname :direction :input |
| | 2558 | :element-type element-type |
| | 2559 | #-gcl2.6 :external-format #-gcl2.6 external-format |
| | 2560 | :if-does-not-exist if-does-not-exist) |
| | 2561 | (funcall thunk s))) |
| | 2562 | |
| | 2563 | (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body) |
| | 2564 | (declare (ignore element-type external-format)) |
| | 2565 | `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) |
| | 2566 | |
| | 2567 | |
| | 2568 | ;;; Ensure output buffers are flushed |
| | 2569 | |
| | 2570 | (defun* finish-outputs (&rest streams) |
| | 2571 | "Finish output on the main output streams as well as any specified one. |
| | 2572 | Useful for portably flushing I/O before user input or program exit." |
| | 2573 | ;; CCL notably buffers its stream output by default. |
| | 2574 | (dolist (s (append streams |
| | 2575 | (list *stderr* *error-output* *standard-output* *trace-output* |
| | 2576 | *debug-io* *terminal-io* *debug-io* *query-io*))) |
| | 2577 | (ignore-errors (finish-output s))) |
| 2010 | | (defun* node-for (o c) |
| 2011 | | (cons (class-name (class-of o)) c)) |
| 2012 | | |
| 2013 | | (defmethod operation-ancestor ((operation operation)) |
| 2014 | | (aif (operation-parent operation) |
| 2015 | | (operation-ancestor it) |
| 2016 | | operation)) |
| 2017 | | |
| 2018 | | |
| 2019 | | (defun* make-sub-operation (c o dep-c dep-o) |
| 2020 | | "C is a component, O is an operation, DEP-C is another |
| 2021 | | component, and DEP-O, confusingly enough, is an operation |
| 2022 | | class specifier, not an operation." |
| 2023 | | (let* ((args (copy-list (operation-original-initargs o))) |
| 2024 | | (force-p (getf args :force))) |
| 2025 | | ;; note explicit comparison with T: any other non-NIL force value |
| 2026 | | ;; (e.g. :recursive) will pass through |
| 2027 | | (cond ((and (null (component-parent c)) |
| 2028 | | (null (component-parent dep-c)) |
| 2029 | | (not (eql c dep-c))) |
| 2030 | | (when (eql force-p t) |
| 2031 | | (setf (getf args :force) nil)) |
| 2032 | | (apply 'make-instance dep-o |
| 2033 | | :parent o |
| 2034 | | :original-initargs args args)) |
| 2035 | | ((subtypep (type-of o) dep-o) |
| 2036 | | o) |
| 2037 | | (t |
| 2038 | | (apply 'make-instance dep-o |
| 2039 | | :parent o :original-initargs args args))))) |
| 2040 | | |
| 2041 | | |
| 2042 | | (defmethod visit-component ((o operation) (c component) data) |
| 2043 | | (unless (component-visited-p o c) |
| 2044 | | (setf (gethash (node-for o c) |
| 2045 | | (operation-visited-nodes (operation-ancestor o))) |
| 2046 | | (cons t data)))) |
| 2047 | | |
| 2048 | | (defmethod component-visited-p ((o operation) (c component)) |
| 2049 | | (gethash (node-for o c) |
| 2050 | | (operation-visited-nodes (operation-ancestor o)))) |
| 2051 | | |
| 2052 | | (defmethod (setf visiting-component) (new-value operation component) |
| 2053 | | ;; MCL complains about unused lexical variables |
| 2054 | | (declare (ignorable operation component)) |
| 2055 | | new-value) |
| 2056 | | |
| 2057 | | (defmethod (setf visiting-component) (new-value (o operation) (c component)) |
| 2058 | | (let ((node (node-for o c)) |
| 2059 | | (a (operation-ancestor o))) |
| 2060 | | (if new-value |
| 2061 | | (setf (gethash node (operation-visiting-nodes a)) t) |
| 2062 | | (remhash node (operation-visiting-nodes a))) |
| 2063 | | new-value)) |
| 2064 | | |
| 2065 | | (defmethod component-visiting-p ((o operation) (c component)) |
| 2066 | | (let ((node (node-for o c))) |
| 2067 | | (gethash node (operation-visiting-nodes (operation-ancestor o))))) |
| 2068 | | |
| 2069 | | (defmethod component-depends-on ((op-spec symbol) (c component)) |
| 2070 | | ;; Note: we go from op-spec to operation via make-instance |
| 2071 | | ;; to allow for specialization through defmethod's, even though |
| 2072 | | ;; it's a detour in the default case below. |
| 2073 | | (component-depends-on (make-instance op-spec) c)) |
| 2074 | | |
| 2075 | | (defmethod component-depends-on ((o operation) (c component)) |
| 2076 | | (cdr (assoc (type-of o) (component-in-order-to c)))) |
| 2077 | | |
| 2078 | | (defmethod component-self-dependencies ((o operation) (c component)) |
| 2079 | | (remove-if-not |
| 2080 | | #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) |
| 2081 | | (component-depends-on o c))) |
| 2082 | | |
| 2083 | | (defmethod input-files ((operation operation) (c component)) |
| 2084 | | (let ((parent (component-parent c)) |
| 2085 | | (self-deps (component-self-dependencies operation c))) |
| 2086 | | (if self-deps |
| 2087 | | (mapcan #'(lambda (dep) |
| 2088 | | (destructuring-bind (op name) dep |
| 2089 | | (output-files (make-instance op) |
| 2090 | | (find-component parent name)))) |
| 2091 | | self-deps) |
| 2092 | | ;; no previous operations needed? I guess we work with the |
| 2093 | | ;; original source file, then |
| 2094 | | (list (component-pathname c))))) |
| 2095 | | |
| 2096 | | (defmethod input-files ((operation operation) (c module)) |
| 2097 | | (declare (ignorable operation c)) |
| 2098 | | nil) |
| 2099 | | |
| 2100 | | (defmethod component-operation-time (o c) |
| 2101 | | (gethash (type-of o) (component-operation-times c))) |
| 2102 | | |
| 2103 | | (defmethod operation-done-p ((o operation) (c component)) |
| 2104 | | (let ((out-files (output-files o c)) |
| 2105 | | (in-files (input-files o c)) |
| 2106 | | (op-time (component-operation-time o c))) |
| 2107 | | (flet ((earliest-out () |
| 2108 | | (reduce #'min (mapcar #'safe-file-write-date out-files))) |
| 2109 | | (latest-in () |
| 2110 | | (reduce #'max (mapcar #'safe-file-write-date in-files)))) |
| | 2580 | (defun* format! (stream format &rest args) |
| | 2581 | "Just like format, but call finish-outputs before and after the output." |
| | 2582 | (finish-outputs stream) |
| | 2583 | (apply 'format stream format args) |
| | 2584 | (finish-output stream)) |
| | 2585 | |
| | 2586 | (defun* safe-format! (stream format &rest args) |
| | 2587 | (with-safe-io-syntax () |
| | 2588 | (ignore-errors (apply 'format! stream format args)) |
| | 2589 | (finish-outputs stream))) ; just in case format failed |
| | 2590 | |
| | 2591 | |
| | 2592 | ;;; Simple Whole-Stream processing |
| | 2593 | |
| | 2594 | |
| | 2595 | (defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) |
| | 2596 | "Copy the contents of the INPUT stream into the OUTPUT stream. |
| | 2597 | If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. |
| | 2598 | Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." |
| | 2599 | (with-open-stream (input input) |
| | 2600 | (if linewise |
| | 2601 | (loop* :for (line eof) = (multiple-value-list (read-line input nil nil)) |
| | 2602 | :while line :do |
| | 2603 | (when prefix (princ prefix output)) |
| | 2604 | (princ line output) |
| | 2605 | (unless eof (terpri output)) |
| | 2606 | (finish-output output) |
| | 2607 | (when eof (return))) |
| | 2608 | (loop |
| | 2609 | :with buffer-size = (or buffer-size 8192) |
| | 2610 | :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) |
| | 2611 | :for end = (read-sequence buffer input) |
| | 2612 | :until (zerop end) |
| | 2613 | :do (write-sequence buffer output :end end) |
| | 2614 | (when (< end buffer-size) (return)))))) |
| | 2615 | |
| | 2616 | (defun* concatenate-files (inputs output) |
| | 2617 | (with-open-file (o output :element-type '(unsigned-byte 8) |
| | 2618 | :direction :output :if-exists :rename-and-delete) |
| | 2619 | (dolist (input inputs) |
| | 2620 | (with-open-file (i input :element-type '(unsigned-byte 8) |
| | 2621 | :direction :input :if-does-not-exist :error) |
| | 2622 | (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) |
| | 2623 | |
| | 2624 | (defun* slurp-stream-string (input &key (element-type 'character)) |
| | 2625 | "Read the contents of the INPUT stream as a string" |
| | 2626 | (with-open-stream (input input) |
| | 2627 | (with-output-to-string (output) |
| | 2628 | (copy-stream-to-stream input output :element-type element-type)))) |
| | 2629 | |
| | 2630 | (defun* slurp-stream-lines (input &key count) |
| | 2631 | "Read the contents of the INPUT stream as a list of lines, return those lines. |
| | 2632 | |
| | 2633 | Read no more than COUNT lines." |
| | 2634 | (check-type count (or null integer)) |
| | 2635 | (with-open-stream (input input) |
| | 2636 | (loop :for n :from 0 |
| | 2637 | :for l = (and (or (not count) (< n count)) |
| | 2638 | (read-line input nil nil)) |
| | 2639 | :while l :collect l))) |
| | 2640 | |
| | 2641 | (defun* slurp-stream-line (input &key (at 0)) |
| | 2642 | "Read the contents of the INPUT stream as a list of lines, |
| | 2643 | then return the ACCESS-AT of that list of lines using the AT specifier. |
| | 2644 | PATH defaults to 0, i.e. return the first line. |
| | 2645 | PATH is typically an integer, or a list of an integer and a function. |
| | 2646 | If PATH is NIL, it will return all the lines in the file. |
| | 2647 | |
| | 2648 | The stream will not be read beyond the Nth lines, |
| | 2649 | where N is the index specified by path |
| | 2650 | if path is either an integer or a list that starts with an integer." |
| | 2651 | (access-at (slurp-stream-lines input :count (access-at-count at)) at)) |
| | 2652 | |
| | 2653 | (defun* slurp-stream-forms (input &key count) |
| | 2654 | "Read the contents of the INPUT stream as a list of forms, |
| | 2655 | and return those forms. |
| | 2656 | |
| | 2657 | If COUNT is null, read to the end of the stream; |
| | 2658 | if COUNT is an integer, stop after COUNT forms were read. |
| | 2659 | |
| | 2660 | BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" |
| | 2661 | (check-type count (or null integer)) |
| | 2662 | (loop :with eof = '#:eof |
| | 2663 | :for n :from 0 |
| | 2664 | :for form = (if (and count (>= n count)) |
| | 2665 | eof |
| | 2666 | (read-preserving-whitespace input nil eof)) |
| | 2667 | :until (eq form eof) :collect form)) |
| | 2668 | |
| | 2669 | (defun* slurp-stream-form (input &key (at 0)) |
| | 2670 | "Read the contents of the INPUT stream as a list of forms, |
| | 2671 | then return the ACCESS-AT of these forms following the AT. |
| | 2672 | AT defaults to 0, i.e. return the first form. |
| | 2673 | AT is typically a list of integers. |
| | 2674 | If AT is NIL, it will return all the forms in the file. |
| | 2675 | |
| | 2676 | The stream will not be read beyond the Nth form, |
| | 2677 | where N is the index specified by path, |
| | 2678 | if path is either an integer or a list that starts with an integer. |
| | 2679 | |
| | 2680 | BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" |
| | 2681 | (access-at (slurp-stream-forms input :count (access-at-count at)) at)) |
| | 2682 | |
| | 2683 | (defun* read-file-string (file &rest keys) |
| | 2684 | "Open FILE with option KEYS, read its contents as a string" |
| | 2685 | (apply 'call-with-input-file file 'slurp-stream-string keys)) |
| | 2686 | |
| | 2687 | (defun* read-file-lines (file &rest keys) |
| | 2688 | "Open FILE with option KEYS, read its contents as a list of lines |
| | 2689 | BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" |
| | 2690 | (apply 'call-with-input-file file 'slurp-stream-lines keys)) |
| | 2691 | |
| | 2692 | (defun* read-file-forms (file &rest keys &key count &allow-other-keys) |
| | 2693 | "Open input FILE with option KEYS (except COUNT), |
| | 2694 | and read its contents as per SLURP-STREAM-FORMS with given COUNT. |
| | 2695 | BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" |
| | 2696 | (apply 'call-with-input-file file |
| | 2697 | #'(lambda (input) (slurp-stream-forms input :count count)) |
| | 2698 | (remove-plist-key :count keys))) |
| | 2699 | |
| | 2700 | (defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys) |
| | 2701 | "Open input FILE with option KEYS (except AT), |
| | 2702 | and read its contents as per SLURP-STREAM-FORM with given AT specifier. |
| | 2703 | BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" |
| | 2704 | (apply 'call-with-input-file file |
| | 2705 | #'(lambda (input) (slurp-stream-form input :at at)) |
| | 2706 | (remove-plist-key :at keys))) |
| | 2707 | |
| | 2708 | (defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) |
| | 2709 | "Reads the specified form from the top of a file using a safe standardized syntax. |
| | 2710 | Extracts the form using READ-FILE-FORM, |
| | 2711 | within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." |
| | 2712 | (with-safe-io-syntax (:package package) |
| | 2713 | (apply 'read-file-form pathname (remove-plist-key :package keys)))) |
| | 2714 | |
| | 2715 | (defun* eval-input (input) |
| | 2716 | "Portably read and evaluate forms from INPUT, return the last values." |
| | 2717 | (with-input (input) |
| | 2718 | (loop :with results :with eof ='#:eof |
| | 2719 | :for form = (read input nil eof) |
| | 2720 | :until (eq form eof) |
| | 2721 | :do (setf results (multiple-value-list (eval form))) |
| | 2722 | :finally (return (apply 'values results))))) |
| | 2723 | |
| | 2724 | (defun* eval-thunk (thunk) |
| | 2725 | "Evaluate a THUNK of code: |
| | 2726 | If a function, FUNCALL it without arguments. |
| | 2727 | If a constant literal and not a sequence, return it. |
| | 2728 | If a cons or a symbol, EVAL it. |
| | 2729 | If a string, repeatedly read and evaluate from it, returning the last values." |
| | 2730 | (etypecase thunk |
| | 2731 | ((or boolean keyword number character pathname) thunk) |
| | 2732 | ((or cons symbol) (eval thunk)) |
| | 2733 | (function (funcall thunk)) |
| | 2734 | (string (eval-input thunk)))) |
| | 2735 | |
| | 2736 | (defun* standard-eval-thunk (thunk &key (package :cl)) |
| | 2737 | "Like EVAL-THUNK, but in a more standardized evaluation context." |
| | 2738 | ;; Note: it's "standard-" not "safe-", because evaluation is never safe. |
| | 2739 | (when thunk |
| | 2740 | (with-safe-io-syntax (:package package) |
| | 2741 | (let ((*read-eval* t)) |
| | 2742 | (eval-thunk thunk))))) |
| | 2743 | |
| | 2744 | |
| | 2745 | ;;; Encodings |
| | 2746 | |
| | 2747 | (defvar *default-encoding* :default |
| | 2748 | "Default encoding for source files. |
| | 2749 | The default value :default preserves the legacy behavior. |
| | 2750 | A future default might be :utf-8 or :autodetect |
| | 2751 | reading emacs-style -*- coding: utf-8 -*- specifications, |
| | 2752 | and falling back to utf-8 or latin1 if nothing is specified.") |
| | 2753 | |
| | 2754 | (defparameter *utf-8-external-format* |
| | 2755 | #+(and asdf-unicode (not clisp)) :utf-8 |
| | 2756 | #+(and asdf-unicode clisp) charset:utf-8 |
| | 2757 | #-asdf-unicode :default |
| | 2758 | "Default :external-format argument to pass to CL:OPEN and also |
| | 2759 | CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. |
| | 2760 | On modern implementations, this will decode UTF-8 code points as CL characters. |
| | 2761 | On legacy implementations, it may fall back on some 8-bit encoding, |
| | 2762 | with non-ASCII code points being read as several CL characters; |
| | 2763 | hopefully, if done consistently, that won't affect program behavior too much.") |
| | 2764 | |
| | 2765 | (defun* always-default-encoding (pathname) |
| | 2766 | (declare (ignore pathname)) |
| | 2767 | *default-encoding*) |
| | 2768 | |
| | 2769 | (defvar *encoding-detection-hook* #'always-default-encoding |
| | 2770 | "Hook for an extension to define a function to automatically detect a file's encoding") |
| | 2771 | |
| | 2772 | (defun* detect-encoding (pathname) |
| | 2773 | (if (and pathname (not (directory-pathname-p pathname)) (probe-file pathname)) |
| | 2774 | (funcall *encoding-detection-hook* pathname) |
| | 2775 | *default-encoding*)) |
| | 2776 | |
| | 2777 | (defun* default-encoding-external-format (encoding) |
| | 2778 | (case encoding |
| | 2779 | (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. |
| | 2780 | (:utf-8 *utf-8-external-format*) |
| | 2781 | (otherwise |
| | 2782 | (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding) |
| | 2783 | :default))) |
| | 2784 | |
| | 2785 | (defvar *encoding-external-format-hook* |
| | 2786 | #'default-encoding-external-format |
| | 2787 | "Hook for an extension to define a mapping between non-default encodings |
| | 2788 | and implementation-defined external-format's") |
| | 2789 | |
| | 2790 | (defun* encoding-external-format (encoding) |
| | 2791 | (funcall *encoding-external-format-hook* encoding)) |
| | 2792 | |
| | 2793 | ;;;; --------------------------------------------------------------------------- |
| | 2794 | ;;;; Access to the Operating System |
| | 2795 | |
| | 2796 | (asdf/package:define-package :asdf/os |
| | 2797 | (:recycle :asdf/os :asdf) |
| | 2798 | (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream) |
| | 2799 | (:export |
| | 2800 | #:featurep #:os-unix-p #:os-windows-p ;; features |
| | 2801 | #:getenv #:getenvp ;; environment variables |
| | 2802 | #:native-namestring #:parse-native-namestring |
| | 2803 | #:inter-directory-separator #:split-native-pathnames-string |
| | 2804 | #:getenv-pathname #:getenv-pathnames |
| | 2805 | #:getenv-absolute-directory #:getenv-absolute-directories |
| | 2806 | #:implementation-identifier ;; implementation identifier |
| | 2807 | #:implementation-type #:*implementation-type* |
| | 2808 | #:operating-system #:architecture #:lisp-version-string |
| | 2809 | #:hostname #:user-homedir #:lisp-implementation-directory |
| | 2810 | #:getcwd #:chdir #:call-with-current-directory #:with-current-directory |
| | 2811 | #:*temporary-directory* #:temporary-directory #:default-temporary-directory |
| | 2812 | #:setup-temporary-directory |
| | 2813 | #:call-with-temporary-file #:with-temporary-file)) |
| | 2814 | (in-package :asdf/os) |
| | 2815 | |
| | 2816 | ;;; Features |
| | 2817 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| | 2818 | (defun* featurep (x &optional (*features* *features*)) |
| | 2819 | (cond |
| | 2820 | ((atom x) (and (member x *features*) t)) |
| | 2821 | ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) |
| | 2822 | ((eq :or (car x)) (some #'featurep (cdr x))) |
| | 2823 | ((eq :and (car x)) (every #'featurep (cdr x))) |
| | 2824 | (t (error "Malformed feature specification ~S" x)))) |
| | 2825 | |
| | 2826 | (defun* os-unix-p () |
| | 2827 | (featurep '(:or :unix :cygwin :darwin))) |
| | 2828 | |
| | 2829 | (defun* os-windows-p () |
| | 2830 | (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32)))) |
| | 2831 | |
| | 2832 | (defun* os-genera-p () |
| | 2833 | (featurep :genera)) |
| | 2834 | |
| | 2835 | (defun* detect-os () |
| | 2836 | (flet ((yes (yes) (pushnew yes *features*)) |
| | 2837 | (no (no) (setf *features* (remove no *features*)))) |
| 2112 | | ((and (not in-files) (not out-files)) |
| 2113 | | ;; arbitrary decision: an operation that uses nothing to |
| 2114 | | ;; produce nothing probably isn't doing much. |
| 2115 | | ;; e.g. operations on systems, modules that have no immediate action, |
| 2116 | | ;; but are only meaningful through traversed dependencies |
| 2117 | | t) |
| 2118 | | ((not out-files) |
| 2119 | | ;; an operation without output-files is probably meant |
| 2120 | | ;; for its side-effects in the current image, |
| 2121 | | ;; assumed to be idem-potent, |
| 2122 | | ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. |
| 2123 | | (and op-time (>= op-time (latest-in)))) |
| 2124 | | ((not in-files) |
| 2125 | | ;; an operation with output-files and no input-files |
| 2126 | | ;; is probably meant for its side-effects on the file-system, |
| 2127 | | ;; assumed to have to be done everytime. |
| 2128 | | ;; (I don't think there is any such case in ASDF unless extended) |
| 2129 | | nil) |
| 2130 | | (t |
| 2131 | | ;; an operation with both input and output files is assumed |
| 2132 | | ;; as computing the latter from the former, |
| 2133 | | ;; assumed to have been done if the latter are all older |
| 2134 | | ;; than the former. |
| 2135 | | ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. |
| 2136 | | ;; We use >= instead of > to play nice with generated files. |
| 2137 | | ;; This opens a race condition if an input file is changed |
| 2138 | | ;; after the output is created but within the same second |
| 2139 | | ;; of filesystem time; but the same race condition exists |
| 2140 | | ;; whenever the computation from input to output takes more |
| 2141 | | ;; than one second of filesystem time (or just crosses the |
| 2142 | | ;; second). So that's cool. |
| 2143 | | (and |
| 2144 | | (every #'probe-file* in-files) |
| 2145 | | (every #'probe-file* out-files) |
| 2146 | | (>= (earliest-out) (latest-in)))))))) |
| 2147 | | |
| 2148 | | |
| 2149 | | |
| 2150 | | ;;; For 1.700 I've done my best to refactor TRAVERSE |
| 2151 | | ;;; by splitting it up in a bunch of functions, |
| 2152 | | ;;; so as to improve the collection and use-detection algorithm. --fare |
| 2153 | | ;;; The protocol is as follows: we pass around operation, dependency, |
| 2154 | | ;;; bunch of other stuff, and a force argument. Return a force flag. |
| 2155 | | ;;; The returned flag is T if anything has changed that requires a rebuild. |
| 2156 | | ;;; The force argument is a list of components that will require a rebuild |
| 2157 | | ;;; if the flag is T, at which point whoever returns the flag has to |
| 2158 | | ;;; mark them all as forced, and whoever recurses again can use a NIL list |
| 2159 | | ;;; as a further argument. |
| 2160 | | |
| 2161 | | (defvar *forcing* nil |
| 2162 | | "This dynamically-bound variable is used to force operations in |
| 2163 | | recursive calls to traverse.") |
| 2164 | | |
| 2165 | | (defgeneric* do-traverse (operation component collect)) |
| 2166 | | |
| 2167 | | (defun* resolve-dependency-name (component name &optional version) |
| 2168 | | (loop |
| 2169 | | (restart-case |
| 2170 | | (return |
| 2171 | | (let ((comp (find-component (component-parent component) name))) |
| 2172 | | (unless comp |
| 2173 | | (error 'missing-dependency |
| 2174 | | :required-by component |
| 2175 | | :requires name)) |
| 2176 | | (when version |
| 2177 | | (unless (version-satisfies comp version) |
| 2178 | | (error 'missing-dependency-of-version |
| 2179 | | :required-by component |
| 2180 | | :version version |
| 2181 | | :requires name))) |
| 2182 | | comp)) |
| 2183 | | (retry () |
| 2184 | | :report (lambda (s) |
| 2185 | | (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name)) |
| 2186 | | :test |
| 2187 | | (lambda (c) |
| 2188 | | (or (null c) |
| 2189 | | (and (typep c 'missing-dependency) |
| 2190 | | (eq (missing-required-by c) component) |
| 2191 | | (equal (missing-requires c) name)))))))) |
| 2192 | | |
| 2193 | | (defun* resolve-dependency-spec (component dep-spec) |
| 2194 | | (cond |
| 2195 | | ((atom dep-spec) |
| 2196 | | (resolve-dependency-name component dep-spec)) |
| 2197 | | ;; Structured dependencies --- this parses keywords. |
| 2198 | | ;; The keywords could conceivably be broken out and cleanly (extensibly) |
| 2199 | | ;; processed by EQL methods. But for now, here's what we've got. |
| 2200 | | ((eq :version (first dep-spec)) |
| 2201 | | ;; https://bugs.launchpad.net/asdf/+bug/527788 |
| 2202 | | (resolve-dependency-name component (second dep-spec) (third dep-spec))) |
| 2203 | | ((eq :feature (first dep-spec)) |
| 2204 | | ;; This particular subform is not documented and |
| 2205 | | ;; has always been broken in the past. |
| 2206 | | ;; Therefore no one uses it, and I'm cerroring it out, |
| 2207 | | ;; after fixing it |
| 2208 | | ;; See https://bugs.launchpad.net/asdf/+bug/518467 |
| 2209 | | (cerror "Continue nonetheless." |
| 2210 | | "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") |
| 2211 | | (when (find (second dep-spec) *features* :test 'string-equal) |
| 2212 | | (resolve-dependency-name component (third dep-spec)))) |
| 2213 | | (t |
| 2214 | | (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec)))) |
| 2215 | | |
| 2216 | | (defun* do-one-dep (op c collect dep-op dep-c) |
| 2217 | | ;; Collects a partial plan for performing dep-op on dep-c |
| 2218 | | ;; as dependencies of a larger plan involving op and c. |
| 2219 | | ;; Returns t if this should force recompilation of those who depend on us. |
| 2220 | | ;; dep-op is an operation class name (not an operation object), |
| 2221 | | ;; whereas dep-c is a component object.n |
| 2222 | | (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) |
| 2223 | | |
| 2224 | | (defun* do-dep (op c collect dep-op-spec dep-c-specs) |
| 2225 | | ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs |
| 2226 | | ;; as dependencies of a larger plan involving op and c. |
| 2227 | | ;; Returns t if this should force recompilation of those who depend on us. |
| 2228 | | ;; dep-op-spec is either an operation class name (not an operation object), |
| 2229 | | ;; or the magic symbol asdf:feature. |
| 2230 | | ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, |
| 2231 | | ;; and the plan will succeed if that keyword is present in *feature*, |
| 2232 | | ;; or fail if it isn't |
| 2233 | | ;; (at which point c's :if-component-dep-fails will kick in). |
| 2234 | | ;; If dep-op-spec is an operation class name, |
| 2235 | | ;; then dep-c-specs specifies a list of sibling component of c, |
| 2236 | | ;; as per resolve-dependency-spec, such that operating op on c |
| 2237 | | ;; depends on operating dep-op-spec on each of them. |
| 2238 | | (cond ((eq dep-op-spec 'feature) |
| 2239 | | (if (member (car dep-c-specs) *features*) |
| 2240 | | nil |
| 2241 | | (error 'missing-dependency |
| 2242 | | :required-by c |
| 2243 | | :requires (list :feature (car dep-c-specs))))) |
| 2244 | | (t |
| 2245 | | (let ((flag nil)) |
| 2246 | | (dolist (d dep-c-specs) |
| 2247 | | (when (do-one-dep op c collect dep-op-spec |
| 2248 | | (resolve-dependency-spec c d)) |
| 2249 | | (setf flag t))) |
| 2250 | | flag)))) |
| 2251 | | |
| 2252 | | (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes |
| 2253 | | |
| 2254 | | (defun* do-collect (collect x) |
| 2255 | | (funcall collect x)) |
| 2256 | | |
| 2257 | | (defmethod do-traverse ((operation operation) (c component) collect) |
| 2258 | | (let ((*forcing* *forcing*) |
| 2259 | | (flag nil)) ;; return value: must we rebuild this and its dependencies? |
| 2260 | | (labels |
| 2261 | | ((update-flag (x) |
| 2262 | | (orf flag x)) |
| 2263 | | (dep (op comp) |
| 2264 | | (update-flag (do-dep operation c collect op comp)))) |
| 2265 | | ;; Have we been visited yet? If so, just process the result. |
| 2266 | | (aif (component-visited-p operation c) |
| 2267 | | (progn |
| 2268 | | (update-flag (cdr it)) |
| 2269 | | (return-from do-traverse flag))) |
| 2270 | | ;; dependencies |
| 2271 | | (when (component-visiting-p operation c) |
| 2272 | | (error 'circular-dependency :components (list c))) |
| 2273 | | (setf (visiting-component operation c) t) |
| 2274 | | (unwind-protect |
| 2275 | | (block nil |
| 2276 | | (when (typep c 'system) ;; systems can be forced or forced-not |
| 2277 | | (let ((ancestor (operation-ancestor operation))) |
| 2278 | | (flet ((match? (f) |
| 2279 | | (and f (or (not (consp f)) ;; T or :ALL |
| 2280 | | (member (component-name c) f :test #'equal))))) |
| 2281 | | (cond |
| 2282 | | ((match? (operation-forced ancestor)) |
| 2283 | | (setf *forcing* t)) |
| 2284 | | ((match? (operation-forced-not ancestor)) |
| 2285 | | (return)))))) |
| 2286 | | ;; first we check and do all the dependencies for the module. |
| 2287 | | ;; Operations planned in this loop will show up |
| 2288 | | ;; in the results, and are consumed below. |
| 2289 | | (let ((*forcing* nil)) |
| 2290 | | ;; upstream dependencies are never forced to happen just because |
| 2291 | | ;; the things that depend on them are.... |
| 2292 | | (loop |
| 2293 | | :for (required-op . deps) :in (component-depends-on operation c) |
| 2294 | | :do (dep required-op deps))) |
| 2295 | | ;; constituent bits |
| 2296 | | (let ((module-ops |
| 2297 | | (when (typep c 'module) |
| 2298 | | (let ((at-least-one nil) |
| 2299 | | ;; This is set based on the results of the |
| 2300 | | ;; dependencies and whether we are in the |
| 2301 | | ;; context of a *forcing* call... |
| 2302 | | ;; inter-system dependencies do NOT trigger |
| 2303 | | ;; building components |
| 2304 | | (*forcing* |
| 2305 | | (or *forcing* |
| 2306 | | (and flag (not (typep c 'system))))) |
| 2307 | | (error nil)) |
| 2308 | | (while-collecting (internal-collect) |
| 2309 | | (dolist (kid (module-components c)) |
| 2310 | | (handler-case |
| 2311 | | (update-flag |
| 2312 | | (do-traverse operation kid #'internal-collect)) |
| 2313 | | #-genera |
| 2314 | | (missing-dependency (condition) |
| 2315 | | (when (eq (module-if-component-dep-fails c) |
| 2316 | | :fail) |
| 2317 | | (error condition)) |
| 2318 | | (setf error condition)) |
| 2319 | | (:no-error (c) |
| 2320 | | (declare (ignore c)) |
| 2321 | | (setf at-least-one t)))) |
| 2322 | | (when (and (eq (module-if-component-dep-fails c) |
| 2323 | | :try-next) |
| 2324 | | (not at-least-one)) |
| 2325 | | (error error))))))) |
| 2326 | | (update-flag (or *forcing* (not (operation-done-p operation c)))) |
| 2327 | | ;; For sub-operations, check whether |
| 2328 | | ;; the original ancestor operation was forced, |
| 2329 | | ;; or names us amongst an explicit list of things to force... |
| 2330 | | ;; except that this check doesn't distinguish |
| 2331 | | ;; between all the things with a given name. Sigh. |
| 2332 | | ;; BROKEN! |
| 2333 | | (when flag |
| 2334 | | (let ((do-first (cdr (assoc (class-name (class-of operation)) |
| 2335 | | (component-do-first c))))) |
| 2336 | | (loop :for (required-op . deps) :in do-first |
| 2337 | | :do (do-dep operation c collect required-op deps))) |
| 2338 | | (do-collect collect (vector module-ops)) |
| 2339 | | (do-collect collect (cons operation c))))) |
| 2340 | | (setf (visiting-component operation c) nil))) |
| 2341 | | (visit-component operation c (when flag (incf *visit-count*))) |
| 2342 | | flag)) |
| 2343 | | |
| 2344 | | (defun* flatten-tree (l) |
| 2345 | | ;; You collected things into a list. |
| 2346 | | ;; Most elements are just things to collect again. |
| 2347 | | ;; A (simple-vector 1) indicate that you should recurse into its contents. |
| 2348 | | ;; This way, in two passes (rather than N being the depth of the tree), |
| 2349 | | ;; you can collect things with marginally constant-time append, |
| 2350 | | ;; achieving linear time collection instead of quadratic time. |
| 2351 | | (while-collecting (c) |
| 2352 | | (labels ((r (x) |
| 2353 | | (if (typep x '(simple-vector 1)) |
| 2354 | | (r* (svref x 0)) |
| 2355 | | (c x))) |
| 2356 | | (r* (l) |
| 2357 | | (map () #'r l))) |
| 2358 | | (r* l)))) |
| 2359 | | |
| 2360 | | (defmethod traverse ((operation operation) (c component)) |
| 2361 | | (flatten-tree |
| 2362 | | (while-collecting (collect) |
| 2363 | | (let ((*visit-count* 0)) |
| 2364 | | (do-traverse operation c #'collect))))) |
| 2365 | | |
| 2366 | | (defmethod perform ((operation operation) (c source-file)) |
| 2367 | | (sysdef-error |
| 2368 | | (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") |
| 2369 | | (class-of operation) (class-of c))) |
| 2370 | | |
| 2371 | | (defmethod perform ((operation operation) (c module)) |
| 2372 | | (declare (ignorable operation c)) |
| 2373 | | nil) |
| 2374 | | |
| 2375 | | (defmethod mark-operation-done ((operation operation) (c component)) |
| 2376 | | (setf (gethash (type-of operation) (component-operation-times c)) |
| 2377 | | (reduce #'max |
| 2378 | | (cons (get-universal-time) |
| 2379 | | (mapcar #'safe-file-write-date (input-files operation c)))))) |
| 2380 | | |
| 2381 | | (defmethod perform-with-restarts (operation component) |
| 2382 | | ;; TOO verbose, especially as the default. Add your own :before method |
| 2383 | | ;; to perform-with-restart or perform if you want that: |
| 2384 | | #|(when *asdf-verbose* (explain operation component))|# |
| 2385 | | (perform operation component)) |
| 2386 | | |
| 2387 | | (defmethod perform-with-restarts :around (operation component) |
| 2388 | | (loop |
| 2389 | | (restart-case |
| 2390 | | (return (call-next-method)) |
| 2391 | | (retry () |
| 2392 | | :report |
| 2393 | | (lambda (s) |
| 2394 | | (format s (compatfmt "~@<Retry ~A.~@:>") |
| 2395 | | (operation-description operation component)))) |
| 2396 | | (accept () |
| 2397 | | :report |
| 2398 | | (lambda (s) |
| 2399 | | (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") |
| 2400 | | (operation-description operation component))) |
| 2401 | | (mark-operation-done operation component) |
| 2402 | | (return))))) |
| 2403 | | |
| 2404 | | (defmethod explain ((operation operation) (component component)) |
| 2405 | | (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") |
| 2406 | | (operation-description operation component))) |
| 2407 | | |
| 2408 | | (defmethod operation-description (operation component) |
| 2409 | | (format nil (compatfmt "~@<~A on ~A~@:>") |
| 2410 | | (class-of operation) component)) |
| 2411 | | |
| 2412 | | ;;;; ------------------------------------------------------------------------- |
| 2413 | | ;;;; compile-op |
| 2414 | | |
| 2415 | | (defclass compile-op (operation) |
| 2416 | | ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) |
| 2417 | | (on-warnings :initarg :on-warnings :accessor operation-on-warnings |
| 2418 | | :initform *compile-file-warnings-behaviour*) |
| 2419 | | (on-failure :initarg :on-failure :accessor operation-on-failure |
| 2420 | | :initform *compile-file-failure-behaviour*) |
| 2421 | | (flags :initarg :flags :accessor compile-op-flags |
| 2422 | | :initform nil))) |
| 2423 | | |
| 2424 | | (defun* output-file (operation component) |
| 2425 | | "The unique output file of performing OPERATION on COMPONENT" |
| 2426 | | (let ((files (output-files operation component))) |
| 2427 | | (assert (length=n-p files 1)) |
| 2428 | | (first files))) |
| 2429 | | |
| 2430 | | (defun* ensure-all-directories-exist (pathnames) |
| 2431 | | (dolist (pathname pathnames) |
| 2432 | | (ensure-directories-exist (translate-logical-pathname pathname)))) |
| 2433 | | |
| 2434 | | (defmethod perform :before ((operation compile-op) (c source-file)) |
| 2435 | | (ensure-all-directories-exist (output-files operation c))) |
| 2436 | | |
| 2437 | | (defmethod perform :after ((operation operation) (c component)) |
| 2438 | | (mark-operation-done operation c)) |
| 2439 | | |
| 2440 | | (defgeneric* around-compile-hook (component)) |
| 2441 | | (defgeneric* call-with-around-compile-hook (component thunk)) |
| 2442 | | |
| 2443 | | (defmethod around-compile-hook ((c component)) |
| 2444 | | (cond |
| 2445 | | ((slot-boundp c 'around-compile) |
| 2446 | | (slot-value c 'around-compile)) |
| 2447 | | ((component-parent c) |
| 2448 | | (around-compile-hook (component-parent c))))) |
| 2449 | | |
| 2450 | | (defun ensure-function (fun &key (package :asdf)) |
| 2451 | | (etypecase fun |
| 2452 | | ((or symbol function) fun) |
| 2453 | | (cons (eval `(function ,fun))) |
| 2454 | | (string (eval `(function ,(with-standard-io-syntax |
| 2455 | | (let ((*package* (find-package package))) |
| 2456 | | (read-from-string fun)))))))) |
| 2457 | | |
| 2458 | | (defun call-around-hook (hook function) |
| 2459 | | (funcall (or (ensure-function hook) 'funcall) function)) |
| 2460 | | |
| 2461 | | (defmethod call-with-around-compile-hook ((c component) function) |
| 2462 | | (call-around-hook (around-compile-hook c) function)) |
| 2463 | | |
| 2464 | | ;;; perform is required to check output-files to find out where to put |
| 2465 | | ;;; its answers, in case it has been overridden for site policy |
| 2466 | | (defmethod perform ((operation compile-op) (c cl-source-file)) |
| 2467 | | (let ((source-file (component-pathname c)) |
| 2468 | | ;; on some implementations, there are more than one output-file, |
| 2469 | | ;; but the first one should always be the primary fasl that gets loaded. |
| 2470 | | (output-file (first (output-files operation c))) |
| 2471 | | (*compile-file-warnings-behaviour* (operation-on-warnings operation)) |
| 2472 | | (*compile-file-failure-behaviour* (operation-on-failure operation))) |
| 2473 | | (multiple-value-bind (output warnings-p failure-p) |
| 2474 | | (call-with-around-compile-hook |
| 2475 | | c #'(lambda (&rest flags) |
| 2476 | | (apply *compile-op-compile-file-function* source-file |
| 2477 | | :output-file output-file |
| 2478 | | :external-format (component-external-format c) |
| 2479 | | (append flags (compile-op-flags operation))))) |
| 2480 | | (unless output |
| 2481 | | (error 'compile-error :component c :operation operation)) |
| 2482 | | (when failure-p |
| 2483 | | (case (operation-on-failure operation) |
| 2484 | | (:warn (warn |
| 2485 | | (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>") |
| 2486 | | operation c)) |
| 2487 | | (:error (error 'compile-failed :component c :operation operation)) |
| 2488 | | (:ignore nil))) |
| 2489 | | (when warnings-p |
| 2490 | | (case (operation-on-warnings operation) |
| 2491 | | (:warn (warn |
| 2492 | | (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") |
| 2493 | | operation c)) |
| 2494 | | (:error (error 'compile-warned :component c :operation operation)) |
| 2495 | | (:ignore nil)))))) |
| 2496 | | |
| 2497 | | (defmethod output-files ((operation compile-op) (c cl-source-file)) |
| 2498 | | (declare (ignorable operation)) |
| 2499 | | (let* ((p (lispize-pathname (component-pathname c))) |
| 2500 | | (f (compile-file-pathname ;; fasl |
| 2501 | | p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) |
| 2502 | | #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file |
| 2503 | | #+ecl (if (use-ecl-byte-compiler-p) |
| 2504 | | (list f) |
| 2505 | | (list (compile-file-pathname p :type :object) f)) |
| 2506 | | #+mkcl (list o f) |
| 2507 | | #-(or ecl mkcl) (list f))) |
| 2508 | | |
| 2509 | | (defmethod perform ((operation compile-op) (c static-file)) |
| 2510 | | (declare (ignorable operation c)) |
| 2511 | | nil) |
| 2512 | | |
| 2513 | | (defmethod output-files ((operation compile-op) (c static-file)) |
| 2514 | | (declare (ignorable operation c)) |
| 2515 | | nil) |
| 2516 | | |
| 2517 | | (defmethod input-files ((operation compile-op) (c static-file)) |
| 2518 | | (declare (ignorable operation c)) |
| 2519 | | nil) |
| 2520 | | |
| 2521 | | (defmethod operation-description ((operation compile-op) component) |
| 2522 | | (declare (ignorable operation)) |
| 2523 | | (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component)) |
| 2524 | | |
| 2525 | | (defmethod operation-description ((operation compile-op) (component module)) |
| 2526 | | (declare (ignorable operation)) |
| 2527 | | (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component)) |
| 2528 | | |
| 2529 | | |
| 2530 | | ;;;; ------------------------------------------------------------------------- |
| 2531 | | ;;;; load-op |
| 2532 | | |
| 2533 | | (defclass basic-load-op (operation) ()) |
| 2534 | | |
| 2535 | | (defclass load-op (basic-load-op) ()) |
| 2536 | | |
| 2537 | | (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) |
| 2538 | | (loop |
| 2539 | | (restart-case |
| 2540 | | (return (call-next-method)) |
| 2541 | | (try-recompiling () |
| 2542 | | :report (lambda (s) |
| 2543 | | (format s "Recompile ~a and try loading it again" |
| 2544 | | (component-name c))) |
| 2545 | | (perform (make-sub-operation c o c 'compile-op) c))))) |
| 2546 | | |
| 2547 | | (defmethod perform ((o load-op) (c cl-source-file)) |
| 2548 | | (map () #'load |
| 2549 | | #-(or ecl mkcl) |
| 2550 | | (input-files o c) |
| 2551 | | #+(or ecl mkcl) |
| 2552 | | (loop :for i :in (input-files o c) |
| 2553 | | :unless (string= (pathname-type i) "fas") |
| 2554 | | :collect (compile-file-pathname (lispize-pathname i))))) |
| 2555 | | |
| 2556 | | (defmethod perform ((operation load-op) (c static-file)) |
| 2557 | | (declare (ignorable operation c)) |
| 2558 | | nil) |
| 2559 | | |
| 2560 | | (defmethod operation-done-p ((operation load-op) (c static-file)) |
| 2561 | | (declare (ignorable operation c)) |
| 2562 | | t) |
| 2563 | | |
| 2564 | | (defmethod output-files ((operation operation) (c component)) |
| 2565 | | (declare (ignorable operation c)) |
| 2566 | | nil) |
| 2567 | | |
| 2568 | | (defmethod component-depends-on ((operation load-op) (c component)) |
| 2569 | | (declare (ignorable operation)) |
| 2570 | | (cons (list 'compile-op (component-name c)) |
| 2571 | | (call-next-method))) |
| 2572 | | |
| 2573 | | (defmethod operation-description ((operation load-op) component) |
| 2574 | | (declare (ignorable operation)) |
| 2575 | | (format nil (compatfmt "~@<loading ~3i~_~A~@:>") |
| 2576 | | component)) |
| 2577 | | |
| 2578 | | (defmethod operation-description ((operation load-op) (component cl-source-file)) |
| 2579 | | (declare (ignorable operation)) |
| 2580 | | (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") |
| 2581 | | component)) |
| 2582 | | |
| 2583 | | (defmethod operation-description ((operation load-op) (component module)) |
| 2584 | | (declare (ignorable operation)) |
| 2585 | | (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") |
| 2586 | | component)) |
| 2587 | | |
| 2588 | | ;;;; ------------------------------------------------------------------------- |
| 2589 | | ;;;; load-source-op |
| 2590 | | |
| 2591 | | (defclass load-source-op (basic-load-op) ()) |
| 2592 | | |
| 2593 | | (defmethod perform ((o load-source-op) (c cl-source-file)) |
| 2594 | | (declare (ignorable o)) |
| 2595 | | (let ((source (component-pathname c))) |
| 2596 | | (setf (component-property c 'last-loaded-as-source) |
| 2597 | | (and (call-with-around-compile-hook |
| 2598 | | c #'(lambda () (load source :external-format (component-external-format c)))) |
| 2599 | | (get-universal-time))))) |
| 2600 | | |
| 2601 | | (defmethod perform ((operation load-source-op) (c static-file)) |
| 2602 | | (declare (ignorable operation c)) |
| 2603 | | nil) |
| 2604 | | |
| 2605 | | (defmethod output-files ((operation load-source-op) (c component)) |
| 2606 | | (declare (ignorable operation c)) |
| 2607 | | nil) |
| 2608 | | |
| 2609 | | ;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. |
| 2610 | | (defmethod component-depends-on ((o load-source-op) (c component)) |
| 2611 | | (declare (ignorable o)) |
| 2612 | | (loop :with what-would-load-op-do = (component-depends-on 'load-op c) |
| 2613 | | :for (op . co) :in what-would-load-op-do |
| 2614 | | :when (eq op 'load-op) :collect (cons 'load-source-op co))) |
| 2615 | | |
| 2616 | | (defmethod operation-done-p ((o load-source-op) (c source-file)) |
| 2617 | | (declare (ignorable o)) |
| 2618 | | (and (component-property c 'last-loaded-as-source) |
| 2619 | | (<= (safe-file-write-date (component-pathname c)) |
| 2620 | | (component-property c 'last-loaded-as-source)))) |
| 2621 | | |
| 2622 | | (defmethod operation-description ((operation load-source-op) component) |
| 2623 | | (declare (ignorable operation)) |
| 2624 | | (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") |
| 2625 | | component)) |
| 2626 | | |
| 2627 | | (defmethod operation-description ((operation load-source-op) (component module)) |
| 2628 | | (declare (ignorable operation)) |
| 2629 | | (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component)) |
| 2630 | | |
| 2631 | | |
| 2632 | | ;;;; ------------------------------------------------------------------------- |
| 2633 | | ;;;; test-op |
| 2634 | | |
| 2635 | | (defclass test-op (operation) ()) |
| 2636 | | |
| 2637 | | (defmethod perform ((operation test-op) (c component)) |
| 2638 | | (declare (ignorable operation c)) |
| 2639 | | nil) |
| 2640 | | |
| 2641 | | (defmethod operation-done-p ((operation test-op) (c system)) |
| 2642 | | "Testing a system is _never_ done." |
| 2643 | | (declare (ignorable operation c)) |
| 2644 | | nil) |
| 2645 | | |
| 2646 | | (defmethod component-depends-on :around ((o test-op) (c system)) |
| 2647 | | (declare (ignorable o)) |
| 2648 | | (cons `(load-op ,(component-name c)) (call-next-method))) |
| 2649 | | |
| 2650 | | |
| 2651 | | ;;;; ------------------------------------------------------------------------- |
| 2652 | | ;;;; Invoking Operations |
| 2653 | | |
| 2654 | | (defgeneric* operate (operation-class system &key &allow-other-keys)) |
| 2655 | | (defgeneric* perform-plan (plan &key)) |
| 2656 | | (defgeneric* plan-operates-on-p (plan component)) |
| 2657 | | |
| 2658 | | ;;;; Separating this into a different function makes it more forward-compatible |
| 2659 | | (defun* cleanup-upgraded-asdf (old-version) |
| 2660 | | (let ((new-version (asdf-version))) |
| 2661 | | (unless (equal old-version new-version) |
| 2662 | | (cond |
| 2663 | | ((version-satisfies new-version old-version) |
| 2664 | | (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") |
| 2665 | | old-version new-version)) |
| 2666 | | ((version-satisfies old-version new-version) |
| 2667 | | (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") |
| 2668 | | old-version new-version)) |
| 2669 | | (t |
| 2670 | | (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") |
| 2671 | | old-version new-version))) |
| 2672 | | (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) |
| 2673 | | ;; Invalidate all systems but ASDF itself. |
| 2674 | | (setf *defined-systems* (make-defined-systems-table)) |
