1;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- 2;;; This is ASDF 3.2.1: Another System Definition Facility. 3;;; 4;;; Feedback, bug reports, and patches are all welcome: 5;;; please mail to <asdf-devel@common-lisp.net>. 6;;; Note first that the canonical source for ASDF is presently 7;;; <URL:http://common-lisp.net/project/asdf/>. 8;;; 9;;; If you obtained this copy from anywhere else, and you experience 10;;; trouble using it, or find bugs, you may want to check at the 11;;; location above for a more recent version (and for documentation 12;;; and test files, if your copy came without them) before reporting 13;;; bugs. There are usually two "supported" revisions - the git master 14;;; branch is the latest development version, whereas the git release 15;;; branch may be slightly older but is considered `stable' 16 17;;; -- LICENSE START 18;;; (This is the MIT / X Consortium license as taken from 19;;; http://www.opensource.org/licenses/mit-license.html on or about 20;;; Monday; July 13, 2009) 21;;; 22;;; Copyright (c) 2001-2016 Daniel Barlow and contributors 23;;; 24;;; Permission is hereby granted, free of charge, to any person obtaining 25;;; a copy of this software and associated documentation files (the 26;;; "Software"), to deal in the Software without restriction, including 27;;; without limitation the rights to use, copy, modify, merge, publish, 28;;; distribute, sublicense, and/or sell copies of the Software, and to 29;;; permit persons to whom the Software is furnished to do so, subject to 30;;; the following conditions: 31;;; 32;;; The above copyright notice and this permission notice shall be 33;;; included in all copies or substantial portions of the Software. 34;;; 35;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 36;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 37;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 38;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 39;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 40;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 41;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 42;;; 43;;; -- LICENSE END 44 45;;; The problem with writing a defsystem replacement is bootstrapping: 46;;; we can't use defsystem to compile it. Hence, all in one file. 47 48;;;; --------------------------------------------------------------------------- 49;;;; Handle ASDF package upgrade, including implementation-dependent magic. 50;; 51;; See https://bugs.launchpad.net/asdf/+bug/485687 52;; 53 54(defpackage :uiop/package 55 ;; CAUTION: we must handle the first few packages specially for hot-upgrade. 56 ;; This package definition MUST NOT change unless its name too changes; 57 ;; if/when it changes, don't forget to add new functions missing from below. 58 ;; Until then, uiop/package is frozen to forever 59 ;; import and export the same exact symbols as for ASDF 2.27. 60 ;; Any other symbol must be import-from'ed and re-export'ed in a different package. 61 (:use :common-lisp) 62 (:export 63 #:find-package* #:find-symbol* #:symbol-call 64 #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* 65 #:symbol-shadowing-p #:home-package-p 66 #:symbol-package-name #:standard-common-lisp-symbol-p 67 #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol 68 #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol 69 #:ensure-package-unused #:delete-package* 70 #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away 71 #:package-definition-form #:parse-define-package-form 72 #:ensure-package #:define-package)) 73 74(in-package :uiop/package) 75 76;;;; General purpose package utilities 77 78(eval-when (:load-toplevel :compile-toplevel :execute) 79 (defun find-package* (package-designator &optional (error t)) 80 (let ((package (find-package package-designator))) 81 (cond 82 (package package) 83 (error (error "No package named ~S" (string package-designator))) 84 (t nil)))) 85 (defun find-symbol* (name package-designator &optional (error t)) 86 "Find a symbol in a package of given string'ified NAME; 87unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax 88by letting you supply a symbol or keyword for the name; 89also works well when the package is not present. 90If optional ERROR argument is NIL, return NIL instead of an error 91when the symbol is not found." 92 (block nil 93 (let ((package (find-package* package-designator error))) 94 (when package ;; package error handled by find-package* already 95 (multiple-value-bind (symbol status) (find-symbol (string name) package) 96 (cond 97 (status (return (values symbol status))) 98 (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) 99 (values nil nil)))) 100 (defun symbol-call (package name &rest args) 101 "Call a function associated with symbol of given name in given package, 102with given ARGS. Useful when the call is read before the package is loaded, 103or when loading the package is optional." 104 (apply (find-symbol* name package) args)) 105 (defun intern* (name package-designator &optional (error t)) 106 (intern (string name) (find-package* package-designator error))) 107 (defun export* (name package-designator) 108 (let* ((package (find-package* package-designator)) 109 (symbol (intern* name package))) 110 (export (or symbol (list symbol)) package))) 111 (defun import* (symbol package-designator) 112 (import (or symbol (list symbol)) (find-package* package-designator))) 113 (defun shadowing-import* (symbol package-designator) 114 (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) 115 (defun shadow* (name package-designator) 116 (shadow (list (string name)) (find-package* package-designator))) 117 (defun make-symbol* (name) 118 (etypecase name 119 (string (make-symbol name)) 120 (symbol (copy-symbol name)))) 121 (defun unintern* (name package-designator &optional (error t)) 122 (block nil 123 (let ((package (find-package* package-designator error))) 124 (when package 125 (multiple-value-bind (symbol status) (find-symbol* name package error) 126 (cond 127 (status (unintern symbol package) 128 (return (values symbol status))) 129 (error (error "symbol ~A not present in package ~A" 130 (string symbol) (package-name package)))))) 131 (values nil nil)))) 132 (defun symbol-shadowing-p (symbol package) 133 (and (member symbol (package-shadowing-symbols package)) t)) 134 (defun home-package-p (symbol package) 135 (and package (let ((sp (symbol-package symbol))) 136 (and sp (let ((pp (find-package* package))) 137 (and pp (eq sp pp)))))))) 138 139 140(eval-when (:load-toplevel :compile-toplevel :execute) 141 (defun symbol-package-name (symbol) 142 (let ((package (symbol-package symbol))) 143 (and package (package-name package)))) 144 (defun standard-common-lisp-symbol-p (symbol) 145 (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) 146 (and (eq sym symbol) (eq status :external)))) 147 (defun reify-package (package &optional package-context) 148 (if (eq package package-context) t 149 (etypecase package 150 (null nil) 151 ((eql (find-package :cl)) :cl) 152 (package (package-name package))))) 153 (defun unreify-package (package &optional package-context) 154 (etypecase package 155 (null nil) 156 ((eql t) package-context) 157 ((or symbol string) (find-package package)))) 158 (defun reify-symbol (symbol &optional package-context) 159 (etypecase symbol 160 ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) 161 (symbol (vector (symbol-name symbol) 162 (reify-package (symbol-package symbol) package-context))))) 163 (defun unreify-symbol (symbol &optional package-context) 164 (etypecase symbol 165 (symbol symbol) 166 ((simple-vector 2) 167 (let* ((symbol-name (svref symbol 0)) 168 (package-foo (svref symbol 1)) 169 (package (unreify-package package-foo package-context))) 170 (if package (intern* symbol-name package) 171 (make-symbol* symbol-name))))))) 172 173(eval-when (:load-toplevel :compile-toplevel :execute) 174 (defvar *all-package-happiness* '()) 175 (defvar *all-package-fishiness* (list t)) 176 (defun record-fishy (info) 177 ;;(format t "~&FISHY: ~S~%" info) 178 (push info *all-package-fishiness*)) 179 (defmacro when-package-fishiness (&body body) 180 `(when *all-package-fishiness* ,@body)) 181 (defmacro note-package-fishiness (&rest info) 182 `(when-package-fishiness (record-fishy (list ,@info))))) 183 184(eval-when (:load-toplevel :compile-toplevel :execute) 185 #+(or clisp clozure) 186 (defun get-setf-function-symbol (symbol) 187 #+clisp (let ((sym (get symbol 'system::setf-function))) 188 (if sym (values sym :setf-function) 189 (let ((sym (get symbol 'system::setf-expander))) 190 (if sym (values sym :setf-expander) 191 (values nil nil))))) 192 #+clozure (gethash symbol ccl::%setf-function-names%)) 193 #+(or clisp clozure) 194 (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) 195 #+clisp (assert (member kind '(:setf-function :setf-expander))) 196 #+clozure (assert (eq kind t)) 197 #+clisp 198 (cond 199 ((null new-setf-symbol) 200 (remprop symbol 'system::setf-function) 201 (remprop symbol 'system::setf-expander)) 202 ((eq kind :setf-function) 203 (setf (get symbol 'system::setf-function) new-setf-symbol)) 204 ((eq kind :setf-expander) 205 (setf (get symbol 'system::setf-expander) new-setf-symbol)) 206 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" 207 kind symbol new-setf-symbol))) 208 #+clozure 209 (progn 210 (gethash symbol ccl::%setf-function-names%) new-setf-symbol 211 (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) 212 #+(or clisp clozure) 213 (defun create-setf-function-symbol (symbol) 214 #+clisp (system::setf-symbol symbol) 215 #+clozure (ccl::construct-setf-function-name symbol)) 216 (defun set-dummy-symbol (symbol reason other-symbol) 217 (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) 218 (defun make-dummy-symbol (symbol) 219 (let ((dummy (copy-symbol symbol))) 220 (set-dummy-symbol dummy 'replacing symbol) 221 (set-dummy-symbol symbol 'replaced-by dummy) 222 dummy)) 223 (defun dummy-symbol (symbol) 224 (get symbol 'dummy-symbol)) 225 (defun get-dummy-symbol (symbol) 226 (let ((existing (dummy-symbol symbol))) 227 (if existing (values (cdr existing) (car existing)) 228 (make-dummy-symbol symbol)))) 229 (defun nuke-symbol-in-package (symbol package-designator) 230 (let ((package (find-package* package-designator)) 231 (name (symbol-name symbol))) 232 (multiple-value-bind (sym stat) (find-symbol name package) 233 (when (and (member stat '(:internal :external)) (eq symbol sym)) 234 (if (symbol-shadowing-p symbol package) 235 (shadowing-import* (get-dummy-symbol symbol) package) 236 (unintern* symbol package)))))) 237 (defun nuke-symbol (symbol &optional (packages (list-all-packages))) 238 #+(or clisp clozure) 239 (multiple-value-bind (setf-symbol kind) 240 (get-setf-function-symbol symbol) 241 (when kind (nuke-symbol setf-symbol))) 242 (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) 243 (defun rehome-symbol (symbol package-designator) 244 "Changes the home package of a symbol, also leaving it present in its old home if any" 245 (let* ((name (symbol-name symbol)) 246 (package (find-package* package-designator)) 247 (old-package (symbol-package symbol)) 248 (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) 249 (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) 250 (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) 251 (unless (eq package old-package) 252 (let ((overwritten-symbol-shadowing-p 253 (and overwritten-symbol-status 254 (symbol-shadowing-p overwritten-symbol package)))) 255 (note-package-fishiness 256 :rehome-symbol name 257 (when old-package (package-name old-package)) old-status (and shadowing t) 258 (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) 259 (when old-package 260 (if shadowing 261 (shadowing-import* shadowing old-package)) 262 (unintern* symbol old-package)) 263 (cond 264 (overwritten-symbol-shadowing-p 265 (shadowing-import* symbol package)) 266 (t 267 (when overwritten-symbol-status 268 (unintern* overwritten-symbol package)) 269 (import* symbol package))) 270 (if shadowing 271 (shadowing-import* symbol old-package) 272 (import* symbol old-package)) 273 #+(or clisp clozure) 274 (multiple-value-bind (setf-symbol kind) 275 (get-setf-function-symbol symbol) 276 (when kind 277 (let* ((setf-function (fdefinition setf-symbol)) 278 (new-setf-symbol (create-setf-function-symbol symbol))) 279 (note-package-fishiness 280 :setf-function 281 name (package-name package) 282 (symbol-name setf-symbol) (symbol-package-name setf-symbol) 283 (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) 284 (when (symbol-package setf-symbol) 285 (unintern* setf-symbol (symbol-package setf-symbol))) 286 (setf (fdefinition new-setf-symbol) setf-function) 287 (set-setf-function-symbol new-setf-symbol symbol kind)))) 288 #+(or clisp clozure) 289 (multiple-value-bind (overwritten-setf foundp) 290 (get-setf-function-symbol overwritten-symbol) 291 (when foundp 292 (unintern overwritten-setf))) 293 (when (eq old-status :external) 294 (export* symbol old-package)) 295 (when (eq overwritten-symbol-status :external) 296 (export* symbol package)))) 297 (values overwritten-symbol overwritten-symbol-status)))) 298 (defun ensure-package-unused (package) 299 (loop :for p :in (package-used-by-list package) :do 300 (unuse-package package p))) 301 (defun delete-package* (package &key nuke) 302 (let ((p (find-package package))) 303 (when p 304 (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) 305 (ensure-package-unused p) 306 (delete-package package)))) 307 (defun package-names (package) 308 (cons (package-name package) (package-nicknames package))) 309 (defun packages-from-names (names) 310 (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) 311 (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) 312 separator 313 (index (random most-positive-fixnum))) 314 (loop :for i :from index 315 :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) 316 :thereis (and (not (find-package n)) n))) 317 (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) 318 (let ((new-name 319 (apply 'fresh-package-name 320 :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) 321 (record-fishy (list :rename-away (package-names p) new-name)) 322 (rename-package p new-name)))) 323 324 325;;; Communicable representation of symbol and package information 326 327(eval-when (:load-toplevel :compile-toplevel :execute) 328 (defun package-definition-form (package-designator 329 &key (nicknamesp t) (usep t) 330 (shadowp t) (shadowing-import-p t) 331 (exportp t) (importp t) internp (error t)) 332 (let* ((package (or (find-package* package-designator error) 333 (return-from package-definition-form nil))) 334 (name (package-name package)) 335 (nicknames (package-nicknames package)) 336 (use (mapcar #'package-name (package-use-list package))) 337 (shadow ()) 338 (shadowing-import (make-hash-table :test 'equal)) 339 (import (make-hash-table :test 'equal)) 340 (export ()) 341 (intern ())) 342 (when package 343 (loop :for sym :being :the :symbols :in package 344 :for status = (nth-value 1 (find-symbol* sym package)) :do 345 (ecase status 346 ((nil :inherited)) 347 ((:internal :external) 348 (let* ((name (symbol-name sym)) 349 (external (eq status :external)) 350 (home (symbol-package sym)) 351 (home-name (package-name home)) 352 (imported (not (eq home package))) 353 (shadowing (symbol-shadowing-p sym package))) 354 (cond 355 ((and shadowing imported) 356 (push name (gethash home-name shadowing-import))) 357 (shadowing 358 (push name shadow)) 359 (imported 360 (push name (gethash home-name import)))) 361 (cond 362 (external 363 (push name export)) 364 (imported) 365 (t (push name intern))))))) 366 (labels ((sort-names (names) 367 (sort (copy-list names) #'string<)) 368 (table-keys (table) 369 (loop :for k :being :the :hash-keys :of table :collect k)) 370 (when-relevant (key value) 371 (when value (list (cons key value)))) 372 (import-options (key table) 373 (loop :for i :in (sort-names (table-keys table)) 374 :collect `(,key ,i ,@(sort-names (gethash i table)))))) 375 `(defpackage ,name 376 ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) 377 (:use ,@(and usep (sort-names use))) 378 ,@(when-relevant :shadow (and shadowp (sort-names shadow))) 379 ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) 380 ,@(import-options :import-from (and importp import)) 381 ,@(when-relevant :export (and exportp (sort-names export))) 382 ,@(when-relevant :intern (and internp (sort-names intern))))))))) 383 384 385;;; ensure-package, define-package 386(eval-when (:load-toplevel :compile-toplevel :execute) 387 (defun ensure-shadowing-import (name to-package from-package shadowed imported) 388 (check-type name string) 389 (check-type to-package package) 390 (check-type from-package package) 391 (check-type shadowed hash-table) 392 (check-type imported hash-table) 393 (let ((import-me (find-symbol* name from-package))) 394 (multiple-value-bind (existing status) (find-symbol name to-package) 395 (cond 396 ((gethash name shadowed) 397 (unless (eq import-me existing) 398 (error "Conflicting shadowings for ~A" name))) 399 (t 400 (setf (gethash name shadowed) t) 401 (setf (gethash name imported) t) 402 (unless (or (null status) 403 (and (member status '(:internal :external)) 404 (eq existing import-me) 405 (symbol-shadowing-p existing to-package))) 406 (note-package-fishiness 407 :shadowing-import name 408 (package-name from-package) 409 (or (home-package-p import-me from-package) (symbol-package-name import-me)) 410 (package-name to-package) status 411 (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) 412 (shadowing-import* import-me to-package)))))) 413 (defun ensure-imported (import-me into-package &optional from-package) 414 (check-type import-me symbol) 415 (check-type into-package package) 416 (check-type from-package (or null package)) 417 (let ((name (symbol-name import-me))) 418 (multiple-value-bind (existing status) (find-symbol name into-package) 419 (cond 420 ((not status) 421 (import* import-me into-package)) 422 ((eq import-me existing)) 423 (t 424 (let ((shadowing-p (symbol-shadowing-p existing into-package))) 425 (note-package-fishiness 426 :ensure-imported name 427 (and from-package (package-name from-package)) 428 (or (home-package-p import-me from-package) (symbol-package-name import-me)) 429 (package-name into-package) 430 status 431 (and status (or (home-package-p existing into-package) (symbol-package-name existing))) 432 shadowing-p) 433 (cond 434 ((or shadowing-p (eq status :inherited)) 435 (shadowing-import* import-me into-package)) 436 (t 437 (unintern* existing into-package) 438 (import* import-me into-package)))))))) 439 (values)) 440 (defun ensure-import (name to-package from-package shadowed imported) 441 (check-type name string) 442 (check-type to-package package) 443 (check-type from-package package) 444 (check-type shadowed hash-table) 445 (check-type imported hash-table) 446 (multiple-value-bind (import-me import-status) (find-symbol name from-package) 447 (when (null import-status) 448 (note-package-fishiness 449 :import-uninterned name (package-name from-package) (package-name to-package)) 450 (setf import-me (intern* name from-package))) 451 (multiple-value-bind (existing status) (find-symbol name to-package) 452 (cond 453 ((and imported (gethash name imported)) 454 (unless (and status (eq import-me existing)) 455 (error "Can't import ~S from both ~S and ~S" 456 name (package-name (symbol-package existing)) (package-name from-package)))) 457 ((gethash name shadowed) 458 (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) 459 (t 460 (setf (gethash name imported) t)))) 461 (ensure-imported import-me to-package from-package))) 462 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) 463 (check-type name string) 464 (check-type symbol symbol) 465 (check-type to-package package) 466 (check-type from-package package) 467 (check-type mixp (member nil t)) ; no cl:boolean on Genera 468 (check-type shadowed hash-table) 469 (check-type imported hash-table) 470 (check-type inherited hash-table) 471 (multiple-value-bind (existing status) (find-symbol name to-package) 472 (let* ((sp (symbol-package symbol)) 473 (in (gethash name inherited)) 474 (xp (and status (symbol-package existing)))) 475 (when (null sp) 476 (note-package-fishiness 477 :import-uninterned name 478 (package-name from-package) (package-name to-package) mixp) 479 (import* symbol from-package) 480 (setf sp (package-name from-package))) 481 (cond 482 ((gethash name shadowed)) 483 (in 484 (unless (equal sp (first in)) 485 (if mixp 486 (ensure-shadowing-import name to-package (second in) shadowed imported) 487 (error "Can't inherit ~S from ~S, it is inherited from ~S" 488 name (package-name sp) (package-name (first in)))))) 489 ((gethash name imported) 490 (unless (eq symbol existing) 491 (error "Can't inherit ~S from ~S, it is imported from ~S" 492 name (package-name sp) (package-name xp)))) 493 (t 494 (setf (gethash name inherited) (list sp from-package)) 495 (when (and status (not (eq sp xp))) 496 (let ((shadowing (symbol-shadowing-p existing to-package))) 497 (note-package-fishiness 498 :inherited name 499 (package-name from-package) 500 (or (home-package-p symbol from-package) (symbol-package-name symbol)) 501 (package-name to-package) 502 (or (home-package-p existing to-package) (symbol-package-name existing))) 503 (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) 504 (unintern* existing to-package))))))))) 505 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) 506 (check-type name string) 507 (check-type symbol symbol) 508 (check-type to-package package) 509 (check-type from-package package) 510 (check-type shadowed hash-table) 511 (check-type imported hash-table) 512 (check-type inherited hash-table) 513 (unless (gethash name shadowed) 514 (multiple-value-bind (existing status) (find-symbol name to-package) 515 (let* ((sp (symbol-package symbol)) 516 (im (gethash name imported)) 517 (in (gethash name inherited))) 518 (cond 519 ((or (null status) 520 (and status (eq symbol existing)) 521 (and in (eq sp (first in)))) 522 (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) 523 (in 524 (remhash name inherited) 525 (ensure-shadowing-import name to-package (second in) shadowed imported)) 526 (im 527 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]" 528 name (package-name from-package) 529 (home-package-p symbol from-package) (symbol-package-name symbol) 530 (package-name to-package) 531 (home-package-p existing to-package) (symbol-package-name existing))) 532 (t 533 (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) 534 535 (defun recycle-symbol (name recycle exported) 536 ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE 537 ;; packages, and a hash-table of names (strings) of symbols scheduled to be 538 ;; EXPORTED from the package being defined. It returns two values, the 539 ;; symbol found (if any, or else NIL), and a boolean flag indicating whether 540 ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the 541 ;; re-homing of the symbol, etc. 542 (check-type name string) 543 (check-type recycle list) 544 (check-type exported hash-table) 545 (when (gethash name exported) ;; don't bother recycling private symbols 546 (let (recycled foundp) 547 (dolist (r recycle (values recycled foundp)) 548 (multiple-value-bind (symbol status) (find-symbol name r) 549 (when (and status (home-package-p symbol r)) 550 (cond 551 (foundp 552 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. 553 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) 554 (t 555 (setf recycled symbol foundp r))))))))) 556 (defun symbol-recycled-p (sym recycle) 557 (check-type sym symbol) 558 (check-type recycle list) 559 (and (member (symbol-package sym) recycle) t)) 560 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) 561 (check-type name string) 562 (check-type package package) 563 (check-type intern (member nil t)) ; no cl:boolean on Genera 564 (check-type shadowed hash-table) 565 (check-type imported hash-table) 566 (check-type inherited hash-table) 567 (unless (or (gethash name shadowed) 568 (gethash name imported) 569 (gethash name inherited)) 570 (multiple-value-bind (existing status) 571 (find-symbol name package) 572 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) 573 (cond 574 ((and status (eq existing recycled) (eq previous package))) 575 (previous 576 (rehome-symbol recycled package)) 577 ((and status (eq package (symbol-package existing)))) 578 (t 579 (when status 580 (note-package-fishiness 581 :ensure-symbol name 582 (reify-package (symbol-package existing) package) 583 status intern) 584 (unintern existing)) 585 (when intern 586 (intern* name package)))))))) 587 (declaim (ftype (function (t t t &optional t) t) ensure-exported)) 588 (defun ensure-exported-to-user (name symbol to-package &optional recycle) 589 (check-type name string) 590 (check-type symbol symbol) 591 (check-type to-package package) 592 (check-type recycle list) 593 (assert (equal name (symbol-name symbol))) 594 (multiple-value-bind (existing status) (find-symbol name to-package) 595 (unless (and status (eq symbol existing)) 596 (let ((accessible 597 (or (null status) 598 (let ((shadowing (symbol-shadowing-p existing to-package)) 599 (recycled (symbol-recycled-p existing recycle))) 600 (unless (and shadowing (not recycled)) 601 (note-package-fishiness 602 :ensure-export name (symbol-package-name symbol) 603 (package-name to-package) 604 (or (home-package-p existing to-package) (symbol-package-name existing)) 605 status shadowing) 606 (if (or (eq status :inherited) shadowing) 607 (shadowing-import* symbol to-package) 608 (unintern existing to-package)) 609 t))))) 610 (when (and accessible (eq status :external)) 611 (ensure-exported name symbol to-package recycle)))))) 612 (defun ensure-exported (name symbol from-package &optional recycle) 613 (dolist (to-package (package-used-by-list from-package)) 614 (ensure-exported-to-user name symbol to-package recycle)) 615 (unless (eq from-package (symbol-package symbol)) 616 (ensure-imported symbol from-package)) 617 (export* name from-package)) 618 (defun ensure-export (name from-package &optional recycle) 619 (multiple-value-bind (symbol status) (find-symbol* name from-package) 620 (unless (eq status :external) 621 (ensure-exported name symbol from-package recycle)))) 622 (defun ensure-package (name &key 623 nicknames documentation use 624 shadow shadowing-import-from 625 import-from export intern 626 recycle mix reexport 627 unintern) 628 #+genera (declare (ignore documentation)) 629 (let* ((package-name (string name)) 630 (nicknames (mapcar #'string nicknames)) 631 (names (cons package-name nicknames)) 632 (previous (packages-from-names names)) 633 (discarded (cdr previous)) 634 (to-delete ()) 635 (package (or (first previous) (make-package package-name :nicknames nicknames))) 636 (recycle (packages-from-names recycle)) 637 (use (mapcar 'find-package* use)) 638 (mix (mapcar 'find-package* mix)) 639 (reexport (mapcar 'find-package* reexport)) 640 (shadow (mapcar 'string shadow)) 641 (export (mapcar 'string export)) 642 (intern (mapcar 'string intern)) 643 (unintern (mapcar 'string unintern)) 644 (shadowed (make-hash-table :test 'equal)) ; string to bool 645 (imported (make-hash-table :test 'equal)) ; string to bool 646 (exported (make-hash-table :test 'equal)) ; string to bool 647 ;; string to list home package and use package: 648 (inherited (make-hash-table :test 'equal))) 649 (when-package-fishiness (record-fishy package-name)) 650 #-genera 651 (when documentation (setf (documentation package t) documentation)) 652 (loop :for p :in (set-difference (package-use-list package) (append mix use)) 653 :do (note-package-fishiness :over-use name (package-names p)) 654 (unuse-package p package)) 655 (loop :for p :in discarded 656 :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) 657 (package-names p)) 658 :do (note-package-fishiness :nickname name (package-names p)) 659 (cond (n (rename-package p (first n) (rest n))) 660 (t (rename-package-away p) 661 (push p to-delete)))) 662 (rename-package package package-name nicknames) 663 (dolist (name unintern) 664 (multiple-value-bind (existing status) (find-symbol name package) 665 (when status 666 (unless (eq status :inherited) 667 (note-package-fishiness 668 :unintern (package-name package) name (symbol-package-name existing) status) 669 (unintern* name package nil))))) 670 (dolist (name export) 671 (setf (gethash name exported) t)) 672 (dolist (p reexport) 673 (do-external-symbols (sym p) 674 (setf (gethash (string sym) exported) t))) 675 (do-external-symbols (sym package) 676 (let ((name (symbol-name sym))) 677 (unless (gethash name exported) 678 (note-package-fishiness 679 :over-export (package-name package) name 680 (or (home-package-p sym package) (symbol-package-name sym))) 681 (unexport sym package)))) 682 (dolist (name shadow) 683 (setf (gethash name shadowed) t) 684 (multiple-value-bind (existing status) (find-symbol name package) 685 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) 686 (let ((shadowing (and status (symbol-shadowing-p existing package)))) 687 (cond 688 ((eq previous package)) 689 (previous 690 (rehome-symbol recycled package)) 691 ((or (member status '(nil :inherited)) 692 (home-package-p existing package))) 693 (t 694 (let ((dummy (make-symbol name))) 695 (note-package-fishiness 696 :shadow-imported (package-name package) name 697 (symbol-package-name existing) status shadowing) 698 (shadowing-import* dummy package) 699 (import* dummy package))))))) 700 (shadow* name package)) 701 (loop :for (p . syms) :in shadowing-import-from 702 :for pp = (find-package* p) :do 703 (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) 704 (loop :for p :in mix 705 :for pp = (find-package* p) :do 706 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) 707 (loop :for (p . syms) :in import-from 708 :for pp = (find-package p) :do 709 (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) 710 (dolist (p (append use mix)) 711 (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) 712 (use-package p package)) 713 (loop :for name :being :the :hash-keys :of exported :do 714 (ensure-symbol name package t recycle shadowed imported inherited exported) 715 (ensure-export name package recycle)) 716 (dolist (name intern) 717 (ensure-symbol name package t recycle shadowed imported inherited exported)) 718 (do-symbols (sym package) 719 (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) 720 (map () 'delete-package* to-delete) 721 package))) 722 723(eval-when (:load-toplevel :compile-toplevel :execute) 724 (defun parse-define-package-form (package clauses) 725 (loop 726 :with use-p = nil :with recycle-p = nil 727 :with documentation = nil 728 :for (kw . args) :in clauses 729 :when (eq kw :nicknames) :append args :into nicknames :else 730 :when (eq kw :documentation) 731 :do (cond 732 (documentation (error "define-package: can't define documentation twice")) 733 ((or (atom args) (cdr args)) (error "define-package: bad documentation")) 734 (t (setf documentation (car args)))) :else 735 :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else 736 :when (eq kw :shadow) :append args :into shadow :else 737 :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else 738 :when (eq kw :import-from) :collect args :into import-from :else 739 :when (eq kw :export) :append args :into export :else 740 :when (eq kw :intern) :append args :into intern :else 741 :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else 742 :when (eq kw :mix) :append args :into mix :else 743 :when (eq kw :reexport) :append args :into reexport :else 744 :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport 745 :and :do (setf use-p t) :else 746 :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport 747 :and :do (setf use-p t) :else 748 :when (eq kw :unintern) :append args :into unintern :else 749 :do (error "unrecognized define-package keyword ~S" kw) 750 :finally (return `(,package 751 :nicknames ,nicknames :documentation ,documentation 752 :use ,(if use-p use '(:common-lisp)) 753 :shadow ,shadow :shadowing-import-from ,shadowing-import-from 754 :import-from ,import-from :export ,export :intern ,intern 755 :recycle ,(if recycle-p recycle (cons package nicknames)) 756 :mix ,mix :reexport ,reexport :unintern ,unintern))))) 757 758(defmacro define-package (package &rest clauses) 759 "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form 760\(KEYWORD . ARGS\). 761DEFINE-PACKAGE supports the following keywords: 762USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE. 763RECYCLE -- Recycle the package's exported symbols from the specified packages, 764in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE, 765either through an :EXPORT option or a :REEXPORT option, if the symbol exists in 766one of the :RECYCLE packages, the first such symbol is re-homed to the package 767being defined. 768For the sake of idempotence, it is important that the package being defined 769should appear in first position if it already exists, and even if it doesn't, 770ahead of any package that is not going to be deleted afterwards and never 771created again. In short, except for special cases, always make it the first 772package on the list if the list is not empty. 773MIX -- Takes a list of package designators. MIX behaves like 774\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to 775resolve conflicts in favor of the first found symbol. It may still yield 776an error if there is a conflict with an explicitly :IMPORT-FROM symbol. 777REEXPORT -- Takes a list of package designators. For each package, p, in the list, 778export symbols with the same name as those exported from p. Note that in the case 779of shadowing, etc. the symbols with the same name may not be the same symbols. 780UNINTERN -- Remove symbols here from PACKAGE." 781 (let ((ensure-form 782 `(apply 'ensure-package ',(parse-define-package-form package clauses)))) 783 `(progn 784 #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) 785 (eval-when (:compile-toplevel :load-toplevel :execute) 786 ,ensure-form)))) 787;;;; ------------------------------------------------------------------------- 788;;;; Handle compatibility with multiple implementations. 789;;; This file is for papering over the deficiencies and peculiarities 790;;; of various Common Lisp implementations. 791;;; For implementation-specific access to the system, see os.lisp instead. 792;;; A few functions are defined here, but actually exported from utility; 793;;; from this package only common-lisp symbols are exported. 794 795(uiop/package:define-package :uiop/common-lisp 796 (:nicknames :uoip/cl) 797 (:use :uiop/package) 798 (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) 799 #+allegro (:intern #:*acl-warn-save*) 800 #+cormanlisp (:shadow #:user-homedir-pathname) 801 #+cormanlisp 802 (:export 803 #:logical-pathname #:translate-logical-pathname 804 #:make-broadcast-stream #:file-namestring) 805 #+genera (:shadowing-import-from :scl #:boolean) 806 #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) 807 #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) 808(in-package :uiop/common-lisp) 809 810#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 811(error "ASDF is not supported on your implementation. Please help us port it.") 812 813;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. 814 815 816;;;; Early meta-level tweaks 817 818#+(or allegro clasp clisp clozure cmucl ecl mkcl sbcl) 819(eval-when (:load-toplevel :compile-toplevel :execute) 820 (when (and #+allegro (member :ics *features*) 821 #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*) 822 #+clozure (member :openmcl-unicode-strings *features*) 823 #+sbcl (member :sb-unicode *features*)) 824 ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode 825 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. 826 (pushnew :asdf-unicode *features*))) 827 828#+allegro 829(eval-when (:load-toplevel :compile-toplevel :execute) 830 ;; We need to disable autoloading BEFORE any mention of package ASDF. 831 ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file 832 ;; or any previous file. 833 (setf excl::*autoload-package-name-alist* 834 (remove "asdf" excl::*autoload-package-name-alist* 835 :test 'equalp :key 'car)) 836 (defparameter *acl-warn-save* 837 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 838 excl:*warn-on-nested-reader-conditionals*)) 839 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 840 (setf excl:*warn-on-nested-reader-conditionals* nil)) 841 (setf *print-readably* nil)) 842 843#+clasp 844(eval-when (:load-toplevel :compile-toplevel :execute) 845 (setf *load-verbose* nil) 846 (defun use-ecl-byte-compiler-p () nil)) 847 848#+clozure (in-package :ccl) 849#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 850(eval-when (:load-toplevel :compile-toplevel :execute) 851 (unless (fboundp 'external-process-wait) 852 (in-development-mode 853 (defun external-process-wait (proc) 854 (when (and (external-process-pid proc) (eq (external-process-%status proc) :running)) 855 (with-interrupts-enabled 856 (wait-on-semaphore (external-process-completed proc)))) 857 (values (external-process-%exit-code proc) 858 (external-process-%status proc)))))) 859#+clozure (in-package :uiop/common-lisp) ;; back in this package. 860 861#+cmucl 862(eval-when (:load-toplevel :compile-toplevel :execute) 863 (setf ext:*gc-verbose* nil) 864 (defun user-homedir-pathname () 865 (first (ext:search-list (cl:user-homedir-pathname))))) 866 867#+cormanlisp 868(eval-when (:load-toplevel :compile-toplevel :execute) 869 (deftype logical-pathname () nil) 870 (defun make-broadcast-stream () *error-output*) 871 (defun translate-logical-pathname (x) x) 872 (defun user-homedir-pathname (&optional host) 873 (declare (ignore host)) 874 (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) 875 (defun file-namestring (p) 876 (setf p (pathname p)) 877 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) 878 879#+ecl 880(eval-when (:load-toplevel :compile-toplevel :execute) 881 (setf *load-verbose* nil) 882 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) 883 (unless (use-ecl-byte-compiler-p) (require :cmp))) 884 885#+gcl 886(eval-when (:load-toplevel :compile-toplevel :execute) 887 (unless (member :ansi-cl *features*) 888 (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) 889 (setf compiler::*compiler-default-type* (pathname "") 890 compiler::*lsp-ext* "") 891 #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later. 892 (cond 893 #+gcl 894 ((or (< system::*gcl-major-version* 2) 895 (and (= system::*gcl-major-version* 2) 896 (< system::*gcl-minor-version* 7))) 897 '(error "GCL 2.7 or later required to use ASDF"))))) 898 (eval code) 899 code)) 900 901#+genera 902(eval-when (:load-toplevel :compile-toplevel :execute) 903 (unless (fboundp 'lambda) 904 (defmacro lambda (&whole form &rest bvl-decls-and-body) 905 (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) 906 `#',(cons 'lisp::lambda (cdr form)))) 907 (unless (fboundp 'ensure-directories-exist) 908 (defun ensure-directories-exist (path) 909 (fs:create-directories-recursively (pathname path)))) 910 (unless (fboundp 'read-sequence) 911 (defun read-sequence (sequence stream &key (start 0) end) 912 (scl:send stream :string-in nil sequence start end))) 913 (unless (fboundp 'write-sequence) 914 (defun write-sequence (sequence stream &key (start 0) end) 915 (scl:send stream :string-out sequence start end) 916 sequence))) 917 918#+lispworks 919(eval-when (:load-toplevel :compile-toplevel :execute) 920 ;; lispworks 3 and earlier cannot be checked for so we always assume 921 ;; at least version 4 922 (unless (member :lispworks4 *features*) 923 (pushnew :lispworks5+ *features*) 924 (unless (member :lispworks5 *features*) 925 (pushnew :lispworks6+ *features*) 926 (unless (member :lispworks6 *features*) 927 (pushnew :lispworks7+ *features*))))) 928 929#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick 930 (read-from-string 931 "(eval-when (:load-toplevel :compile-toplevel :execute) 932 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) 933 (ccl:define-entry-point (_system \"system\") ((name :string)) :int) 934 ;; Note: ASDF may expect user-homedir-pathname to provide 935 ;; the pathname of the current user's home directory, whereas 936 ;; MCL by default provides the directory from which MCL was started. 937 ;; See http://code.google.com/p/mcl/wiki/Portability 938 (defun user-homedir-pathname () 939 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) 940 (defun probe-posix (posix-namestring) 941 \"If a file exists for the posix namestring, return the pathname\" 942 (ccl::with-cstrs ((cpath posix-namestring)) 943 (ccl::rlet ((is-dir :boolean) 944 (fsref :fsref)) 945 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) 946 (ccl::%path-from-fsref fsref is-dir))))))")) 947 948#+mkcl 949(eval-when (:load-toplevel :compile-toplevel :execute) 950 (require :cmp) 951 (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics 952 953 954;;;; Looping 955(eval-when (:load-toplevel :compile-toplevel :execute) 956 (defmacro loop* (&rest rest) 957 #-genera `(loop ,@rest) 958 #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh. 959 960 961;;;; compatfmt: avoid fancy format directives when unsupported 962(eval-when (:load-toplevel :compile-toplevel :execute) 963 (defun frob-substrings (string substrings &optional frob) 964 "for each substring in SUBSTRINGS, find occurrences of it within STRING 965that don't use parts of matched occurrences of previous strings, and 966FROB them, that is to say, remove them if FROB is NIL, 967replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, 968call FROB with the match and a function that emits a string in the output. 969Return a string made of the parts not omitted or emitted by FROB." 970 (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3))) 971 (let ((length (length string)) (stream nil)) 972 (labels ((emit-string (x &optional (start 0) (end (length x))) 973 (when (< start end) 974 (unless stream (setf stream (make-string-output-stream))) 975 (write-string x stream :start start :end end))) 976 (emit-substring (start end) 977 (when (and (zerop start) (= end length)) 978 (return-from frob-substrings string)) 979 (emit-string string start end)) 980 (recurse (substrings start end) 981 (cond 982 ((>= start end)) 983 ((null substrings) (emit-substring start end)) 984 (t (let* ((sub-spec (first substrings)) 985 (sub (if (consp sub-spec) (car sub-spec) sub-spec)) 986 (fun (if (consp sub-spec) (cdr sub-spec) frob)) 987 (found (search sub string :start2 start :end2 end)) 988 (more (rest substrings))) 989 (cond 990 (found 991 (recurse more start found) 992 (etypecase fun 993 (null) 994 (string (emit-string fun)) 995 (function (funcall fun sub #'emit-string))) 996 (recurse substrings (+ found (length sub)) end)) 997 (t 998 (recurse more start end)))))))) 999 (recurse substrings 0 length)) 1000 (if stream (get-output-stream-string stream) ""))) 1001 1002 (defmacro compatfmt (format) 1003 #+(or gcl genera) 1004 (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) 1005 #-(or gcl genera) format)) 1006;;;; ------------------------------------------------------------------------- 1007;;;; General Purpose Utilities for ASDF 1008 1009(uiop/package:define-package :uiop/utility 1010 (:use :uiop/common-lisp :uiop/package) 1011 ;; import and reexport a few things defined in :uiop/common-lisp 1012 (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings 1013 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) 1014 (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt 1015 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) 1016 (:export 1017 ;; magic helper to define debugging functions: 1018 #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* 1019 #:with-upgradability ;; (un)defining functions in an upgrade-friendly way 1020 #:defun* #:defgeneric* 1021 #:nest #:if-let ;; basic flow control 1022 #:parse-body ;; macro definition helper 1023 #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists 1024 #:remove-plist-keys #:remove-plist-key ;; plists 1025 #:emptyp ;; sequences 1026 #:+non-base-chars-exist-p+ ;; characters 1027 #:+max-character-type-index+ #:character-type-index #:+character-types+ 1028 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings 1029 #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ 1030 #:string-prefix-p #:string-enclosed-p #:string-suffix-p 1031 #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols 1032 #:coerce-class ;; CLOS 1033 #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps 1034 #:earlier-stamp #:stamps-earliest #:earliest-stamp 1035 #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f 1036 #:list-to-hash-set #:ensure-gethash ;; hash-table 1037 #:ensure-function #:access-at #:access-at-count ;; functions 1038 #:call-function #:call-functions #:register-hook-function 1039 #:lexicographic< #:lexicographic<= ;; version 1040 #:simple-style-warning #:style-warn ;; simple style warnings 1041 #:match-condition-p #:match-any-condition-p ;; conditions 1042 #:call-with-muffled-conditions #:with-muffled-conditions 1043 #:not-implemented-error #:parameter-error)) 1044(in-package :uiop/utility) 1045 1046;;;; Defining functions in a way compatible with hot-upgrade: 1047;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, 1048;; thus replacing the function without warning or error 1049;; even if the signature and/or generic-ness of the function has changed. 1050;; For a generic function, this invalidates any previous DEFMETHOD. 1051(eval-when (:load-toplevel :compile-toplevel :execute) 1052 (macrolet 1053 ((defdef (def* def) 1054 `(defmacro ,def* (name formals &rest rest) 1055 (destructuring-bind (name &key (supersede t)) 1056 (if (or (atom name) (eq (car name) 'setf)) 1057 (list name :supersede nil) 1058 name) 1059 (declare (ignorable supersede)) 1060 `(progn 1061 ;; We usually try to do it only for the functions that need it, 1062 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer. 1063 ,@(when supersede 1064 `((fmakunbound ',name))) 1065 ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl 1066 `((declaim (notinline ,name)))) 1067 (,',def ,name ,formals ,@rest)))))) 1068 (defdef defgeneric* defgeneric) 1069 (defdef defun* defun)) 1070 (defmacro with-upgradability ((&optional) &body body) 1071 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified 1072to also declare the functions NOTINLINE and to accept a wrapping the function name 1073specification into a list with keyword argument SUPERSEDE (which defaults to T if the name 1074is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION 1075to supersede any previous definition." 1076 `(eval-when (:compile-toplevel :load-toplevel :execute) 1077 ,@(loop :for form :in body :collect 1078 (if (consp form) 1079 (destructuring-bind (car . cdr) form 1080 (case car 1081 ((defun) `(defun* ,@cdr)) 1082 ((defgeneric) `(defgeneric* ,@cdr)) 1083 (otherwise form))) 1084 form))))) 1085 1086;;; Magic debugging help. See contrib/debug.lisp 1087(with-upgradability () 1088 (defvar *uiop-debug-utility* 1089 '(or (ignore-errors 1090 (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) 1091 (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "common-lisp/asdf/uiop/contrib/debug.lisp")) 1092 "form that evaluates to the pathname to your favorite debugging utilities") 1093 1094 (defmacro uiop-debug (&rest keys) 1095 `(eval-when (:compile-toplevel :load-toplevel :execute) 1096 (load-uiop-debug-utility ,@keys))) 1097 1098 (defun load-uiop-debug-utility (&key package utility-file) 1099 (let* ((*package* (if package (find-package package) *package*)) 1100 (keyword (read-from-string 1101 (format nil ":DBG-~:@(~A~)" (package-name *package*))))) 1102 (unless (member keyword *features*) 1103 (let* ((utility-file (or utility-file *uiop-debug-utility*)) 1104 (file (ignore-errors (probe-file (eval utility-file))))) 1105 (if file (load file) 1106 (error "Failed to locate debug utility file: ~S" utility-file))))))) 1107 1108;;; Flow control 1109(with-upgradability () 1110 (defmacro nest (&rest things) 1111 "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer 1112 (reduce #'(lambda (outer inner) `(,@outer ,inner)) 1113 things :from-end t)) 1114 1115 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria 1116 ;; bindings can be (var form) or ((var1 form1) ...) 1117 (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) 1118 (list bindings) 1119 bindings)) 1120 (variables (mapcar #'car binding-list))) 1121 `(let ,binding-list 1122 (if (and ,@variables) 1123 ,then-form 1124 ,else-form))))) 1125 1126;;; Macro definition helper 1127(with-upgradability () 1128 (defun parse-body (body &key documentation whole) ;; from alexandria 1129 "Parses BODY into (values remaining-forms declarations doc-string). 1130Documentation strings are recognized only if DOCUMENTATION is true. 1131Syntax errors in body are signalled and WHOLE is used in the signal 1132arguments when given." 1133 (let ((doc nil) 1134 (decls nil) 1135 (current nil)) 1136 (tagbody 1137 :declarations 1138 (setf current (car body)) 1139 (when (and documentation (stringp current) (cdr body)) 1140 (if doc 1141 (error "Too many documentation strings in ~S." (or whole body)) 1142 (setf doc (pop body))) 1143 (go :declarations)) 1144 (when (and (listp current) (eql (first current) 'declare)) 1145 (push (pop body) decls) 1146 (go :declarations))) 1147 (values body (nreverse decls) doc)))) 1148 1149 1150;;; List manipulation 1151(with-upgradability () 1152 (defmacro while-collecting ((&rest collectors) &body body) 1153 "COLLECTORS should be a list of names for collections. A collector 1154defines a function that, when applied to an argument inside BODY, will 1155add its argument to the corresponding collection. Returns multiple values, 1156a list for each collection, in order. 1157 E.g., 1158\(while-collecting \(foo bar\) 1159 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) 1160 \(foo \(first x\)\) 1161 \(bar \(second x\)\)\)\) 1162Returns two values: \(A B C\) and \(1 2 3\)." 1163 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) 1164 (initial-values (mapcar (constantly nil) collectors))) 1165 `(let ,(mapcar #'list vars initial-values) 1166 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) 1167 ,@body 1168 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) 1169 1170 (define-modify-macro appendf (&rest args) 1171 append "Append onto list") ;; only to be used on short lists. 1172 1173 (defun length=n-p (x n) ;is it that (= (length x) n) ? 1174 (check-type n (integer 0 *)) 1175 (loop 1176 :for l = x :then (cdr l) 1177 :for i :downfrom n :do 1178 (cond 1179 ((zerop i) (return (null l))) 1180 ((not (consp l)) (return nil))))) 1181 1182 (defun ensure-list (x) 1183 (if (listp x) x (list x)))) 1184 1185 1186;;; Remove a key from a plist, i.e. for keyword argument cleanup 1187(with-upgradability () 1188 (defun remove-plist-key (key plist) 1189 "Remove a single key from a plist" 1190 (loop* :for (k v) :on plist :by #'cddr 1191 :unless (eq k key) 1192 :append (list k v))) 1193 1194 (defun remove-plist-keys (keys plist) 1195 "Remove a list of keys from a plist" 1196 (loop* :for (k v) :on plist :by #'cddr 1197 :unless (member k keys) 1198 :append (list k v)))) 1199 1200 1201;;; Sequences 1202(with-upgradability () 1203 (defun emptyp (x) 1204 "Predicate that is true for an empty sequence" 1205 (or (null x) (and (vectorp x) (zerop (length x)))))) 1206 1207 1208;;; Characters 1209(with-upgradability () 1210 ;; base-char != character on ECL, LW, SBCL, Genera. 1211 ;; NB: We assume a total order on character types. 1212 ;; If that's not true... this code will need to be updated. 1213 (defparameter +character-types+ ;; assuming a simple hierarchy 1214 #.(coerce (loop* :for (type next) :on 1215 '(;; In SCL, all characters seem to be 16-bit base-char 1216 ;; Yet somehow character fails to be a subtype of base-char 1217 #-scl base-char 1218 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER 1219 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER 1220 #+lispworks7+ lw:bmp-char 1221 #+lispworks lw:simple-char 1222 character) 1223 :unless (and next (subtypep next type)) 1224 :collect type) 'vector)) 1225 (defparameter +max-character-type-index+ (1- (length +character-types+))) 1226 (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+)) 1227 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) 1228 1229(with-upgradability () 1230 (defun character-type-index (x) 1231 (declare (ignorable x)) 1232 #.(case +max-character-type-index+ 1233 (0 0) 1234 (1 '(etypecase x 1235 (character (if (typep x 'base-char) 0 1)) 1236 (symbol (if (subtypep x 'base-char) 0 1)))) 1237 (otherwise 1238 '(or (position-if (etypecase x 1239 (character #'(lambda (type) (typep x type))) 1240 (symbol #'(lambda (type) (subtypep x type)))) 1241 +character-types+) 1242 (error "Not a character or character type: ~S" x)))))) 1243 1244 1245;;; Strings 1246(with-upgradability () 1247 (defun base-string-p (string) 1248 "Does the STRING only contain BASE-CHARs?" 1249 (declare (ignorable string)) 1250 (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) 1251 1252 (defun strings-common-element-type (strings) 1253 "What least subtype of CHARACTER can contain all the elements of all the STRINGS?" 1254 (declare (ignorable strings)) 1255 #.(if +non-base-chars-exist-p+ 1256 `(aref +character-types+ 1257 (loop :with index = 0 :for s :in strings :do 1258 (flet ((consider (i) 1259 (cond ((= i ,+max-character-type-index+) (return i)) 1260 ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i))))))) 1261 (cond 1262 ((emptyp s)) ;; NIL or empty string 1263 ((characterp s) (consider (character-type-index s))) 1264 ((stringp s) (let ((string-type-index 1265 (character-type-index (array-element-type s)))) 1266 (unless (>= index string-type-index) 1267 (loop :for c :across s :for i = (character-type-index c) 1268 :do (consider i) 1269 ,@(when (> +max-character-type-index+ 1) 1270 `((when (= i string-type-index) (return)))))))) 1271 (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))) 1272 :finally (return index))) 1273 ''character)) 1274 1275 (defun reduce/strcat (strings &key key start end) 1276 "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. 1277NIL is interpreted as an empty string. A character is interpreted as a string of length one." 1278 (when (or start end) (setf strings (subseq strings start end))) 1279 (when key (setf strings (mapcar key strings))) 1280 (loop :with output = (make-string (loop :for s :in strings 1281 :sum (if (characterp s) 1 (length s))) 1282 :element-type (strings-common-element-type strings)) 1283 :with pos = 0 1284 :for input :in strings 1285 :do (etypecase input 1286 (null) 1287 (character (setf (char output pos) input) (incf pos)) 1288 (string (replace output input :start1 pos) (incf pos (length input)))) 1289 :finally (return output))) 1290 1291 (defun strcat (&rest strings) 1292 "Concatenate strings. 1293NIL is interpreted as an empty string, a character as a string of length one." 1294 (reduce/strcat strings)) 1295 1296 (defun first-char (s) 1297 "Return the first character of a non-empty string S, or NIL" 1298 (and (stringp s) (plusp (length s)) (char s 0))) 1299 1300 (defun last-char (s) 1301 "Return the last character of a non-empty string S, or NIL" 1302 (and (stringp s) (plusp (length s)) (char s (1- (length s))))) 1303 1304 (defun split-string (string &key max (separator '(#\Space #\Tab))) 1305 "Split STRING into a list of components separated by 1306any of the characters in the sequence SEPARATOR. 1307If MAX is specified, then no more than max(1,MAX) components will be returned, 1308starting the separation from the end, e.g. when called with arguments 1309 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." 1310 (block () 1311 (let ((list nil) (words 0) (end (length string))) 1312 (when (zerop end) (return nil)) 1313 (flet ((separatorp (char) (find char separator)) 1314 (done () (return (cons (subseq string 0 end) list)))) 1315 (loop 1316 :for start = (if (and max (>= words (1- max))) 1317 (done) 1318 (position-if #'separatorp string :end end :from-end t)) 1319 :do (when (null start) (done)) 1320 (push (subseq string (1+ start) end) list) 1321 (incf words) 1322 (setf end start)))))) 1323 1324 (defun string-prefix-p (prefix string) 1325 "Does STRING begin with PREFIX?" 1326 (let* ((x (string prefix)) 1327 (y (string string)) 1328 (lx (length x)) 1329 (ly (length y))) 1330 (and (<= lx ly) (string= x y :end2 lx)))) 1331 1332 (defun string-suffix-p (string suffix) 1333 "Does STRING end with SUFFIX?" 1334 (let* ((x (string string)) 1335 (y (string suffix)) 1336 (lx (length x)) 1337 (ly (length y))) 1338 (and (<= ly lx) (string= x y :start1 (- lx ly))))) 1339 1340 (defun string-enclosed-p (prefix string suffix) 1341 "Does STRING begin with PREFIX and end with SUFFIX?" 1342 (and (string-prefix-p prefix string) 1343 (string-suffix-p string suffix))) 1344 1345 (defvar +cr+ (coerce #(#\Return) 'string)) 1346 (defvar +lf+ (coerce #(#\Linefeed) 'string)) 1347 (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) 1348 1349 (defun stripln (x) 1350 "Strip a string X from any ending CR, LF or CRLF. 1351Return two values, the stripped string and the ending that was stripped, 1352or the original value and NIL if no stripping took place. 1353Since our STRCAT accepts NIL as empty string designator, 1354the two results passed to STRCAT always reconstitute the original string" 1355 (check-type x string) 1356 (block nil 1357 (flet ((c (end) (when (string-suffix-p x end) 1358 (return (values (subseq x 0 (- (length x) (length end))) end))))) 1359 (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) 1360 1361 (defun standard-case-symbol-name (name-designator) 1362 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING; 1363if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\" 1364platform such as Allegro with modern syntax." 1365 (check-type name-designator (or string symbol)) 1366 (cond 1367 ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)) 1368 (string name-designator)) 1369 ;; Should we be doing something on CLISP? 1370 (t (string-upcase name-designator)))) 1371 1372 (defun find-standard-case-symbol (name-designator package-designator &optional (error t)) 1373 "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR, 1374where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings. 1375If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." 1376 (find-symbol* (standard-case-symbol-name name-designator) 1377 (etypecase package-designator 1378 ((or package symbol) package-designator) 1379 (string (standard-case-symbol-name package-designator))) 1380 error))) 1381 1382;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity 1383(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) 1384 (deftype stamp () '(or real boolean))) 1385(with-upgradability () 1386 (defun stamp< (x y) 1387 (etypecase x 1388 (null (and y t)) 1389 ((eql t) nil) 1390 (real (etypecase y 1391 (null nil) 1392 ((eql t) t) 1393 (real (< x y)))))) 1394 (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y))) 1395 (defun stamp*< (&rest list) (stamps< list)) 1396 (defun stamp<= (x y) (not (stamp< y x))) 1397 (defun earlier-stamp (x y) (if (stamp< x y) x y)) 1398 (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t)) 1399 (defun earliest-stamp (&rest list) (stamps-earliest list)) 1400 (defun later-stamp (x y) (if (stamp< x y) y x)) 1401 (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil)) 1402 (defun latest-stamp (&rest list) (stamps-latest list)) 1403 (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)) 1404 1405 1406;;; Function designators 1407(with-upgradability () 1408 (defun ensure-function (fun &key (package :cl)) 1409 "Coerce the object FUN into a function. 1410 1411If FUN is a FUNCTION, return it. 1412If the FUN is a non-sequence literal constant, return constantly that, 1413i.e. for a boolean keyword character number or pathname. 1414Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. 1415If FUN is a CONS, return the function that applies its CAR 1416to the appended list of the rest of its CDR and the arguments, 1417unless the CAR is LAMBDA, in which case the expression is evaluated. 1418If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) 1419and EVAL that in a (FUNCTION ...) context." 1420 (etypecase fun 1421 (function fun) 1422 ((or boolean keyword character number pathname) (constantly fun)) 1423 (hash-table #'(lambda (x) (gethash x fun))) 1424 (symbol (fdefinition fun)) 1425 (cons (if (eq 'lambda (car fun)) 1426 (eval fun) 1427 #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) 1428 (string (eval `(function ,(with-standard-io-syntax 1429 (let ((*package* (find-package package))) 1430 (read-from-string fun)))))))) 1431 1432 (defun access-at (object at) 1433 "Given an OBJECT and an AT specifier, list of successive accessors, 1434call each accessor on the result of the previous calls. 1435An accessor may be an integer, meaning a call to ELT, 1436a keyword, meaning a call to GETF, 1437NIL, meaning identity, 1438a function or other symbol, meaning itself, 1439or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. 1440As a degenerate case, the AT specifier may be an atom of a single such accessor 1441instead of a list." 1442 (flet ((access (object accessor) 1443 (etypecase accessor 1444 (function (funcall accessor object)) 1445 (integer (elt object accessor)) 1446 (keyword (getf object accessor)) 1447 (null object) 1448 (symbol (funcall accessor object)) 1449 (cons (funcall (ensure-function accessor) object))))) 1450 (if (listp at) 1451 (dolist (accessor at object) 1452 (setf object (access object accessor))) 1453 (access object at)))) 1454 1455 (defun access-at-count (at) 1456 "From an AT specification, extract a COUNT of maximum number 1457of sub-objects to read as per ACCESS-AT" 1458 (cond 1459 ((integerp at) 1460 (1+ at)) 1461 ((and (consp at) (integerp (first at))) 1462 (1+ (first at))))) 1463 1464 (defun call-function (function-spec &rest arguments) 1465 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION, 1466with the given ARGUMENTS" 1467 (apply (ensure-function function-spec) arguments)) 1468 1469 (defun call-functions (function-specs) 1470 "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION" 1471 (map () 'call-function function-specs)) 1472 1473 (defun register-hook-function (variable hook &optional call-now-p) 1474 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE. 1475When CALL-NOW-P is true, also call the function immediately." 1476 (pushnew hook (symbol-value variable) :test 'equal) 1477 (when call-now-p (call-function hook)))) 1478 1479 1480;;; CLOS 1481(with-upgradability () 1482 (defun coerce-class (class &key (package :cl) (super t) (error 'error)) 1483 "Coerce CLASS to a class that is subclass of SUPER if specified, 1484or invoke ERROR handler as per CALL-FUNCTION. 1485 1486A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. 1487-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. 1488A string is read as a symbol while in PACKAGE, the symbol designates a class. 1489 1490A class object designates itself. 1491NIL designates itself (no class). 1492A symbol otherwise designates a class by name." 1493 (let* ((normalized 1494 (typecase class 1495 (keyword (or (find-symbol* class package nil) 1496 (find-symbol* class *package* nil))) 1497 (string (symbol-call :uiop :safe-read-from-string class :package package)) 1498 (t class))) 1499 (found 1500 (etypecase normalized 1501 ((or standard-class built-in-class) normalized) 1502 ((or null keyword) nil) 1503 (symbol (find-class normalized nil nil)))) 1504 (super-class 1505 (etypecase super 1506 ((or standard-class built-in-class) super) 1507 ((or null keyword) nil) 1508 (symbol (find-class super nil nil))))) 1509 #+allegro (when found (mop:finalize-inheritance found)) 1510 (or (and found 1511 (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class)) 1512 found) 1513 (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super))))) 1514 1515 1516;;; Hash-tables 1517(with-upgradability () 1518 (defun ensure-gethash (key table default) 1519 "Lookup the TABLE for a KEY as by GETHASH, but if not present, 1520call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, 1521set the corresponding entry to the result in the table. 1522Return two values: the entry after its optional computation, and whether it was found" 1523 (multiple-value-bind (value foundp) (gethash key table) 1524 (values 1525 (if foundp 1526 value 1527 (setf (gethash key table) (call-function default))) 1528 foundp))) 1529 1530 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) 1531 "Convert a LIST into hash-table that has the same elements when viewed as a set, 1532up to the given equality TEST" 1533 (dolist (x list h) (setf (gethash x h) t)))) 1534 1535 1536;;; Lexicographic comparison of lists of numbers 1537(with-upgradability () 1538 (defun lexicographic< (element< x y) 1539 "Lexicographically compare two lists of using the function element< to compare elements. 1540element< is a strict total order; the resulting order on X and Y will also be strict." 1541 (cond ((null y) nil) 1542 ((null x) t) 1543 ((funcall element< (car x) (car y)) t) 1544 ((funcall element< (car y) (car x)) nil) 1545 (t (lexicographic< element< (cdr x) (cdr y))))) 1546 1547 (defun lexicographic<= (element< x y) 1548 "Lexicographically compare two lists of using the function element< to compare elements. 1549element< is a strict total order; the resulting order on X and Y will be a non-strict total order." 1550 (not (lexicographic< element< y x)))) 1551 1552 1553;;; Simple style warnings 1554(with-upgradability () 1555 (define-condition simple-style-warning 1556 #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) 1557 ()) 1558 1559 (defun style-warn (datum &rest arguments) 1560 (etypecase datum 1561 (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments))) 1562 (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments)) 1563 (style-warning (apply 'warn datum arguments))))) 1564 1565 1566;;; Condition control 1567 1568(with-upgradability () 1569 (defparameter +simple-condition-format-control-slot+ 1570 #+abcl 'system::format-control 1571 #+allegro 'excl::format-control 1572 #+(or clasp ecl mkcl) 'si::format-control 1573 #+clisp 'system::$format-control 1574 #+clozure 'ccl::format-control 1575 #+(or cmucl scl) 'conditions::format-control 1576 #+(or gcl lispworks) 'conditions::format-string 1577 #+sbcl 'sb-kernel:format-control 1578 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil 1579 "Name of the slot for FORMAT-CONTROL in simple-condition") 1580 1581 (defun match-condition-p (x condition) 1582 "Compare received CONDITION to some pattern X: 1583a symbol naming a condition class, 1584a simple vector of length 2, arguments to find-symbol* with result as above, 1585or a string describing the format-control of a simple-condition." 1586 (etypecase x 1587 (symbol (typep condition x)) 1588 ((simple-vector 2) 1589 (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) 1590 (function (funcall x condition)) 1591 (string (and (typep condition 'simple-condition) 1592 ;; On SBCL, it's always set and the check triggers a warning 1593 #+(or allegro clozure cmucl lispworks scl) 1594 (slot-boundp condition +simple-condition-format-control-slot+) 1595 (ignore-errors (equal (simple-condition-format-control condition) x)))))) 1596 1597 (defun match-any-condition-p (condition conditions) 1598 "match CONDITION against any of the patterns of CONDITIONS supplied" 1599 (loop :for x :in conditions :thereis (match-condition-p x condition))) 1600 1601 (defun call-with-muffled-conditions (thunk conditions) 1602 "calls the THUNK in a context where the CONDITIONS are muffled" 1603 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) 1604 (muffle-warning c))))) 1605 (funcall thunk))) 1606 1607 (defmacro with-muffled-conditions ((conditions) &body body) 1608 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" 1609 `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) 1610 1611;;; Conditions 1612 1613(with-upgradability () 1614 (define-condition not-implemented-error (error) 1615 ((functionality :initarg :functionality) 1616 (format-control :initarg :format-control) 1617 (format-arguments :initarg :format-arguments)) 1618 (:report (lambda (condition stream) 1619 (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]" 1620 (nth-value 1 (symbol-call :uiop :implementation-type)) 1621 (slot-value condition 'functionality) 1622 (slot-value condition 'format-control) 1623 (slot-value condition 'format-arguments))))) 1624 1625 (defun not-implemented-error (functionality &optional format-control &rest format-arguments) 1626 "Signal an error because some FUNCTIONALITY is not implemented in the current version 1627of the software on the current platform; it may or may not be implemented in different combinations 1628of version of the software and of the underlying platform. Optionally, report a formatted error 1629message." 1630 (error 'not-implemented-error 1631 :functionality functionality 1632 :format-control format-control 1633 :format-arguments format-arguments)) 1634 1635 (define-condition parameter-error (error) 1636 ((functionality :initarg :functionality) 1637 (format-control :initarg :format-control) 1638 (format-arguments :initarg :format-arguments)) 1639 (:report (lambda (condition stream) 1640 (apply 'format stream 1641 (slot-value condition 'format-control) 1642 (slot-value condition 'functionality) 1643 (slot-value condition 'format-arguments))))) 1644 1645 ;; Note that functionality MUST be passed as the second argument to parameter-error, just after 1646 ;; the format-control. If you want it to not appear in first position in actual message, use 1647 ;; ~* and ~:* to adjust parameter order. 1648 (defun parameter-error (format-control functionality &rest format-arguments) 1649 "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying 1650platform does not accept a given parameter or combination of parameters. Report a formatted error 1651message, that takes the functionality as its first argument (that can be skipped with ~*)." 1652 (error 'parameter-error 1653 :functionality functionality 1654 :format-control format-control 1655 :format-arguments format-arguments))) 1656 1657(uiop/package:define-package :uiop/version 1658 (:recycle :uiop/version :uiop/utility :asdf) 1659 (:use :uiop/common-lisp :uiop/package :uiop/utility) 1660 (:export 1661 #:*uiop-version* 1662 #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility 1663 #:next-version 1664 #:deprecated-function-condition #:deprecated-function-name ;; deprecation control 1665 #:deprecated-function-style-warning #:deprecated-function-warning 1666 #:deprecated-function-error #:deprecated-function-should-be-deleted 1667 #:version-deprecation #:with-deprecation)) 1668(in-package :uiop/version) 1669 1670(with-upgradability () 1671 (defparameter *uiop-version* "3.2.1") 1672 1673 (defun unparse-version (version-list) 1674 "From a parsed version (a list of natural numbers), compute the version string" 1675 (format nil "~{~D~^.~}" version-list)) 1676 1677 (defun parse-version (version-string &optional on-error) 1678 "Parse a VERSION-STRING as a series of natural numbers separated by dots. 1679Return a (non-null) list of integers if the string is valid; 1680otherwise return NIL. 1681 1682When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, 1683with format arguments explaining why the version is invalid. 1684ON-ERROR is also called if the version is not canonical 1685in that it doesn't print back to itself, but the list is returned anyway." 1686 (block nil 1687 (unless (stringp version-string) 1688 (call-function on-error "~S: ~S is not a string" 'parse-version version-string) 1689 (return)) 1690 (unless (loop :for prev = nil :then c :for c :across version-string 1691 :always (or (digit-char-p c) 1692 (and (eql c #\.) prev (not (eql prev #\.)))) 1693 :finally (return (and c (digit-char-p c)))) 1694 (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" 1695 'parse-version version-string) 1696 (return)) 1697 (let* ((version-list 1698 (mapcar #'parse-integer (split-string version-string :separator "."))) 1699 (normalized-version (unparse-version version-list))) 1700 (unless (equal version-string normalized-version) 1701 (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) 1702 version-list))) 1703 1704 (defun next-version (version) 1705 "When VERSION is not nil, it is a string, then parse it as a version, compute the next version 1706and return it as a string." 1707 (when version 1708 (let ((version-list (parse-version version))) 1709 (incf (car (last version-list))) 1710 (unparse-version version-list)))) 1711 1712 (defun version< (version1 version2) 1713 "Given two version strings, return T if the second is strictly newer" 1714 (let ((v1 (parse-version version1 nil)) 1715 (v2 (parse-version version2 nil))) 1716 (lexicographic< '< v1 v2))) 1717 1718 (defun version<= (version1 version2) 1719 "Given two version strings, return T if the second is newer or the same" 1720 (not (version< version2 version1)))) 1721 1722 1723(with-upgradability () 1724 (define-condition deprecated-function-condition (condition) 1725 ((name :initarg :name :reader deprecated-function-name))) 1726 (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ()) 1727 (define-condition deprecated-function-warning (deprecated-function-condition warning) ()) 1728 (define-condition deprecated-function-error (deprecated-function-condition error) ()) 1729 (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ()) 1730 1731 (defun deprecated-function-condition-kind (type) 1732 (ecase type 1733 ((deprecated-function-style-warning) :style-warning) 1734 ((deprecated-function-warning) :warning) 1735 ((deprecated-function-error) :error) 1736 ((deprecated-function-should-be-deleted) :delete))) 1737 1738 (defmethod print-object ((c deprecated-function-condition) stream) 1739 (let ((name (deprecated-function-name c))) 1740 (cond 1741 (*print-readably* 1742 (let ((fmt "#.(make-condition '~S :name ~S)") 1743 (args (list (type-of c) name))) 1744 (if *read-eval* 1745 (apply 'format stream fmt args) 1746 (error "Can't print ~?" fmt args)))) 1747 (*print-escape* 1748 (print-unreadable-object (c stream :type t) (format stream ":name ~S" name))) 1749 (t 1750 (let ((*package* (find-package :cl)) 1751 (type (type-of c))) 1752 (format stream 1753 (if (eq type 'deprecated-function-should-be-deleted) 1754 "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete" 1755 "~A: Using deprecated function ~S -- please update your code to use a newer API.~ 1756~@[~%The docstring for this function says:~%~A~%~]") 1757 type name (when (symbolp name) (documentation name 'function)))))))) 1758 1759 (defun notify-deprecated-function (status name) 1760 (ecase status 1761 ((nil) nil) 1762 ((:style-warning) (style-warn 'deprecated-function-style-warning :name name)) 1763 ((:warning) (warn 'deprecated-function-warning :name name)) 1764 ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name)))) 1765 1766 (defun version-deprecation (version &key (style-warning nil) 1767 (warning (next-version style-warning)) 1768 (error (next-version warning)) 1769 (delete (next-version error))) 1770 "Given a VERSION string, and the starting versions for notifying the programmer of 1771various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION 1772that is the highest level that has a declared version older than the specified version. 1773Each start version for a level of deprecation can be specified by a keyword argument, or 1774if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation." 1775 (cond 1776 ((and delete (version<= delete version)) :delete) 1777 ((and error (version<= error version)) :error) 1778 ((and warning (version<= warning version)) :warning) 1779 ((and style-warning (version<= style-warning version)) :style-warning))) 1780 1781 (defmacro with-deprecation ((level) &body definitions) 1782 "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the 1783DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function 1784when it is compiled or called. 1785 1786Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet), 1787:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used), 1788:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while 1789at that level). 1790 1791Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD 1792from instrumentation by enclosing it in a PROGN." 1793 (let ((level (eval level))) 1794 (check-type level (member nil :style-warning :warning :error :delete)) 1795 (when (eq level :delete) 1796 (error 'deprecated-function-should-be-deleted :name 1797 (mapcar 'second 1798 (remove-if-not #'(lambda (x) (member x '(defun defmethod))) 1799 definitions :key 'first)))) 1800 (labels ((instrument (name head body whole) 1801 (if level 1802 (let ((notifiedp 1803 (intern (format nil "*~A-~A-~A-~A*" 1804 :deprecated-function level name :notified-p)))) 1805 (multiple-value-bind (remaining-forms declarations doc-string) 1806 (parse-body body :documentation t :whole whole) 1807 `(progn 1808 (defparameter ,notifiedp nil) 1809 ;; tell some implementations to use the compiler-macro 1810 (declaim (inline ,name)) 1811 (define-compiler-macro ,name (&whole form &rest args) 1812 (declare (ignore args)) 1813 (notify-deprecated-function ,level ',name) 1814 form) 1815 (,@head ,@(when doc-string (list doc-string)) ,@declarations 1816 (unless ,notifiedp 1817 (setf ,notifiedp t) 1818 (notify-deprecated-function ,level ',name)) 1819 ,@remaining-forms)))) 1820 `(progn 1821 (eval-when (:compile-toplevel :load-toplevel :execute) 1822 (setf (compiler-macro-function ',name) nil)) 1823 (declaim (notinline ,name)) 1824 (,@head ,@body))))) 1825 `(progn 1826 ,@(loop :for form :in definitions :collect 1827 (cond 1828 ((and (consp form) (eq (car form) 'defun)) 1829 (instrument (second form) (subseq form 0 3) (subseq form 3) form)) 1830 ((and (consp form) (eq (car form) 'defmethod)) 1831 (let ((body-start (if (listp (third form)) 3 4))) 1832 (instrument (second form) 1833 (subseq form 0 body-start) 1834 (subseq form body-start) 1835 form))) 1836 (t 1837 form)))))))) 1838;;;; --------------------------------------------------------------------------- 1839;;;; Access to the Operating System 1840 1841(uiop/package:define-package :uiop/os 1842 (:use :uiop/common-lisp :uiop/package :uiop/utility) 1843 (:export 1844 #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features 1845 #:os-cond 1846 #:getenv #:getenvp ;; environment variables 1847 #:implementation-identifier ;; implementation identifier 1848 #:implementation-type #:*implementation-type* 1849 #:operating-system #:architecture #:lisp-version-string 1850 #:hostname #:getcwd #:chdir 1851 ;; Windows shortcut support 1852 #:read-null-terminated-string #:read-little-endian 1853 #:parse-file-location-info #:parse-windows-shortcut)) 1854(in-package :uiop/os) 1855 1856;;; Features 1857(with-upgradability () 1858 (defun featurep (x &optional (*features* *features*)) 1859 "Checks whether a feature expression X is true with respect to the *FEATURES* set, 1860as per the CLHS standard for #+ and #-. Beware that just like the CLHS, 1861we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- 1862your reader will not have magically used the KEYWORD package, so you need specify 1863keywords explicitly." 1864 (cond 1865 ((atom x) (and (member x *features*) t)) 1866 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) 1867 ((eq :or (car x)) (some #'featurep (cdr x))) 1868 ((eq :and (car x)) (every #'featurep (cdr x))) 1869 (t (parameter-error "~S: malformed feature specification ~S" 'featurep x)))) 1870 1871 ;; Starting with UIOP 3.1.5, these are runtime tests. 1872 ;; You may bind *features* with a copy of what your target system offers to test its properties. 1873 (defun os-macosx-p () 1874 "Is the underlying operating system MacOS X?" 1875 ;; OS-MACOSX is not mutually exclusive with OS-UNIX, 1876 ;; in fact the former implies the latter. 1877 (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)))) 1878 1879 (defun os-unix-p () 1880 "Is the underlying operating system some Unix variant?" 1881 (or (featurep '(:or :unix :cygwin)) (os-macosx-p))) 1882 1883 (defun os-windows-p () 1884 "Is the underlying operating system Microsoft Windows?" 1885 (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64)))) 1886 1887 (defun os-genera-p () 1888 "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" 1889 (featurep :genera)) 1890 1891 (defun os-oldmac-p () 1892 "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" 1893 (featurep :mcl)) 1894 1895 (defun os-haiku-p () 1896 "Is the underlying operating system Haiku?" 1897 (featurep :haiku)) 1898 1899 (defun detect-os () 1900 "Detects the current operating system. Only needs be run at compile-time, 1901except on ABCL where it might change between FASL compilation and runtime." 1902 (loop* :with o 1903 :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) 1904 (:os-windows . os-windows-p) 1905 (:genera . os-genera-p) (:os-oldmac . os-oldmac-p) 1906 (:haiku . os-haiku-p)) 1907 :when (and (or (not o) (eq feature :os-macosx)) (funcall detect)) 1908 :do (setf o feature) (pushnew feature *features*) 1909 :else :do (setf *features* (remove feature *features*)) 1910 :finally 1911 (return (or o (error "Congratulations for trying ASDF on an operating system~%~ 1912that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) 1913 1914 (defmacro os-cond (&rest clauses) 1915 #+abcl `(cond ,@clauses) 1916 #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) 1917 1918 (detect-os)) 1919 1920;;;; Environment variables: getting them, and parsing them. 1921(with-upgradability () 1922 (defun getenv (x) 1923 "Query the environment, as in C getenv. 1924Beware: may return empty string if a variable is present but empty; 1925use getenvp to return NIL in such a case." 1926 (declare (ignorable x)) 1927 #+(or abcl clasp clisp ecl xcl) (ext:getenv x) 1928 #+allegro (sys:getenv x) 1929 #+clozure (ccl:getenv x) 1930 #+cmucl (unix:unix-getenv x) 1931 #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) 1932 #+cormanlisp 1933 (let* ((buffer (ct:malloc 1)) 1934 (cname (ct:lisp-string-to-c-string x)) 1935 (needed-size (win:getenvironmentvariable cname buffer 0)) 1936 (buffer1 (ct:malloc (1+ needed-size)))) 1937 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) 1938 nil 1939 (ct:c-string-to-lisp-string buffer1)) 1940 (ct:free buffer) 1941 (ct:free buffer1))) 1942 #+gcl (system:getenv x) 1943 #+genera nil 1944 #+lispworks (lispworks:environment-variable x) 1945 #+mcl (ccl:with-cstrs ((name x)) 1946 (let ((value (_getenv name))) 1947 (unless (ccl:%null-ptr-p value) 1948 (ccl:%get-cstring value)))) 1949 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) 1950 #+sbcl (sb-ext:posix-getenv x) 1951 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 1952 (not-implemented-error 'getenv)) 1953 1954 (defsetf getenv (x) (val) 1955 "Set an environment variable." 1956 (declare (ignorable x val)) 1957 #+allegro `(setf (sys:getenv ,x) ,val) 1958 #+clisp `(system::setenv ,x ,val) 1959 #+clozure `(ccl:setenv ,x ,val) 1960 #+cmucl `(unix:unix-setenv ,x ,val 1) 1961 #+ecl `(ext:setenv ,x ,val) 1962 #+lispworks `(hcl:setenv ,x ,val) 1963 #+mkcl `(mkcl:setenv ,x ,val) 1964 #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) 1965 #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl) 1966 '(not-implemented-error '(setf getenv))) 1967 1968 (defun getenvp (x) 1969 "Predicate that is true if the named variable is present in the libc environment, 1970then returning the non-empty string value of the variable" 1971 (let ((g (getenv x))) (and (not (emptyp g)) g)))) 1972 1973 1974;;;; implementation-identifier 1975;; 1976;; produce a string to identify current implementation. 1977;; Initially stolen from SLIME's SWANK, completely rewritten since. 1978;; We're back to runtime checking, for the sake of e.g. ABCL. 1979 1980(with-upgradability () 1981 (defun first-feature (feature-sets) 1982 "A helper for various feature detection functions" 1983 (dolist (x feature-sets) 1984 (multiple-value-bind (short long feature-expr) 1985 (if (consp x) 1986 (values (first x) (second x) (cons :or (rest x))) 1987 (values x x x)) 1988 (when (featurep feature-expr) 1989 (return (values short long)))))) 1990 1991 (defun implementation-type () 1992 "The type of Lisp implementation used, as a short UIOP-standardized keyword" 1993 (first-feature 1994 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) 1995 (:cmu :cmucl :cmu) :clasp :ecl :gcl 1996 (:lwpe :lispworks-personal-edition) (:lw :lispworks) 1997 :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) 1998 1999 (defvar *implementation-type* (implementation-type) 2000 "The type of Lisp implementation used, as a short UIOP-standardized keyword") 2001 2002 (defun operating-system () 2003 "The operating system of the current host" 2004 (first-feature 2005 '(:cygwin 2006 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 2007 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd 2008 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd 2009 (:solaris :solaris :sunos) 2010 (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) 2011 :unix 2012 :genera))) 2013 2014 (defun architecture () 2015 "The CPU architecture of the current host" 2016 (first-feature 2017 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) 2018 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) 2019 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) 2020 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) 2021 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach 2022 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, 2023 ;; we may have to segregate the code still by architecture. 2024 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) 2025 2026 #+clozure 2027 (defun ccl-fasl-version () 2028 ;; the fasl version is target-dependent from CCL 1.8 on. 2029 (or (let ((s 'ccl::target-fasl-version)) 2030 (and (fboundp s) (funcall s))) 2031 (and (boundp 'ccl::fasl-version) 2032 (symbol-value 'ccl::fasl-version)) 2033 (error "Can't determine fasl version."))) 2034 2035 (defun lisp-version-string () 2036 "return a string that identifies the current Lisp implementation version" 2037 (let ((s (lisp-implementation-version))) 2038 (car ; as opposed to OR, this idiom prevents some unreachable code warning 2039 (list 2040 #+allegro 2041 (format nil "~A~@[~A~]~@[~A~]~@[~A~]" 2042 excl::*common-lisp-version-number* 2043 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) 2044 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") 2045 ;; Note if not using International ACL 2046 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 2047 (excl:ics-target-case (:-ics "8")) 2048 (and (member :smp *features*) "S")) 2049 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 2050 #+clisp 2051 (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 2052 #+clozure 2053 (format nil "~d.~d-f~d" ; shorten for windows 2054 ccl::*openmcl-major-version* 2055 ccl::*openmcl-minor-version* 2056 (logand (ccl-fasl-version) #xFF)) 2057 #+cmucl (substitute #\- #\/ s) 2058 #+scl (format nil "~A~A" s 2059 ;; ANSI upper case vs lower case. 2060 (ecase ext:*case-mode* (:upper "") (:lower "l"))) 2061 #+ecl (format nil "~A~@[-~A~]" s 2062 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 2063 (unless (equal vcs-id "UNKNOWN") 2064 (subseq vcs-id 0 (min (length vcs-id) 8))))) 2065 #+gcl (subseq s (1+ (position #\space s))) 2066 #+genera 2067 (multiple-value-bind (major minor) (sct:get-system-version "System") 2068 (format nil "~D.~D" major minor)) 2069 #+mcl (subseq s 8) ; strip the leading "Version " 2070 ;; seems like there should be a shorter way to do this, like ACALL. 2071 #+mkcl (or 2072 (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) 2073 (when (and fname (fboundp fname)) 2074 (funcall fname))) 2075 s) 2076 s)))) 2077 2078 (defun implementation-identifier () 2079 "Return a string that identifies the ABI of the current implementation, 2080suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." 2081 (substitute-if 2082 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) 2083 (format nil "~(~a~@{~@[-~a~]~}~)" 2084 (or (implementation-type) (lisp-implementation-type)) 2085 (lisp-version-string) 2086 (or (operating-system) (software-type)) 2087 (or (architecture) (machine-type)))))) 2088 2089 2090;;;; Other system information 2091 2092(with-upgradability () 2093 (defun hostname () 2094 "return the hostname of the current host" 2095 ;; Note: untested on RMCL 2096 #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) 2097 #+cormanlisp "localhost" ;; is there a better way? Does it matter? 2098 #+allegro (symbol-call :excl.osi :gethostname) 2099 #+clisp (first (split-string (machine-instance) :separator " ")) 2100 #+gcl (system:gethostname))) 2101 2102 2103;;; Current directory 2104(with-upgradability () 2105 2106 #+cmucl 2107 (defun parse-unix-namestring* (unix-namestring) 2108 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" 2109 (multiple-value-bind (host device directory name type version) 2110 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) 2111 (make-pathname :host (or host lisp::*unix-host*) :device device 2112 :directory directory :name name :type type :version version))) 2113 2114 (defun getcwd () 2115 "Get the current working directory as per POSIX getcwd(3), as a pathname object" 2116 (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical! 2117 #+allegro (excl::current-directory) 2118 #+clisp (ext:default-directory) 2119 #+clozure (ccl:current-directory) 2120 #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring 2121 (strcat (nth-value 1 (unix:unix-current-directory)) "/")) 2122 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? 2123 #+(or clasp ecl) (ext:getcwd) 2124 #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) 2125 #+lispworks (hcl:get-working-directory) 2126 #+mkcl (mk-ext:getcwd) 2127 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) 2128 #+xcl (extensions:current-directory) 2129 (not-implemented-error 'getcwd))) 2130 2131 (defun chdir (x) 2132 "Change current directory, as per POSIX chdir(2), to a given pathname object" 2133 (if-let (x (pathname x)) 2134 #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! 2135 #+allegro (excl:chdir x) 2136 #+clisp (ext:cd x) 2137 #+clozure (setf (ccl:current-directory) x) 2138 #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) 2139 #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) 2140 (error "Could not set current directory to ~A" x)) 2141 #+(or clasp ecl) (ext:chdir x) 2142 #+gcl (system:chdir x) 2143 #+lispworks (hcl:change-directory x) 2144 #+mkcl (mk-ext:chdir x) 2145 #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) 2146 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) 2147 (not-implemented-error 'chdir)))) 2148 2149 2150;;;; ----------------------------------------------------------------- 2151;;;; Windows shortcut support. Based on: 2152;;;; 2153;;;; Jesse Hager: The Windows Shortcut File Format. 2154;;;; http://www.wotsit.org/list.asp?fc=13 2155 2156#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it 2157(with-upgradability () 2158 (defparameter *link-initial-dword* 76) 2159 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) 2160 2161 (defun read-null-terminated-string (s) 2162 "Read a null-terminated string from an octet stream S" 2163 ;; note: doesn't play well with UNICODE 2164 (with-output-to-string (out) 2165 (loop :for code = (read-byte s) 2166 :until (zerop code) 2167 :do (write-char (code-char code) out)))) 2168 2169 (defun read-little-endian (s &optional (bytes 4)) 2170 "Read a number in little-endian format from an byte (octet) stream S, 2171the number having BYTES octets (defaulting to 4)." 2172 (loop :for i :from 0 :below bytes 2173 :sum (ash (read-byte s) (* 8 i)))) 2174 2175 (defun parse-file-location-info (s) 2176 "helper to parse-windows-shortcut" 2177 (let ((start (file-position s)) 2178 (total-length (read-little-endian s)) 2179 (end-of-header (read-little-endian s)) 2180 (fli-flags (read-little-endian s)) 2181 (local-volume-offset (read-little-endian s)) 2182 (local-offset (read-little-endian s)) 2183 (network-volume-offset (read-little-endian s)) 2184 (remaining-offset (read-little-endian s))) 2185 (declare (ignore total-length end-of-header local-volume-offset)) 2186 (unless (zerop fli-flags) 2187 (cond 2188 ((logbitp 0 fli-flags) 2189 (file-position s (+ start local-offset))) 2190 ((logbitp 1 fli-flags) 2191 (file-position s (+ start 2192 network-volume-offset 2193 #x14)))) 2194 (strcat (read-null-terminated-string s) 2195 (progn 2196 (file-position s (+ start remaining-offset)) 2197 (read-null-terminated-string s)))))) 2198 2199 (defun parse-windows-shortcut (pathname) 2200 "From a .lnk windows shortcut, extract the pathname linked to" 2201 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. 2202 (with-open-file (s pathname :element-type '(unsigned-byte 8)) 2203 (handler-case 2204 (when (and (= (read-little-endian s) *link-initial-dword*) 2205 (let ((header (make-array (length *link-guid*)))) 2206 (read-sequence header s) 2207 (equalp header *link-guid*))) 2208 (let ((flags (read-little-endian s))) 2209 (file-position s 76) ;skip rest of header 2210 (when (logbitp 0 flags) 2211 ;; skip shell item id list 2212 (let ((length (read-little-endian s 2))) 2213 (file-position s (+ length (file-position s))))) 2214 (cond 2215 ((logbitp 1 flags) 2216 (parse-file-location-info s)) 2217 (t 2218 (when (logbitp 2 flags) 2219 ;; skip description string 2220 (let ((length (read-little-endian s 2))) 2221 (file-position s (+ length (file-position s))))) 2222 (when (logbitp 3 flags) 2223 ;; finally, our pathname 2224 (let* ((length (read-little-endian s 2)) 2225 (buffer (make-array length))) 2226 (read-sequence buffer s) 2227 (map 'string #'code-char buffer))))))) 2228 (end-of-file (c) 2229 (declare (ignore c)) 2230 nil))))) 2231 2232 2233;;;; ------------------------------------------------------------------------- 2234;;;; Portability layer around Common Lisp pathnames 2235;; This layer allows for portable manipulation of pathname objects themselves, 2236;; which all is necessary prior to any access the filesystem or environment. 2237 2238(uiop/package:define-package :uiop/pathname 2239 (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic 2240 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) 2241 (:export 2242 ;; Making and merging pathnames, portably 2243 #:normalize-pathname-directory-component #:denormalize-pathname-directory-component 2244 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* 2245 #:make-pathname-component-logical #:make-pathname-logical 2246 #:merge-pathnames* 2247 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults 2248 ;; Predicates 2249 #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname 2250 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p 2251 ;; Directories 2252 #:pathname-directory-pathname #:pathname-parent-directory-pathname 2253 #:directory-pathname-p #:ensure-directory-pathname 2254 ;; Parsing filenames 2255 #:split-name-type #:parse-unix-namestring #:unix-namestring 2256 #:split-unix-namestring-directory-components 2257 ;; Absolute and relative pathnames 2258 #:subpathname #:subpathname* 2259 #:ensure-absolute-pathname 2260 #:pathname-root #:pathname-host-pathname 2261 #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname 2262 ;; Checking constraints 2263 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints 2264 ;; Wildcard pathnames 2265 #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* 2266 #:*wild-inferiors* #:*wild-path* #:wilden 2267 ;; Translate a pathname 2268 #:relativize-directory-component #:relativize-pathname-directory 2269 #:directory-separator-for-host #:directorize-pathname-host-device 2270 #:translate-pathname* 2271 #:*output-translation-function*)) 2272(in-package :uiop/pathname) 2273 2274;;; Normalizing pathnames across implementations 2275 2276(with-upgradability () 2277 (defun normalize-pathname-directory-component (directory) 2278 "Convert the DIRECTORY component from a format usable by the underlying 2279implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format 2280that is a list and not a string." 2281 (cond 2282 #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. 2283 ((stringp directory) `(:absolute ,directory)) 2284 ((or (null directory) 2285 (and (consp directory) (member (first directory) '(:absolute :relative)))) 2286 directory) 2287 #+gcl 2288 ((consp directory) 2289 (cons :relative directory)) 2290 (t 2291 (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>") 2292 'normalize-pathname-directory-component directory)))) 2293 2294 (defun denormalize-pathname-directory-component (directory-component) 2295 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable 2296by the underlying implementation's MAKE-PATHNAME and other primitives" 2297 directory-component) 2298 2299 (defun merge-pathname-directory-components (specified defaults) 2300 "Helper for MERGE-PATHNAMES* that handles directory components" 2301 (let ((directory (normalize-pathname-directory-component specified))) 2302 (ecase (first directory) 2303 ((nil) defaults) 2304 (:absolute specified) 2305 (:relative 2306 (let ((defdir (normalize-pathname-directory-component defaults)) 2307 (reldir (cdr directory))) 2308 (cond 2309 ((null defdir) 2310 directory) 2311 ((not (eq :back (first reldir))) 2312 (append defdir reldir)) 2313 (t 2314 (loop :with defabs = (first defdir) 2315 :with defrev = (reverse (rest defdir)) 2316 :while (and (eq :back (car reldir)) 2317 (or (and (eq :absolute defabs) (null defrev)) 2318 (stringp (car defrev)))) 2319 :do (pop reldir) (pop defrev) 2320 :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) 2321 2322 ;; Giving :unspecific as :type argument to make-pathname is not portable. 2323 ;; See CLHS make-pathname and 19.2.2.2.3. 2324 ;; This will be :unspecific if supported, or NIL if not. 2325 (defparameter *unspecific-pathname-type* 2326 #+(or abcl allegro clozure cmucl genera lispworks sbcl scl) :unspecific 2327 #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil 2328 "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") 2329 2330 (defun make-pathname* (&rest keys &key directory host device name type version defaults 2331 #+scl &allow-other-keys) 2332 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and 2333 tries hard to make a pathname that will actually behave as documented, 2334 despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." 2335 (declare (ignore host device directory name type version defaults)) 2336 (apply 'make-pathname keys)) 2337 2338 (defun make-pathname-component-logical (x) 2339 "Make a pathname component suitable for use in a logical-pathname" 2340 (typecase x 2341 ((eql :unspecific) nil) 2342 #+clisp (string (string-upcase x)) 2343 #+clisp (cons (mapcar 'make-pathname-component-logical x)) 2344 (t x))) 2345 2346 (defun make-pathname-logical (pathname host) 2347 "Take a PATHNAME's directory, name, type and version components, 2348and make a new pathname with corresponding components and specified logical HOST" 2349 (make-pathname 2350 :host host 2351 :directory (make-pathname-component-logical (pathname-directory pathname)) 2352 :name (make-pathname-component-logical (pathname-name pathname)) 2353 :type (make-pathname-component-logical (pathname-type pathname)) 2354 :version (make-pathname-component-logical (pathname-version pathname)))) 2355 2356 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) 2357 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that 2358if the SPECIFIED pathname does not have an absolute directory, 2359then the HOST and DEVICE both come from the DEFAULTS, whereas 2360if the SPECIFIED pathname does have an absolute directory, 2361then the HOST and DEVICE both come from the SPECIFIED pathname. 2362This is what users want on a modern Unix or Windows operating system, 2363unlike the MERGE-PATHNAMES behavior. 2364Also, if either argument is NIL, then the other argument is returned unmodified; 2365this is unlike MERGE-PATHNAMES which always merges with a pathname, 2366by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." 2367 (when (null specified) (return-from merge-pathnames* defaults)) 2368 (when (null defaults) (return-from merge-pathnames* specified)) 2369 #+scl 2370 (ext:resolve-pathname specified defaults) 2371 #-scl 2372 (let* ((specified (pathname specified)) 2373 (defaults (pathname defaults)) 2374 (directory (normalize-pathname-directory-component (pathname-directory specified))) 2375 (name (or (pathname-name specified) (pathname-name defaults))) 2376 (type (or (pathname-type specified) (pathname-type defaults))) 2377 (version (or (pathname-version specified) (pathname-version defaults)))) 2378 (labels ((unspecific-handler (p) 2379 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) 2380 (multiple-value-bind (host device directory unspecific-handler) 2381 (ecase (first directory) 2382 ((:absolute) 2383 (values (pathname-host specified) 2384 (pathname-device specified) 2385 directory 2386 (unspecific-handler specified))) 2387 ((nil :relative) 2388 (values (pathname-host defaults) 2389 (pathname-device defaults) 2390 (merge-pathname-directory-components directory (pathname-directory defaults)) 2391 (unspecific-handler defaults)))) 2392 (make-pathname :host host :device device :directory directory 2393 :name (funcall unspecific-handler name) 2394 :type (funcall unspecific-handler type) 2395 :version (funcall unspecific-handler version)))))) 2396 2397 (defun logical-pathname-p (x) 2398 "is X a logical-pathname?" 2399 (typep x 'logical-pathname)) 2400 2401 (defun physical-pathname-p (x) 2402 "is X a pathname that is not a logical-pathname?" 2403 (and (pathnamep x) (not (logical-pathname-p x)))) 2404 2405 (defun physicalize-pathname (x) 2406 "if X is a logical pathname, use translate-logical-pathname on it." 2407 ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP 2408 (let ((p (when x (pathname x)))) 2409 (if (logical-pathname-p p) (translate-logical-pathname p) p))) 2410 2411 (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) 2412 "A pathname that is as neutral as possible for use as defaults 2413when merging, making or parsing pathnames" 2414 ;; 19.2.2.2.1 says a NIL host can mean a default host; 2415 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests 2416 ;; strings and lists of strings or :unspecific 2417 ;; But CMUCL decides to die on NIL. 2418 ;; MCL has issues with make-pathname, nil and defaulting 2419 (declare (ignorable defaults)) 2420 #.`(make-pathname :directory nil :name nil :type nil :version nil 2421 :device (or #+(and mkcl os-unix) :unspecific) 2422 :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost") 2423 #+scl ,@'(:scheme nil :scheme-specific-part nil 2424 :username nil :password nil :parameters nil :query nil :fragment nil) 2425 ;; the default shouldn't matter, but we really want something physical 2426 #-mcl ,@'(:defaults defaults))) 2427 2428 (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) 2429 "A pathname that is as neutral as possible for use as defaults 2430when merging, making or parsing pathnames") 2431 2432 (defmacro with-pathname-defaults ((&optional defaults) &body body) 2433 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified, 2434where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except 2435on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory." 2436 `(let ((*default-pathname-defaults* 2437 ,(or defaults 2438 #-(or abcl genera xcl) '*nil-pathname* 2439 #+(or abcl genera xcl) '*default-pathname-defaults*))) 2440 ,@body))) 2441 2442 2443;;; Some pathname predicates 2444(with-upgradability () 2445 (defun pathname-equal (p1 p2) 2446 "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" 2447 (when (stringp p1) (setf p1 (pathname p1))) 2448 (when (stringp p2) (setf p2 (pathname p2))) 2449 (flet ((normalize-component (x) 2450 (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) 2451 x))) 2452 (macrolet ((=? (&rest accessors) 2453 (flet ((frob (x) 2454 (reduce 'list (cons 'normalize-component accessors) 2455 :initial-value x :from-end t))) 2456 `(equal ,(frob 'p1) ,(frob 'p2))))) 2457 (or (and (null p1) (null p2)) 2458 (and (pathnamep p1) (pathnamep p2) 2459 (and (=? pathname-host) 2460 #-(and mkcl os-unix) (=? pathname-device) 2461 (=? normalize-pathname-directory-component pathname-directory) 2462 (=? pathname-name) 2463 (=? pathname-type) 2464 #-mkcl (=? pathname-version))))))) 2465 2466 (defun absolute-pathname-p (pathspec) 2467 "If PATHSPEC is a pathname or namestring object that parses as a pathname 2468possessing an :ABSOLUTE directory component, return the (parsed) pathname. 2469Otherwise return NIL" 2470 (and pathspec 2471 (typep pathspec '(or null pathname string)) 2472 (let ((pathname (pathname pathspec))) 2473 (and (eq :absolute (car (normalize-pathname-directory-component 2474 (pathname-directory pathname)))) 2475 pathname)))) 2476 2477 (defun relative-pathname-p (pathspec) 2478 "If PATHSPEC is a pathname or namestring object that parses as a pathname 2479possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. 2480Otherwise return NIL" 2481 (and pathspec 2482 (typep pathspec '(or null pathname string)) 2483 (let* ((pathname (pathname pathspec)) 2484 (directory (normalize-pathname-directory-component 2485 (pathname-directory pathname)))) 2486 (when (or (null directory) (eq :relative (car directory))) 2487 pathname)))) 2488 2489 (defun hidden-pathname-p (pathname) 2490 "Return a boolean that is true if the pathname is hidden as per Unix style, 2491i.e. its name starts with a dot." 2492 (and pathname (equal (first-char (pathname-name pathname)) #\.))) 2493 2494 (defun file-pathname-p (pathname) 2495 "Does PATHNAME represent a file, i.e. has a non-null NAME component? 2496 2497Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. 2498 2499Note that this does _not_ check to see that PATHNAME points to an 2500actually-existing file. 2501 2502Returns the (parsed) PATHNAME when true" 2503 (when pathname 2504 (let ((pathname (pathname pathname))) 2505 (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) 2506 (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) 2507 pathname))))) 2508 2509 2510;;; Directory pathnames 2511(with-upgradability () 2512 (defun pathname-directory-pathname (pathname) 2513 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, 2514and NIL NAME, TYPE and VERSION components" 2515 (when pathname 2516 (make-pathname :name nil :type nil :version nil :defaults pathname))) 2517 2518 (defun pathname-parent-directory-pathname (pathname) 2519 "Returns a new pathname that corresponds to the parent of the current pathname's directory, 2520i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is 2521Unix pathname /foo/bar/baz/file.type then return /foo/bar/" 2522 (when pathname 2523 (make-pathname :name nil :type nil :version nil 2524 :directory (merge-pathname-directory-components 2525 '(:relative :back) (pathname-directory pathname)) 2526 :defaults pathname))) 2527 2528 (defun directory-pathname-p (pathname) 2529 "Does PATHNAME represent a directory? 2530 2531A directory-pathname is a pathname _without_ a filename. The three 2532ways that the filename components can be missing are for it to be NIL, 2533:UNSPECIFIC or the empty string. 2534 2535Note that this does _not_ check to see that PATHNAME points to an 2536actually-existing directory." 2537 (when pathname 2538 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, 2539 ;; because it rejects apparently legal pathnames as 2540 ;; ill-formed. [2014/02/10:rpg] 2541 (let ((pathname (pathname pathname))) 2542 (flet ((check-one (x) 2543 (member x '(nil :unspecific) :test 'equal))) 2544 (and (not (wild-pathname-p pathname)) 2545 (check-one (pathname-name pathname)) 2546 (check-one (pathname-type pathname)) 2547 t))))) 2548 2549 (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) 2550 "Converts the non-wild pathname designator PATHSPEC to directory form." 2551 (cond 2552 ((stringp pathspec) 2553 (ensure-directory-pathname (pathname pathspec))) 2554 ((not (pathnamep pathspec)) 2555 (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec)) 2556 ((wild-pathname-p pathspec) 2557 (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) 2558 ((directory-pathname-p pathspec) 2559 pathspec) 2560 (t 2561 (handler-case 2562 (make-pathname :directory (append (or (normalize-pathname-directory-component 2563 (pathname-directory pathspec)) 2564 (list :relative)) 2565 (list (file-namestring pathspec))) 2566 :name nil :type nil :version nil :defaults pathspec) 2567 (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c))))))) 2568 2569 2570;;; Parsing filenames 2571(with-upgradability () 2572 (declaim (ftype function ensure-pathname)) ; forward reference 2573 2574 (defun split-unix-namestring-directory-components 2575 (unix-namestring &key ensure-directory dot-dot) 2576 "Splits the path string UNIX-NAMESTRING, returning four values: 2577A flag that is either :absolute or :relative, indicating 2578 how the rest of the values are to be interpreted. 2579A directory path --- a list of strings and keywords, suitable for 2580 use with MAKE-PATHNAME when prepended with the flag value. 2581 Directory components with an empty name or the name . are removed. 2582 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). 2583A last-component, either a file-namestring including type extension, 2584 or NIL in the case of a directory pathname. 2585A flag that is true iff the unix-style-pathname was just 2586 a file-namestring without / path specification. 2587ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: 2588the third return value will be NIL, and final component of the namestring 2589will be treated as part of the directory path. 2590 2591An empty string is thus read as meaning a pathname object with all fields nil. 2592 2593Note that colon characters #\: will NOT be interpreted as host specification. 2594Absolute pathnames are only appropriate on Unix-style systems. 2595 2596The intention of this function is to support structured component names, 2597e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." 2598 (check-type unix-namestring string) 2599 (check-type dot-dot (member nil :back :up)) 2600 (if (and (not (find #\/ unix-namestring)) (not ensure-directory) 2601 (plusp (length unix-namestring))) 2602 (values :relative () unix-namestring t) 2603 (let* ((components (split-string unix-namestring :separator "/")) 2604 (last-comp (car (last components)))) 2605 (multiple-value-bind (relative components) 2606 (if (equal (first components) "") 2607 (if (equal (first-char unix-namestring) #\/) 2608 (values :absolute (cdr components)) 2609 (values :relative nil)) 2610 (values :relative components)) 2611 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) 2612 components)) 2613 (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) 2614 (cond 2615 ((equal last-comp "") 2616 (values relative components nil nil)) ; "" already removed from components 2617 (ensure-directory 2618 (values relative components nil nil)) 2619 (t 2620 (values relative (butlast components) last-comp nil))))))) 2621 2622 (defun split-name-type (filename) 2623 "Split a filename into two values NAME and TYPE that are returned. 2624We assume filename has no directory component. 2625The last . if any separates name and type from from type, 2626except that if there is only one . and it is in first position, 2627the whole filename is the NAME with an empty type. 2628NAME is always a string. 2629For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." 2630 (check-type filename string) 2631 (assert (plusp (length filename))) 2632 (destructuring-bind (name &optional (type *unspecific-pathname-type*)) 2633 (split-string filename :max 2 :separator ".") 2634 (if (equal name "") 2635 (values filename *unspecific-pathname-type*) 2636 (values name type)))) 2637 2638 (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory 2639 &allow-other-keys) 2640 "Coerce NAME into a PATHNAME using standard Unix syntax. 2641 2642Unix syntax is used whether or not the underlying system is Unix; 2643on such non-Unix systems it is reliably usable only for relative pathnames. 2644This function is especially useful to manipulate relative pathnames portably, 2645where it is of crucial to possess a portable pathname syntax independent of the underlying OS. 2646This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. 2647 2648When given a PATHNAME object, just return it untouched. 2649When given NIL, just return NIL. 2650When given a non-null SYMBOL, first downcase its name and treat it as a string. 2651When given a STRING, portably decompose it into a pathname as below. 2652 2653#\\/ separates directory components. 2654 2655The last #\\/-separated substring is interpreted as follows: 26561- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, 2657 the string is made the last directory component, and NAME and TYPE are NIL. 2658 if the string is empty, it's the empty pathname with all slots NIL. 26592- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE 2660 are separated by SPLIT-NAME-TYPE. 26613- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. 2662 2663Directory components with an empty name or the name \".\" are removed. 2664Any directory named \"..\" is read as DOT-DOT, 2665which must be one of :BACK or :UP and defaults to :BACK. 2666 2667HOST, DEVICE and VERSION components are taken from DEFAULTS, 2668which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. 2669No host or device can be specified in the string itself, 2670which makes it unsuitable for absolute pathnames outside Unix. 2671 2672For relative pathnames, these components (and hence the defaults) won't matter 2673if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, 2674which is an important reason to always use MERGE-PATHNAMES*. 2675 2676Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME 2677with those keys, removing TYPE DEFAULTS and DOT-DOT. 2678When you're manipulating pathnames that are supposed to make sense portably 2679even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T 2680to throw an error if the pathname is absolute" 2681 (block nil 2682 (check-type type (or null string (eql :directory))) 2683 (when ensure-directory 2684 (setf type :directory)) 2685 (etypecase name 2686 ((or null pathname) (return name)) 2687 (symbol 2688 (setf name (string-downcase name))) 2689 (string)) 2690 (multiple-value-bind (relative path filename file-only) 2691 (split-unix-namestring-directory-components 2692 name :dot-dot dot-dot :ensure-directory (eq type :directory)) 2693 (multiple-value-bind (name type) 2694 (cond 2695 ((or (eq type :directory) (null filename)) 2696 (values nil nil)) 2697 (type 2698 (values filename type)) 2699 (t 2700 (split-name-type filename))) 2701 (apply 'ensure-pathname 2702 (make-pathname 2703 :directory (unless file-only (cons relative path)) 2704 :name name :type type 2705 :defaults (or #-mcl defaults *nil-pathname*)) 2706 (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) 2707 2708 (defun unix-namestring (pathname) 2709 "Given a non-wild PATHNAME, return a Unix-style namestring for it. 2710If the PATHNAME is NIL or a STRING, return it unchanged. 2711 2712This only considers the DIRECTORY, NAME and TYPE components of the pathname. 2713This is a portable solution for representing relative pathnames, 2714But unless you are running on a Unix system, it is not a general solution 2715to representing native pathnames. 2716 2717An error is signaled if the argument is not NULL, a STRING or a PATHNAME, 2718or if it is a PATHNAME but some of its components are not recognized." 2719 (etypecase pathname 2720 ((or null string) pathname) 2721 (pathname 2722 (with-output-to-string (s) 2723 (flet ((err () (parameter-error "~S: invalid unix-namestring ~S" 2724 'unix-namestring pathname))) 2725 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) 2726 (name (pathname-name pathname)) 2727 (name (and (not (eq name :unspecific)) name)) 2728 (type (pathname-type pathname)) 2729 (type (and (not (eq type :unspecific)) type))) 2730 (cond 2731 ((member dir '(nil :unspecific))) 2732 ((eq dir '(:relative)) (princ "./" s)) 2733 ((consp dir) 2734 (destructuring-bind (relabs &rest dirs) dir 2735 (or (member relabs '(:relative :absolute)) (err)) 2736 (when (eq relabs :absolute) (princ #\/ s)) 2737 (loop :for x :in dirs :do 2738 (cond 2739 ((member x '(:back :up)) (princ "../" s)) 2740 ((equal x "") (err)) 2741 ;;((member x '("." "..") :test 'equal) (err)) 2742 ((stringp x) (format s "~A/" x)) 2743 (t (err)))))) 2744 (t (err))) 2745 (cond 2746 (name 2747 (unless (and (stringp name) (or (null type) (stringp type))) (err)) 2748 (format s "~A~@[.~A~]" name type)) 2749 (t 2750 (or (null type) (err))))))))))) 2751 2752;;; Absolute and relative pathnames 2753(with-upgradability () 2754 (defun subpathname (pathname subpath &key type) 2755 "This function takes a PATHNAME and a SUBPATH and a TYPE. 2756If SUBPATH is already a PATHNAME object (not namestring), 2757and is an absolute pathname at that, it is returned unchanged; 2758otherwise, SUBPATH is turned into a relative pathname with given TYPE 2759as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, 2760then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." 2761 (or (and (pathnamep subpath) (absolute-pathname-p subpath)) 2762 (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) 2763 (pathname-directory-pathname pathname)))) 2764 2765 (defun subpathname* (pathname subpath &key type) 2766 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." 2767 (and pathname 2768 (subpathname (ensure-directory-pathname pathname) subpath :type type))) 2769 2770 (defun pathname-root (pathname) 2771 "return the root directory for the host and device of given PATHNAME" 2772 (make-pathname :directory '(:absolute) 2773 :name nil :type nil :version nil 2774 :defaults pathname ;; host device, and on scl, *some* 2775 ;; scheme-specific parts: port username password, not others: 2776 . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) 2777 2778 (defun pathname-host-pathname (pathname) 2779 "return a pathname with the same host as given PATHNAME, and all other fields NIL" 2780 (make-pathname :directory nil 2781 :name nil :type nil :version nil :device nil 2782 :defaults pathname ;; host device, and on scl, *some* 2783 ;; scheme-specific parts: port username password, not others: 2784 . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) 2785 2786 (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) 2787 "Given a pathname designator PATH, return an absolute pathname as specified by PATH 2788considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, 2789with a format control-string and other arguments as arguments" 2790 (cond 2791 ((absolute-pathname-p path)) 2792 ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) 2793 ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) 2794 ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) 2795 (or (if (absolute-pathname-p default-pathname) 2796 (absolute-pathname-p (merge-pathnames* path default-pathname)) 2797 (call-function on-error "Default pathname ~S is not an absolute pathname" 2798 default-pathname)) 2799 (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" 2800 path default-pathname)))) 2801 (t (call-function on-error 2802 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" 2803 path defaults)))) 2804 2805 (defun subpathp (maybe-subpath base-pathname) 2806 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that 2807when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." 2808 (and (pathnamep maybe-subpath) (pathnamep base-pathname) 2809 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) 2810 (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) 2811 (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) 2812 (with-pathname-defaults (*nil-pathname*) 2813 (let ((enough (enough-namestring maybe-subpath base-pathname))) 2814 (and (relative-pathname-p enough) (pathname enough)))))) 2815 2816 (defun enough-pathname (maybe-subpath base-pathname) 2817 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that 2818when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." 2819 (let ((sub (when maybe-subpath (pathname maybe-subpath))) 2820 (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) 2821 (or (and base (subpathp sub base)) sub))) 2822 2823 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) 2824 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, 2825or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH 2826given DEFAULTS-PATHNAME as a base pathname." 2827 (let ((enough (enough-pathname maybe-subpath defaults-pathname)) 2828 (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) 2829 (funcall thunk enough))) 2830 2831 (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) 2832 (defaults *default-pathname-defaults*)) 2833 &body body) 2834 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" 2835 `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) 2836 2837 2838;;; Wildcard pathnames 2839(with-upgradability () 2840 (defparameter *wild* (or #+cormanlisp "*" :wild) 2841 "Wild component for use with MAKE-PATHNAME") 2842 (defparameter *wild-directory-component* (or :wild) 2843 "Wild directory component for use with MAKE-PATHNAME") 2844 (defparameter *wild-inferiors-component* (or :wild-inferiors) 2845 "Wild-inferiors directory component for use with MAKE-PATHNAME") 2846 (defparameter *wild-file* 2847 (make-pathname :directory nil :name *wild* :type *wild* 2848 :version (or #-(or allegro abcl xcl) *wild*)) 2849 "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") 2850 (defparameter *wild-file-for-directory* 2851 (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) 2852 :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) 2853 "A pathname object with wildcards for matching any file with DIRECTORY") 2854 (defparameter *wild-directory* 2855 (make-pathname :directory `(:relative ,*wild-directory-component*) 2856 :name nil :type nil :version nil) 2857 "A pathname object with wildcards for matching any subdirectory") 2858 (defparameter *wild-inferiors* 2859 (make-pathname :directory `(:relative ,*wild-inferiors-component*) 2860 :name nil :type nil :version nil) 2861 "A pathname object with wildcards for matching any recursive subdirectory") 2862 (defparameter *wild-path* 2863 (merge-pathnames* *wild-file* *wild-inferiors*) 2864 "A pathname object with wildcards for matching any file in any recursive subdirectory") 2865 2866 (defun wilden (path) 2867 "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" 2868 (merge-pathnames* *wild-path* path))) 2869 2870 2871;;; Translate a pathname 2872(with-upgradability () 2873 (defun relativize-directory-component (directory-component) 2874 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" 2875 (let ((directory (normalize-pathname-directory-component directory-component))) 2876 (cond 2877 ((stringp directory) 2878 (list :relative directory)) 2879 ((eq (car directory) :absolute) 2880 (cons :relative (cdr directory))) 2881 (t 2882 directory)))) 2883 2884 (defun relativize-pathname-directory (pathspec) 2885 "Given a PATHNAME, return a relative pathname with otherwise the same components" 2886 (let ((p (pathname pathspec))) 2887 (make-pathname 2888 :directory (relativize-directory-component (pathname-directory p)) 2889 :defaults p))) 2890 2891 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) 2892 "Given a PATHNAME, return the character used to delimit directory names on this host and device." 2893 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) 2894 (last-char (namestring foo)))) 2895 2896 #-scl 2897 (defun directorize-pathname-host-device (pathname) 2898 "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components 2899added to its DIRECTORY component. This is useful for output translations." 2900 (os-cond 2901 ((os-unix-p) 2902 (when (physical-pathname-p pathname) 2903 (return-from directorize-pathname-host-device pathname)))) 2904 (let* ((root (pathname-root pathname)) 2905 (wild-root (wilden root)) 2906 (absolute-pathname (merge-pathnames* pathname root)) 2907 (separator (directory-separator-for-host root)) 2908 (root-namestring (namestring root)) 2909 (root-string 2910 (substitute-if #\/ 2911 #'(lambda (x) (or (eql x #\:) 2912 (eql x separator))) 2913 root-namestring))) 2914 (multiple-value-bind (relative path filename) 2915 (split-unix-namestring-directory-components root-string :ensure-directory t) 2916 (declare (ignore relative filename)) 2917 (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) 2918 (translate-pathname absolute-pathname wild-root (wilden new-base)))))) 2919 2920 #+scl 2921 (defun directorize-pathname-host-device (pathname) 2922 (let ((scheme (ext:pathname-scheme pathname)) 2923 (host (pathname-host pathname)) 2924 (port (ext:pathname-port pathname)) 2925 (directory (pathname-directory pathname))) 2926 (flet ((specificp (x) (and x (not (eq x :unspecific))))) 2927 (if (or (specificp port) 2928 (and (specificp host) (plusp (length host))) 2929 (specificp scheme)) 2930 (let ((prefix "")) 2931 (when (specificp port) 2932 (setf prefix (format nil ":~D" port))) 2933 (when (and (specificp host) (plusp (length host))) 2934 (setf prefix (strcat host prefix))) 2935 (setf prefix (strcat ":" prefix)) 2936 (when (specificp scheme) 2937 (setf prefix (strcat scheme prefix))) 2938 (assert (and directory (eq (first directory) :absolute))) 2939 (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) 2940 :defaults pathname))) 2941 pathname))) 2942 2943 (defun* (translate-pathname*) (path absolute-source destination &optional root source) 2944 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. 2945PATH is the pathname to be translated. 2946ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, 2947DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, 2948or a relative pathname, to be merged with ROOT and used as destination for translate-pathname 2949or an absolute pathname, to be used as destination for translate-pathname. 2950In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." 2951 (declare (ignore source)) 2952 (cond 2953 ((functionp destination) 2954 (funcall destination path absolute-source)) 2955 ((eq destination t) 2956 path) 2957 ((not (pathnamep destination)) 2958 (parameter-error "~S: Invalid destination" 'translate-pathname*)) 2959 ((not (absolute-pathname-p destination)) 2960 (translate-pathname path absolute-source (merge-pathnames* destination root))) 2961 (root 2962 (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) 2963 (t 2964 (translate-pathname path absolute-source destination)))) 2965 2966 (defvar *output-translation-function* 'identity 2967 "Hook for output translations. 2968 2969This function needs to be idempotent, so that actions can work 2970whether their inputs were translated or not, 2971which they will be if we are composing operations. e.g. if some 2972create-lisp-op creates a lisp file from some higher-level input, 2973you need to still be able to use compile-op on that lisp file.")) 2974;;;; ------------------------------------------------------------------------- 2975;;;; Portability layer around Common Lisp filesystem access 2976 2977(uiop/package:define-package :uiop/filesystem 2978 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) 2979 (:export 2980 ;; Native namestrings 2981 #:native-namestring #:parse-native-namestring 2982 ;; Probing the filesystem 2983 #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p 2984 #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories 2985 #:collect-sub*directories 2986 ;; Resolving symlinks somewhat 2987 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks* 2988 ;; merging with cwd 2989 #:get-pathname-defaults #:call-with-current-directory #:with-current-directory 2990 ;; Environment pathnames 2991 #:inter-directory-separator #:split-native-pathnames-string 2992 #:getenv-pathname #:getenv-pathnames 2993 #:getenv-absolute-directory #:getenv-absolute-directories 2994 #:lisp-implementation-directory #:lisp-implementation-pathname-p 2995 ;; Simple filesystem operations 2996 #:ensure-all-directories-exist 2997 #:rename-file-overwriting-target 2998 #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) 2999(in-package :uiop/filesystem) 3000 3001;;; Native namestrings, as seen by the operating system calls rather than Lisp 3002(with-upgradability () 3003 (defun native-namestring (x) 3004 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" 3005 (when x 3006 (let ((p (pathname x))) 3007 #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 3008 #+(or cmucl scl) (ext:unix-namestring p nil) 3009 #+sbcl (sb-ext:native-namestring p) 3010 #-(or clozure cmucl sbcl scl) 3011 (os-cond 3012 ((os-unix-p) (unix-namestring p)) 3013 (t (namestring p)))))) 3014 3015 (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) 3016 "From a native namestring suitable for use by the operating system, return 3017a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" 3018 (check-type string (or string null)) 3019 (let* ((pathname 3020 (when string 3021 (with-pathname-defaults () 3022 #+clozure (ccl:native-to-pathname string) 3023 #+cmucl (uiop/os::parse-unix-namestring* string) 3024 #+sbcl (sb-ext:parse-native-namestring string) 3025 #+scl (lisp::parse-unix-namestring string) 3026 #-(or clozure cmucl sbcl scl) 3027 (os-cond 3028 ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) 3029 (t (parse-namestring string)))))) 3030 (pathname 3031 (if ensure-directory 3032 (and pathname (ensure-directory-pathname pathname)) 3033 pathname))) 3034 (apply 'ensure-pathname pathname constraints)))) 3035 3036 3037;;; Probing the filesystem 3038(with-upgradability () 3039 (defun truename* (p) 3040 "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories" 3041 (when p 3042 (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p)))) 3043 (values 3044 (or (ignore-errors (truename p)) 3045 ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying 3046 ;; a trailing directory separator, causes an error on some lisps. 3047 #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))))))) 3048 3049 (defun safe-file-write-date (pathname) 3050 "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." 3051 ;; If FILE-WRITE-DATE returns NIL, it's possible that 3052 ;; the user or some other agent has deleted an input file. 3053 ;; Also, generated files will not exist at the time planning is done 3054 ;; and calls compute-action-stamp which calls safe-file-write-date. 3055 ;; So it is very possible that we can't get a valid file-write-date, 3056 ;; and we can survive and we will continue the planning 3057 ;; as if the file were very old. 3058 ;; (or should we treat the case in a different, special way?) 3059 (and pathname 3060 (handler-case (file-write-date (physicalize-pathname pathname)) 3061 (file-error () nil)))) 3062 3063 (defun probe-file* (p &key truename) 3064 "when given a pathname P (designated by a string as per PARSE-NAMESTRING), 3065probes the filesystem for a file or directory with given pathname. 3066If it exists, return its truename if TRUENAME is true, 3067or the original (parsed) pathname if it is false (the default)." 3068 (values 3069 (ignore-errors 3070 (setf p (funcall 'ensure-pathname p 3071 :namestring :lisp 3072 :ensure-physical t 3073 :ensure-absolute t :defaults 'get-pathname-defaults 3074 :want-non-wild t 3075 :on-error nil)) 3076 (when p 3077 #+allegro 3078 (probe-file p :follow-symlinks truename) 3079 #+gcl 3080 (if truename 3081 (truename* p) 3082 (let ((kind (car (si::stat p)))) 3083 (when (eq kind :link) 3084 (setf kind (ignore-errors (car (si::stat (truename* p)))))) 3085 (ecase kind 3086 ((nil) nil) 3087 ((:file :link) 3088 (cond 3089 ((file-pathname-p p) p) 3090 ((directory-pathname-p p) 3091 (subpathname p (car (last (pathname-directory p))))))) 3092 (:directory (ensure-directory-pathname p))))) 3093 #+clisp 3094 #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) 3095 (pp (find-symbol* '#:probe-pathname :ext nil))) 3096 `(if truename 3097 ,(if pp 3098 `(values (,pp p)) 3099 '(or (truename* p) 3100 (truename* (ignore-errors (ensure-directory-pathname p))))) 3101 ,(cond 3102 (fs `(and (,fs p) p)) 3103 (pp `(nth-value 1 (,pp p))) 3104 (t '(or (and (truename* p) p) 3105 (if-let (d (ensure-directory-pathname p)) 3106 (and (truename* d) d))))))) 3107 #-(or allegro clisp gcl) 3108 (if truename 3109 (probe-file p) 3110 (and 3111 #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) 3112 #+(and lispworks os-unix) (system:get-file-stat p) 3113 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) 3114 #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p) 3115 p)))))) 3116 3117 (defun directory-exists-p (x) 3118 "Is X the name of a directory that exists on the filesystem?" 3119 #+allegro 3120 (excl:probe-directory x) 3121 #+clisp 3122 (handler-case (ext:probe-directory x) 3123 (sys::simple-file-error () 3124 nil)) 3125 #-(or allegro clisp) 3126 (let ((p (probe-file* x :truename t))) 3127 (and (directory-pathname-p p) p))) 3128 3129 (defun file-exists-p (x) 3130 "Is X the name of a file that exists on the filesystem?" 3131 (let ((p (probe-file* x :truename t))) 3132 (and (file-pathname-p p) p))) 3133 3134 (defun directory* (pathname-spec &rest keys &key &allow-other-keys) 3135 "Return a list of the entries in a directory by calling DIRECTORY. 3136Try to override the defaults to not resolving symlinks, if implementation allows." 3137 (apply 'directory pathname-spec 3138 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) 3139 #+(or clozure digitool) '(:follow-links nil) 3140 #+clisp '(:circle t :if-does-not-exist :ignore) 3141 #+(or cmucl scl) '(:follow-links nil :truenamep nil) 3142 #+lispworks '(:link-transparency nil) 3143 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) 3144 '(:resolve-symlinks nil)))))) 3145 3146 (defun filter-logical-directory-results (directory entries merger) 3147 "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is, 3148given ENTRIES in the DIRECTORY, remove the entries which are physical yet 3149when transformed by MERGER have a different TRUENAME. 3150Also remove duplicates as may appear with some translation rules. 3151This function is used as a helper to DIRECTORY-FILES to avoid invalid entries 3152when using logical-pathnames." 3153 (if (logical-pathname-p directory) 3154 (remove-duplicates ;; on CLISP, querying ~/ will return duplicates 3155 ;; Try hard to not resolve logical-pathname into physical pathnames; 3156 ;; otherwise logical-pathname users/lovers will be disappointed. 3157 ;; If directory* could use some implementation-dependent magic, 3158 ;; we will have logical pathnames already; otherwise, 3159 ;; we only keep pathnames for which specifying the name and 3160 ;; translating the LPN commute. 3161 (loop :for f :in entries 3162 :for p = (or (and (logical-pathname-p f) f) 3163 (let* ((u (ignore-errors (call-function merger f)))) 3164 ;; The first u avoids a cumbersome (truename u) error. 3165 ;; At this point f should already be a truename, 3166 ;; but isn't quite in CLISP, for it doesn't have :version :newest 3167 (and u (equal (truename* u) (truename* f)) u))) 3168 :when p :collect p) 3169 :test 'pathname-equal) 3170 entries)) 3171 3172 (defun directory-files (directory &optional (pattern *wild-file-for-directory*)) 3173 "Return a list of the files in a directory according to the PATTERN. 3174Subdirectories should NOT be returned. 3175 PATTERN defaults to a pattern carefully chosen based on the implementation; 3176override the default at your own risk. 3177 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this, 3178but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations." 3179 (let ((dir (pathname directory))) 3180 (when (logical-pathname-p dir) 3181 ;; Because of the filtering we do below, 3182 ;; logical pathnames have restrictions on wild patterns. 3183 ;; Not that the results are very portable when you use these patterns on physical pathnames. 3184 (when (wild-pathname-p dir) 3185 (parameter-error "~S: Invalid wild pattern in logical directory ~S" 3186 'directory-files directory)) 3187 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) 3188 (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory)) 3189 (setf pattern (make-pathname-logical pattern (pathname-host dir)))) 3190 (let* ((pat (merge-pathnames* pattern dir)) 3191 (entries (ignore-errors (directory* pat)))) 3192 (remove-if 'directory-pathname-p 3193 (filter-logical-directory-results 3194 directory entries 3195 #'(lambda (f) 3196 (make-pathname :defaults dir 3197 :name (make-pathname-component-logical (pathname-name f)) 3198 :type (make-pathname-component-logical (pathname-type f)) 3199 :version (make-pathname-component-logical (pathname-version f))))))))) 3200 3201 (defun subdirectories (directory) 3202 "Given a DIRECTORY pathname designator, return a list of the subdirectories under it. 3203The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." 3204 (let* ((directory (ensure-directory-pathname directory)) 3205 #-(or abcl cormanlisp genera xcl) 3206 (wild (merge-pathnames* 3207 #-(or abcl allegro cmucl lispworks sbcl scl xcl) 3208 *wild-directory* 3209 #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" 3210 directory)) 3211 (dirs 3212 #-(or abcl cormanlisp genera xcl) 3213 (ignore-errors 3214 (directory* wild . #.(or #+clozure '(:directories t :files nil) 3215 #+mcl '(:directories t)))) 3216 #+(or abcl xcl) (system:list-directory directory) 3217 #+cormanlisp (cl::directory-subdirs directory) 3218 #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) 3219 #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) 3220 (dirs (loop :for x :in dirs 3221 :for d = #+(or abcl xcl) (extensions:probe-directory x) 3222 #+allegro (excl:probe-directory x) 3223 #+(or cmucl sbcl scl) (directory-pathname-p x) 3224 #+genera (getf (cdr x) :directory) 3225 #+lispworks (lw:file-directory-p x) 3226 :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d) 3227 #+genera (ensure-directory-pathname (first x)) 3228 #+(or cmucl lispworks sbcl scl) x))) 3229 (filter-logical-directory-results 3230 directory dirs 3231 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) 3232 '(:absolute)))) ; because allegro returns NIL for #p"FOO:" 3233 #'(lambda (d) 3234 (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) 3235 (and (consp dir) (consp (cdr dir)) 3236 (make-pathname 3237 :defaults directory :name nil :type nil :version nil 3238 :directory (append prefix (make-pathname-component-logical (last dir))))))))))) 3239 3240 (defun collect-sub*directories (directory collectp recursep collector) 3241 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory, 3242call-function the COLLECTOR function designator on the directory, 3243and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them. 3244This function will thus let you traverse a filesystem hierarchy, 3245superseding the functionality of CL-FAD:WALK-DIRECTORY. 3246The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." 3247 (when (call-function collectp directory) 3248 (call-function collector directory) 3249 (dolist (subdir (subdirectories directory)) 3250 (when (call-function recursep subdir) 3251 (collect-sub*directories subdir collectp recursep collector)))))) 3252 3253;;; Resolving symlinks somewhat 3254(with-upgradability () 3255 (defun truenamize (pathname) 3256 "Resolve as much of a pathname as possible" 3257 (block nil 3258 (when (typep pathname '(or null logical-pathname)) (return pathname)) 3259 (let ((p pathname)) 3260 (unless (absolute-pathname-p p) 3261 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil)) 3262 (return p)))) 3263 (when (logical-pathname-p p) (return p)) 3264 (let ((found (probe-file* p :truename t))) 3265 (when found (return found))) 3266 (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) 3267 (up-components (reverse (rest directory))) 3268 (down-components ())) 3269 (assert (eq :absolute (first directory))) 3270 (loop :while up-components :do 3271 (if-let (parent 3272 (ignore-errors 3273 (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) 3274 :name nil :type nil :version nil :defaults p)))) 3275 (if-let (simplified 3276 (ignore-errors 3277 (merge-pathnames* 3278 (make-pathname :directory `(:relative ,@down-components) 3279 :defaults p) 3280 (ensure-directory-pathname parent)))) 3281 (return simplified))) 3282 (push (pop up-components) down-components) 3283 :finally (return p)))))) 3284 3285 (defun resolve-symlinks (path) 3286 "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." 3287 #-allegro (truenamize path) 3288 #+allegro 3289 (if (physical-pathname-p path) 3290 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) 3291 path)) 3292 3293 (defvar *resolve-symlinks* t 3294 "Determine whether or not ASDF resolves symlinks when defining systems. 3295Defaults to T.") 3296 3297 (defun resolve-symlinks* (path) 3298 "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)." 3299 (if *resolve-symlinks* 3300 (and path (resolve-symlinks path)) 3301 path))) 3302 3303 3304;;; Check pathname constraints 3305(with-upgradability () 3306 (defun ensure-pathname 3307 (pathname &key 3308 on-error 3309 defaults type dot-dot namestring 3310 empty-is-nil 3311 want-pathname 3312 want-logical want-physical ensure-physical 3313 want-relative want-absolute ensure-absolute ensure-subpath 3314 want-non-wild want-wild wilden 3315 want-file want-directory ensure-directory 3316 want-existing ensure-directories-exist 3317 truename resolve-symlinks truenamize 3318 &aux (p pathname)) ;; mutable working copy, preserve original 3319 "Coerces its argument into a PATHNAME, 3320optionally doing some transformations and checking specified constraints. 3321 3322If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. 3323 3324If the argument is a STRING, it is first converted to a pathname via 3325PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively 3326depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively, 3327or else by using CALL-FUNCTION on the NAMESTRING argument; 3328if :UNIX is specified (or NIL, the default, which specifies the same thing), 3329then PARSE-UNIX-NAMESTRING it is called with the keywords 3330DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and 3331the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true. 3332 3333The pathname passed or resulting from parsing the string 3334is then subjected to all the checks and transformations below are run. 3335 3336Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. 3337The boolean T is an alias for ERROR. 3338ERROR means that an error will be raised if the constraint is not satisfied. 3339CERROR means that an continuable error will be raised if the constraint is not satisfied. 3340IGNORE means just return NIL instead of the pathname. 3341 3342The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) 3343that will be called with the the following arguments: 3344a generic format string for ensure pathname, the pathname, 3345the keyword argument corresponding to the failed check or transformation, 3346a format string for the reason ENSURE-PATHNAME failed, 3347and a list with arguments to that format string. 3348If ON-ERROR is NIL, ERROR is used instead, which does the right thing. 3349You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). 3350 3351The transformations and constraint checks are done in this order, 3352which is also the order in the lambda-list: 3353 3354EMPTY-IS-NIL returns NIL if the argument is an empty string. 3355WANT-PATHNAME checks that pathname (after parsing if needed) is not null. 3356Otherwise, if the pathname is NIL, ensure-pathname returns NIL. 3357WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME 3358WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME 3359ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME 3360WANT-RELATIVE checks that pathname has a relative directory component 3361WANT-ABSOLUTE checks that pathname does have an absolute directory component 3362ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again 3363that the result absolute is an absolute pathname indeed. 3364ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. 3365WANT-FILE checks that pathname has a non-nil FILE component 3366WANT-DIRECTORY checks that pathname has nil FILE and TYPE components 3367ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret 3368any file and type components as being actually a last directory component. 3369WANT-NON-WILD checks that pathname is not a wild pathname 3370WANT-WILD checks that pathname is a wild pathname 3371WILDEN merges the pathname with **/*.*.* if it is not wild 3372WANT-EXISTING checks that a file (or directory) exists with that pathname. 3373ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. 3374TRUENAME replaces the pathname by its truename, or errors if not possible. 3375RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. 3376TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." 3377 (block nil 3378 (flet ((report-error (keyword description &rest arguments) 3379 (call-function (or on-error 'error) 3380 "Invalid pathname ~S: ~*~?" 3381 pathname keyword description arguments))) 3382 (macrolet ((err (constraint &rest arguments) 3383 `(report-error ',(intern* constraint :keyword) ,@arguments)) 3384 (check (constraint condition &rest arguments) 3385 `(when ,constraint 3386 (unless ,condition (err ,constraint ,@arguments)))) 3387 (transform (transform condition expr) 3388 `(when ,transform 3389 (,@(if condition `(when ,condition) '(progn)) 3390 (setf p ,expr))))) 3391 (etypecase p 3392 ((or null pathname)) 3393 (string 3394 (when (and (emptyp p) empty-is-nil) 3395 (return-from ensure-pathname nil)) 3396 (setf p (case namestring 3397 ((:unix nil) 3398 (parse-unix-namestring 3399 p :defaults defaults :type type :dot-dot dot-dot 3400 :ensure-directory ensure-directory :want-relative want-relative)) 3401 ((:native) 3402 (parse-native-namestring p)) 3403 ((:lisp) 3404 (parse-namestring p)) 3405 (t 3406 (call-function namestring p)))))) 3407 (etypecase p 3408 (pathname) 3409 (null 3410 (check want-pathname (pathnamep p) "Expected a pathname, not NIL") 3411 (return nil))) 3412 (check want-logical (logical-pathname-p p) "Expected a logical pathname") 3413 (check want-physical (physical-pathname-p p) "Expected a physical pathname") 3414 (transform ensure-physical () (physicalize-pathname p)) 3415 (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") 3416 (check want-relative (relative-pathname-p p) "Expected a relative pathname") 3417 (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") 3418 (transform ensure-absolute (not (absolute-pathname-p p)) 3419 (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) 3420 (check ensure-absolute (absolute-pathname-p p) 3421 "Could not make into an absolute pathname even after merging with ~S" defaults) 3422 (check ensure-subpath (absolute-pathname-p defaults) 3423 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) 3424 (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) 3425 (check want-file (file-pathname-p p) "Expected a file pathname") 3426 (check want-directory (directory-pathname-p p) "Expected a directory pathname") 3427 (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) 3428 (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") 3429 (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") 3430 (transform wilden (not (wild-pathname-p p)) (wilden p)) 3431 (when want-existing 3432 (let ((existing (probe-file* p :truename truename))) 3433 (if existing 3434 (when truename 3435 (return existing)) 3436 (err want-existing "Expected an existing pathname")))) 3437 (when ensure-directories-exist (ensure-directories-exist p)) 3438 (when truename 3439 (let ((truename (truename* p))) 3440 (if truename 3441 (return truename) 3442 (err truename "Can't get a truename for pathname")))) 3443 (transform resolve-symlinks () (resolve-symlinks p)) 3444 (transform truenamize () (truenamize p)) 3445 p))))) 3446 3447 3448;;; Pathname defaults 3449(with-upgradability () 3450 (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) 3451 "Find the actual DEFAULTS to use for pathnames, including 3452resolving them with respect to GETCWD if the DEFAULTS were relative" 3453 (or (absolute-pathname-p defaults) 3454 (merge-pathnames* defaults (getcwd)))) 3455 3456 (defun call-with-current-directory (dir thunk) 3457 "call the THUNK in a context where the current directory was changed to DIR, if not NIL. 3458Note that this operation is usually NOT thread-safe." 3459 (if dir 3460 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) 3461 (cwd (getcwd)) 3462 (*default-pathname-defaults* dir)) 3463 (chdir dir) 3464 (unwind-protect 3465 (funcall thunk) 3466 (chdir cwd))) 3467 (funcall thunk))) 3468 3469 (defmacro with-current-directory ((&optional dir) &body body) 3470 "Call BODY while the POSIX current working directory is set to DIR" 3471 `(call-with-current-directory ,dir #'(lambda () ,@body)))) 3472 3473 3474;;; Environment pathnames 3475(with-upgradability () 3476 (defun inter-directory-separator () 3477 "What character does the current OS conventionally uses to separate directories?" 3478 (os-cond ((os-unix-p) #\:) (t #\;))) 3479 3480 (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) 3481 "Given a string of pathnames specified in native OS syntax, separate them in a list, 3482check constraints and normalize each one as per ENSURE-PATHNAME, 3483where an empty string denotes NIL." 3484 (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) 3485 :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints)))) 3486 3487 (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) 3488 "Extract a pathname from a user-configured environment variable, as per native OS, 3489check constraints and normalize as per ENSURE-PATHNAME." 3490 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory 3491 (apply 'parse-native-namestring (getenvp x) 3492 :ensure-directory (or ensure-directory want-directory) 3493 :on-error (or on-error 3494 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) 3495 constraints)) 3496 (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) 3497 "Extract a list of pathname from a user-configured environment variable, as per native OS, 3498check constraints and normalize each one as per ENSURE-PATHNAME. 3499 Any empty entries in the environment variable X will be returned as NILs." 3500 (unless (getf constraints :empty-is-nil t) 3501 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames)) 3502 (apply 'split-native-pathnames-string (getenvp x) 3503 :on-error (or on-error 3504 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) 3505 :empty-is-nil t 3506 constraints)) 3507 (defun getenv-absolute-directory (x) 3508 "Extract an absolute directory pathname from a user-configured environment variable, 3509as per native OS" 3510 (getenv-pathname x :want-absolute t :ensure-directory t)) 3511 (defun getenv-absolute-directories (x) 3512 "Extract a list of absolute directories from a user-configured environment variable, 3513as per native OS. Any empty entries in the environment variable X will be returned as 3514NILs." 3515 (getenv-pathnames x :want-absolute t :ensure-directory t)) 3516 3517 (defun lisp-implementation-directory (&key truename) 3518 "Where are the system files of the current installation of the CL implementation?" 3519 (declare (ignorable truename)) 3520 (let ((dir 3521 #+abcl extensions:*lisp-home* 3522 #+(or allegro clasp ecl mkcl) #p"SYS:" 3523 #+clisp custom:*lib-directory* 3524 #+clozure #p"ccl:" 3525 #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) 3526 #+gcl system::*system-directory* 3527 #+lispworks lispworks:*lispworks-directory* 3528 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) 3529 (funcall it) 3530 (getenv-pathname "SBCL_HOME" :ensure-directory t)) 3531 #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) 3532 #+xcl ext:*xcl-home*)) 3533 (if (and dir truename) 3534 (truename* dir) 3535 dir))) 3536 3537 (defun lisp-implementation-pathname-p (pathname) 3538 "Is the PATHNAME under the current installation of the CL implementation?" 3539 ;; Other builtin systems are those under the implementation directory 3540 (and (when pathname 3541 (if-let (impdir (lisp-implementation-directory)) 3542 (or (subpathp pathname impdir) 3543 (when *resolve-symlinks* 3544 (if-let (truename (truename* pathname)) 3545 (if-let (trueimpdir (truename* impdir)) 3546 (subpathp truename trueimpdir))))))) 3547 t))) 3548 3549 3550;;; Simple filesystem operations 3551(with-upgradability () 3552 (defun ensure-all-directories-exist (pathnames) 3553 "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" 3554 (dolist (pathname pathnames) 3555 (when pathname 3556 (ensure-directories-exist (physicalize-pathname pathname))))) 3557 3558 (defun delete-file-if-exists (x) 3559 "Delete a file X if it already exists" 3560 (when x (handler-case (delete-file x) (file-error () nil)))) 3561 3562 (defun rename-file-overwriting-target (source target) 3563 "Rename a file, overwriting any previous file with the TARGET name, 3564in an atomic way if the implementation allows." 3565 (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) 3566 (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) 3567 #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic 3568 (progn (funcall 'require "syscalls") 3569 (symbol-call :posix :copy-file source target :method :rename)) 3570 #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic 3571 #-clisp 3572 (rename-file source target 3573 #+(or clasp clozure ecl) :if-exists 3574 #+clozure :rename-and-delete #+(or clasp ecl) t))) 3575 3576 (defun delete-empty-directory (directory-pathname) 3577 "Delete an empty directory" 3578 #+(or abcl digitool gcl) (delete-file directory-pathname) 3579 #+allegro (excl:delete-directory directory-pathname) 3580 #+clisp (ext:delete-directory directory-pathname) 3581 #+clozure (ccl::delete-empty-directory directory-pathname) 3582 #+(or cmucl scl) (multiple-value-bind (ok errno) 3583 (unix:unix-rmdir (native-namestring directory-pathname)) 3584 (unless ok 3585 #+cmucl (error "Error number ~A when trying to delete directory ~A" 3586 errno directory-pathname) 3587 #+scl (error "~@<Error deleting ~S: ~A~@:>" 3588 directory-pathname (unix:get-unix-error-msg errno)))) 3589 #+cormanlisp (win32:delete-directory directory-pathname) 3590 #+(or clasp ecl) (si:rmdir directory-pathname) 3591 #+genera (fs:delete-directory directory-pathname) 3592 #+lispworks (lw:delete-directory directory-pathname) 3593 #+mkcl (mkcl:rmdir directory-pathname) 3594 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) 3595 `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later 3596 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) 3597 #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) 3598 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) 3599 (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera 3600 3601 (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) 3602 "Delete a directory including all its recursive contents, aka rm -rf. 3603 3604To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be 3605a physical non-wildcard directory pathname (not namestring). 3606 3607If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: 3608if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. 3609 3610Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass 3611the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument 3612which in practice is thus compulsory, and validates by returning a non-NIL result. 3613If you're suicidal or extremely confident, just use :VALIDATE T." 3614 (check-type if-does-not-exist (member :error :ignore)) 3615 (cond 3616 ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) 3617 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) 3618 (parameter-error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" 3619 'delete-directory-tree directory-pathname)) 3620 ((not validatep) 3621 (parameter-error "~S was asked to delete ~S but was not provided a validation predicate" 3622 'delete-directory-tree directory-pathname)) 3623 ((not (call-function validate directory-pathname)) 3624 (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" 3625 'delete-directory-tree directory-pathname validate)) 3626 ((not (directory-exists-p directory-pathname)) 3627 (ecase if-does-not-exist 3628 (:error 3629 (error "~S was asked to delete ~S but the directory does not exist" 3630 'delete-directory-tree directory-pathname)) 3631 (:ignore nil))) 3632 #-(or allegro cmucl clozure genera sbcl scl) 3633 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, 3634 ;; except on implementations where we can prevent DIRECTORY from following symlinks; 3635 ;; instead spawn a standard external program to do the dirty work. 3636 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) 3637 (t 3638 ;; On supported implementation, call supported system functions 3639 #+allegro (symbol-call :excl.osi :delete-directory-and-files 3640 directory-pathname :if-does-not-exist if-does-not-exist) 3641 #+clozure (ccl:delete-directory directory-pathname) 3642 #+genera (fs:delete-directory directory-pathname :confirm nil) 3643 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) 3644 `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later 3645 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) 3646 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, 3647 ;; do things the hard way. 3648 #-(or allegro clozure genera sbcl) 3649 (let ((sub*directories 3650 (while-collecting (c) 3651 (collect-sub*directories directory-pathname t t #'c)))) 3652 (dolist (d (nreverse sub*directories)) 3653 (map () 'delete-file (directory-files d)) 3654 (delete-empty-directory d))))))) 3655;;;; --------------------------------------------------------------------------- 3656;;;; Utilities related to streams 3657 3658(uiop/package:define-package :uiop/stream 3659 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) 3660 (:export 3661 #:*default-stream-element-type* 3662 #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr 3663 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding 3664 #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format 3665 #:*default-encoding* #:*utf-8-external-format* 3666 #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string 3667 #:with-output #:output-string #:with-input #:input-string 3668 #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file 3669 #:null-device-pathname #:call-with-null-input #:with-null-input 3670 #:call-with-null-output #:with-null-output 3671 #:finish-outputs #:format! #:safe-format! 3672 #:copy-stream-to-stream #:concatenate-files #:copy-file 3673 #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line 3674 #:slurp-stream-forms #:slurp-stream-form 3675 #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line 3676 #:read-file-forms #:read-file-form #:safe-read-file-form 3677 #:eval-input #:eval-thunk #:standard-eval-thunk 3678 #:println #:writeln 3679 #:file-stream-p #:file-or-synonym-stream-p 3680 ;; Temporary files 3681 #:*temporary-directory* #:temporary-directory #:default-temporary-directory 3682 #:setup-temporary-directory 3683 #:call-with-temporary-file #:with-temporary-file 3684 #:add-pathname-suffix #:tmpize-pathname 3685 #:call-with-staging-pathname #:with-staging-pathname)) 3686(in-package :uiop/stream) 3687 3688(with-upgradability () 3689 (defvar *default-stream-element-type* 3690 (or #+(or abcl cmucl cormanlisp scl xcl) 'character 3691 #+lispworks 'lw:simple-char 3692 :default) 3693 "default element-type for open (depends on the current CL implementation)") 3694 3695 (defvar *stdin* *standard-input* 3696 "the original standard input stream at startup") 3697 3698 (defun setup-stdin () 3699 (setf *stdin* 3700 #.(or #+clozure 'ccl::*stdin* 3701 #+(or cmucl scl) 'system:*stdin* 3702 #+(or clasp ecl) 'ext::+process-standard-input+ 3703 #+sbcl 'sb-sys:*stdin* 3704 '*standard-input*))) 3705 3706 (defvar *stdout* *standard-output* 3707 "the original standard output stream at startup") 3708 3709 (defun setup-stdout () 3710 (setf *stdout* 3711 #.(or #+clozure 'ccl::*stdout* 3712 #+(or cmucl scl) 'system:*stdout* 3713 #+(or clasp ecl) 'ext::+process-standard-output+ 3714 #+sbcl 'sb-sys:*stdout* 3715 '*standard-output*))) 3716 3717 (defvar *stderr* *error-output* 3718 "the original error output stream at startup") 3719 3720 (defun setup-stderr () 3721 (setf *stderr* 3722 #.(or #+allegro 'excl::*stderr* 3723 #+clozure 'ccl::*stderr* 3724 #+(or cmucl scl) 'system:*stderr* 3725 #+(or clasp ecl) 'ext::+process-error-output+ 3726 #+sbcl 'sb-sys:*stderr* 3727 '*error-output*))) 3728 3729 ;; Run them now. In image.lisp, we'll register them to be run at image restart. 3730 (setup-stdin) (setup-stdout) (setup-stderr)) 3731 3732 3733;;; Encodings (mostly hooks only; full support requires asdf-encodings) 3734(with-upgradability () 3735 (defparameter *default-encoding* 3736 ;; preserve explicit user changes to something other than the legacy default :default 3737 (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) 3738 (unless (eq previous :default) previous)) 3739 :utf-8) 3740 "Default encoding for source files. 3741The default value :utf-8 is the portable thing. 3742The legacy behavior was :default. 3743If you (asdf:load-system :asdf-encodings) then 3744you will have autodetection via *encoding-detection-hook* below, 3745reading emacs-style -*- coding: utf-8 -*- specifications, 3746and falling back to utf-8 or latin1 if nothing is specified.") 3747 3748 (defparameter *utf-8-external-format* 3749 (if (featurep :asdf-unicode) 3750 (or #+clisp charset:utf-8 :utf-8) 3751 :default) 3752 "Default :external-format argument to pass to CL:OPEN and also 3753CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. 3754On modern implementations, this will decode UTF-8 code points as CL characters. 3755On legacy implementations, it may fall back on some 8-bit encoding, 3756with non-ASCII code points being read as several CL characters; 3757hopefully, if done consistently, that won't affect program behavior too much.") 3758 3759 (defun always-default-encoding (pathname) 3760 "Trivial function to use as *encoding-detection-hook*, 3761always 'detects' the *default-encoding*" 3762 (declare (ignore pathname)) 3763 *default-encoding*) 3764 3765 (defvar *encoding-detection-hook* #'always-default-encoding 3766 "Hook for an extension to define a function to automatically detect a file's encoding") 3767 3768 (defun detect-encoding (pathname) 3769 "Detects the encoding of a specified file, going through user-configurable hooks" 3770 (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) 3771 (funcall *encoding-detection-hook* pathname) 3772 *default-encoding*)) 3773 3774 (defun default-encoding-external-format (encoding) 3775 "Default, ignorant, function to transform a character ENCODING as a 3776portable keyword to an implementation-dependent EXTERNAL-FORMAT specification. 3777Load system ASDF-ENCODINGS to hook in a better one." 3778 (case encoding 3779 (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. 3780 (:utf-8 *utf-8-external-format*) 3781 (otherwise 3782 (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) 3783 :default))) 3784 3785 (defvar *encoding-external-format-hook* 3786 #'default-encoding-external-format 3787 "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping 3788from non-default encodings to and implementation-defined external-format's") 3789 3790 (defun encoding-external-format (encoding) 3791 "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT, 3792going through all the proper hooks." 3793 (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) 3794 3795 3796;;; Safe syntax 3797(with-upgradability () 3798 (defvar *standard-readtable* (with-standard-io-syntax *readtable*) 3799 "The standard readtable, implementing the syntax specified by the CLHS. 3800It must never be modified, though only good implementations will even enforce that.") 3801 3802 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) 3803 "Establish safe CL reader options around the evaluation of BODY" 3804 `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) 3805 3806 (defun call-with-safe-io-syntax (thunk &key (package :cl)) 3807 (with-standard-io-syntax 3808 (let ((*package* (find-package package)) 3809 (*read-default-float-format* 'double-float) 3810 (*print-readably* nil) 3811 (*read-eval* nil)) 3812 (funcall thunk)))) 3813 3814 (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) 3815 "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX" 3816 (with-safe-io-syntax (:package package) 3817 (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) 3818 3819;;; Output helpers 3820(with-upgradability () 3821 (defun call-with-output-file (pathname thunk 3822 &key 3823 (element-type *default-stream-element-type*) 3824 (external-format *utf-8-external-format*) 3825 (if-exists :error) 3826 (if-does-not-exist :create)) 3827 "Open FILE for input with given recognizes options, call THUNK with the resulting stream. 3828Other keys are accepted but discarded." 3829 (with-open-file (s pathname :direction :output 3830 :element-type element-type 3831 :external-format external-format 3832 :if-exists if-exists 3833 :if-does-not-exist if-does-not-exist) 3834 (funcall thunk s))) 3835 3836 (defmacro with-output-file ((var pathname &rest keys 3837 &key element-type external-format if-exists if-does-not-exist) 3838 &body body) 3839 (declare (ignore element-type external-format if-exists if-does-not-exist)) 3840 `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)) 3841 3842 (defun call-with-output (output function &key keys) 3843 "Calls FUNCTION with an actual stream argument, 3844behaving like FORMAT with respect to how stream designators are interpreted: 3845If OUTPUT is a STREAM, use it as the stream. 3846If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. 3847If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. 3848If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream. 3849If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE 3850-- this latter as an extension since ASDF 3.1. 3851Otherwise, signal an error." 3852 (etypecase output 3853 (null 3854 (with-output-to-string (stream) (funcall function stream))) 3855 ((eql t) 3856 (funcall function *standard-output*)) 3857 (stream 3858 (funcall function output)) 3859 (string 3860 (assert (fill-pointer output)) 3861 (with-output-to-string (stream output) (funcall function stream))) 3862 (pathname 3863 (apply 'call-with-output-file output function keys)))) 3864 3865 (defmacro with-output ((output-var &optional (value output-var)) &body body) 3866 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) 3867as per FORMAT, and evaluate BODY within the scope of this binding." 3868 `(call-with-output ,value #'(lambda (,output-var) ,@body))) 3869 3870 (defun output-string (string &optional output) 3871 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" 3872 (if output 3873 (with-output (output) (princ string output)) 3874 string))) 3875 3876 3877;;; Input helpers 3878(with-upgradability () 3879 (defun call-with-input-file (pathname thunk 3880 &key 3881 (element-type *default-stream-element-type*) 3882 (external-format *utf-8-external-format*) 3883 (if-does-not-exist :error)) 3884 "Open FILE for input with given recognizes options, call THUNK with the resulting stream. 3885Other keys are accepted but discarded." 3886 (with-open-file (s pathname :direction :input 3887 :element-type element-type 3888 :external-format external-format 3889 :if-does-not-exist if-does-not-exist) 3890 (funcall thunk s))) 3891 3892 (defmacro with-input-file ((var pathname &rest keys 3893 &key element-type external-format if-does-not-exist) 3894 &body body) 3895 (declare (ignore element-type external-format if-does-not-exist)) 3896 `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) 3897 3898 (defun call-with-input (input function &key keys) 3899 "Calls FUNCTION with an actual stream argument, interpreting 3900stream designators like READ, but also coercing strings to STRING-INPUT-STREAM, 3901and PATHNAME to FILE-STREAM. 3902If INPUT is a STREAM, use it as the stream. 3903If INPUT is NIL, use a *STANDARD-INPUT* as the stream. 3904If INPUT is T, use *TERMINAL-IO* as the stream. 3905If INPUT is a STRING, use it as a string-input-stream. 3906If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE 3907-- the latter is an extension since ASDF 3.1. 3908Otherwise, signal an error." 3909 (etypecase input 3910 (null (funcall function *standard-input*)) 3911 ((eql t) (funcall function *terminal-io*)) 3912 (stream (funcall function input)) 3913 (string (with-input-from-string (stream input) (funcall function stream))) 3914 (pathname (apply 'call-with-input-file input function keys)))) 3915 3916 (defmacro with-input ((input-var &optional (value input-var)) &body body) 3917 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) 3918as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." 3919 `(call-with-input ,value #'(lambda (,input-var) ,@body))) 3920 3921 (defun input-string (&optional input) 3922 "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string 3923and return that" 3924 (if (stringp input) 3925 input 3926 (with-input (input) (funcall 'slurp-stream-string input))))) 3927 3928;;; Null device 3929(with-upgradability () 3930 (defun null-device-pathname () 3931 "Pathname to a bit bucket device that discards any information written to it 3932and always returns EOF when read from" 3933 (os-cond 3934 ((os-unix-p) #p"/dev/null") 3935 ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? 3936 (t (error "No /dev/null on your OS")))) 3937 (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist) 3938 "Call FUN with an input stream from the null device; pass keyword arguments to OPEN." 3939 (declare (ignore element-type external-format if-does-not-exist)) 3940 (apply 'call-with-input-file (null-device-pathname) fun keys)) 3941 (defmacro with-null-input ((var &rest keys 3942 &key element-type external-format if-does-not-exist) 3943 &body body) 3944 (declare (ignore element-type external-format if-does-not-exist)) 3945 "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device. 3946Pass keyword arguments to OPEN." 3947 `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) 3948 (defun call-with-null-output (fun 3949 &key (element-type *default-stream-element-type*) 3950 (external-format *utf-8-external-format*) 3951 (if-exists :overwrite) 3952 (if-does-not-exist :error)) 3953 "Call FUN with an output stream to the null device; pass keyword arguments to OPEN." 3954 (call-with-output-file 3955 (null-device-pathname) fun 3956 :element-type element-type :external-format external-format 3957 :if-exists if-exists :if-does-not-exist if-does-not-exist)) 3958 (defmacro with-null-output ((var &rest keys 3959 &key element-type external-format if-does-not-exist if-exists) 3960 &body body) 3961 "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device. 3962Pass keyword arguments to OPEN." 3963 (declare (ignore element-type external-format if-exists if-does-not-exist)) 3964 `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) 3965 3966;;; Ensure output buffers are flushed 3967(with-upgradability () 3968 (defun finish-outputs (&rest streams) 3969 "Finish output on the main output streams as well as any specified one. 3970Useful for portably flushing I/O before user input or program exit." 3971 ;; CCL notably buffers its stream output by default. 3972 (dolist (s (append streams 3973 (list *stdout* *stderr* *error-output* *standard-output* *trace-output* 3974 *debug-io* *terminal-io* *query-io*))) 3975 (ignore-errors (finish-output s))) 3976 (values)) 3977 3978 (defun format! (stream format &rest args) 3979 "Just like format, but call finish-outputs before and after the output." 3980 (finish-outputs stream) 3981 (apply 'format stream format args) 3982 (finish-outputs stream)) 3983 3984 (defun safe-format! (stream format &rest args) 3985 "Variant of FORMAT that is safe against both 3986dangerous syntax configuration and errors while printing." 3987 (with-safe-io-syntax () 3988 (ignore-errors (apply 'format! stream format args)) 3989 (finish-outputs stream)))) ; just in case format failed 3990 3991 3992;;; Simple Whole-Stream processing 3993(with-upgradability () 3994 (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) 3995 "Copy the contents of the INPUT stream into the OUTPUT stream. 3996If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. 3997Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." 3998 (with-open-stream (input input) 3999 (if linewise 4000 (loop* :for (line eof) = (multiple-value-list (read-line input nil nil)) 4001 :while line :do 4002 (when prefix (princ prefix output)) 4003 (princ line output) 4004 (unless eof (terpri output)) 4005 (finish-output output) 4006 (when eof (return))) 4007 (loop 4008 :with buffer-size = (or buffer-size 8192) 4009 :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) 4010 :for end = (read-sequence buffer input) 4011 :until (zerop end) 4012 :do (write-sequence buffer output :end end) 4013 (when (< end buffer-size) (return)))))) 4014 4015 (defun concatenate-files (inputs output) 4016 "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files." 4017 (with-open-file (o output :element-type '(unsigned-byte 8) 4018 :direction :output :if-exists :rename-and-delete) 4019 (dolist (input inputs) 4020 (with-open-file (i input :element-type '(unsigned-byte 8) 4021 :direction :input :if-does-not-exist :error) 4022 (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) 4023 4024 (defun copy-file (input output) 4025 "Copy contents of the INPUT file to the OUTPUT file" 4026 ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) 4027 #+allegro 4028 (excl.osi:copy-file input output) 4029 #+ecl 4030 (ext:copy-file input output) 4031 #-(or allegro ecl) 4032 (concatenate-files (list input) output)) 4033 4034 (defun slurp-stream-string (input &key (element-type 'character) stripped) 4035 "Read the contents of the INPUT stream as a string" 4036 (let ((string 4037 (with-open-stream (input input) 4038 (with-output-to-string (output) 4039 (copy-stream-to-stream input output :element-type element-type))))) 4040 (if stripped (stripln string) string))) 4041 4042 (defun slurp-stream-lines (input &key count) 4043 "Read the contents of the INPUT stream as a list of lines, return those lines. 4044 4045Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR 4046from the line-ending if the file or stream had CR+LF but Lisp only removed LF. 4047 4048Read no more than COUNT lines." 4049 (check-type count (or null integer)) 4050 (with-open-stream (input input) 4051 (loop :for n :from 0 4052 :for l = (and (or (not count) (< n count)) 4053 (read-line input nil nil)) 4054 ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF 4055 :while l :collect (stripln l)))) 4056 4057 (defun slurp-stream-line (input &key (at 0)) 4058 "Read the contents of the INPUT stream as a list of lines, 4059then return the ACCESS-AT of that list of lines using the AT specifier. 4060PATH defaults to 0, i.e. return the first line. 4061PATH is typically an integer, or a list of an integer and a function. 4062If PATH is NIL, it will return all the lines in the file. 4063 4064The stream will not be read beyond the Nth lines, 4065where N is the index specified by path 4066if path is either an integer or a list that starts with an integer." 4067 (access-at (slurp-stream-lines input :count (access-at-count at)) at)) 4068 4069 (defun slurp-stream-forms (input &key count) 4070 "Read the contents of the INPUT stream as a list of forms, 4071and return those forms. 4072 4073If COUNT is null, read to the end of the stream; 4074if COUNT is an integer, stop after COUNT forms were read. 4075 4076BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4077 (check-type count (or null integer)) 4078 (loop :with eof = '#:eof 4079 :for n :from 0 4080 :for form = (if (and count (>= n count)) 4081 eof 4082 (read-preserving-whitespace input nil eof)) 4083 :until (eq form eof) :collect form)) 4084 4085 (defun slurp-stream-form (input &key (at 0)) 4086 "Read the contents of the INPUT stream as a list of forms, 4087then return the ACCESS-AT of these forms following the AT. 4088AT defaults to 0, i.e. return the first form. 4089AT is typically a list of integers. 4090If AT is NIL, it will return all the forms in the file. 4091 4092The stream will not be read beyond the Nth form, 4093where N is the index specified by path, 4094if path is either an integer or a list that starts with an integer. 4095 4096BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4097 (access-at (slurp-stream-forms input :count (access-at-count at)) at)) 4098 4099 (defun read-file-string (file &rest keys) 4100 "Open FILE with option KEYS, read its contents as a string" 4101 (apply 'call-with-input-file file 'slurp-stream-string keys)) 4102 4103 (defun read-file-lines (file &rest keys) 4104 "Open FILE with option KEYS, read its contents as a list of lines 4105BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4106 (apply 'call-with-input-file file 'slurp-stream-lines keys)) 4107 4108 (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys) 4109 "Open input FILE with option KEYS (except AT), 4110and read its contents as per SLURP-STREAM-LINE with given AT specifier. 4111BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4112 (apply 'call-with-input-file file 4113 #'(lambda (input) (slurp-stream-line input :at at)) 4114 (remove-plist-key :at keys))) 4115 4116 (defun read-file-forms (file &rest keys &key count &allow-other-keys) 4117 "Open input FILE with option KEYS (except COUNT), 4118and read its contents as per SLURP-STREAM-FORMS with given COUNT. 4119BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4120 (apply 'call-with-input-file file 4121 #'(lambda (input) (slurp-stream-forms input :count count)) 4122 (remove-plist-key :count keys))) 4123 4124 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys) 4125 "Open input FILE with option KEYS (except AT), 4126and read its contents as per SLURP-STREAM-FORM with given AT specifier. 4127BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" 4128 (apply 'call-with-input-file file 4129 #'(lambda (input) (slurp-stream-form input :at at)) 4130 (remove-plist-key :at keys))) 4131 4132 (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys) 4133 "Reads the specified line from the top of a file using a safe standardized syntax. 4134Extracts the line using READ-FILE-LINE, 4135within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." 4136 (with-safe-io-syntax (:package package) 4137 (apply 'read-file-line pathname (remove-plist-key :package keys)))) 4138 4139 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) 4140 "Reads the specified form from the top of a file using a safe standardized syntax. 4141Extracts the form using READ-FILE-FORM, 4142within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." 4143 (with-safe-io-syntax (:package package) 4144 (apply 'read-file-form pathname (remove-plist-key :package keys)))) 4145 4146 (defun eval-input (input) 4147 "Portably read and evaluate forms from INPUT, return the last values." 4148 (with-input (input) 4149 (loop :with results :with eof ='#:eof 4150 :for form = (read input nil eof) 4151 :until (eq form eof) 4152 :do (setf results (multiple-value-list (eval form))) 4153 :finally (return (values-list results))))) 4154 4155 (defun eval-thunk (thunk) 4156 "Evaluate a THUNK of code: 4157If a function, FUNCALL it without arguments. 4158If a constant literal and not a sequence, return it. 4159If a cons or a symbol, EVAL it. 4160If a string, repeatedly read and evaluate from it, returning the last values." 4161 (etypecase thunk 4162 ((or boolean keyword number character pathname) thunk) 4163 ((or cons symbol) (eval thunk)) 4164 (function (funcall thunk)) 4165 (string (eval-input thunk)))) 4166 4167 (defun standard-eval-thunk (thunk &key (package :cl)) 4168 "Like EVAL-THUNK, but in a more standardized evaluation context." 4169 ;; Note: it's "standard-" not "safe-", because evaluation is never safe. 4170 (when thunk 4171 (with-safe-io-syntax (:package package) 4172 (let ((*read-eval* t)) 4173 (eval-thunk thunk)))))) 4174 4175(with-upgradability () 4176 (defun println (x &optional (stream *standard-output*)) 4177 "Variant of PRINC that also calls TERPRI afterwards" 4178 (princ x stream) (terpri stream) (finish-output stream) (values)) 4179 4180 (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) 4181 "Variant of WRITE that also calls TERPRI afterwards" 4182 (apply 'write x keys) (terpri stream) (finish-output stream) (values))) 4183 4184 4185;;; Using temporary files 4186(with-upgradability () 4187 (defun default-temporary-directory () 4188 "Return a default directory to use for temporary files" 4189 (os-cond 4190 ((os-unix-p) 4191 (or (getenv-pathname "TMPDIR" :ensure-directory t) 4192 (parse-native-namestring "/tmp/"))) 4193 ((os-windows-p) 4194 (getenv-pathname "TEMP" :ensure-directory t)) 4195 (t (subpathname (user-homedir-pathname) "tmp/")))) 4196 4197 (defvar *temporary-directory* nil "User-configurable location for temporary files") 4198 4199 (defun temporary-directory () 4200 "Return a directory to use for temporary files" 4201 (or *temporary-directory* (default-temporary-directory))) 4202 4203 (defun setup-temporary-directory () 4204 "Configure a default temporary directory to use." 4205 (setf *temporary-directory* (default-temporary-directory)) 4206 #+gcl (setf system::*tmp-dir* *temporary-directory*)) 4207 4208 (defun call-with-temporary-file 4209 (thunk &key 4210 (want-stream-p t) (want-pathname-p t) (direction :io) keep after 4211 directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) 4212 (element-type *default-stream-element-type*) 4213 (external-format *utf-8-external-format*)) 4214 "Call a THUNK with stream and/or pathname arguments identifying a temporary file. 4215 4216The temporary file's pathname will be based on concatenating 4217PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string, 4218and optional SUFFIX (defaults to \"-tmp\" if a type was provided) 4219and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), 4220within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. 4221 4222The file will be open with specified DIRECTION (defaults to :IO), 4223ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and 4224EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). 4225If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed 4226with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), 4227and stream will be closed after the THUNK exits (either normally or abnormally). 4228If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then 4229THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. 4230Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. 4231If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. 4232Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." 4233 #+xcl (declare (ignorable typep)) 4234 (check-type direction (member :output :io)) 4235 (assert (or want-stream-p want-pathname-p)) 4236 (loop 4237 :with prefix-pn = (ensure-absolute-pathname 4238 (or prefix "tmp") 4239 (or (ensure-pathname 4240 directory 4241 :namestring :native 4242 :ensure-directory t 4243 :ensure-physical t) 4244 #'temporary-directory)) 4245 :with prefix-nns = (native-namestring prefix-pn) 4246 :with results = (progn (ensure-directories-exist prefix-pn) 4247 ()) 4248 :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) 4249 :for pathname = (parse-native-namestring 4250 (format nil "~A~36R~@[~A~]~@[.~A~]" 4251 prefix-nns counter suffix (unless (eq type :unspecific) type))) 4252 :for okp = nil :do 4253 ;; TODO: on Unix, do something about umask 4254 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL 4255 ;; TODO: on Unix, use CFFI and mkstemp -- 4256 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. 4257 ;; Can we at least design some hook? 4258 (unwind-protect 4259 (progn 4260 (ensure-directories-exist pathname) 4261 (with-open-file (stream pathname 4262 :direction direction 4263 :element-type element-type 4264 :external-format external-format 4265 :if-exists nil :if-does-not-exist :create) 4266 (when stream 4267 (setf okp pathname) 4268 (when want-stream-p 4269 ;; Note: can't return directly from within with-open-file 4270 ;; or the non-local return causes the file creation to be undone. 4271 (setf results (multiple-value-list 4272 (if want-pathname-p 4273 (funcall thunk stream pathname) 4274 (funcall thunk stream))))))) 4275 (cond 4276 ((not okp) nil) 4277 (after (return (call-function after okp))) 4278 ((and want-pathname-p (not want-stream-p)) (return (call-function thunk okp))) 4279 (t (return (values-list results))))) 4280 (when (and okp (not (call-function keep))) 4281 (ignore-errors (delete-file-if-exists okp)))))) 4282 4283 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) 4284 (pathname (gensym "PATHNAME") pathnamep) 4285 directory prefix suffix type 4286 keep direction element-type external-format) 4287 &body body) 4288 "Evaluate BODY where the symbols specified by keyword arguments 4289STREAM and PATHNAME (if respectively specified) are bound corresponding 4290to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. 4291At least one of STREAM or PATHNAME must be specified. 4292If the STREAM is not specified, it will be closed before the BODY is evaluated. 4293If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, 4294separates forms run before and after the stream is closed. 4295The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned. 4296Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." 4297 (check-type stream symbol) 4298 (check-type pathname symbol) 4299 (assert (or streamp pathnamep)) 4300 (let* ((afterp (position :close-stream body)) 4301 (before (if afterp (subseq body 0 afterp) body)) 4302 (after (when afterp (subseq body (1+ afterp)))) 4303 (beforef (gensym "BEFORE")) 4304 (afterf (gensym "AFTER"))) 4305 `(flet (,@(when before 4306 `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) 4307 ,@(when after `((declare (ignorable ,pathname)))) 4308 ,@before))) 4309 ,@(when after 4310 (assert pathnamep) 4311 `((,afterf (,pathname) ,@after)))) 4312 #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) 4313 (call-with-temporary-file 4314 ,(when before `#',beforef) 4315 :want-stream-p ,streamp 4316 :want-pathname-p ,pathnamep 4317 ,@(when direction `(:direction ,direction)) 4318 ,@(when directory `(:directory ,directory)) 4319 ,@(when prefix `(:prefix ,prefix)) 4320 ,@(when suffix `(:suffix ,suffix)) 4321 ,@(when type `(:type ,type)) 4322 ,@(when keep `(:keep ,keep)) 4323 ,@(when after `(:after #',afterf)) 4324 ,@(when element-type `(:element-type ,element-type)) 4325 ,@(when external-format `(:external-format ,external-format)))))) 4326 4327 (defun get-temporary-file (&key directory prefix suffix type) 4328 (with-temporary-file (:pathname pn :keep t 4329 :directory directory :prefix prefix :suffix suffix :type type) 4330 pn)) 4331 4332 ;; Temporary pathnames in simple cases where no contention is assumed 4333 (defun add-pathname-suffix (pathname suffix &rest keys) 4334 "Add a SUFFIX to the name of a PATHNAME, return a new pathname. 4335Further KEYS can be passed to MAKE-PATHNAME." 4336 (apply 'make-pathname :name (strcat (pathname-name pathname) suffix) 4337 :defaults pathname keys)) 4338 4339 (defun tmpize-pathname (x) 4340 "Return a new pathname modified from X by adding a trivial random suffix. 4341A new empty file with said temporary pathname is created, to ensure there is no 4342clash with any concurrent process attempting the same thing." 4343 (let* ((px (ensure-pathname x :ensure-physical t)) 4344 (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) 4345 (directory (pathname-directory-pathname px))) 4346 (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)))) 4347 4348 (defun call-with-staging-pathname (pathname fun) 4349 "Calls FUN with a staging pathname, and atomically 4350renames the staging pathname to the PATHNAME in the end. 4351NB: this protects only against failure of the program, not against concurrent attempts. 4352For the latter case, we ought pick a random suffix and atomically open it." 4353 (let* ((pathname (pathname pathname)) 4354 (staging (tmpize-pathname pathname))) 4355 (unwind-protect 4356 (multiple-value-prog1 4357 (funcall fun staging) 4358 (rename-file-overwriting-target staging pathname)) 4359 (delete-file-if-exists staging)))) 4360 4361 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) 4362 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" 4363 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) 4364 4365(with-upgradability () 4366 (defun file-stream-p (stream) 4367 (typep stream 'file-stream)) 4368 (defun file-or-synonym-stream-p (stream) 4369 (or (file-stream-p stream) 4370 (and (typep stream 'synonym-stream) 4371 (file-or-synonym-stream-p 4372 (symbol-value (synonym-stream-symbol stream))))))) 4373;;;; ------------------------------------------------------------------------- 4374;;;; Starting, Stopping, Dumping a Lisp image 4375 4376(uiop/package:define-package :uiop/image 4377 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) 4378 (:export 4379 #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* 4380 #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 4381 #:*lisp-interaction* 4382 #:fatal-condition #:fatal-condition-p 4383 #:handle-fatal-condition 4384 #:call-with-fatal-condition-handler #:with-fatal-condition-handler 4385 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* 4386 #:*image-postlude* #:*image-dump-hook* 4387 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace 4388 #:shell-boolean-exit 4389 #:register-image-restore-hook #:register-image-dump-hook 4390 #:call-image-restore-hook #:call-image-dump-hook 4391 #:restore-image #:dump-image #:create-image 4392)) 4393(in-package :uiop/image) 4394 4395(with-upgradability () 4396 (defvar *lisp-interaction* t 4397 "Is this an interactive Lisp environment, or is it batch processing?") 4398 4399 (defvar *command-line-arguments* nil 4400 "Command-line arguments") 4401 4402 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments 4403 "Is this a dumped image? As a standalone executable?") 4404 4405 (defvar *image-restore-hook* nil 4406 "Functions to call (in reverse order) when the image is restored") 4407 4408 (defvar *image-restored-p* nil 4409 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") 4410 4411 (defvar *image-prelude* nil 4412 "a form to evaluate, or string containing forms to read and evaluate 4413when the image is restarted, but before the entry point is called.") 4414 4415 (defvar *image-entry-point* nil 4416 "a function with which to restart the dumped image when execution is restored from it.") 4417 4418 (defvar *image-postlude* nil 4419 "a form to evaluate, or string containing forms to read and evaluate 4420before the image dump hooks are called and before the image is dumped.") 4421 4422 (defvar *image-dump-hook* nil 4423 "Functions to call (in order) when before an image is dumped") 4424 4425 (deftype fatal-condition () 4426 `(and serious-condition #+clozure (not ccl:process-reset)))) 4427 4428;;; Exiting properly or im- 4429(with-upgradability () 4430 (defun quit (&optional (code 0) (finish-output t)) 4431 "Quits from the Lisp world, with the given exit status if provided. 4432This is designed to abstract away the implementation specific quit forms." 4433 (when finish-output ;; essential, for ClozureCL, and for standard compliance. 4434 (finish-outputs)) 4435 #+(or abcl xcl) (ext:quit :status code) 4436 #+allegro (excl:exit code :quiet t) 4437 #+(or clasp ecl) (si:quit code) 4438 #+clisp (ext:quit code) 4439 #+clozure (ccl:quit code) 4440 #+cormanlisp (win32:exitprocess code) 4441 #+(or cmucl scl) (unix:unix-exit code) 4442 #+gcl (system:quit code) 4443 #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) 4444 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) 4445 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? 4446 #+mkcl (mk-ext:quit :exit-code code) 4447 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) 4448 (quit (find-symbol* :quit :sb-ext nil))) 4449 (cond 4450 (exit `(,exit :code code :abort (not finish-output))) 4451 (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) 4452 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 4453 (not-implemented-error 'quit "(called with exit code ~S)" code)) 4454 4455 (defun die (code format &rest arguments) 4456 "Die in error with some error message" 4457 (with-safe-io-syntax () 4458 (ignore-errors 4459 (format! *stderr* "~&~?~&" format arguments))) 4460 (quit code)) 4461 4462 (defun raw-print-backtrace (&key (stream *debug-io*) count condition) 4463 "Print a backtrace, directly accessing the implementation" 4464 (declare (ignorable stream count condition)) 4465 #+abcl 4466 (loop :for i :from 0 4467 :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do 4468 (safe-format! stream "~&~D: ~A~%" i frame)) 4469 #+allegro 4470 (let ((*terminal-io* stream) 4471 (*standard-output* stream) 4472 (tpl:*zoom-print-circle* *print-circle*) 4473 (tpl:*zoom-print-level* *print-level*) 4474 (tpl:*zoom-print-length* *print-length*)) 4475 (tpl:do-command "zoom" 4476 :from-read-eval-print-loop nil 4477 :count (or count t) 4478 :all t)) 4479 #+(or clasp ecl mkcl) 4480 (let* ((top (si:ihs-top)) 4481 (repeats (if count (min top count) top)) 4482 (backtrace (loop :for ihs :from 0 :below top 4483 :collect (list (si::ihs-fun ihs) 4484 (si::ihs-env ihs))))) 4485 (loop :for i :from 0 :below repeats 4486 :for frame :in (nreverse backtrace) :do 4487 (safe-format! stream "~&~D: ~S~%" i frame))) 4488 #+clisp 4489 (system::print-backtrace :out stream :limit count) 4490 #+(or clozure mcl) 4491 (let ((*debug-io* stream)) 4492 #+clozure (ccl:print-call-history :count count :start-frame-number 1) 4493 #+mcl (ccl:print-call-history :detailed-p nil) 4494 (finish-output stream)) 4495 #+(or cmucl scl) 4496 (let ((debug:*debug-print-level* *print-level*) 4497 (debug:*debug-print-length* *print-length*)) 4498 (debug:backtrace (or count most-positive-fixnum) stream)) 4499 #+gcl 4500 (let ((*debug-io* stream)) 4501 (ignore-errors 4502 (with-safe-io-syntax () 4503 (if condition 4504 (conditions::condition-backtrace condition) 4505 (system::simple-backtrace))))) 4506 #+lispworks 4507 (let ((dbg::*debugger-stack* 4508 (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) 4509 (*debug-io* stream) 4510 (dbg:*debug-print-level* *print-level*) 4511 (dbg:*debug-print-length* *print-length*)) 4512 (dbg:bug-backtrace nil)) 4513 #+sbcl 4514 (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) 4515 #+xcl 4516 (loop :for i :from 0 :below (or count most-positive-fixnum) 4517 :for frame :in (extensions:backtrace-as-list) :do 4518 (safe-format! stream "~&~D: ~S~%" i frame))) 4519 4520 (defun print-backtrace (&rest keys &key stream count condition) 4521 "Print a backtrace" 4522 (declare (ignore stream count condition)) 4523 (with-safe-io-syntax (:package :cl) 4524 (let ((*print-readably* nil) 4525 (*print-circle* t) 4526 (*print-miser-width* 75) 4527 (*print-length* nil) 4528 (*print-level* nil) 4529 (*print-pretty* t)) 4530 (ignore-errors (apply 'raw-print-backtrace keys))))) 4531 4532 (defun print-condition-backtrace (condition &key (stream *stderr*) count) 4533 "Print a condition after a backtrace triggered by that condition" 4534 ;; We print the condition *after* the backtrace, 4535 ;; for the sake of who sees the backtrace at a terminal. 4536 ;; It is up to the caller to print the condition *before*, with some context. 4537 (print-backtrace :stream stream :count count :condition condition) 4538 (when condition 4539 (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" 4540 condition))) 4541 4542 (defun fatal-condition-p (condition) 4543 "Is the CONDITION fatal?" 4544 (typep condition 'fatal-condition)) 4545 4546 (defun handle-fatal-condition (condition) 4547 "Handle a fatal CONDITION: 4548depending on whether *LISP-INTERACTION* is set, enter debugger or die" 4549 (cond 4550 (*lisp-interaction* 4551 (invoke-debugger condition)) 4552 (t 4553 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) 4554 (print-condition-backtrace condition :stream *stderr*) 4555 (die 99 "~A" condition)))) 4556 4557 (defun call-with-fatal-condition-handler (thunk) 4558 "Call THUNK in a context where fatal conditions are appropriately handled" 4559 (handler-bind ((fatal-condition #'handle-fatal-condition)) 4560 (funcall thunk))) 4561 4562 (defmacro with-fatal-condition-handler ((&optional) &body body) 4563 "Execute BODY in a context where fatal conditions are appropriately handled" 4564 `(call-with-fatal-condition-handler #'(lambda () ,@body))) 4565 4566 (defun shell-boolean-exit (x) 4567 "Quit with a return code that is 0 iff argument X is true" 4568 (quit (if x 0 1)))) 4569 4570 4571;;; Using image hooks 4572(with-upgradability () 4573 (defun register-image-restore-hook (hook &optional (call-now-p t)) 4574 "Regiter a hook function to be run when restoring a dumped image" 4575 (register-hook-function '*image-restore-hook* hook call-now-p)) 4576 4577 (defun register-image-dump-hook (hook &optional (call-now-p nil)) 4578 "Register a the hook function to be run before to dump an image" 4579 (register-hook-function '*image-dump-hook* hook call-now-p)) 4580 4581 (defun call-image-restore-hook () 4582 "Call the hook functions registered to be run when restoring a dumped image" 4583 (call-functions (reverse *image-restore-hook*))) 4584 4585 (defun call-image-dump-hook () 4586 "Call the hook functions registered to be run before to dump an image" 4587 (call-functions *image-dump-hook*))) 4588 4589 4590;;; Proper command-line arguments 4591(with-upgradability () 4592 (defun raw-command-line-arguments () 4593 "Find what the actual command line for this process was." 4594 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! 4595 #+allegro (sys:command-line-arguments) ; default: :application t 4596 #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) 4597 #+clisp (coerce (ext:argv) 'list) 4598 #+clozure ccl:*command-line-argument-list* 4599 #+(or cmucl scl) extensions:*command-line-strings* 4600 #+gcl si:*command-args* 4601 #+(or genera mcl) nil 4602 #+lispworks sys:*line-arguments-list* 4603 #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) 4604 #+sbcl sb-ext:*posix-argv* 4605 #+xcl system:*argv* 4606 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 4607 (not-implemented-error 'raw-command-line-arguments)) 4608 4609 (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) 4610 "Extract user arguments from command-line invocation of current process. 4611Assume the calling conventions of a generated script that uses -- 4612if we are not called from a directly executable image." 4613 (block nil 4614 #+abcl (return arguments) 4615 ;; SBCL and Allegro already separate user arguments from implementation arguments. 4616 #-(or sbcl allegro) 4617 (unless (eq *image-dumped-p* :executable) 4618 ;; LispWorks command-line processing isn't transparent to the user 4619 ;; unless you create a standalone executable; in that case, 4620 ;; we rely on cl-launch or some other script to set the arguments for us. 4621 #+lispworks (return *command-line-arguments*) 4622 ;; On other implementations, on non-standalone executables, 4623 ;; we trust cl-launch or whichever script starts the program 4624 ;; to use -- as a delimiter between implementation arguments and user arguments. 4625 #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) 4626 (rest arguments))) 4627 4628 (defun argv0 () 4629 "On supported implementations (most that matter), or when invoked by a proper wrapper script, 4630return a string that for the name with which the program was invoked, i.e. argv[0] in C. 4631Otherwise, return NIL." 4632 (cond 4633 ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! 4634 ;; NB: not currently available on ABCL, Corman, Genera, MCL 4635 (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) 4636 (first (raw-command-line-arguments)) 4637 #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) 4638 (t ;; argv[0] is the name of the interpreter. 4639 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. 4640 (getenvp "__CL_ARGV0")))) 4641 4642 (defun setup-command-line-arguments () 4643 (setf *command-line-arguments* (command-line-arguments))) 4644 4645 (defun restore-image (&key 4646 (lisp-interaction *lisp-interaction*) 4647 (restore-hook *image-restore-hook*) 4648 (prelude *image-prelude*) 4649 (entry-point *image-entry-point*) 4650 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) 4651 "From a freshly restarted Lisp image, restore the saved Lisp environment 4652by setting appropriate variables, running various hooks, and calling any specified entry point. 4653 4654If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*, 4655call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return 4656immediately to the surrounding restore process if allowed to continue. 4657 4658Then, comes the restore process itself: 4659First, call each function in the RESTORE-HOOK, 4660in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. 4661Second, evaluate the prelude, which is often Lisp text that is read, 4662as per EVAL-INPUT. 4663Third, call the ENTRY-POINT function, if any is specified, with no argument. 4664 4665The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL, 4666any unhandled error leads to a backtrace and an exit with an error status. 4667If LISP-INTERACTION is NIL, the process also exits when no error occurs: 4668if neither restart nor entry function is provided, the program will exit with status 0 (success); 4669if a function was provided, the program will exit after the function returns (if it returns), 4670with status 0 if and only if the primary return value of result is generalized boolean true, 4671and with status 1 if this value is NIL. 4672 4673If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result 4674of the function will be returned rather than interpreted as a boolean designating an exit code." 4675 (when *image-restored-p* 4676 (if if-already-restored 4677 (call-function if-already-restored "Image already ~:[being ~;~]restored" 4678 (eq *image-restored-p* t)) 4679 (return-from restore-image))) 4680 (with-fatal-condition-handler () 4681 (setf *lisp-interaction* lisp-interaction) 4682 (setf *image-restore-hook* restore-hook) 4683 (setf *image-prelude* prelude) 4684 (setf *image-restored-p* :in-progress) 4685 (call-image-restore-hook) 4686 (standard-eval-thunk prelude) 4687 (setf *image-restored-p* t) 4688 (let ((results (multiple-value-list 4689 (if entry-point 4690 (call-function entry-point) 4691 t)))) 4692 (if lisp-interaction 4693 (values-list results) 4694 (shell-boolean-exit (first results))))))) 4695 4696 4697;;; Dumping an image 4698 4699(with-upgradability () 4700 (defun dump-image (filename &key output-name executable 4701 (postlude *image-postlude*) 4702 (dump-hook *image-dump-hook*) 4703 #+clozure prepend-symbols #+clozure (purify t) 4704 #+sbcl compression 4705 #+(and sbcl os-windows) application-type) 4706 "Dump an image of the current Lisp environment at pathname FILENAME, with various options. 4707 4708First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of 4709 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK. 4710 4711If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup. 4712 4713Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL, 4714or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." 4715 ;; Note: at least SBCL saves only global values of variables in the heap image, 4716 ;; so make sure things you want to dump are NOT just local bindings shadowing the global values. 4717 (declare (ignorable filename output-name executable)) 4718 (setf *image-dumped-p* (if executable :executable t)) 4719 (setf *image-restored-p* :in-regress) 4720 (setf *image-postlude* postlude) 4721 (standard-eval-thunk *image-postlude*) 4722 (setf *image-dump-hook* dump-hook) 4723 (call-image-dump-hook) 4724 (setf *image-restored-p* nil) 4725 #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) 4726 (when executable 4727 (not-implemented-error 'dump-image "dumping an executable")) 4728 #+allegro 4729 (progn 4730 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 4731 (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) 4732 #+clisp 4733 (apply #'ext:saveinitmem filename 4734 :quiet t 4735 :start-package *package* 4736 :keep-global-handlers nil 4737 :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x 4738 (when executable 4739 (list 4740 ;; :parse-options nil ;--- requires a non-standard patch to clisp. 4741 :norc t :script nil :init-function #'restore-image))) 4742 #+clozure 4743 (flet ((dump (prepend-kernel) 4744 (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify 4745 :toplevel-function (when executable #'restore-image)))) 4746 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) 4747 (if prepend-symbols 4748 (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) 4749 (require 'elf) 4750 (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) 4751 (dump path)) 4752 (dump t))) 4753 #+(or cmucl scl) 4754 (progn 4755 (ext:gc :full t) 4756 (setf ext:*batch-mode* nil) 4757 (setf ext::*gc-run-time* 0) 4758 (apply 'ext:save-lisp filename 4759 :allow-other-keys t ;; hush SCL and old versions of CMUCL 4760 #+(and cmucl executable) :executable #+(and cmucl executable) t 4761 (when executable '(:init-function restore-image :process-command-line nil 4762 :quiet t :load-init-file nil :site-init nil)))) 4763 #+gcl 4764 (progn 4765 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) 4766 (si::save-system filename)) 4767 #+lispworks 4768 (if executable 4769 (lispworks:deliver 'restore-image filename 0 :interface nil) 4770 (hcl:save-image filename :environment nil)) 4771 #+sbcl 4772 (progn 4773 ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself 4774 (setf sb-ext::*gc-run-time* 0) 4775 (apply 'sb-ext:save-lisp-and-die filename 4776 :executable t ;--- always include the runtime that goes with the core 4777 (append 4778 (when compression (list :compression compression)) 4779 ;;--- only save runtime-options for standalone executables 4780 (when executable (list :toplevel #'restore-image :save-runtime-options t)) 4781 #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. 4782 ;; the default is :console - only works with SBCL 1.1.15 or later. 4783 (when application-type (list :application-type application-type))))) 4784 #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) 4785 (not-implemented-error 'dump-image)) 4786 4787 (defun create-image (destination lisp-object-files 4788 &key kind output-name prologue-code epilogue-code extra-object-files 4789 (prelude () preludep) (postlude () postludep) 4790 (entry-point () entry-point-p) build-args no-uiop) 4791 (declare (ignorable destination lisp-object-files extra-object-files kind output-name 4792 prologue-code epilogue-code prelude preludep postlude postludep 4793 entry-point entry-point-p build-args no-uiop)) 4794 "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" 4795 ;; Is it meaningful to run these in the current environment? 4796 ;; only if we also track the object files that constitute the "current" image, 4797 ;; and otherwise simulate dump-image, including quitting at the end. 4798 #-(or clasp ecl mkcl) (not-implemented-error 'create-image) 4799 #+(or clasp ecl mkcl) 4800 (let ((epilogue-code 4801 (if no-uiop 4802 epilogue-code 4803 (let ((forms 4804 (append 4805 (when epilogue-code `(,epilogue-code)) 4806 (when postludep `((setf *image-postlude* ',postlude))) 4807 (when preludep `((setf *image-prelude* ',prelude))) 4808 (when entry-point-p `((setf *image-entry-point* ',entry-point))) 4809 (case kind 4810 ((:image) 4811 (setf kind :program) ;; to ECL, it's just another program. 4812 `((setf *image-dumped-p* t) 4813 (si::top-level #+(or clasp ecl) t) (quit))) 4814 ((:program) 4815 `((setf *image-dumped-p* :executable) 4816 (shell-boolean-exit 4817 (restore-image)))))))) 4818 (when forms `(progn ,@forms)))))) 4819 #+(or clasp ecl mkcl) 4820 (check-type kind (member :dll :shared-library :lib :static-library 4821 :fasl :fasb :program)) 4822 (apply #+clasp 'cmp:builder #+clasp kind 4823 #+(or ecl mkcl) 4824 (ecase kind 4825 ((:dll :shared-library) 4826 #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library) 4827 ((:lib :static-library) 4828 #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library) 4829 ((:fasl #+ecl :fasb) 4830 #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl) 4831 #+mkcl ((:fasb) 'compiler:build-bundle) 4832 ((:program) 4833 #+ecl 'c::build-program #+mkcl 'compiler:build-program)) 4834 (pathname destination) 4835 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files 4836 (append lisp-object-files #+(or clasp ecl) extra-object-files) 4837 #+ecl :init-name 4838 #+ecl (c::compute-init-name (or output-name destination) 4839 :kind (if (eq kind :fasb) :fasl kind)) 4840 (append 4841 (when prologue-code `(:prologue-code ,prologue-code)) 4842 (when epilogue-code `(:epilogue-code ,epilogue-code)) 4843 #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) 4844 build-args))))) 4845 4846 4847;;; Some universal image restore hooks 4848(with-upgradability () 4849 (map () 'register-image-restore-hook 4850 '(setup-stdin setup-stdout setup-stderr 4851 setup-command-line-arguments setup-temporary-directory 4852 #+abcl detect-os))) 4853;;;; ------------------------------------------------------------------------- 4854;;;; Support to build (compile and load) Lisp files 4855 4856(uiop/package:define-package :uiop/lisp-build 4857 (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp 4858 (:use :uiop/common-lisp :uiop/package :uiop/utility 4859 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) 4860 (:export 4861 ;; Variables 4862 #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* 4863 #:*output-translation-function* 4864 #:*optimization-settings* #:*previous-optimization-settings* 4865 #:*base-build-directory* 4866 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error 4867 #:compile-warned-warning #:compile-failed-warning 4868 #:check-lisp-compile-results #:check-lisp-compile-warnings 4869 #:*uninteresting-conditions* #:*usual-uninteresting-conditions* 4870 #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* 4871 ;; Types 4872 #+sbcl #:sb-grovel-unknown-constant-condition 4873 ;; Functions & Macros 4874 #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings 4875 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions 4876 #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions 4877 #:reify-simple-sexp #:unreify-simple-sexp 4878 #:reify-deferred-warnings #:unreify-deferred-warnings 4879 #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings 4880 #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* 4881 #:enable-deferred-warnings-check #:disable-deferred-warnings-check 4882 #:current-lisp-file-pathname #:load-pathname 4883 #:lispize-pathname #:compile-file-type #:call-around-hook 4884 #:compile-file* #:compile-file-pathname* #:*compile-check* 4885 #:load* #:load-from-string #:combine-fasls) 4886 (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) 4887(in-package :uiop/lisp-build) 4888 4889(with-upgradability () 4890 (defvar *compile-file-warnings-behaviour* 4891 (or #+clisp :ignore :warn) 4892 "How should ASDF react if it encounters a warning when compiling a file? 4893Valid values are :error, :warn, and :ignore.") 4894 4895 (defvar *compile-file-failure-behaviour* 4896 (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) 4897 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) 4898when compiling a file, which includes any non-style-warning warning. 4899Valid values are :error, :warn, and :ignore. 4900Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") 4901 4902 (defvar *base-build-directory* nil 4903 "When set to a non-null value, it should be an absolute directory pathname, 4904which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, 4905what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. 4906This can help you produce more deterministic output for FASLs.")) 4907 4908;;; Optimization settings 4909(with-upgradability () 4910 (defvar *optimization-settings* nil 4911 "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") 4912 (defvar *previous-optimization-settings* nil 4913 "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") 4914 (defparameter +optimization-variables+ 4915 ;; TODO: allegro genera corman mcl 4916 (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*) 4917 #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) 4918 #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* 4919 ccl::*nx-debug* ccl::*nx-cspeed*) 4920 #+(or cmucl scl) '(c::*default-cookie*) 4921 #+clasp '() 4922 #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) 4923 #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) 4924 #+lispworks '(compiler::*optimization-level*) 4925 #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) 4926 #+sbcl '(sb-c::*policy*))) 4927 (defun get-optimization-settings () 4928 "Get current compiler optimization settings, ready to PROCLAIM again" 4929 #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) 4930 (warn "~S does not support ~S. Please help me fix that." 4931 'get-optimization-settings (implementation-type)) 4932 #+(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) 4933 (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) 4934 #.`(loop #+(or allegro clozure) 4935 ,@'(:with info = #+allegro (sys:declaration-information 'optimize) 4936 #+clozure (ccl:declaration-information 'optimize nil)) 4937 :for x :in settings 4938 ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) 4939 :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order 4940 #+clisp (gethash x system::*optimize* 1) 4941 #+(or abcl clasp ecl mkcl xcl) (symbol-value v) 4942 #+(or cmucl scl) (slot-value c::*default-cookie* 4943 (case x (compilation-speed 'c::cspeed) 4944 (otherwise x))) 4945 #+lispworks (slot-value compiler::*optimization-level* x) 4946 #+sbcl (sb-c::policy-quality sb-c::*policy* x)) 4947 :when y :collect (list x y)))) 4948 (defun proclaim-optimization-settings () 4949 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" 4950 (proclaim `(optimize ,@*optimization-settings*)) 4951 (let ((settings (get-optimization-settings))) 4952 (unless (equal *previous-optimization-settings* settings) 4953 (setf *previous-optimization-settings* settings)))) 4954 (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body) 4955 #+(or allegro clisp) 4956 (let ((previous-settings (gensym "PREVIOUS-SETTINGS"))) 4957 `(let ((,previous-settings (get-optimization-settings))) 4958 ,@(when settings `((proclaim `(optimize ,@,settings)))) 4959 (unwind-protect (progn ,@body) 4960 (proclaim `(optimize ,@,previous-settings))))) 4961 #-(or allegro clisp) 4962 `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) 4963 ,@(when settings `((proclaim `(optimize ,@,settings)))) 4964 ,@body))) 4965 4966 4967;;; Condition control 4968(with-upgradability () 4969 #+sbcl 4970 (progn 4971 (defun sb-grovel-unknown-constant-condition-p (c) 4972 "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL" 4973 (and (typep c 'sb-int:simple-style-warning) 4974 (string-enclosed-p 4975 "Couldn't grovel for " 4976 (simple-condition-format-control c) 4977 " (unknown to the C compiler)."))) 4978 (deftype sb-grovel-unknown-constant-condition () 4979 '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) 4980 4981 (defvar *usual-uninteresting-conditions* 4982 (append 4983 ;;#+clozure '(ccl:compiler-warning) 4984 #+cmucl '("Deleting unreachable code.") 4985 #+lispworks '("~S being redefined in ~A (previously in ~A)." 4986 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. 4987 #+sbcl 4988 '(sb-c::simple-compiler-note 4989 "&OPTIONAL and &KEY found in the same lambda list: ~S" 4990 #+sb-eval sb-kernel:lexical-environment-too-complex 4991 sb-kernel:undefined-alien-style-warning 4992 sb-grovel-unknown-constant-condition ; defined above. 4993 sb-ext:implicit-generic-function-warning ;; Controversial. 4994 sb-int:package-at-variance 4995 sb-kernel:uninteresting-redefinition 4996 ;; BEWARE: the below four are controversial to include here. 4997 sb-kernel:redefinition-with-defun 4998 sb-kernel:redefinition-with-defgeneric 4999 sb-kernel:redefinition-with-defmethod 5000 sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs 5001 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop 5002 "A suggested value to which to set or bind *uninteresting-conditions*.") 5003 5004 (defvar *uninteresting-conditions* '() 5005 "Conditions that may be skipped while compiling or loading Lisp code.") 5006 (defvar *uninteresting-compiler-conditions* '() 5007 "Additional conditions that may be skipped while compiling Lisp code.") 5008 (defvar *uninteresting-loader-conditions* 5009 (append 5010 '("Overwriting already existing readtable ~S." ;; from named-readtables 5011 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers 5012 #+clisp '(clos::simple-gf-replacing-method-warning)) 5013 "Additional conditions that may be skipped while loading Lisp code.")) 5014 5015;;;; ----- Filtering conditions while building ----- 5016(with-upgradability () 5017 (defun call-with-muffled-compiler-conditions (thunk) 5018 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled" 5019 (call-with-muffled-conditions 5020 thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) 5021 (defmacro with-muffled-compiler-conditions ((&optional) &body body) 5022 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS" 5023 `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) 5024 (defun call-with-muffled-loader-conditions (thunk) 5025 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled" 5026 (call-with-muffled-conditions 5027 thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) 5028 (defmacro with-muffled-loader-conditions ((&optional) &body body) 5029 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS" 5030 `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) 5031 5032 5033;;;; Handle warnings and failures 5034(with-upgradability () 5035 (define-condition compile-condition (condition) 5036 ((context-format 5037 :initform nil :reader compile-condition-context-format :initarg :context-format) 5038 (context-arguments 5039 :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) 5040 (description 5041 :initform nil :reader compile-condition-description :initarg :description)) 5042 (:report (lambda (c s) 5043 (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") 5044 (or (compile-condition-description c) (type-of c)) 5045 (compile-condition-context-format c) 5046 (compile-condition-context-arguments c))))) 5047 (define-condition compile-file-error (compile-condition error) ()) 5048 (define-condition compile-warned-warning (compile-condition warning) ()) 5049 (define-condition compile-warned-error (compile-condition error) ()) 5050 (define-condition compile-failed-warning (compile-condition warning) ()) 5051 (define-condition compile-failed-error (compile-condition error) ()) 5052 5053 (defun check-lisp-compile-warnings (warnings-p failure-p 5054 &optional context-format context-arguments) 5055 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings, 5056raise an error or warning as appropriate" 5057 (when failure-p 5058 (case *compile-file-failure-behaviour* 5059 (:warn (warn 'compile-failed-warning 5060 :description "Lisp compilation failed" 5061 :context-format context-format 5062 :context-arguments context-arguments)) 5063 (:error (error 'compile-failed-error 5064 :description "Lisp compilation failed" 5065 :context-format context-format 5066 :context-arguments context-arguments)) 5067 (:ignore nil))) 5068 (when warnings-p 5069 (case *compile-file-warnings-behaviour* 5070 (:warn (warn 'compile-warned-warning 5071 :description "Lisp compilation had style-warnings" 5072 :context-format context-format 5073 :context-arguments context-arguments)) 5074 (:error (error 'compile-warned-error 5075 :description "Lisp compilation had style-warnings" 5076 :context-format context-format 5077 :context-arguments context-arguments)) 5078 (:ignore nil)))) 5079 5080 (defun check-lisp-compile-results (output warnings-p failure-p 5081 &optional context-format context-arguments) 5082 "Given the results of COMPILE-FILE, raise an error or warning as appropriate" 5083 (unless output 5084 (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) 5085 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))) 5086 5087 5088;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. 5089;;; 5090;;; To support an implementation, three functions must be implemented: 5091;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings 5092;;; See their respective docstrings. 5093(with-upgradability () 5094 (defun reify-simple-sexp (sexp) 5095 "Given a simple SEXP, return a representation of it as a portable SEXP. 5096Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells." 5097 (etypecase sexp 5098 (symbol (reify-symbol sexp)) 5099 ((or number character simple-string pathname) sexp) 5100 (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) 5101 (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) 5102 5103 (defun unreify-simple-sexp (sexp) 5104 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents" 5105 (etypecase sexp 5106 ((or symbol number character simple-string pathname) sexp) 5107 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) 5108 ((simple-vector 2) (unreify-symbol sexp)) 5109 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) 5110 5111 #+clozure 5112 (progn 5113 (defun reify-source-note (source-note) 5114 (when source-note 5115 (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) 5116 (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note 5117 (declare (ignorable source)) 5118 (list :filename filename :start-pos start-pos :end-pos end-pos 5119 #|:source (reify-source-note source)|#)))) 5120 (defun unreify-source-note (source-note) 5121 (when source-note 5122 (destructuring-bind (&key filename start-pos end-pos source) source-note 5123 (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos 5124 :source (unreify-source-note source))))) 5125 (defun unsymbolify-function-name (name) 5126 (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) 5127 `(setf ,setfed) 5128 name)) 5129 (defun symbolify-function-name (name) 5130 (if (and (consp name) (eq (first name) 'setf)) 5131 (let ((setfed (second name))) 5132 (gethash setfed ccl::%setf-function-names%)) 5133 name)) 5134 (defun reify-function-name (function-name) 5135 (let ((name (or (first function-name) ;; defun: extract the name 5136 (let ((sec (second function-name))) 5137 (or (and (atom sec) sec) ; scoped method: drop scope 5138 (first sec)))))) ; method: keep gf name, drop method specializers 5139 (list name))) 5140 (defun unreify-function-name (function-name) 5141 function-name) 5142 (defun nullify-non-literals (sexp) 5143 (typecase sexp 5144 ((or number character simple-string symbol pathname) sexp) 5145 (cons (cons (nullify-non-literals (car sexp)) 5146 (nullify-non-literals (cdr sexp)))) 5147 (t nil))) 5148 (defun reify-deferred-warning (deferred-warning) 5149 (with-accessors ((warning-type ccl::compiler-warning-warning-type) 5150 (args ccl::compiler-warning-args) 5151 (source-note ccl:compiler-warning-source-note) 5152 (function-name ccl:compiler-warning-function-name)) deferred-warning 5153 (list :warning-type warning-type :function-name (reify-function-name function-name) 5154 :source-note (reify-source-note source-note) 5155 :args (destructuring-bind (fun &rest more) 5156 args 5157 (cons (unsymbolify-function-name fun) 5158 (nullify-non-literals more)))))) 5159 (defun unreify-deferred-warning (reified-deferred-warning) 5160 (destructuring-bind (&key warning-type function-name source-note args) 5161 reified-deferred-warning 5162 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) 5163 'ccl::compiler-warning) 5164 :function-name (unreify-function-name function-name) 5165 :source-note (unreify-source-note source-note) 5166 :warning-type warning-type 5167 :args (destructuring-bind (fun . more) args 5168 (cons (symbolify-function-name fun) more)))))) 5169 #+(or cmucl scl) 5170 (defun reify-undefined-warning (warning) 5171 ;; Extracting undefined-warnings from the compilation-unit 5172 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" 5173 (list* 5174 (c::undefined-warning-kind warning) 5175 (c::undefined-warning-name warning) 5176 (c::undefined-warning-count warning) 5177 (mapcar 5178 #'(lambda (frob) 5179 ;; the lexenv slot can be ignored for reporting purposes 5180 `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob) 5181 :source ,(c::compiler-error-context-source frob) 5182 :original-source ,(c::compiler-error-context-original-source frob) 5183 :context ,(c::compiler-error-context-context frob) 5184 :file-name ,(c::compiler-error-context-file-name frob) ; a pathname 5185 :file-position ,(c::compiler-error-context-file-position frob) ; an integer 5186 :original-source-path ,(c::compiler-error-context-original-source-path frob))) 5187 (c::undefined-warning-warnings warning)))) 5188 5189 #+sbcl 5190 (defun reify-undefined-warning (warning) 5191 ;; Extracting undefined-warnings from the compilation-unit 5192 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" 5193 (list* 5194 (sb-c::undefined-warning-kind warning) 5195 (sb-c::undefined-warning-name warning) 5196 (sb-c::undefined-warning-count warning) 5197 (mapcar 5198 #'(lambda (frob) 5199 ;; the lexenv slot can be ignored for reporting purposes 5200 `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob) 5201 :source ,(sb-c::compiler-error-context-source frob) 5202 :original-source ,(sb-c::compiler-error-context-original-source frob) 5203 :context ,(sb-c::compiler-error-context-context frob) 5204 :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname 5205 :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer 5206 :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) 5207 (sb-c::undefined-warning-warnings warning)))) 5208 5209 (defun reify-deferred-warnings () 5210 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation 5211using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by 5212WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." 5213 #+allegro 5214 (list :functions-defined excl::.functions-defined. 5215 :functions-called excl::.functions-called.) 5216 #+clozure 5217 (mapcar 'reify-deferred-warning 5218 (if-let (dw ccl::*outstanding-deferred-warnings*) 5219 (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) 5220 (ccl::deferred-warnings.warnings mdw)))) 5221 #+(or cmucl scl) 5222 (when lisp::*in-compilation-unit* 5223 ;; Try to send nothing through the pipe if nothing needs to be accumulated 5224 `(,@(when c::*undefined-warnings* 5225 `((c::*undefined-warnings* 5226 ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*)))) 5227 ,@(loop :for what :in '(c::*compiler-error-count* 5228 c::*compiler-warning-count* 5229 c::*compiler-note-count*) 5230 :for value = (symbol-value what) 5231 :when (plusp value) 5232 :collect `(,what . ,value)))) 5233 #+sbcl 5234 (when sb-c::*in-compilation-unit* 5235 ;; Try to send nothing through the pipe if nothing needs to be accumulated 5236 `(,@(when sb-c::*undefined-warnings* 5237 `((sb-c::*undefined-warnings* 5238 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) 5239 ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* 5240 sb-c::*compiler-error-count* 5241 sb-c::*compiler-warning-count* 5242 sb-c::*compiler-style-warning-count* 5243 sb-c::*compiler-note-count*) 5244 :for value = (symbol-value what) 5245 :when (plusp value) 5246 :collect `(,what . ,value))))) 5247 5248 (defun unreify-deferred-warnings (reified-deferred-warnings) 5249 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding 5250deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. 5251Handle any warning that has been resolved already, 5252such as an undefined function that has been defined since. 5253One of three functions required for deferred-warnings support in ASDF." 5254 (declare (ignorable reified-deferred-warnings)) 5255 #+allegro 5256 (destructuring-bind (&key functions-defined functions-called) 5257 reified-deferred-warnings 5258 (setf excl::.functions-defined. 5259 (append functions-defined excl::.functions-defined.) 5260 excl::.functions-called. 5261 (append functions-called excl::.functions-called.))) 5262 #+clozure 5263 (let ((dw (or ccl::*outstanding-deferred-warnings* 5264 (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) 5265 (appendf (ccl::deferred-warnings.warnings dw) 5266 (mapcar 'unreify-deferred-warning reified-deferred-warnings))) 5267 #+(or cmucl scl) 5268 (dolist (item reified-deferred-warnings) 5269 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. 5270 ;; For *undefined-warnings*, the adjustment is a list of initargs. 5271 ;; For everything else, it's an integer. 5272 (destructuring-bind (symbol . adjustment) item 5273 (case symbol 5274 ((c::*undefined-warnings*) 5275 (setf c::*undefined-warnings* 5276 (nconc (mapcan 5277 #'(lambda (stuff) 5278 (destructuring-bind (kind name count . rest) stuff 5279 (unless (case kind (:function (fboundp name))) 5280 (list 5281 (c::make-undefined-warning 5282 :name name 5283 :kind kind 5284 :count count 5285 :warnings 5286 (mapcar #'(lambda (x) 5287 (apply #'c::make-compiler-error-context x)) 5288 rest)))))) 5289 adjustment) 5290 c::*undefined-warnings*))) 5291 (otherwise 5292 (set symbol (+ (symbol-value symbol) adjustment)))))) 5293 #+sbcl 5294 (dolist (item reified-deferred-warnings) 5295 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. 5296 ;; For *undefined-warnings*, the adjustment is a list of initargs. 5297 ;; For everything else, it's an integer. 5298 (destructuring-bind (symbol . adjustment) item 5299 (case symbol 5300 ((sb-c::*undefined-warnings*) 5301 (setf sb-c::*undefined-warnings* 5302 (nconc (mapcan 5303 #'(lambda (stuff) 5304 (destructuring-bind (kind name count . rest) stuff 5305 (unless (case kind (:function (fboundp name))) 5306 (list 5307 (sb-c::make-undefined-warning 5308 :name name 5309 :kind kind 5310 :count count 5311 :warnings 5312 (mapcar #'(lambda (x) 5313 (apply #'sb-c::make-compiler-error-context x)) 5314 rest)))))) 5315 adjustment) 5316 sb-c::*undefined-warnings*))) 5317 (otherwise 5318 (set symbol (+ (symbol-value symbol) adjustment))))))) 5319 5320 (defun reset-deferred-warnings () 5321 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. 5322One of three functions required for deferred-warnings support in ASDF." 5323 #+allegro 5324 (setf excl::.functions-defined. nil 5325 excl::.functions-called. nil) 5326 #+clozure 5327 (if-let (dw ccl::*outstanding-deferred-warnings*) 5328 (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) 5329 (setf (ccl::deferred-warnings.warnings mdw) nil))) 5330 #+(or cmucl scl) 5331 (when lisp::*in-compilation-unit* 5332 (setf c::*undefined-warnings* nil 5333 c::*compiler-error-count* 0 5334 c::*compiler-warning-count* 0 5335 c::*compiler-note-count* 0)) 5336 #+sbcl 5337 (when sb-c::*in-compilation-unit* 5338 (setf sb-c::*undefined-warnings* nil 5339 sb-c::*aborted-compilation-unit-count* 0 5340 sb-c::*compiler-error-count* 0 5341 sb-c::*compiler-warning-count* 0 5342 sb-c::*compiler-style-warning-count* 0 5343 sb-c::*compiler-note-count* 0))) 5344 5345 (defun save-deferred-warnings (warnings-file) 5346 "Save forward reference conditions so they may be issued at a latter time, 5347possibly in a different process." 5348 (with-open-file (s warnings-file :direction :output :if-exists :supersede 5349 :element-type *default-stream-element-type* 5350 :external-format *utf-8-external-format*) 5351 (with-safe-io-syntax () 5352 (write (reify-deferred-warnings) :stream s :pretty t :readably t) 5353 (terpri s)))) 5354 5355 (defun warnings-file-type (&optional implementation-type) 5356 "The pathname type for warnings files on given IMPLEMENTATION-TYPE, 5357where NIL designates the current one" 5358 (case (or implementation-type *implementation-type*) 5359 ((:acl :allegro) "allegro-warnings") 5360 ;;((:clisp) "clisp-warnings") 5361 ((:cmu :cmucl) "cmucl-warnings") 5362 ((:sbcl) "sbcl-warnings") 5363 ((:clozure :ccl) "ccl-warnings") 5364 ((:scl) "scl-warnings"))) 5365 5366 (defvar *warnings-file-type* nil 5367 "Pathname type for warnings files, or NIL if disabled") 5368 5369 (defun enable-deferred-warnings-check () 5370 "Enable the saving of deferred warnings" 5371 (setf *warnings-file-type* (warnings-file-type))) 5372 5373 (defun disable-deferred-warnings-check () 5374 "Disable the saving of deferred warnings" 5375 (setf *warnings-file-type* nil)) 5376 5377 (defun warnings-file-p (file &optional implementation-type) 5378 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE? 5379If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead." 5380 (if-let (type (if implementation-type 5381 (warnings-file-type implementation-type) 5382 *warnings-file-type*)) 5383 (equal (pathname-type file) type))) 5384 5385 (defun check-deferred-warnings (files &optional context-format context-arguments) 5386 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS, 5387re-intern and raise any warnings that are still meaningful." 5388 (let ((file-errors nil) 5389 (failure-p nil) 5390 (warnings-p nil)) 5391 (handler-bind 5392 ((warning #'(lambda (c) 5393 (setf warnings-p t) 5394 (unless (typep c 'style-warning) 5395 (setf failure-p t))))) 5396 (with-compilation-unit (:override t) 5397 (reset-deferred-warnings) 5398 (dolist (file files) 5399 (unreify-deferred-warnings 5400 (handler-case (safe-read-file-form file) 5401 (error (c) 5402 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging 5403 (push c file-errors) 5404 nil)))))) 5405 (dolist (error file-errors) (error error)) 5406 (check-lisp-compile-warnings 5407 (or failure-p warnings-p) failure-p context-format context-arguments))) 5408 5409 #| 5410 Mini-guide to adding support for deferred warnings on an implementation. 5411 5412 First, look at what such a warning looks like: 5413 5414 (describe 5415 (handler-case 5416 (and (eval '(lambda () (some-undefined-function))) nil) 5417 (t (c) c))) 5418 5419 Then you can grep for the condition type in your compiler sources 5420 and see how to catch those that have been deferred, 5421 and/or read, clear and restore the deferred list. 5422 5423 Also look at 5424 (macroexpand-1 '(with-compilation-unit () foo)) 5425 |# 5426 5427 (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring) 5428 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK 5429and save those warnings to the given file for latter use, 5430possibly in a different process. Otherwise just call THUNK." 5431 (declare (ignorable source-namestring)) 5432 (if warnings-file 5433 (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring) 5434 (unwind-protect 5435 (let (#+sbcl (sb-c::*undefined-warnings* nil)) 5436 (multiple-value-prog1 5437 (funcall thunk) 5438 (save-deferred-warnings warnings-file))) 5439 (reset-deferred-warnings))) 5440 (funcall thunk))) 5441 5442 (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body) 5443 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" 5444 `(call-with-saved-deferred-warnings 5445 #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring))) 5446 5447 5448;;; from ASDF 5449(with-upgradability () 5450 (defun current-lisp-file-pathname () 5451 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" 5452 (or *compile-file-pathname* *load-pathname*)) 5453 5454 (defun load-pathname () 5455 "Portably return the LOAD-PATHNAME of the current source file or fasl" 5456 *load-pathname*) ;; magic no longer needed for GCL. 5457 5458 (defun lispize-pathname (input-file) 5459 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" 5460 (make-pathname :type "lisp" :defaults input-file)) 5461 5462 (defun compile-file-type (&rest keys) 5463 "pathname TYPE for lisp FASt Loading files" 5464 (declare (ignorable keys)) 5465 #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) 5466 #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) 5467 5468 (defun call-around-hook (hook function) 5469 "Call a HOOK around the execution of FUNCTION" 5470 (call-function (or hook 'funcall) function)) 5471 5472 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) 5473 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" 5474 (let* ((keys 5475 (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format 5476 ,@(unless output-file '(:output-file))) keys))) 5477 (if (absolute-pathname-p output-file) 5478 ;; what cfp should be doing, w/ mp* instead of mp 5479 (let* ((type (pathname-type (apply 'compile-file-type keys))) 5480 (defaults (make-pathname 5481 :type type :defaults (merge-pathnames* input-file)))) 5482 (merge-pathnames* output-file defaults)) 5483 (funcall *output-translation-function* 5484 (apply 'compile-file-pathname input-file keys))))) 5485 5486 (defvar *compile-check* nil 5487 "A hook for user-defined compile-time invariants") 5488 5489 (defun* (compile-file*) (input-file &rest keys 5490 &key (compile-check *compile-check*) output-file warnings-file 5491 #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl 5492 &allow-other-keys) 5493 "This function provides a portable wrapper around COMPILE-FILE. 5494It ensures that the OUTPUT-FILE value is only returned and 5495the file only actually created if the compilation was successful, 5496even though your implementation may not do that. It also checks an optional 5497user-provided consistency function COMPILE-CHECK to determine success; 5498it will call this function if not NIL at the end of the compilation 5499with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE 5500where TMP-FILE is the name of a temporary output-file. 5501It also checks two flags (with legacy british spelling from ASDF1), 5502*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* 5503with appropriate implementation-dependent defaults, 5504and if a failure (respectively warnings) are reported by COMPILE-FILE, 5505it will consider that an error unless the respective behaviour flag 5506is one of :SUCCESS :WARN :IGNORE. 5507If WARNINGS-FILE is defined, deferred warnings are saved to that file. 5508On ECL or MKCL, it creates both the linkable object and loadable fasl files. 5509On implementations that erroneously do not recognize standard keyword arguments, 5510it will filter them appropriately." 5511 #+(or clasp ecl) 5512 (when (and object-file (equal (compile-file-type) (pathname object-file))) 5513 (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" 5514 'compile-file* output-file object-file) 5515 (rotatef output-file object-file)) 5516 (let* ((keywords (remove-plist-keys 5517 `(:output-file :compile-check :warnings-file 5518 #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) 5519 (output-file 5520 (or output-file 5521 (apply 'compile-file-pathname* input-file :output-file output-file keywords))) 5522 (physical-output-file (physicalize-pathname output-file)) 5523 #+(or clasp ecl) 5524 (object-file 5525 (unless (use-ecl-byte-compiler-p) 5526 (or object-file 5527 #+ecl (compile-file-pathname output-file :type :object) 5528 #+clasp (compile-file-pathname output-file :output-type :object)))) 5529 #+mkcl 5530 (object-file 5531 (or object-file 5532 (compile-file-pathname output-file :fasl-p nil))) 5533 (tmp-file (tmpize-pathname physical-output-file)) 5534 #+sbcl 5535 (cfasl-file (etypecase emit-cfasl 5536 (null nil) 5537 ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file)) 5538 (string (parse-namestring emit-cfasl)) 5539 (pathname emit-cfasl))) 5540 #+sbcl 5541 (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file))) 5542 #+clisp 5543 (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) 5544 (multiple-value-bind (output-truename warnings-p failure-p) 5545 (with-enough-pathname (input-file :defaults *base-build-directory*) 5546 (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) 5547 (with-muffled-compiler-conditions () 5548 (or #-(or clasp ecl mkcl) 5549 (apply 'compile-file input-file :output-file tmp-file 5550 #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) 5551 #-sbcl keywords) 5552 #+ecl (apply 'compile-file input-file :output-file 5553 (if object-file 5554 (list* object-file :system-p t keywords) 5555 (list* tmp-file keywords))) 5556 #+clasp (apply 'compile-file input-file :output-file 5557 (if object-file 5558 (list* object-file :output-type :object #|:system-p t|# keywords) 5559 (list* tmp-file keywords))) 5560 #+mkcl (apply 'compile-file input-file 5561 :output-file object-file :fasl-p nil keywords))))) 5562 (cond 5563 ((and output-truename 5564 (flet ((check-flag (flag behaviour) 5565 (or (not flag) (member behaviour '(:success :warn :ignore))))) 5566 (and (check-flag failure-p *compile-file-failure-behaviour*) 5567 (check-flag warnings-p *compile-file-warnings-behaviour*))) 5568 (progn 5569 #+(or clasp ecl mkcl) 5570 (when (and #+(or clasp ecl) object-file) 5571 (setf output-truename 5572 (compiler::build-fasl tmp-file 5573 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list object-file)))) 5574 (or (not compile-check) 5575 (apply compile-check input-file 5576 :output-file output-truename 5577 keywords)))) 5578 (delete-file-if-exists physical-output-file) 5579 (when output-truename 5580 #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename)) 5581 ;; see CLISP bug 677 5582 #+clisp 5583 (progn 5584 (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) 5585 (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) 5586 (rename-file-overwriting-target tmp-lib lib-file)) 5587 #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) 5588 (rename-file-overwriting-target output-truename physical-output-file) 5589 (setf output-truename (truename physical-output-file))) 5590 #+clasp (delete-file-if-exists tmp-file) 5591 #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 5592 (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup 5593 (t ;; error or failed check 5594 (delete-file-if-exists output-truename) 5595 #+clisp (delete-file-if-exists tmp-lib) 5596 #+sbcl (delete-file-if-exists tmp-cfasl) 5597 (setf output-truename nil))) 5598 (values output-truename warnings-p failure-p)))) 5599 5600 (defun load* (x &rest keys &key &allow-other-keys) 5601 "Portable wrapper around LOAD that properly handles loading from a stream." 5602 (with-muffled-loader-conditions () 5603 (etypecase x 5604 ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) 5605 (apply 'load x keys)) 5606 ;; Genera can't load from a string-input-stream 5607 ;; ClozureCL 1.6 can only load from file input stream 5608 ;; Allegro 5, I don't remember but it must have been broken when I tested. 5609 #+(or allegro clozure genera) 5610 (stream ;; make do this way 5611 (let ((*package* *package*) 5612 (*readtable* *readtable*) 5613 (*load-pathname* nil) 5614 (*load-truename* nil)) 5615 (eval-input x)))))) 5616 5617 (defun load-from-string (string) 5618 "Portably read and evaluate forms from a STRING." 5619 (with-input-from-string (s string) (load* s)))) 5620 5621;;; Links FASLs together 5622(with-upgradability () 5623 (defun combine-fasls (inputs output) 5624 "Combine a list of FASLs INPUTS into a single FASL OUTPUT" 5625 #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl) 5626 (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output) 5627 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 5628 #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output) 5629 #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) 5630 #+lispworks 5631 (let (fasls) 5632 (unwind-protect 5633 (progn 5634 (loop :for i :in inputs 5635 :for n :from 1 5636 :for f = (add-pathname-suffix 5637 output (format nil "-FASL~D" n)) 5638 :do (copy-file i f) 5639 (push f fasls)) 5640 (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) 5641 (eval `(scm:defsystem :fasls-to-concatenate 5642 (:default-pathname ,(pathname-directory-pathname output)) 5643 :members 5644 ,(loop :for f :in (reverse fasls) 5645 :collect `(,(namestring f) :load-only t)))) 5646 (scm:concatenate-system output :fasls-to-concatenate :force t)) 5647 (loop :for f :in fasls :do (ignore-errors (delete-file f))) 5648 (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) 5649;;;; ------------------------------------------------------------------------- 5650;;;; launch-program - semi-portably spawn asynchronous subprocesses 5651 5652(uiop/package:define-package :uiop/launch-program 5653 (:use :uiop/common-lisp :uiop/package :uiop/utility 5654 :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) 5655 (:export 5656 ;;; Escaping the command invocation madness 5657 #:easy-sh-character-p #:escape-sh-token #:escape-sh-command 5658 #:escape-windows-token #:escape-windows-command 5659 #:escape-shell-token #:escape-shell-command 5660 #:escape-token #:escape-command 5661 5662 ;;; launch-program 5663 #:launch-program 5664 #:close-streams #:process-alive-p #:terminate-process #:wait-process 5665 #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid)) 5666(in-package :uiop/launch-program) 5667 5668;;;; ----- Escaping strings for the shell ----- 5669(with-upgradability () 5670 (defun requires-escaping-p (token &key good-chars bad-chars) 5671 "Does this token require escaping, given the specification of 5672either good chars that don't need escaping or bad chars that do need escaping, 5673as either a recognizing function or a sequence of characters." 5674 (some 5675 (cond 5676 ((and good-chars bad-chars) 5677 (parameter-error "~S: only one of good-chars and bad-chars can be provided" 5678 'requires-escaping-p)) 5679 ((typep good-chars 'function) 5680 (complement good-chars)) 5681 ((typep bad-chars 'function) 5682 bad-chars) 5683 ((and good-chars (typep good-chars 'sequence)) 5684 #'(lambda (c) (not (find c good-chars)))) 5685 ((and bad-chars (typep bad-chars 'sequence)) 5686 #'(lambda (c) (find c bad-chars))) 5687 (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p))) 5688 token)) 5689 5690 (defun escape-token (token &key stream quote good-chars bad-chars escaper) 5691 "Call the ESCAPER function on TOKEN string if it needs escaping as per 5692REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, 5693using STREAM as output (or returning result as a string if NIL)" 5694 (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) 5695 (with-output (stream) 5696 (apply escaper token stream (when quote `(:quote ,quote)))) 5697 (output-string token stream))) 5698 5699 (defun escape-windows-token-within-double-quotes (x &optional s) 5700 "Escape a string token X within double-quotes 5701for use within a MS Windows command-line, outputing to S." 5702 (labels ((issue (c) (princ c s)) 5703 (issue-backslash (n) (loop :repeat n :do (issue #\\)))) 5704 (loop 5705 :initially (issue #\") :finally (issue #\") 5706 :with l = (length x) :with i = 0 5707 :for i+1 = (1+ i) :while (< i l) :do 5708 (case (char x i) 5709 ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) 5710 ((#\\) 5711 (let* ((j (and (< i+1 l) (position-if-not 5712 #'(lambda (c) (eql c #\\)) x :start i+1))) 5713 (n (- (or j l) i))) 5714 (cond 5715 ((null j) 5716 (issue-backslash (* 2 n)) (setf i l)) 5717 ((and (< j l) (eql (char x j) #\")) 5718 (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) 5719 (t 5720 (issue-backslash n) (setf i j))))) 5721 (otherwise 5722 (issue (char x i)) (setf i i+1)))))) 5723 5724 (defun easy-windows-character-p (x) 5725 "Is X an \"easy\" character that does not require quoting by the shell?" 5726 (or (alphanumericp x) (find x "+-_.,@:/="))) 5727 5728 (defun escape-windows-token (token &optional s) 5729 "Escape a string TOKEN within double-quotes if needed 5730for use within a MS Windows command-line, outputing to S." 5731 (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil 5732 :escaper 'escape-windows-token-within-double-quotes)) 5733 5734 (defun escape-sh-token-within-double-quotes (x s &key (quote t)) 5735 "Escape a string TOKEN within double-quotes 5736for use within a POSIX Bourne shell, outputing to S; 5737omit the outer double-quotes if key argument :QUOTE is NIL" 5738 (when quote (princ #\" s)) 5739 (loop :for c :across x :do 5740 (when (find c "$`\\\"") (princ #\\ s)) 5741 (princ c s)) 5742 (when quote (princ #\" s))) 5743 5744 (defun easy-sh-character-p (x) 5745 "Is X an \"easy\" character that does not require quoting by the shell?" 5746 (or (alphanumericp x) (find x "+-_.,%@:/="))) 5747 5748 (defun escape-sh-token (token &optional s) 5749 "Escape a string TOKEN within double-quotes if needed 5750for use within a POSIX Bourne shell, outputing to S." 5751 (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p 5752 :escaper 'escape-sh-token-within-double-quotes)) 5753 5754 (defun escape-shell-token (token &optional s) 5755 "Escape a token for the current operating system shell" 5756 (os-cond 5757 ((os-unix-p) (escape-sh-token token s)) 5758 ((os-windows-p) (escape-windows-token token s)))) 5759 5760 (defun escape-command (command &optional s 5761 (escaper 'escape-shell-token)) 5762 "Given a COMMAND as a list of tokens, return a string of the 5763spaced, escaped tokens, using ESCAPER to escape." 5764 (etypecase command 5765 (string (output-string command s)) 5766 (list (with-output (s) 5767 (loop :for first = t :then nil :for token :in command :do 5768 (unless first (princ #\space s)) 5769 (funcall escaper token s)))))) 5770 5771 (defun escape-windows-command (command &optional s) 5772 "Escape a list of command-line arguments into a string suitable for parsing 5773by CommandLineToArgv in MS Windows" 5774 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx 5775 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx 5776 (escape-command command s 'escape-windows-token)) 5777 5778 (defun escape-sh-command (command &optional s) 5779 "Escape a list of command-line arguments into a string suitable for parsing 5780by /bin/sh in POSIX" 5781 (escape-command command s 'escape-sh-token)) 5782 5783 (defun escape-shell-command (command &optional stream) 5784 "Escape a command for the current operating system's shell" 5785 (escape-command command stream 'escape-shell-token))) 5786 5787 5788(with-upgradability () 5789 ;;; Internal helpers for run-program 5790 (defun %normalize-io-specifier (specifier &optional role) 5791 "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent 5792argument to pass to the internal RUN-PROGRAM" 5793 (declare (ignorable role)) 5794 (typecase specifier 5795 (null (or #+(or allegro lispworks) (null-device-pathname))) 5796 (string (parse-native-namestring specifier)) 5797 (pathname specifier) 5798 (stream specifier) 5799 ((eql :stream) :stream) 5800 ((eql :interactive) 5801 #+(or allegro lispworks) nil 5802 #+clisp :terminal 5803 #+(or abcl clozure cmucl ecl mkcl sbcl scl) t 5804 #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp) 5805 (not-implemented-error :interactive-output 5806 "On this lisp implementation, cannot interpret ~a value of ~a" 5807 specifier role)) 5808 ((eql :output) 5809 (cond ((eq role :error-output) 5810 #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) 5811 :output 5812 #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) 5813 (not-implemented-error :error-output-redirect 5814 "Can't send ~a to ~a on this lisp implementation." 5815 role specifier)) 5816 (t (parameter-error "~S IO specifier invalid for ~S" specifier role)))) 5817 (otherwise 5818 (parameter-error "Incorrect I/O specifier ~S for ~S" 5819 specifier role)))) 5820 5821 (defun %interactivep (input output error-output) 5822 (member :interactive (list input output error-output))) 5823 5824 (defun %signal-to-exit-code (signum) 5825 (+ 128 signum)) 5826 5827 #+mkcl 5828 (defun %mkcl-signal-to-number (signal) 5829 (require :mk-unix) 5830 (symbol-value (find-symbol signal :mk-unix))) 5831 5832 (defclass process-info () 5833 ((process :initform nil) 5834 (input-stream :initform nil) 5835 (output-stream :initform nil) 5836 (bidir-stream :initform nil) 5837 (error-output-stream :initform nil) 5838 ;; For backward-compatibility, to maintain the property (zerop 5839 ;; exit-code) <-> success, an exit in response to a signal is 5840 ;; encoded as 128+signum. 5841 (exit-code :initform nil) 5842 ;; If the platform allows it, distinguish exiting with a code 5843 ;; >128 from exiting in response to a signal by setting this code 5844 (signal-code :initform nil))) 5845 5846;;;--------------------------------------------------------------------------- 5847;;; The following two helper functions take care of handling the IF-EXISTS and 5848;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the 5849;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master 5850;;; function to treat input and output files unconditionally for reading and 5851;;; writing. 5852;;;--------------------------------------------------------------------------- 5853 5854 (defun %handle-if-exists (file if-exists) 5855 (when (or (stringp file) (pathnamep file)) 5856 (ecase if-exists 5857 ((:append :supersede :error) 5858 (with-open-file (dummy file :direction :output :if-exists if-exists) 5859 (declare (ignorable dummy))))))) 5860 5861 (defun %handle-if-does-not-exist (file if-does-not-exist) 5862 (when (or (stringp file) (pathnamep file)) 5863 (ecase if-does-not-exist 5864 ((:create :error) 5865 (with-open-file (dummy file :direction :probe 5866 :if-does-not-exist if-does-not-exist) 5867 (declare (ignorable dummy))))))) 5868 5869 (defun process-info-error-output (process-info) 5870 (slot-value process-info 'error-output-stream)) 5871 (defun process-info-input (process-info) 5872 (or (slot-value process-info 'bidir-stream) 5873 (slot-value process-info 'input-stream))) 5874 (defun process-info-output (process-info) 5875 (or (slot-value process-info 'bidir-stream) 5876 (slot-value process-info 'output-stream))) 5877 5878 (defun process-info-pid (process-info) 5879 (let ((process (slot-value process-info 'process))) 5880 (declare (ignorable process)) 5881 #+abcl (symbol-call :sys :process-pid process) 5882 #+allegro process 5883 #+clozure (ccl:external-process-id process) 5884 #+ecl (ext:external-process-pid process) 5885 #+(or cmucl scl) (ext:process-pid process) 5886 #+lispworks7+ (sys:pipe-pid process) 5887 #+(and lispworks (not lispworks7+)) process 5888 #+mkcl (mkcl:process-id process) 5889 #+sbcl (sb-ext:process-pid process) 5890 #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl) 5891 (not-implemented-error 'process-info-pid))) 5892 5893 (defun %process-status (process-info) 5894 (if-let (exit-code (slot-value process-info 'exit-code)) 5895 (return-from %process-status 5896 (if-let (signal-code (slot-value process-info 'signal-code)) 5897 (values :signaled signal-code) 5898 (values :exited exit-code)))) 5899 #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) 5900 (not-implemented-error '%process-status) 5901 (if-let (process (slot-value process-info 'process)) 5902 (multiple-value-bind (status code) 5903 (progn 5904 #+allegro (multiple-value-bind (exit-code pid signal) 5905 (sys:reap-os-subprocess :pid process :wait nil) 5906 (assert pid) 5907 (cond ((null exit-code) :running) 5908 ((null signal) (values :exited exit-code)) 5909 (t (values :signaled signal)))) 5910 #+clozure (ccl:external-process-status process) 5911 #+(or cmucl scl) (let ((status (ext:process-status process))) 5912 (values status (if (member status '(:exited :signaled)) 5913 (ext:process-exit-code process)))) 5914 #+ecl (ext:external-process-status process) 5915 #+lispworks 5916 ;; a signal is only returned on LispWorks 7+ 5917 (multiple-value-bind (exit-code signal) 5918 (funcall #+lispworks7+ #'sys:pipe-exit-status 5919 #-lispworks7+ #'sys:pid-exit-status 5920 process :wait nil) 5921 (cond ((null exit-code) :running) 5922 ((null signal) (values :exited exit-code)) 5923 (t (values :signaled signal)))) 5924 #+mkcl (let ((status (mk-ext:process-status process)) 5925 (code (mk-ext:process-exit-code process))) 5926 (if (stringp code) 5927 (values :signaled (%mkcl-signal-to-number code)) 5928 (values status code))) 5929 #+sbcl (let ((status (sb-ext:process-status process))) 5930 (values status (if (member status '(:exited :signaled)) 5931 (sb-ext:process-exit-code process))))) 5932 (case status 5933 (:exited (setf (slot-value process-info 'exit-code) code)) 5934 (:signaled (let ((%code (%signal-to-exit-code code))) 5935 (setf (slot-value process-info 'exit-code) %code 5936 (slot-value process-info 'signal-code) code)))) 5937 (values status code)))) 5938 5939 (defun process-alive-p (process-info) 5940 "Check if a process has yet to exit." 5941 (unless (slot-value process-info 'exit-code) 5942 #+abcl (sys:process-alive-p (slot-value process-info 'process)) 5943 #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process)) 5944 #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process)) 5945 #-(or abcl cmucl sbcl scl) (member (%process-status process-info) 5946 '(:running :sleeping)))) 5947 5948 (defun wait-process (process-info) 5949 "Wait for the process to terminate, if it is still running. 5950Otherwise, return immediately. An exit code (a number) will be 5951returned, with 0 indicating success, and anything else indicating 5952failure. If the process exits after receiving a signal, the exit code 5953will be the sum of 128 and the (positive) numeric signal code. A second 5954value may be returned in this case: the numeric signal code itself. 5955Any asynchronously spawned process requires this function to be run 5956before it is garbage-collected in order to free up resources that 5957might otherwise be irrevocably lost." 5958 (if-let (exit-code (slot-value process-info 'exit-code)) 5959 (if-let (signal-code (slot-value process-info 'signal-code)) 5960 (values exit-code signal-code) 5961 exit-code) 5962 (let ((process (slot-value process-info 'process))) 5963 #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) 5964 (not-implemented-error 'wait-process) 5965 (when process 5966 ;; 1- wait 5967 #+clozure (ccl::external-process-wait process) 5968 #+(or cmucl scl) (ext:process-wait process) 5969 #+sbcl (sb-ext:process-wait process) 5970 ;; 2- extract result 5971 (multiple-value-bind (exit-code signal-code) 5972 (progn 5973 #+abcl (sys:process-wait process) 5974 #+allegro (multiple-value-bind (exit-code pid signal) 5975 (sys:reap-os-subprocess :pid process :wait t) 5976 (assert pid) 5977 (values exit-code signal)) 5978 #+clozure (multiple-value-bind (status code) 5979 (ccl:external-process-status process) 5980 (if (eq status :signaled) 5981 (values nil code) 5982 code)) 5983 #+(or cmucl scl) (let ((status (ext:process-status process)) 5984 (code (ext:process-exit-code process))) 5985 (if (eq status :signaled) 5986 (values nil code) 5987 code)) 5988 #+ecl (multiple-value-bind (status code) 5989 (ext:external-process-wait process t) 5990 (if (eq status :signaled) 5991 (values nil code) 5992 code)) 5993 #+lispworks (funcall #+lispworks7+ #'sys:pipe-exit-status 5994 #-lispworks7+ #'sys:pid-exit-status 5995 process :wait t) 5996 #+mkcl (let ((code (mkcl:join-process process))) 5997 (if (stringp code) 5998 (values nil (%mkcl-signal-to-number code)) 5999 code)) 6000 #+sbcl (let ((status (sb-ext:process-status process)) 6001 (code (sb-ext:process-exit-code process))) 6002 (if (eq status :signaled) 6003 (values nil code) 6004 code))) 6005 (if signal-code 6006 (let ((%exit-code (%signal-to-exit-code signal-code))) 6007 (setf (slot-value process-info 'exit-code) %exit-code 6008 (slot-value process-info 'signal-code) signal-code) 6009 (values %exit-code signal-code)) 6010 (progn (setf (slot-value process-info 'exit-code) exit-code) 6011 exit-code))))))) 6012 6013 ;; WARNING: For signals other than SIGTERM and SIGKILL this may not 6014 ;; do what you expect it to. Sending SIGSTOP to a process spawned 6015 ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used 6016 ;; to run the command (via `sh -c command`) but not the actual 6017 ;; command. 6018 #+os-unix 6019 (defun %posix-send-signal (process-info signal) 6020 #+allegro (excl.osi:kill (slot-value process-info 'process) signal) 6021 #+clozure (ccl:signal-external-process (slot-value process-info 'process) 6022 signal :error-if-exited nil) 6023 #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal) 6024 #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal) 6025 #-(or allegro clozure cmucl sbcl scl) 6026 (if-let (pid (process-info-pid process-info)) 6027 (symbol-call :uiop :run-program 6028 (format nil "kill -~a ~a" signal pid) :ignore-error-status t))) 6029 6030 ;;; this function never gets called on Windows, but the compiler cannot tell 6031 ;;; that. [2016/09/25:rpg] 6032 #+os-windows 6033 (defun %posix-send-signal (process-info signal) 6034 (declare (ignore process-info signal)) 6035 (values)) 6036 6037 (defun terminate-process (process-info &key urgent) 6038 "Cause the process to exit. To that end, the process may or may 6039not be sent a signal, which it will find harder (or even impossible) 6040to ignore if URGENT is T. On some platforms, it may also be subject to 6041race conditions." 6042 (declare (ignorable urgent)) 6043 #+abcl (sys:process-kill (slot-value process-info 'process)) 6044 #+clasp (mp:process-kill (slot-value process-info 'process)) 6045 ;; On ECL, this will only work on versions later than 2016-09-06, 6046 ;; but we still want to compile on earlier versions, so we use symbol-call 6047 #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent) 6048 #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process)) 6049 #+mkcl (mk-ext:terminate-process (slot-value process-info 'process) 6050 :force urgent) 6051 #-(or abcl clasp ecl lispworks7+ mkcl) 6052 (os-cond 6053 ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15))) 6054 ((os-windows-p) (if-let (pid (process-info-pid process-info)) 6055 (symbol-call :uiop :run-program 6056 (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid) 6057 :ignore-error-status t))) 6058 (t (not-implemented-error 'terminate-process)))) 6059 6060 (defun close-streams (process-info) 6061 "Close any stream that the process might own. Needs to be run 6062whenever streams were requested by passing :stream to :input, :output, 6063or :error-output." 6064 (dolist (stream 6065 (cons (slot-value process-info 'error-output-stream) 6066 (if-let (bidir-stream (slot-value process-info 'bidir-stream)) 6067 (list bidir-stream) 6068 (list (slot-value process-info 'input-stream) 6069 (slot-value process-info 'output-stream))))) 6070 (when stream (close stream)))) 6071 6072 (defun launch-program (command &rest keys 6073 &key 6074 input (if-input-does-not-exist :error) 6075 output (if-output-exists :supersede) 6076 error-output (if-error-output-exists :supersede) 6077 (element-type #-clozure *default-stream-element-type* 6078 #+clozure 'character) 6079 (external-format *utf-8-external-format*) 6080 directory 6081 #+allegro separate-streams 6082 &allow-other-keys) 6083 "Launch program specified by COMMAND, 6084either a list of strings specifying a program and list of arguments, 6085or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on 6086Windows) _asynchronously_. 6087 6088If OUTPUT is a pathname, a string designating a pathname, or NIL (the 6089default) designating the null device, the file at that path is used as 6090output. 6091If it's :INTERACTIVE, output is inherited from the current process; 6092beware that this may be different from your *STANDARD-OUTPUT*, and 6093under SLIME will be on your *inferior-lisp* buffer. If it's T, output 6094goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new 6095stream will be made available that can be accessed via 6096PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value 6097that the underlying lisp implementation knows how to handle. 6098 6099IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a 6100pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the 6101default). The meaning of these values and their effect on the case 6102where OUTPUT does not exist, is analogous to the IF-EXISTS parameter 6103to OPEN with :DIRECTION :OUTPUT. 6104 6105ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*, 6106:OUTPUT means redirecting the error output to the output stream, 6107and :STREAM causes a stream to be made available via 6108PROCESS-INFO-ERROR-OUTPUT. 6109 6110IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it 6111affects ERROR-OUTPUT rather than OUTPUT. 6112 6113INPUT is similar to OUTPUT, except that T designates the 6114*STANDARD-INPUT* and a stream requested through the :STREAM keyword 6115would be available through PROCESS-INFO-INPUT. 6116 6117IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string 6118or a pathname, can take the values :CREATE and :ERROR (the 6119default). The meaning of these values is analogous to the 6120IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. 6121 6122ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp 6123implementation, when applicable, for creation of the output stream. 6124 6125LAUNCH-PROGRAM returns a PROCESS-INFO object." 6126 #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) 6127 (progn command keys input output error-output directory element-type external-format 6128 if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore 6129 (not-implemented-error 'launch-program)) 6130 #+allegro 6131 (when (some #'(lambda (stream) 6132 (and (streamp stream) 6133 (not (file-stream-p stream)))) 6134 (list input output error-output)) 6135 (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp" 6136 'launch-program)) 6137 #+(or abcl clisp lispworks) 6138 (when (some #'streamp (list input output error-output)) 6139 (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp" 6140 'launch-program)) 6141 #+clisp 6142 (unless (eq error-output :interactive) 6143 (parameter-error "~S: The only admissible value for ~S is ~S on this lisp" 6144 'launch-program :error-output :interactive)) 6145 #+ecl 6146 (when (some #'(lambda (stream) 6147 (and (streamp stream) 6148 (not (file-or-synonym-stream-p stream)))) 6149 (list input output error-output)) 6150 (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp" 6151 'launch-program)) 6152 #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) 6153 (nest 6154 (progn ;; see comments for these functions 6155 (%handle-if-does-not-exist input if-input-does-not-exist) 6156 (%handle-if-exists output if-output-exists) 6157 (%handle-if-exists error-output if-error-output-exists)) 6158 #+ecl (let ((*standard-input* *stdin*) 6159 (*standard-output* *stdout*) 6160 (*error-output* *stderr*))) 6161 (let ((process-info (make-instance 'process-info)) 6162 (input (%normalize-io-specifier input :input)) 6163 (output (%normalize-io-specifier output :output)) 6164 (error-output (%normalize-io-specifier error-output :error-output)) 6165 #+(and allegro os-windows) (interactive (%interactivep input output error-output)) 6166 (command 6167 (etypecase command 6168 #+os-unix (string `("/bin/sh" "-c" ,command)) 6169 #+os-unix (list command) 6170 #+os-windows 6171 (string 6172 ;; NB: On other Windows implementations, this is utterly bogus 6173 ;; except in the most trivial cases where no quoting is needed. 6174 ;; Use at your own risk. 6175 #-(or allegro clisp clozure ecl) 6176 (nest 6177 #+(or ecl sbcl) (unless (find-symbol* :escape-arguments #+ecl :ext #+sbcl :sb-impl nil)) 6178 (parameter-error "~S doesn't support string commands on Windows on this Lisp" 6179 'launch-program command)) 6180 ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified 6181 ;; when the command contains spaces or special characters: 6182 ;; IIUC, the system will use space as a separator, 6183 ;; but the C++ argv-decoding libraries won't, and 6184 ;; you're supposed to use an extra argument to CreateProcess to bridge the gap, 6185 ;; yet neither allegro nor clisp provide access to that argument. 6186 #+(or allegro clisp) (strcat "cmd /c " command) 6187 ;; On ClozureCL for Windows, we assume you are using 6188 ;; r15398 or later in 1.9 or later, 6189 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 6190 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304 6191 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13) 6192 #+(or clozure ecl sbcl) (cons "cmd" (strcat "/c " command))) 6193 #+os-windows 6194 (list 6195 #+allegro (escape-windows-command command) 6196 #-allegro command))))) 6197 #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl) 6198 (let ((program (car command)) 6199 #-allegro (arguments (cdr command)))) 6200 #+(and (or ecl sbcl) os-windows) 6201 (multiple-value-bind (arguments escape-arguments) 6202 (if (listp arguments) 6203 (values arguments t) 6204 (values (list arguments) nil))) 6205 #-(or allegro mkcl sbcl) (with-current-directory (directory)) 6206 (multiple-value-bind 6207 #+(or abcl clozure cmucl sbcl scl) (process) 6208 #+allegro (in-or-io out-or-err err-or-pid pid-or-nil) 6209 #+ecl (stream code process) 6210 #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) 6211 #+mkcl (stream process code) 6212 #.`(apply 6213 #+abcl 'sys:run-program 6214 #+allegro ,@'('excl:run-shell-command 6215 #+os-unix (coerce (cons program command) 'vector) 6216 #+os-windows command) 6217 #+clozure 'ccl:run-program 6218 #+(or cmucl ecl scl) 'ext:run-program 6219 #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed 6220 #+mkcl 'mk-ext:run-program 6221 #+sbcl 'sb-ext:run-program 6222 #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments) 6223 #+(and (or ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments) 6224 :input input :if-input-does-not-exist :error 6225 :output output :if-output-exists :append 6226 ,(or #+(or allegro lispworks) :error-output :error) error-output 6227 ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append 6228 :wait nil :element-type element-type :external-format external-format 6229 :allow-other-keys t 6230 #+allegro ,@`(:directory directory 6231 #+os-windows ,@'(:show-window (if interactive nil :hide))) 6232 #+lispworks ,@'(:save-exit-status t) 6233 #+mkcl ,@'(:directory (native-namestring directory)) 6234 #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys 6235 #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys))))) 6236 (labels ((prop (key value) (setf (slot-value process-info key) value))) 6237 #+allegro 6238 (cond 6239 (separate-streams 6240 (prop 'process pid-or-nil) 6241 (when (eq input :stream) (prop 'input-stream in-or-io)) 6242 (when (eq output :stream) (prop 'output-stream out-or-err)) 6243 (when (eq error-output :stream) (prop 'error-stream err-or-pid))) 6244 (t 6245 (prop 'process err-or-pid) 6246 (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) 6247 (0) 6248 (1 (prop 'input-stream in-or-io)) 6249 (2 (prop 'output-stream in-or-io)) 6250 (3 (prop 'bidir-stream in-or-io))) 6251 (when (eq error-output :stream) 6252 (prop 'error-stream out-or-err)))) 6253 #+(or abcl clozure cmucl sbcl scl) 6254 (progn 6255 (prop 'process process) 6256 (when (eq input :stream) 6257 (nest 6258 (prop 'input-stream) 6259 #+abcl (symbol-call :sys :process-input) 6260 #+clozure (ccl:external-process-input-stream) 6261 #+(or cmucl scl) (ext:process-input) 6262 #+sbcl (sb-ext:process-input) 6263 process)) 6264 (when (eq output :stream) 6265 (nest 6266 (prop 'output-stream) 6267 #+abcl (symbol-call :sys :process-output) 6268 #+clozure (ccl:external-process-output-stream) 6269 #+(or cmucl scl) (ext:process-output) 6270 #+sbcl (sb-ext:process-output) 6271 process)) 6272 (when (eq error-output :stream) 6273 (nest 6274 (prop 'error-output-stream) 6275 #+abcl (symbol-call :sys :process-error) 6276 #+clozure (ccl:external-process-error-stream) 6277 #+(or cmucl scl) (ext:process-error) 6278 #+sbcl (sb-ext:process-error) 6279 process))) 6280 #+(or ecl mkcl) 6281 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) 6282 code ;; ignore 6283 (unless (zerop mode) 6284 (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)) 6285 (prop 'process process)) 6286 #+lispworks 6287 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) 6288 (cond 6289 ((or (plusp mode) (eq error-output :stream)) 6290 (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil) 6291 (when (plusp mode) 6292 (prop (ecase mode 6293 (1 'input-stream) 6294 (2 'output-stream) 6295 (3 'bidir-stream)) io-or-pid)) 6296 (when (eq error-output :stream) 6297 (prop 'error-stream err-or-nil))) 6298 ;; lispworks6 returns (pid), lispworks7 returns (io err pid) of which we keep io 6299 (t (prop 'process io-or-pid))))) 6300 process-info))) 6301 6302;;;; ------------------------------------------------------------------------- 6303;;;; run-program initially from xcvb-driver. 6304 6305(uiop/package:define-package :uiop/run-program 6306 (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. 6307 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version 6308 :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program) 6309 (:export 6310 #:run-program 6311 #:slurp-input-stream #:vomit-output-stream 6312 #:subprocess-error 6313 #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process) 6314 (:import-from :uiop/launch-program 6315 #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep 6316 #:input-stream #:output-stream #:error-output-stream)) 6317(in-package :uiop/run-program) 6318 6319;;;; Slurping a stream, typically the output of another program 6320(with-upgradability () 6321 (defun call-stream-processor (fun processor stream) 6322 "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM, 6323a PROCESSOR specification which is either an atom or a list specifying 6324a processor an keyword arguments, call the specified processor with 6325the given STREAM as input" 6326 (if (consp processor) 6327 (apply fun (first processor) stream (rest processor)) 6328 (funcall fun processor stream))) 6329 6330 (defgeneric slurp-input-stream (processor input-stream &key) 6331 (:documentation 6332 "SLURP-INPUT-STREAM is a generic function with two positional arguments 6333PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) 6334the contents of the INPUT-STREAM and processes them according to a method 6335specified by PROCESSOR. 6336 6337Built-in methods include the following: 6338* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument 6339* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the 6340 INPUT-STREAM and the rest of the list. That is (x . y) will be treated as 6341 \(APPLY x <stream> y\) 6342* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, 6343 per copy-stream-to-stream, with appropriate keyword arguments. 6344* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM 6345 are returned as a string, as per SLURP-STREAM-STRING. 6346* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES. 6347* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE. 6348* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS. 6349* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM. 6350* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned. 6351 6352Programmers are encouraged to define their own methods for this generic function.")) 6353 6354 #-genera 6355 (defmethod slurp-input-stream ((function function) input-stream &key) 6356 (funcall function input-stream)) 6357 6358 (defmethod slurp-input-stream ((list cons) input-stream &key) 6359 (apply (first list) input-stream (rest list))) 6360 6361 #-genera 6362 (defmethod slurp-input-stream ((output-stream stream) input-stream 6363 &key linewise prefix (element-type 'character) buffer-size) 6364 (copy-stream-to-stream 6365 input-stream output-stream 6366 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) 6367 6368 (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) 6369 (slurp-stream-string stream :stripped stripped)) 6370 6371 (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) 6372 (slurp-stream-string stream :stripped stripped)) 6373 6374 (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) 6375 (slurp-stream-lines stream :count count)) 6376 6377 (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) 6378 (slurp-stream-line stream :at at)) 6379 6380 (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) 6381 (slurp-stream-forms stream :count count)) 6382 6383 (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) 6384 (slurp-stream-form stream :at at)) 6385 6386 (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) 6387 (apply 'slurp-input-stream *standard-output* stream keys)) 6388 6389 (defmethod slurp-input-stream ((x null) (stream t) &key) 6390 nil) 6391 6392 (defmethod slurp-input-stream ((pathname pathname) input 6393 &key 6394 (element-type *default-stream-element-type*) 6395 (external-format *utf-8-external-format*) 6396 (if-exists :rename-and-delete) 6397 (if-does-not-exist :create) 6398 buffer-size 6399 linewise) 6400 (with-output-file (output pathname 6401 :element-type element-type 6402 :external-format external-format 6403 :if-exists if-exists 6404 :if-does-not-exist if-does-not-exist) 6405 (copy-stream-to-stream 6406 input output 6407 :element-type element-type :buffer-size buffer-size :linewise linewise))) 6408 6409 (defmethod slurp-input-stream (x stream 6410 &key linewise prefix (element-type 'character) buffer-size) 6411 (declare (ignorable stream linewise prefix element-type buffer-size)) 6412 (cond 6413 #+genera 6414 ((functionp x) (funcall x stream)) 6415 #+genera 6416 ((output-stream-p x) 6417 (copy-stream-to-stream 6418 stream x 6419 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) 6420 (t 6421 (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x))))) 6422 6423;;;; Vomiting a stream, typically into the input of another program. 6424(with-upgradability () 6425 (defgeneric vomit-output-stream (processor output-stream &key) 6426 (:documentation 6427 "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments 6428PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) 6429some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR. 6430 6431Built-in methods include the following: 6432* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument 6433* if PROCESSOR is a list, its first element should be a function. 6434 It will be applied to a cons of the OUTPUT-STREAM and the rest of the list. 6435 That is (x . y) will be treated as \(APPLY x <stream> y\) 6436* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM, 6437 per copy-stream-to-stream, with appropriate keyword arguments. 6438* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM. 6439* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done. 6440 6441Programmers are encouraged to define their own methods for this generic function.")) 6442 6443 #-genera 6444 (defmethod vomit-output-stream ((function function) output-stream &key) 6445 (funcall function output-stream)) 6446 6447 (defmethod vomit-output-stream ((list cons) output-stream &key) 6448 (apply (first list) output-stream (rest list))) 6449 6450 #-genera 6451 (defmethod vomit-output-stream ((input-stream stream) output-stream 6452 &key linewise prefix (element-type 'character) buffer-size) 6453 (copy-stream-to-stream 6454 input-stream output-stream 6455 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) 6456 6457 (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri) 6458 (princ x stream) 6459 (when fresh-line (fresh-line stream)) 6460 (when terpri (terpri stream)) 6461 (values)) 6462 6463 (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) 6464 (apply 'vomit-output-stream *standard-input* stream keys)) 6465 6466 (defmethod vomit-output-stream ((x null) (stream t) &key) 6467 (values)) 6468 6469 (defmethod vomit-output-stream ((pathname pathname) input 6470 &key 6471 (element-type *default-stream-element-type*) 6472 (external-format *utf-8-external-format*) 6473 (if-exists :rename-and-delete) 6474 (if-does-not-exist :create) 6475 buffer-size 6476 linewise) 6477 (with-output-file (output pathname 6478 :element-type element-type 6479 :external-format external-format 6480 :if-exists if-exists 6481 :if-does-not-exist if-does-not-exist) 6482 (copy-stream-to-stream 6483 input output 6484 :element-type element-type :buffer-size buffer-size :linewise linewise))) 6485 6486 (defmethod vomit-output-stream (x stream 6487 &key linewise prefix (element-type 'character) buffer-size) 6488 (declare (ignorable stream linewise prefix element-type buffer-size)) 6489 (cond 6490 #+genera 6491 ((functionp x) (funcall x stream)) 6492 #+genera 6493 ((input-stream-p x) 6494 (copy-stream-to-stream 6495 x stream 6496 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) 6497 (t 6498 (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x))))) 6499 6500 6501;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output. 6502(with-upgradability () 6503 (define-condition subprocess-error (error) 6504 ((code :initform nil :initarg :code :reader subprocess-error-code) 6505 (command :initform nil :initarg :command :reader subprocess-error-command) 6506 (process :initform nil :initarg :process :reader subprocess-error-process)) 6507 (:report (lambda (condition stream) 6508 (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]" 6509 (subprocess-error-process condition) 6510 (subprocess-error-command condition) 6511 (subprocess-error-code condition))))) 6512 6513 (defun %check-result (exit-code &key command process ignore-error-status) 6514 (unless ignore-error-status 6515 (unless (eql exit-code 0) 6516 (cerror "IGNORE-ERROR-STATUS" 6517 'subprocess-error :command command :code exit-code :process process))) 6518 exit-code) 6519 6520 (defun %active-io-specifier-p (specifier) 6521 "Determines whether a run-program I/O specifier requires Lisp-side processing 6522via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), 6523or whether it's already taken care of by the implementation's underlying run-program." 6524 (not (typep specifier '(or null string pathname (member :interactive :output) 6525 #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t)) 6526 #+lispworks file-stream)))) 6527 6528 (defun %run-program (command &rest keys &key &allow-other-keys) 6529 "DEPRECATED. Use LAUNCH-PROGRAM instead." 6530 (apply 'launch-program command keys)) 6531 6532 (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner 6533 &key 6534 (element-type #-clozure *default-stream-element-type* #+clozure 'character) 6535 (external-format *utf-8-external-format*) &allow-other-keys) 6536 ;; handle redirection for run-program and system 6537 ;; SPEC is the specification for the subprocess's input or output or error-output 6538 ;; TVAL is the value used if the spec is T 6539 ;; GF is the generic function to call to handle arbitrary values of SPEC 6540 ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background 6541 ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) 6542 ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument 6543 ;; FUN is a function of the new reduced spec and an activity function to call with a stream 6544 ;; when the subprocess is active and communicating through that stream. 6545 ;; ACTIVEP is a boolean true if we will get to run code while the process is running 6546 ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open. 6547 ;; RETURNER is a function called with the value of the activity. 6548 ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way. 6549 (declare (ignorable stream-easy-p)) 6550 (let* ((actual-spec (if (eq spec t) tval spec)) 6551 (activity-spec (if (eq actual-spec :output) 6552 (ecase direction 6553 ((:input :output) 6554 (parameter-error "~S does not allow ~S as a ~S spec" 6555 'run-program :output direction)) 6556 ((:error-output) 6557 nil)) 6558 actual-spec))) 6559 (labels ((activity (stream) 6560 (call-function returner (call-stream-processor gf activity-spec stream))) 6561 (easy-case () 6562 (funcall fun actual-spec nil)) 6563 (hard-case () 6564 (if activep 6565 (funcall fun :stream #'activity) 6566 (with-temporary-file (:pathname tmp) 6567 (ecase direction 6568 (:input 6569 (with-output-file (s tmp :if-exists :overwrite 6570 :external-format external-format 6571 :element-type element-type) 6572 (activity s)) 6573 (funcall fun tmp nil)) 6574 ((:output :error-output) 6575 (multiple-value-prog1 (funcall fun tmp nil) 6576 (with-input-file (s tmp 6577 :external-format external-format 6578 :element-type element-type) 6579 (activity s))))))))) 6580 (typecase activity-spec 6581 ((or null string pathname (eql :interactive)) 6582 (easy-case)) 6583 #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard 6584 (stream 6585 (if stream-easy-p (easy-case) (hard-case))) 6586 (t 6587 (hard-case)))))) 6588 6589 (defmacro place-setter (place) 6590 (when place 6591 (let ((value (gensym))) 6592 `#'(lambda (,value) (setf ,place ,value))))) 6593 6594 (defmacro with-program-input (((reduced-input-var 6595 &optional (input-activity-var (gensym) iavp)) 6596 input-form &key setf stream-easy-p active keys) &body body) 6597 `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p 6598 #'(lambda (,reduced-input-var ,input-activity-var) 6599 ,@(unless iavp `((declare (ignore ,input-activity-var)))) 6600 ,@body) 6601 :input ,input-form ,active (place-setter ,setf) ,keys)) 6602 6603 (defmacro with-program-output (((reduced-output-var 6604 &optional (output-activity-var (gensym) oavp)) 6605 output-form &key setf stream-easy-p active keys) &body body) 6606 `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p 6607 #'(lambda (,reduced-output-var ,output-activity-var) 6608 ,@(unless oavp `((declare (ignore ,output-activity-var)))) 6609 ,@body) 6610 :output ,output-form ,active (place-setter ,setf) ,keys)) 6611 6612 (defmacro with-program-error-output (((reduced-error-output-var 6613 &optional (error-output-activity-var (gensym) eoavp)) 6614 error-output-form &key setf stream-easy-p active keys) 6615 &body body) 6616 `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p 6617 #'(lambda (,reduced-error-output-var ,error-output-activity-var) 6618 ,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) 6619 ,@body) 6620 :error-output ,error-output-form ,active (place-setter ,setf) ,keys)) 6621 6622 (defun %use-launch-program (command &rest keys 6623 &key input output error-output ignore-error-status &allow-other-keys) 6624 ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM 6625 #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) 6626 (progn 6627 command keys input output error-output ignore-error-status ;; ignore 6628 (not-implemented-error '%use-launch-program)) 6629 (when (member :stream (list input output error-output)) 6630 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" 6631 'run-program :stream)) 6632 (let* ((active-input-p (%active-io-specifier-p input)) 6633 (active-output-p (%active-io-specifier-p output)) 6634 (active-error-output-p (%active-io-specifier-p error-output)) 6635 (activity 6636 (cond 6637 (active-output-p :output) 6638 (active-input-p :input) 6639 (active-error-output-p :error-output) 6640 (t nil))) 6641 output-result error-output-result exit-code process-info) 6642 (with-program-output ((reduced-output output-activity) 6643 output :keys keys :setf output-result 6644 :stream-easy-p t :active (eq activity :output)) 6645 (with-program-error-output ((reduced-error-output error-output-activity) 6646 error-output :keys keys :setf error-output-result 6647 :stream-easy-p t :active (eq activity :error-output)) 6648 (with-program-input ((reduced-input input-activity) 6649 input :keys keys 6650 :stream-easy-p t :active (eq activity :input)) 6651 (setf process-info 6652 (apply 'launch-program command 6653 :input reduced-input :output reduced-output 6654 :error-output (if (eq error-output :output) :output reduced-error-output) 6655 keys)) 6656 (labels ((get-stream (stream-name &optional fallbackp) 6657 (or (slot-value process-info stream-name) 6658 (when fallbackp 6659 (slot-value process-info 'bidir-stream)))) 6660 (run-activity (activity stream-name &optional fallbackp) 6661 (if-let (stream (get-stream stream-name fallbackp)) 6662 (funcall activity stream) 6663 (error 'subprocess-error 6664 :code `(:missing ,stream-name) 6665 :command command :process process-info)))) 6666 (unwind-protect 6667 (ecase activity 6668 ((nil)) 6669 (:input (run-activity input-activity 'input-stream t)) 6670 (:output (run-activity output-activity 'output-stream t)) 6671 (:error-output (run-activity error-output-activity 'error-output-stream))) 6672 (close-streams process-info) 6673 (setf exit-code (wait-process process-info))))))) 6674 (%check-result exit-code 6675 :command command :process process-info 6676 :ignore-error-status ignore-error-status) 6677 (values output-result error-output-result exit-code))) 6678 6679 (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM 6680 (etypecase command 6681 (string command) 6682 (list (escape-shell-command 6683 (os-cond 6684 ((os-unix-p) (cons "exec" command)) 6685 (t command)))))) 6686 6687 (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM 6688 (flet ((redirect (spec operator) 6689 (let ((pathname 6690 (typecase spec 6691 (null (null-device-pathname)) 6692 (string (parse-native-namestring spec)) 6693 (pathname spec) 6694 ((eql :output) 6695 (unless (equal operator " 2>>") 6696 (parameter-error "~S: only the ~S argument can be ~S" 6697 'run-program :error-output :output)) 6698 (return-from redirect '(" 2>&1")))))) 6699 (when pathname 6700 (list operator " " 6701 (escape-shell-token (native-namestring pathname))))))) 6702 (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>"))) 6703 (normalized (%normalize-system-command command)) 6704 (directory (or directory #+(or abcl xcl) (getcwd))) 6705 (chdir (when directory 6706 (let ((dir-arg (escape-shell-token (native-namestring directory)))) 6707 (os-cond 6708 ((os-unix-p) `("cd " ,dir-arg " ; ")) 6709 ((os-windows-p) `("cd /d " ,dir-arg " & "))))))) 6710 (reduce/strcat 6711 (os-cond 6712 ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized)) 6713 ((os-windows-p) `(,@chdir ,@redirections " " ,normalized))))))) 6714 6715 (defun %system (command &rest keys &key directory 6716 input (if-input-does-not-exist :error) 6717 output (if-output-exists :supersede) 6718 error-output (if-error-output-exists :supersede) 6719 &allow-other-keys) 6720 "A portable abstraction of a low-level call to libc's system()." 6721 (declare (ignorable keys directory input if-input-does-not-exist output 6722 if-output-exists error-output if-error-output-exists)) 6723 #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) 6724 (let (#+(or abcl ecl mkcl) 6725 (version (parse-version 6726 #-abcl 6727 (lisp-implementation-version) 6728 #+abcl 6729 (second (split-string (implementation-identifier) :separator '(#\-)))))) 6730 (nest 6731 #+abcl (unless (lexicographic< '< version '(1 4 0))) 6732 #+ecl (unless (lexicographic<= '< version '(16 0 0))) 6733 #+mkcl (unless (lexicographic<= '< version '(1 1 9))) 6734 (return-from %system 6735 (wait-process 6736 (apply 'launch-program (%normalize-system-command command) keys))))) 6737 #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) 6738 (let ((%command (%redirected-system-command command input output error-output directory))) 6739 ;; see comments for these functions 6740 (%handle-if-does-not-exist input if-input-does-not-exist) 6741 (%handle-if-exists output if-output-exists) 6742 (%handle-if-exists error-output if-error-output-exists) 6743 #+abcl (ext:run-shell-command %command) 6744 #+(or clasp ecl) (let ((*standard-input* *stdin*) 6745 (*standard-output* *stdout*) 6746 (*error-output* *stderr*)) 6747 (ext:system %command)) 6748 #+clisp 6749 (let ((raw-exit-code 6750 (or 6751 #.`(#+os-windows ,@'(ext:run-shell-command %command) 6752 #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command)) 6753 :wait t :input :terminal :output :terminal) 6754 0))) 6755 (if (minusp raw-exit-code) 6756 (- 128 raw-exit-code) 6757 raw-exit-code)) 6758 #+cormanlisp (win32:system %command) 6759 #+gcl (system:system %command) 6760 #+genera (not-implemented-error '%system) 6761 #+(and lispworks os-windows) 6762 (system:call-system %command :current-directory directory :wait t) 6763 #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) 6764 #+mkcl (mkcl:system %command) 6765 #+xcl (system:%run-shell-command %command))) 6766 6767 (defun %use-system (command &rest keys 6768 &key input output error-output ignore-error-status &allow-other-keys) 6769 ;; helper for RUN-PROGRAM when using %system 6770 (let (output-result error-output-result exit-code) 6771 (with-program-output ((reduced-output) 6772 output :keys keys :setf output-result) 6773 (with-program-error-output ((reduced-error-output) 6774 error-output :keys keys :setf error-output-result) 6775 (with-program-input ((reduced-input) input :keys keys) 6776 (setf exit-code (apply '%system command 6777 :input reduced-input :output reduced-output 6778 :error-output reduced-error-output keys))))) 6779 (%check-result exit-code 6780 :command command 6781 :ignore-error-status ignore-error-status) 6782 (values output-result error-output-result exit-code))) 6783 6784 (defun run-program (command &rest keys 6785 &key ignore-error-status (force-shell nil force-shell-suppliedp) 6786 input (if-input-does-not-exist :error) 6787 output (if-output-exists :supersede) 6788 error-output (if-error-output-exists :supersede) 6789 (element-type #-clozure *default-stream-element-type* #+clozure 'character) 6790 (external-format *utf-8-external-format*) 6791 &allow-other-keys) 6792 "Run program specified by COMMAND, 6793either a list of strings specifying a program and list of arguments, 6794or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); 6795_synchronously_ process its output as specified and return the processing results 6796when the program and its output processing are complete. 6797 6798Always call a shell (rather than directly execute the command when possible) 6799if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is 6800specified to be NIL. 6801 6802Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), 6803unless IGNORE-ERROR-STATUS is specified. 6804 6805If OUTPUT is a pathname, a string designating a pathname, or NIL (the default) 6806designating the null device, the file at that path is used as output. 6807If it's :INTERACTIVE, output is inherited from the current process; 6808beware that this may be different from your *STANDARD-OUTPUT*, 6809and under SLIME will be on your *inferior-lisp* buffer. 6810If it's T, output goes to your current *STANDARD-OUTPUT* stream. 6811Otherwise, OUTPUT should be a value that is a suitable first argument to 6812SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. 6813In this case, RUN-PROGRAM will create a temporary stream for the program output; 6814the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, 6815using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). 6816The primary value resulting from that call (or NIL if no call was needed) 6817will be the first value returned by RUN-PROGRAM. 6818E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. 6819And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string 6820stripped of any ending newline. 6821 6822IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a 6823pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the 6824default). The meaning of these values and their effect on the case 6825where OUTPUT does not exist, is analogous to the IF-EXISTS parameter 6826to OPEN with :DIRECTION :OUTPUT. 6827 6828ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned 6829as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. 6830Also :OUTPUT means redirecting the error output to the output stream, 6831in which case NIL is returned. 6832 6833IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it 6834affects ERROR-OUTPUT rather than OUTPUT. 6835 6836INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, 6837no value is returned, and T designates the *STANDARD-INPUT*. 6838 6839IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string 6840or a pathname, can take the values :CREATE and :ERROR (the 6841default). The meaning of these values is analogous to the 6842IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. 6843 6844ELEMENT-TYPE and EXTERNAL-FORMAT are passed on 6845to your Lisp implementation, when applicable, for creation of the output stream. 6846 6847One and only one of the stream slurping or vomiting may or may not happen 6848in parallel in parallel with the subprocess, 6849depending on options and implementation, 6850and with priority being given to output processing. 6851Other streams are completely produced or consumed 6852before or after the subprocess is spawned, using temporary files. 6853 6854RUN-PROGRAM returns 3 values: 68550- the result of the OUTPUT slurping if any, or NIL 68561- the result of the ERROR-OUTPUT slurping if any, or NIL 68572- either 0 if the subprocess exited with success status, 6858or an indication of failure via the EXIT-CODE of the process" 6859 (declare (ignorable input output error-output if-input-does-not-exist if-output-exists 6860 if-error-output-exists element-type external-format ignore-error-status)) 6861 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) 6862 (not-implemented-error 'run-program) 6863 (apply (if (or force-shell 6864 ;; Per doc string, set FORCE-SHELL to T if we get command as a string. 6865 ;; But don't override user's specified preference. [2015/06/29:rpg] 6866 (and (stringp command) 6867 (or (not force-shell-suppliedp) 6868 #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t)))) 6869 #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t 6870 ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program 6871 #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) 6872 (lexicographic<= '< ver '(16 0 0))) 6873 #+(and lispworks os-unix) (%interactivep input output error-output)) 6874 '%use-system '%use-launch-program) 6875 command keys))) 6876 6877;;;; --------------------------------------------------------------------------- 6878;;;; Generic support for configuration files 6879 6880(uiop/package:define-package :uiop/configuration 6881 (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. 6882 (:use :uiop/common-lisp :uiop/utility 6883 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) 6884 (:export 6885 #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver 6886 #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem 6887 #:get-folder-path 6888 #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs 6889 #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames 6890 #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames 6891 #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname 6892 #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory 6893 #:configuration-inheritance-directive-p 6894 #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* 6895 #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook 6896 #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* 6897 #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) 6898(in-package :uiop/configuration) 6899 6900(with-upgradability () 6901 (define-condition invalid-configuration () 6902 ((form :reader condition-form :initarg :form) 6903 (location :reader condition-location :initarg :location) 6904 (format :reader condition-format :initarg :format) 6905 (arguments :reader condition-arguments :initarg :arguments :initform nil)) 6906 (:report (lambda (c s) 6907 (format s (compatfmt "~@<~? (will be skipped)~@:>") 6908 (condition-format c) 6909 (list* (condition-form c) (condition-location c) 6910 (condition-arguments c)))))) 6911 6912 (defun configuration-inheritance-directive-p (x) 6913 "Is X a configuration inheritance directive?" 6914 (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) 6915 (or (member x kw) 6916 (and (length=n-p x 1) (member (car x) kw))))) 6917 6918 (defun report-invalid-form (reporter &rest args) 6919 "Report an invalid form according to REPORTER and various ARGS" 6920 (etypecase reporter 6921 (null 6922 (apply 'error 'invalid-configuration args)) 6923 (function 6924 (apply reporter args)) 6925 ((or symbol string) 6926 (apply 'error reporter args)) 6927 (cons 6928 (apply 'apply (append reporter args))))) 6929 6930 (defvar *ignored-configuration-form* nil 6931 "Have configuration forms been ignored while parsing the configuration?") 6932 6933 (defun validate-configuration-form (form tag directive-validator 6934 &key location invalid-form-reporter) 6935 "Validate a configuration FORM. By default it will raise an error if the 6936FORM is not valid. Otherwise it will return the validated form. 6937 Arguments control the behavior: 6938 The configuration FORM should be of the form (TAG . <rest>) 6939 Each element of <rest> will be checked by first seeing if it's a configuration inheritance 6940directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR 6941on it. 6942 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control 6943reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where 6944the configuration form appeared." 6945 (unless (and (consp form) (eq (car form) tag)) 6946 (setf *ignored-configuration-form* t) 6947 (report-invalid-form invalid-form-reporter :form form :location location) 6948 (return-from validate-configuration-form nil)) 6949 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) 6950 :for directive :in (cdr form) 6951 :when (cond 6952 ((configuration-inheritance-directive-p directive) 6953 (incf inherit) t) 6954 ((eq directive :ignore-invalid-entries) 6955 (setf ignore-invalid-p t) t) 6956 ((funcall directive-validator directive) 6957 t) 6958 (ignore-invalid-p 6959 nil) 6960 (t 6961 (setf *ignored-configuration-form* t) 6962 (report-invalid-form invalid-form-reporter :form directive :location location) 6963 nil)) 6964 :do (push directive x) 6965 :finally 6966 (unless (= inherit 1) 6967 (report-invalid-form invalid-form-reporter 6968 :form form :location location 6969 ;; we throw away the form and location arguments, hence the ~2* 6970 ;; this is necessary because of the report in INVALID-CONFIGURATION 6971 :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~ 6972 One and only one of ~S or ~S is required.~@:>") 6973 :arguments '(:inherit-configuration :ignore-inherited-configuration))) 6974 (return (nreverse x)))) 6975 6976 (defun validate-configuration-file (file validator &key description) 6977 "Validate a configuration FILE. The configuration file should have only one s-expression 6978in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error 6979reporting." 6980 (let ((forms (read-file-forms file))) 6981 (unless (length=n-p forms 1) 6982 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") 6983 description forms)) 6984 (funcall validator (car forms) :location file))) 6985 6986 (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter) 6987 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will 6988be applied to the results to yield a configuration form. Current 6989values of TAG include :source-registry and :output-translations." 6990 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list 6991 (remove-if 6992 'hidden-pathname-p 6993 (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) 6994 #'string< :key #'namestring))) 6995 `(,tag 6996 ,@(loop :for file :in files :append 6997 (loop :with ignore-invalid-p = nil 6998 :for form :in (read-file-forms file) 6999 :when (eq form :ignore-invalid-entries) 7000 :do (setf ignore-invalid-p t) 7001 :else 7002 :when (funcall validator form) 7003 :collect form 7004 :else 7005 :when ignore-invalid-p 7006 :do (setf *ignored-configuration-form* t) 7007 :else 7008 :do (report-invalid-form invalid-form-reporter :form form :location file))) 7009 :inherit-configuration))) 7010 7011 (defun resolve-relative-location (x &key ensure-directory wilden) 7012 "Given a designator X for an relative location, resolve it to a pathname." 7013 (ensure-pathname 7014 (etypecase x 7015 (null nil) 7016 (pathname x) 7017 (string (parse-unix-namestring 7018 x :ensure-directory ensure-directory)) 7019 (cons 7020 (if (null (cdr x)) 7021 (resolve-relative-location 7022 (car x) :ensure-directory ensure-directory :wilden wilden) 7023 (let* ((car (resolve-relative-location 7024 (car x) :ensure-directory t :wilden nil))) 7025 (merge-pathnames* 7026 (resolve-relative-location 7027 (cdr x) :ensure-directory ensure-directory :wilden wilden) 7028 car)))) 7029 ((eql :*/) *wild-directory*) 7030 ((eql :**/) *wild-inferiors*) 7031 ((eql :*.*.*) *wild-file*) 7032 ((eql :implementation) 7033 (parse-unix-namestring 7034 (implementation-identifier) :ensure-directory t)) 7035 ((eql :implementation-type) 7036 (parse-unix-namestring 7037 (string-downcase (implementation-type)) :ensure-directory t)) 7038 ((eql :hostname) 7039 (parse-unix-namestring (hostname) :ensure-directory t))) 7040 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) 7041 :want-relative t)) 7042 7043 (defvar *here-directory* nil 7044 "This special variable is bound to the currect directory during calls to 7045PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here 7046directive.") 7047 7048 (defvar *user-cache* nil 7049 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") 7050 7051 (defun resolve-absolute-location (x &key ensure-directory wilden) 7052 "Given a designator X for an absolute location, resolve it to a pathname" 7053 (ensure-pathname 7054 (etypecase x 7055 (null nil) 7056 (pathname x) 7057 (string 7058 (let ((p #-mcl (parse-namestring x) 7059 #+mcl (probe-posix x))) 7060 #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) 7061 (if ensure-directory (ensure-directory-pathname p) p))) 7062 (cons 7063 (return-from resolve-absolute-location 7064 (if (null (cdr x)) 7065 (resolve-absolute-location 7066 (car x) :ensure-directory ensure-directory :wilden wilden) 7067 (merge-pathnames* 7068 (resolve-relative-location 7069 (cdr x) :ensure-directory ensure-directory :wilden wilden) 7070 (resolve-absolute-location 7071 (car x) :ensure-directory t :wilden nil))))) 7072 ((eql :root) 7073 ;; special magic! we return a relative pathname, 7074 ;; but what it means to the output-translations is 7075 ;; "relative to the root of the source pathname's host and device". 7076 (return-from resolve-absolute-location 7077 (let ((p (make-pathname :directory '(:relative)))) 7078 (if wilden (wilden p) p)))) 7079 ((eql :home) (user-homedir-pathname)) 7080 ((eql :here) (resolve-absolute-location 7081 (or *here-directory* (pathname-directory-pathname (load-pathname))) 7082 :ensure-directory t :wilden nil)) 7083 ((eql :user-cache) (resolve-absolute-location 7084 *user-cache* :ensure-directory t :wilden nil))) 7085 :wilden (and wilden (not (pathnamep x))) 7086 :resolve-symlinks *resolve-symlinks* 7087 :want-absolute t)) 7088 7089 ;; Try to override declaration in previous versions of ASDF. 7090 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) 7091 (:ensure-directory boolean)) t) resolve-location)) 7092 7093 (defun* (resolve-location) (x &key ensure-directory wilden directory) 7094 "Resolve location designator X into a PATHNAME" 7095 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory 7096 (loop* :with dirp = (or directory ensure-directory) 7097 :with (first . rest) = (if (atom x) (list x) x) 7098 :with path = (or (resolve-absolute-location 7099 first :ensure-directory (and (or dirp rest) t) 7100 :wilden (and wilden (null rest))) 7101 (return nil)) 7102 :for (element . morep) :on rest 7103 :for dir = (and (or morep dirp) t) 7104 :for wild = (and wilden (not morep)) 7105 :for sub = (merge-pathnames* 7106 (resolve-relative-location 7107 element :ensure-directory dir :wilden wild) 7108 path) 7109 :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) 7110 :finally (return path))) 7111 7112 (defun location-designator-p (x) 7113 "Is X a designator for a location?" 7114 ;; NIL means "skip this entry", or as an output translation, same as translation input. 7115 ;; T means "any input" for a translation, or as output, same as translation input. 7116 (flet ((absolute-component-p (c) 7117 (typep c '(or string pathname 7118 (member :root :home :here :user-cache)))) 7119 (relative-component-p (c) 7120 (typep c '(or string pathname 7121 (member :*/ :**/ :*.*.* :implementation :implementation-type))))) 7122 (or (typep x 'boolean) 7123 (absolute-component-p x) 7124 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) 7125 7126 (defun location-function-p (x) 7127 "Is X the specification of a location function?" 7128 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support. 7129 (and (length=n-p x 2) (eq (car x) :function))) 7130 7131 (defvar *clear-configuration-hook* '()) 7132 7133 (defun register-clear-configuration-hook (hook-function &optional call-now-p) 7134 "Register a function to be called when clearing configuration" 7135 (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) 7136 7137 (defun clear-configuration () 7138 "Call the functions in *CLEAR-CONFIGURATION-HOOK*" 7139 (call-functions *clear-configuration-hook*)) 7140 7141 (register-image-dump-hook 'clear-configuration) 7142 7143 (defun upgrade-configuration () 7144 "If a previous version of ASDF failed to read some configuration, try again now." 7145 (when *ignored-configuration-form* 7146 (clear-configuration) 7147 (setf *ignored-configuration-form* nil))) 7148 7149 7150 (defun get-folder-path (folder) 7151 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path, 7152this function tries to locate the Windows FOLDER for one of 7153:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA. 7154 Returns NIL when the folder is not defined (e.g., not on Windows)." 7155 (or #+(and lispworks os-windows) (sys:get-folder-path folder) 7156 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 7157 (ecase folder 7158 (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") 7159 (subpathname* (get-folder-path :appdata) "Local"))) 7160 (:appdata (getenv-absolute-directory "APPDATA")) 7161 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") 7162 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) 7163 7164 7165 ;; Support for the XDG Base Directory Specification 7166 (defun xdg-data-home (&rest more) 7167 "Returns an absolute pathname for the directory containing user-specific data files. 7168MORE may contain specifications for a subpath relative to this directory: a 7169subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7170also \"Configuration DSL\"\) in the ASDF manual." 7171 (resolve-absolute-location 7172 `(,(or (getenv-absolute-directory "XDG_DATA_HOME") 7173 (os-cond 7174 ((os-windows-p) (get-folder-path :local-appdata)) 7175 (t (subpathname (user-homedir-pathname) ".local/share/")))) 7176 ,more))) 7177 7178 (defun xdg-config-home (&rest more) 7179 "Returns a pathname for the directory containing user-specific configuration files. 7180MORE may contain specifications for a subpath relative to this directory: a 7181subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7182also \"Configuration DSL\"\) in the ASDF manual." 7183 (resolve-absolute-location 7184 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") 7185 (os-cond 7186 ((os-windows-p) (xdg-data-home "config/")) 7187 (t (subpathname (user-homedir-pathname) ".config/")))) 7188 ,more))) 7189 7190 (defun xdg-data-dirs (&rest more) 7191 "The preference-ordered set of additional paths to search for data files. 7192Returns a list of absolute directory pathnames. 7193MORE may contain specifications for a subpath relative to these directories: a 7194subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7195also \"Configuration DSL\"\) in the ASDF manual." 7196 (mapcar #'(lambda (d) (resolve-location `(,d ,more))) 7197 (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS")) 7198 (os-cond 7199 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) 7200 (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))))) 7201 7202 (defun xdg-config-dirs (&rest more) 7203 "The preference-ordered set of additional base paths to search for configuration files. 7204Returns a list of absolute directory pathnames. 7205MORE may contain specifications for a subpath relative to these directories: 7206subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7207also \"Configuration DSL\"\) in the ASDF manual." 7208 (mapcar #'(lambda (d) (resolve-location `(,d ,more))) 7209 (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS")) 7210 (os-cond 7211 ((os-windows-p) (xdg-data-dirs "config/")) 7212 (t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) 7213 7214 (defun xdg-cache-home (&rest more) 7215 "The base directory relative to which user specific non-essential data files should be stored. 7216Returns an absolute directory pathname. 7217MORE may contain specifications for a subpath relative to this directory: a 7218subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7219also \"Configuration DSL\"\) in the ASDF manual." 7220 (resolve-absolute-location 7221 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") 7222 (os-cond 7223 ((os-windows-p) (xdg-data-home "cache/")) 7224 (t (subpathname* (user-homedir-pathname) ".cache/")))) 7225 ,more))) 7226 7227 (defun xdg-runtime-dir (&rest more) 7228 "Pathname for user-specific non-essential runtime files and other file objects, 7229such as sockets, named pipes, etc. 7230Returns an absolute directory pathname. 7231MORE may contain specifications for a subpath relative to this directory: a 7232subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7233also \"Configuration DSL\"\) in the ASDF manual." 7234 ;; The XDG spec says that if not provided by the login system, the application should 7235 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL. 7236 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more))) 7237 7238 ;;; NOTE: modified the docstring because "system user configuration 7239 ;;; directories" seems self-contradictory. I'm not sure my wording is right. 7240 (defun system-config-pathnames (&rest more) 7241 "Return a list of directories where are stored the system's default user configuration information. 7242MORE may contain specifications for a subpath relative to these directories: a 7243subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7244also \"Configuration DSL\"\) in the ASDF manual." 7245 (declare (ignorable more)) 7246 (os-cond 7247 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more)))))) 7248 7249 (defun filter-pathname-set (dirs) 7250 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list." 7251 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal)) 7252 7253 (defun xdg-data-pathnames (&rest more) 7254 "Return a list of absolute pathnames for application data directories. With APP, 7255returns directory for data for that application, without APP, returns the set of directories 7256for storing all application configurations. 7257MORE may contain specifications for a subpath relative to these directories: a 7258subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7259also \"Configuration DSL\"\) in the ASDF manual." 7260 (filter-pathname-set 7261 `(,(xdg-data-home more) 7262 ,@(xdg-data-dirs more)))) 7263 7264 (defun xdg-config-pathnames (&rest more) 7265 "Return a list of pathnames for application configuration. 7266MORE may contain specifications for a subpath relative to these directories: a 7267subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see 7268also \"Configuration DSL\"\) in the ASDF manual." 7269 (filter-pathname-set 7270 `(,(xdg-config-home more) 7271 ,@(xdg-config-dirs more)))) 7272 7273 (defun find-preferred-file (files &key (direction :input)) 7274 "Find first file in the list of FILES that exists (for direction :input or :probe) 7275or just the first one (for direction :output or :io). 7276 Note that when we say \"file\" here, the files in question may be directories." 7277 (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files)) 7278 7279 (defun xdg-data-pathname (&optional more (direction :input)) 7280 (find-preferred-file (xdg-data-pathnames more) :direction direction)) 7281 7282 (defun xdg-config-pathname (&optional more (direction :input)) 7283 (find-preferred-file (xdg-config-pathnames more) :direction direction)) 7284 7285 (defun compute-user-cache () 7286 "Compute (and return) the location of the default user-cache for translate-output 7287objects. Side-effects for cached file location computation." 7288 (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) 7289 (register-image-restore-hook 'compute-user-cache)) 7290;;; ------------------------------------------------------------------------- 7291;;; Hacks for backward-compatibility with older versions of UIOP 7292 7293(uiop/package:define-package :uiop/backward-driver 7294 (:recycle :uiop/backward-driver :asdf/backward-driver :uiop) 7295 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version 7296 :uiop/pathname :uiop/stream :uiop/os :uiop/image 7297 :uiop/run-program :uiop/lisp-build :uiop/configuration) 7298 (:export 7299 #:coerce-pathname 7300 #:user-configuration-directories #:system-configuration-directories 7301 #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory 7302 #:version-compatible-p)) 7303(in-package :uiop/backward-driver) 7304 7305(eval-when (:compile-toplevel :load-toplevel :execute) 7306(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2")) 7307 ;; Backward compatibility with ASDF 2.000 to 2.26 7308 7309 ;; For backward-compatibility only, for people using internals 7310 ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) 7311 ;; Will be removed after 2015-12. 7312 (defun coerce-pathname (name &key type defaults) 7313 "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead." 7314 (parse-unix-namestring name :type type :defaults defaults)) 7315 7316 ;; Backward compatibility for ASDF 2.27 to 3.1.4 7317 (defun user-configuration-directories () 7318 "Return the current user's list of user configuration directories 7319for configuring common-lisp. 7320DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." 7321 (xdg-config-pathnames "common-lisp")) 7322 (defun system-configuration-directories () 7323 "Return the list of system configuration directories for common-lisp. 7324DEPRECATED. Use UIOP:CONFIG-SYSTEM-PATHNAMES instead." 7325 (system-config-pathnames "common-lisp")) 7326 (defun in-first-directory (dirs x &key (direction :input)) 7327 "Finds the first appropriate file named X in the list of DIRS for I/O 7328in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). 7329If direction is :INPUT or :PROBE, will return the first extant file named 7330X in one of the DIRS. 7331If direction is :OUTPUT or :IO, will simply return the file named X in the 7332first element of DIRS that exists. DEPRECATED." 7333 (find-preferred-file 7334 (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs) 7335 :direction direction)) 7336 (defun in-user-configuration-directory (x &key (direction :input)) 7337 "Return the file named X in the user configuration directory for common-lisp. 7338DEPRECATED." 7339 (xdg-config-pathname `("common-lisp" ,x) direction)) 7340 (defun in-system-configuration-directory (x &key (direction :input)) 7341 "Return the pathname for the file named X under the system configuration directory 7342for common-lisp. DEPRECATED." 7343 (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)) 7344 7345 7346 ;; Backward compatibility with ASDF 1 to ASDF 2.32 7347 7348 (defun version-compatible-p (provided-version required-version) 7349 "Is the provided version a compatible substitution for the required-version? 7350If major versions differ, it's not compatible. 7351If they are equal, then any later version is compatible, 7352with later being determined by a lexicographical comparison of minor numbers. 7353DEPRECATED." 7354 (let ((x (parse-version provided-version nil)) 7355 (y (parse-version required-version nil))) 7356 (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))) 7357 7358;;;; --------------------------------------------------------------------------- 7359;;;; Re-export all the functionality in UIOP 7360 7361(uiop/package:define-package :uiop/driver 7362 (:nicknames :uiop :asdf/driver) ;; asdf/driver is obsolete (uiop isn't); 7363 ;; but asdf/driver is still used by swap-bytes, static-vectors. 7364 (:use :uiop/common-lisp) 7365 ;; NB: not reexporting uiop/common-lisp 7366 ;; which include all of CL with compatibility modifications on select platforms, 7367 ;; that could cause potential conflicts for packages that would :use (cl uiop) 7368 ;; or :use (closer-common-lisp uiop), etc. 7369 (:use-reexport 7370 :uiop/package :uiop/utility :uiop/version 7371 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image 7372 :uiop/launch-program :uiop/run-program 7373 :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) 7374 7375;; Provide both lowercase and uppercase, to satisfy more people. 7376(provide "uiop") (provide "UIOP") 7377;;;; ------------------------------------------------------------------------- 7378;;;; Handle upgrade as forward- and backward-compatibly as possible 7379;; See https://bugs.launchpad.net/asdf/+bug/485687 7380 7381(uiop/package:define-package :asdf/upgrade 7382 (:recycle :asdf/upgrade :asdf) 7383 (:use :uiop/common-lisp :uiop) 7384 (:export 7385 #:asdf-version #:*previous-asdf-versions* #:*asdf-version* 7386 #:asdf-message #:*verbose-out* 7387 #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* 7388 #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf 7389 ;; There will be no symbol left behind! 7390 #:with-asdf-deprecation 7391 #:intern*) 7392 (:import-from :uiop/package #:intern* #:find-symbol*)) 7393(in-package :asdf/upgrade) 7394 7395;;; Special magic to detect if this is an upgrade 7396 7397(with-upgradability () 7398 (defun asdf-version () 7399 "Exported interface to the version of ASDF currently installed. A string. 7400You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." 7401 (when (find-package :asdf) 7402 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) 7403 (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) 7404 (rev (and revsym (boundp revsym) (symbol-value revsym)))) 7405 (etypecase rev 7406 (string rev) 7407 (cons (format nil "~{~D~^.~}" rev)) 7408 (null "1.0")))))) 7409 ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, 7410 ;; from which ASDF was upgraded. 7411 ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. 7412 (defvar *previous-asdf-versions* 7413 (let ((previous (asdf-version))) 7414 (when previous 7415 ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package. 7416 (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. 7417 (let ((away (format nil "~A-~A" :asdf previous))) 7418 (rename-package :asdf away) 7419 (when *load-verbose* 7420 (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))) 7421 (list previous)))) 7422 ;; This public variable will be bound shortly to the currently loaded version of ASDF. 7423 (defvar *asdf-version* nil) 7424 ;; We need to clear systems from versions older than the one in this (private) parameter. 7425 ;; The latest incompatible defclass is 2.32.13 renaming a slot in component, 7426 ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses). 7427 ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below). 7428 (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2") 7429 ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages 7430 (defvar *verbose-out* nil) 7431 ;; Private function by which ASDF outputs progress messages and warning messages: 7432 (defun asdf-message (format-string &rest format-args) 7433 (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) 7434 ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: 7435 (defvar *post-upgrade-cleanup-hook* ()) 7436 ;; Private function to detect whether the current upgrade counts as an incompatible 7437 ;; data schema upgrade implying the need to drop data. 7438 (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) 7439 (and *previous-asdf-versions* 7440 (version< (first *previous-asdf-versions*) oldest-compatible-version))) 7441 ;; Private variant of defparameter that works in presence of incompatible upgrades: 7442 ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), 7443 ;; but behaves like defparameter if in presence of an incompatible upgrade. 7444 (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) 7445 (let* ((name (string-trim "*" var)) 7446 (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) 7447 `(progn 7448 (defun ,valfun () ,value) 7449 (defvar ,var (,valfun) ,@(ensure-list docstring)) 7450 (when (upgrading-p ,version) 7451 (setf ,var (,valfun)))))) 7452 ;; Private macro to declare sections of code that are only compiled and run when upgrading. 7453 ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, 7454 ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. 7455 (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) 7456 (upgrading-p `(upgrading-p ,version)) when) &body body) 7457 "A wrapper macro for code that should only be run when upgrading a 7458previously-loaded version of ASDF." 7459 `(with-upgradability () 7460 (when (and ,upgrading-p ,@(when when `(,when))) 7461 (handler-bind ((style-warning #'muffle-warning)) 7462 (eval '(progn ,@body)))))) 7463 ;; Only now can we safely update the version. 7464 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. 7465 ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 7466 ;; can help you do these changes in synch (look at the source for documentation). 7467 ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp. 7468 ;; "3.4" would be the general branch for major version 3, minor version 4. 7469 ;; "3.4.5" would be an official release in the 3.4 branch. 7470 ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. 7471 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 7472 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 7473 (asdf-version "3.2.1") 7474 (existing-version (asdf-version))) 7475 (setf *asdf-version* asdf-version) 7476 (when (and existing-version (not (equal asdf-version existing-version))) 7477 (push existing-version *previous-asdf-versions*) 7478 (when (or *verbose-out* *load-verbose*) 7479 (format (or *verbose-out* *trace-output*) 7480 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") 7481 existing-version asdf-version))))) 7482 7483;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined 7484(when-upgrading () 7485 (let ((redefined-functions ;; List of functions that changes incompatibly since 2.27: 7486 ;; gf signature changed (should NOT happen), defun that became a generic function, 7487 ;; method removed that will mess up with new ones (especially :around :before :after, 7488 ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. 7489 ;; NB: it's too late to do anything about functions in UIOP! 7490 ;; If you introduce some critical incompatibility there, you must change the function name. 7491 ;; Note that we don't need do anything about functions that changed incompatibly 7492 ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. 7493 ;; Also note that we don't include the defgeneric=>defun, because they are 7494 ;; done directly with defun* and need not trigger a punt on data. 7495 ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 7496 '(#:component-depends-on #:input-files ;; methods removed before 3.1.2 7497 #:find-component ;; gf modified in 3.1.7.20 7498 )) 7499 (redefined-classes 7500 ;; redefining the classes causes interim circularities 7501 ;; with the old ASDF during upgrade, and many implementations bork 7502 #-clozure () 7503 #+clozure 7504 '((#:compile-concatenated-source-op (#:operation) ()) 7505 (#:compile-bundle-op (#:operation) ()) 7506 (#:concatenate-source-op (#:operation) ()) 7507 (#:dll-op (#:operation) ()) 7508 (#:lib-op (#:operation) ()) 7509 (#:monolithic-compile-bundle-op (#:operation) ()) 7510 (#:monolithic-concatenate-source-op (#:operation) ())))) 7511 (loop :for name :in redefined-functions 7512 :for sym = (find-symbol* name :asdf nil) 7513 :do (when sym (fmakunbound sym))) 7514 (labels ((asym (x) (multiple-value-bind (s p) 7515 (if (consp x) (values (car x) (cadr x)) (values x :asdf)) 7516 (find-symbol* s p nil))) 7517 (asyms (l) (mapcar #'asym l))) 7518 (loop* :for (name superclasses slots) :in redefined-classes 7519 :for sym = (find-symbol* name :asdf nil) 7520 :when (and sym (find-class sym)) 7521 :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) 7522 7523 7524;;; Self-upgrade functions 7525(with-upgradability () 7526 ;; This private function is called at the end of asdf/footer and ensures that, 7527 ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. 7528 (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) 7529 (let ((new-version (asdf-version))) 7530 (unless (equal old-version new-version) 7531 (push new-version *previous-asdf-versions*) 7532 (when old-version 7533 (if (version<= new-version old-version) 7534 (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") 7535 old-version new-version) 7536 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 7537 old-version new-version)) 7538 ;; In case the previous version was too old to be forward-compatible, clear systems. 7539 ;; TODO: if needed, we may have to define a separate hook to run 7540 ;; in case of forward-compatible upgrade. 7541 ;; Or to move the tests forward-compatibility test inside each hook function? 7542 (unless (version<= *oldest-forward-compatible-asdf-version* old-version) 7543 (call-functions (reverse *post-upgrade-cleanup-hook*))) 7544 t)))) 7545 7546 (defun upgrade-asdf () 7547 "Try to upgrade of ASDF. If a different version was used, return T. 7548 We need do that before we operate on anything that may possibly depend on ASDF." 7549 (let ((*load-print* nil) 7550 (*compile-print* nil)) 7551 (handler-bind (((or style-warning) #'muffle-warning)) 7552 (symbol-call :asdf :load-system :asdf :verbose nil)))) 7553 7554 (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) 7555 `(with-upgradability () 7556 (with-deprecation ((version-deprecation *asdf-version* ,@keys)) 7557 ,@body)))) 7558;;;; ------------------------------------------------------------------------- 7559;;;; Session cache 7560 7561(uiop/package:define-package :asdf/cache 7562 (:use :uiop/common-lisp :uiop :asdf/upgrade) 7563 (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp 7564 #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache 7565 #:do-asdf-cache #:normalize-namestring 7566 #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* 7567 #:clear-configuration-and-retry #:retry)) 7568(in-package :asdf/cache) 7569 7570;;; The ASDF session cache is used to memoize some computations. It is instrumental in achieving: 7571;; * Consistency in the view of the world relied on by ASDF within a given session. 7572;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops 7573;; (a.k.a. stack overflows) and other erratic behavior. 7574;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and 7575;; no expensive recomputations of transitive dependencies for some input-files or output-files. 7576;; * Testability of ASDF with the ability to fake timestamps without actually touching files. 7577 7578(with-upgradability () 7579 ;; The session cache variable. 7580 ;; NIL when outside a session, an equal hash-table when inside a session. 7581 (defvar *asdf-cache* nil) 7582 7583 ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. 7584 ;; Return those values. 7585 (defun set-asdf-cache-entry (key value-list) 7586 (values-list (if *asdf-cache* 7587 (setf (gethash key *asdf-cache*) value-list) 7588 value-list))) 7589 7590 ;; Unset the session cache entry for KEY, when inside a session. 7591 (defun unset-asdf-cache-entry (key) 7592 (when *asdf-cache* 7593 (remhash key *asdf-cache*))) 7594 7595 ;; Consult the session cache entry for KEY if present and in a session; 7596 ;; if not present, compute it by calling the THUNK, 7597 ;; and set the session cache entry accordingly, if in a session. 7598 ;; Return the values from the cache and/or the thunk computation. 7599 (defun consult-asdf-cache (key &optional thunk) 7600 (if *asdf-cache* 7601 (multiple-value-bind (results foundp) (gethash key *asdf-cache*) 7602 (if foundp 7603 (values-list results) 7604 (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) 7605 (call-function thunk))) 7606 7607 ;; Syntactic sugar for consult-asdf-cache 7608 (defmacro do-asdf-cache (key &body body) 7609 `(consult-asdf-cache ,key #'(lambda () ,@body))) 7610 7611 ;; Compute inside a ASDF session with a cache. 7612 ;; First, make sure an ASDF session is underway, by binding the session cache variable 7613 ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). 7614 ;; Second, if a new session was started, establish restarts for retrying the overall computation. 7615 ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache 7616 ;; entry isn't found, or just call the THUNK if no KEY was specified. 7617 (defun call-with-asdf-cache (thunk &key override key) 7618 (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) 7619 (if (and *asdf-cache* (not override)) 7620 (funcall fun) 7621 (loop 7622 (restart-case 7623 (let ((*asdf-cache* (make-hash-table :test 'equal))) 7624 (return (funcall fun))) 7625 (retry () 7626 :report (lambda (s) 7627 (format s (compatfmt "~@<Retry ASDF operation.~@:>")))) 7628 (clear-configuration-and-retry () 7629 :report (lambda (s) 7630 (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>"))) 7631 (clear-configuration))))))) 7632 7633 ;; Syntactic sugar for call-with-asdf-cache 7634 (defmacro with-asdf-cache ((&key key override) &body body) 7635 `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) 7636 7637 7638 ;;; Define specific accessor for file (date) stamp. 7639 7640 ;; Normalize a namestring for use as a key in the session cache. 7641 (defun normalize-namestring (pathname) 7642 (let ((resolved (resolve-symlinks* 7643 (ensure-absolute-pathname 7644 (physicalize-pathname pathname) 7645 'get-pathname-defaults)))) 7646 (with-pathname-defaults () (namestring resolved)))) 7647 7648 ;; Compute the file stamp for a normalized namestring 7649 (defun compute-file-stamp (normalized-namestring) 7650 (with-pathname-defaults () 7651 (safe-file-write-date normalized-namestring))) 7652 7653 ;; Override the time STAMP associated to a given FILE in the session cache. 7654 ;; If no STAMP is specified, recompute a new one from the filesystem. 7655 (defun register-file-stamp (file &optional (stamp nil stampp)) 7656 (let* ((namestring (normalize-namestring file)) 7657 (stamp (if stampp stamp (compute-file-stamp namestring)))) 7658 (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) 7659 7660 ;; Get or compute a memoized stamp for given FILE from the session cache. 7661 (defun get-file-stamp (file) 7662 (when file 7663 (let ((namestring (normalize-namestring file))) 7664 (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))) 7665 7666;;;; ------------------------------------------------------------------------- 7667;;;; Components 7668 7669(uiop/package:define-package :asdf/component 7670 (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) 7671 (:use :uiop/common-lisp :uiop :asdf/upgrade) 7672 (:export 7673 #:component #:component-find-path 7674 #:component-name #:component-pathname #:component-relative-pathname 7675 #:component-parent #:component-system #:component-parent-pathname 7676 #:child-component #:parent-component #:module 7677 #:file-component 7678 #:source-file #:c-source-file #:java-source-file 7679 #:static-file #:doc-file #:html-file 7680 #:file-type 7681 #:source-file-type #:source-file-explicit-type ;; backward-compatibility 7682 #:component-in-order-to #:component-sideway-dependencies 7683 #:component-if-feature #:around-compile-hook 7684 #:component-description #:component-long-description 7685 #:component-version #:version-satisfies 7686 #:component-inline-methods ;; backward-compatibility only. DO NOT USE! 7687 #:component-operation-times ;; For internal use only. 7688 ;; portable ASDF encoding and implementation-specific external-format 7689 #:component-external-format #:component-encoding 7690 #:component-children-by-name #:component-children #:compute-children-by-name 7691 #:component-build-operation 7692 #:module-default-component-class 7693 #:module-components ;; backward-compatibility. DO NOT USE. 7694 #:sub-components 7695 7696 ;; conditions 7697 #:system-definition-error ;; top level, moved here because this is the earliest place for it. 7698 #:duplicate-names 7699 7700 ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes 7701 #:name #:version #:description #:long-description #:author #:maintainer #:licence 7702 #:components-by-name #:components #:children #:children-by-name 7703 #:default-component-class #:source-file 7704 #:defsystem-depends-on ; This symbol retained for backward compatibility. 7705 #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods 7706 #:relative-pathname #:absolute-pathname #:operation-times #:around-compile 7707 #:%encoding #:properties #:component-properties #:parent)) 7708(in-package :asdf/component) 7709 7710(with-upgradability () 7711 (defgeneric component-name (component) 7712 (:documentation "Name of the COMPONENT, unique relative to its parent")) 7713 (defgeneric component-system (component) 7714 (:documentation "Top-level system containing the COMPONENT")) 7715 (defgeneric component-pathname (component) 7716 (:documentation "Pathname of the COMPONENT if any, or NIL.")) 7717 (defgeneric component-relative-pathname (component) 7718 ;; in ASDF4, rename that to component-specified-pathname ? 7719 (:documentation "Specified pathname of the COMPONENT, 7720intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. 7721Despite the function's name, the return value can be an absolute pathname, in which case the merge 7722will leave it unmodified.")) 7723 (defgeneric component-external-format (component) 7724 (:documentation "The external-format of the COMPONENT. 7725By default, deduced from the COMPONENT-ENCODING.")) 7726 (defgeneric component-encoding (component) 7727 (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported. 7728Use asdf-encodings to support more encodings.")) 7729 (defgeneric version-satisfies (component version) 7730 (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent 7731as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL.")) 7732 (defgeneric component-version (component) 7733 (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated 7734natural numbers, or NIL.")) 7735 (defgeneric (setf component-version) (new-version component) 7736 (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated 7737natural numbers, or NIL.")) 7738 (defgeneric component-parent (component) 7739 (:documentation "The parent of a child COMPONENT, 7740or NIL for top-level components (a.k.a. systems)")) 7741 ;; NIL is a designator for the absence of a component, in which case the parent is also absent. 7742 (defmethod component-parent ((component null)) nil) 7743 7744 ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. 7745 ;; TODO: find users, have them stop using that, remove it for ASDF4. 7746 (defgeneric source-file-type (component system) 7747 (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")) 7748 7749 (define-condition system-definition-error (error) () 7750 ;; [this use of :report should be redundant, but unfortunately it's not. 7751 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function 7752 ;; over print-object; this is always conditions::%print-condition for 7753 ;; condition objects, which in turn does inheritance of :report options at 7754 ;; run-time. fortunately, inheritance means we only need this kludge here in 7755 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] 7756 #+cmucl (:report print-object)) 7757 7758 (define-condition duplicate-names (system-definition-error) 7759 ((name :initarg :name :reader duplicate-names-name)) 7760 (:report (lambda (c s) 7761 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>") 7762 (duplicate-names-name c)))))) 7763 7764 7765(with-upgradability () 7766 (defclass component () 7767 ((name :accessor component-name :initarg :name :type string :documentation 7768 "Component name: designator for a string composed of portable pathname characters") 7769 ;; We might want to constrain version with 7770 ;; :type (and string (satisfies parse-version)) 7771 ;; but we cannot until we fix all systems that don't use it correctly! 7772 (version :accessor component-version :initarg :version :initform nil) 7773 (description :accessor component-description :initarg :description :initform nil) 7774 (long-description :accessor component-long-description :initarg :long-description :initform nil) 7775 (sideway-dependencies :accessor component-sideway-dependencies :initform nil) 7776 (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) 7777 ;; In the ASDF object model, dependencies exist between *actions*, 7778 ;; where an action is a pair of an operation and a component. 7779 ;; Dependencies are represented as alists of operations 7780 ;; to a list where each entry is a pair of an operation and a list of component specifiers. 7781 ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: 7782 ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. 7783 ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) 7784 ;; and do-first things that modify the current image (such as loading a fasl). 7785 ;; These are now unified because we now correctly propagate timestamps between dependencies. 7786 ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017, 7787 ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains. 7788 ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! 7789 ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. 7790 ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. 7791 ;; See our ASDF 2 paper for more complete explanations. 7792 (in-order-to :initform nil :initarg :in-order-to 7793 :accessor component-in-order-to) 7794 ;; Methods defined using the "inline" style inside a defsystem form: 7795 ;; we store them here so we can delete them when the system is re-evaluated. 7796 (inline-methods :accessor component-inline-methods :initform nil) 7797 ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. 7798 ;; There is no initform and no direct accessor for this specified pathname, 7799 ;; so we only access the information through appropriate methods, after it has been processed. 7800 ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4. 7801 (relative-pathname :initarg :pathname) 7802 ;; The absolute-pathname is computed based on relative-pathname and parent pathname. 7803 ;; The slot is but a cache used by component-pathname. 7804 (absolute-pathname) 7805 (operation-times :initform (make-hash-table) 7806 :accessor component-operation-times) 7807 (around-compile :initarg :around-compile) 7808 ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE! 7809 (properties :accessor component-properties :initarg :properties 7810 :initform nil) 7811 (%encoding :accessor %component-encoding :initform nil :initarg :encoding) 7812 ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. 7813 (parent :initarg :parent :initform nil :reader component-parent) 7814 (build-operation 7815 :initarg :build-operation :initform nil :reader component-build-operation)) 7816 (:documentation "Base class for all components of a build")) 7817 7818 (defun component-find-path (component) 7819 "Return a path from a root system to the COMPONENT. 7820The return value is a list of component NAMES; a list of strings." 7821 (check-type component (or null component)) 7822 (reverse 7823 (loop :for c = component :then (component-parent c) 7824 :while c :collect (component-name c)))) 7825 7826 (defmethod print-object ((c component) stream) 7827 (print-unreadable-object (c stream :type t :identity nil) 7828 (format stream "~{~S~^ ~}" (component-find-path c)))) 7829 7830 (defmethod component-system ((component component)) 7831 (if-let (system (component-parent component)) 7832 (component-system system) 7833 component))) 7834 7835 7836;;;; Component hierarchy within a system 7837;; The tree typically but not necessarily follows the filesystem hierarchy. 7838(with-upgradability () 7839 (defclass child-component (component) () 7840 (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of 7841a PARENT-COMPONENT.")) 7842 7843 (defclass file-component (child-component) 7844 ((type :accessor file-type :initarg :type)) ; no default 7845 (:documentation "a COMPONENT that represents a file")) 7846 (defclass source-file (file-component) 7847 ((type :accessor source-file-explicit-type ;; backward-compatibility 7848 :initform nil))) ;; NB: many systems have come to rely on this default. 7849 (defclass c-source-file (source-file) 7850 ((type :initform "c"))) 7851 (defclass java-source-file (source-file) 7852 ((type :initform "java"))) 7853 (defclass static-file (source-file) 7854 ((type :initform nil)) 7855 (:documentation "Component for a file to be included as is in the build output")) 7856 (defclass doc-file (static-file) ()) 7857 (defclass html-file (doc-file) 7858 ((type :initform "html"))) 7859 7860 (defclass parent-component (component) 7861 ((children 7862 :initform nil 7863 :initarg :components 7864 :reader module-components ; backward-compatibility 7865 :accessor component-children) 7866 (children-by-name 7867 :reader module-components-by-name ; backward-compatibility 7868 :accessor component-children-by-name) 7869 (default-component-class 7870 :initform nil 7871 :initarg :default-component-class 7872 :accessor module-default-component-class)) 7873 (:documentation "A PARENT-COMPONENT is a component that may have children."))) 7874 7875(with-upgradability () 7876 ;; (Private) Function that given a PARENT component, 7877 ;; the list of children of which has been initialized, 7878 ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name. 7879 ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated. 7880 (defun compute-children-by-name (parent &key only-if-needed-p) 7881 (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) 7882 (let ((hash (make-hash-table :test 'equal))) 7883 (setf (component-children-by-name parent) hash) 7884 (loop :for c :in (component-children parent) 7885 :for name = (component-name c) 7886 :for previous = (gethash name hash) 7887 :do (when previous (error 'duplicate-names :name name)) 7888 (setf (gethash name hash) c)) 7889 hash)))) 7890 7891(with-upgradability () 7892 (defclass module (child-component parent-component) 7893 (#+clisp (components)) ;; backward compatibility during upgrade only 7894 (:documentation "A module is a intermediate component with both a parent and children, 7895typically but not necessarily representing the files in a subdirectory of the build source."))) 7896 7897 7898;;;; component pathnames 7899(with-upgradability () 7900 (defgeneric component-parent-pathname (component) 7901 (:documentation "The pathname of the COMPONENT's parent, if any, or NIL")) 7902 (defmethod component-parent-pathname (component) 7903 (component-pathname (component-parent component))) 7904 7905 ;; The default method for component-pathname tries to extract a cached precomputed 7906 ;; absolute-pathname from the relevant slot, and if not, computes it by merging the 7907 ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute) 7908 ;; with the directory of the component-parent-pathname. 7909 (defmethod component-pathname ((component component)) 7910 (if (slot-boundp component 'absolute-pathname) 7911 (slot-value component 'absolute-pathname) 7912 (let ((pathname 7913 (merge-pathnames* 7914 (component-relative-pathname component) 7915 (pathname-directory-pathname (component-parent-pathname component))))) 7916 (unless (or (null pathname) (absolute-pathname-p pathname)) 7917 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>") 7918 pathname (component-find-path component))) 7919 (setf (slot-value component 'absolute-pathname) pathname) 7920 pathname))) 7921 7922 ;; Default method for component-relative-pathname: 7923 ;; combine the contents of slot relative-pathname (from specified initarg :pathname) 7924 ;; with the appropriate source-file-type, which defaults to the file-type of the component. 7925 (defmethod component-relative-pathname ((component component)) 7926 ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. 7927 ;; We ought to be able to extract this from the component alone with FILE-TYPE. 7928 ;; TODO: track who uses it in Quicklisp, and have them not use it anymore; 7929 ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge? 7930 (parse-unix-namestring 7931 (or (and (slot-boundp component 'relative-pathname) 7932 (slot-value component 'relative-pathname)) 7933 (component-name component)) 7934 :want-relative t 7935 :type (source-file-type component (component-system component)) 7936 :defaults (component-parent-pathname component))) 7937 7938 (defmethod source-file-type ((component parent-component) (system parent-component)) 7939 :directory) 7940 7941 (defmethod source-file-type ((component file-component) (system parent-component)) 7942 (file-type component))) 7943 7944 7945;;;; Encodings 7946(with-upgradability () 7947 (defmethod component-encoding ((c component)) 7948 (or (loop :for x = c :then (component-parent x) 7949 :while x :thereis (%component-encoding x)) 7950 (detect-encoding (component-pathname c)))) 7951 7952 (defmethod component-external-format ((c component)) 7953 (encoding-external-format (component-encoding c)))) 7954 7955 7956;;;; around-compile-hook 7957(with-upgradability () 7958 (defgeneric around-compile-hook (component) 7959 (:documentation "An optional hook function that will be called with one argument, a thunk. 7960The hook function must call the thunk, that will compile code from the component, and may or may not 7961also evaluate the compiled results. The hook function may establish dynamic variable bindings around 7962this compilation, or check its results, etc.")) 7963 (defmethod around-compile-hook ((c component)) 7964 (cond 7965 ((slot-boundp c 'around-compile) 7966 (slot-value c 'around-compile)) 7967 ((component-parent c) 7968 (around-compile-hook (component-parent c)))))) 7969 7970 7971;;;; version-satisfies 7972(with-upgradability () 7973 ;; short-circuit testing of null version specifications. 7974 ;; this is an all-pass, without warning 7975 (defmethod version-satisfies :around ((c t) (version null)) 7976 t) 7977 (defmethod version-satisfies ((c component) version) 7978 (unless (and version (slot-boundp c 'version) (component-version c)) 7979 (when version 7980 (warn "Requested version ~S but ~S has no version" version c)) 7981 (return-from version-satisfies nil)) 7982 (version-satisfies (component-version c) version)) 7983 7984 (defmethod version-satisfies ((cver string) version) 7985 (version<= version cver))) 7986 7987 7988;;; all sub-components (of a given type) 7989(with-upgradability () 7990 (defun sub-components (component &key (type t)) 7991 "Compute the transitive sub-components of given COMPONENT that are of given TYPE" 7992 (while-collecting (c) 7993 (labels ((recurse (x) 7994 (when (if-let (it (component-if-feature x)) (featurep it) t) 7995 (when (typep x type) 7996 (c x)) 7997 (when (typep x 'parent-component) 7998 (map () #'recurse (component-children x)))))) 7999 (recurse component))))) 8000 8001;;;; ------------------------------------------------------------------------- 8002;;;; Systems 8003 8004(uiop/package:define-package :asdf/system 8005 (:recycle :asdf :asdf/system) 8006 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) 8007 (:export 8008 #:system #:proto-system 8009 #:system-source-file #:system-source-directory #:system-relative-pathname 8010 #:reset-system 8011 #:system-description #:system-long-description 8012 #:system-author #:system-maintainer #:system-licence #:system-license 8013 #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on 8014 #:component-build-pathname #:build-pathname 8015 #:component-entry-point #:entry-point 8016 #:homepage #:system-homepage 8017 #:bug-tracker #:system-bug-tracker 8018 #:mailto #:system-mailto 8019 #:long-name #:system-long-name 8020 #:source-control #:system-source-control 8021 #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system 8022(in-package :asdf/system) 8023 8024(with-upgradability () 8025 ;; The method is actually defined in asdf/find-system, 8026 ;; but we declare the function here to avoid a forward reference. 8027 (defgeneric find-system (system &optional error-p) 8028 (:documentation "Given a system designator, find the actual corresponding system object. 8029If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. 8030A system designator is usually a string (conventionally all lowercase) or a symbol, designating 8031the same system as its downcased name; it can also be a system object (designating itself).")) 8032 (defgeneric system-source-file (system) 8033 (:documentation "Return the source file in which system is defined.")) 8034 ;; This is bad design, but was the easiest kluge I found to let the user specify that 8035 ;; some special actions create outputs at locations controled by the user that are not affected 8036 ;; by the usual output-translations. 8037 ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't 8038 ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert 8039 ;; *there* the ability of specifying special output paths, not in the system definition. 8040 (defgeneric component-build-pathname (component) 8041 (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the 8042output pathname for the action using the COMPONENT-BUILD-OPERATION. 8043 8044NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) 8045 8046 ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead? 8047 (defgeneric component-entry-point (component) 8048 (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call 8049(with no argument) when running an image dumped from the COMPONENT. 8050 8051NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) 8052 (defmethod component-entry-point ((c component)) 8053 nil)) 8054 8055 8056;;;; The system class 8057 8058(with-upgradability () 8059 (defclass proto-system () ; slots to keep when resetting a system 8060 ;; To preserve identity for all objects, we'd need keep the components slots 8061 ;; but also to modify parse-component-form to reset the recycled objects. 8062 ((name) (source-file) #|(children) (children-by-names)|#) 8063 (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when 8064a SYSTEM is redefined and its class is modified.")) 8065 8066 (defclass system (module proto-system) 8067 ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. 8068 (;; {,long-}description is now inherited from component, but we add the legacy accessors 8069 (description :accessor system-description) 8070 (long-description :accessor system-long-description) 8071 (author :accessor system-author :initarg :author :initform nil) 8072 (maintainer :accessor system-maintainer :initarg :maintainer :initform nil) 8073 (licence :accessor system-licence :initarg :licence 8074 :accessor system-license :initarg :license :initform nil) 8075 (homepage :accessor system-homepage :initarg :homepage :initform nil) 8076 (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil) 8077 (mailto :accessor system-mailto :initarg :mailto :initform nil) 8078 (long-name :accessor system-long-name :initarg :long-name :initform nil) 8079 ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. 8080 ;; I'm introducing the slot before the conventions are set for maximum compatibility. 8081 (source-control :accessor system-source-control :initarg :source-control :initform nil) 8082 (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) 8083 (build-pathname 8084 :initform nil :initarg :build-pathname :accessor component-build-pathname) 8085 (entry-point 8086 :initform nil :initarg :entry-point :accessor component-entry-point) 8087 (source-file :initform nil :initarg :source-file :accessor system-source-file) 8088 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on 8089 :initform nil) 8090 ;; these two are specially set in parse-component-form, so have no :INITARGs. 8091 (depends-on :reader system-depends-on :initform nil) 8092 (weakly-depends-on :reader system-weakly-depends-on :initform nil)) 8093 (:documentation "SYSTEM is the base class for top-level components that users may request 8094ASDF to build.")) 8095 8096 8097 (defun reset-system (system &rest keys &key &allow-other-keys) 8098 "Erase any data from a SYSTEM except its basic identity, then reinitialize it 8099based on supplied KEYS." 8100 (change-class (change-class system 'proto-system) 'system) 8101 (apply 'reinitialize-instance system keys))) 8102 8103 8104;;;; Pathnames 8105 8106(with-upgradability () 8107 ;; Resolve a system designator to a system before extracting its system-source-file 8108 (defmethod system-source-file ((system-name string)) 8109 (system-source-file (find-system system-name))) 8110 (defmethod system-source-file ((system-name symbol)) 8111 (when system-name 8112 (system-source-file (find-system system-name)))) 8113 8114 (defun system-source-directory (system-designator) 8115 "Return a pathname object corresponding to the directory 8116in which the system specification (.asd file) is located." 8117 (pathname-directory-pathname (system-source-file system-designator))) 8118 8119 (defun* (system-relative-pathname) (system name &key type) 8120 "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, 8121return the absolute pathname of a corresponding file under that system's source code pathname." 8122 (subpathname (system-source-directory system) name :type type)) 8123 8124 (defmethod component-pathname ((system system)) 8125 "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, 8126return the absolute pathname of a corresponding file under that system's source code pathname." 8127 (let ((pathname (or (call-next-method) (system-source-directory system)))) 8128 (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age 8129 (slot-value system 'relative-pathname)) ;; systems that directly access this slot. 8130 (setf (slot-value system 'relative-pathname) pathname)) 8131 pathname)) 8132 8133 ;; The default method of component-relative-pathname for a system: 8134 ;; if a pathname was specified in the .asd file, it must be relative to the .asd file 8135 ;; (actually, to its truename* if *resolve-symlinks* it true, the default). 8136 ;; The method will return an *absolute* pathname, once again showing that the historical name 8137 ;; component-relative-pathname is misleading and should have been component-specified-pathname. 8138 (defmethod component-relative-pathname ((system system)) 8139 (parse-unix-namestring 8140 (and (slot-boundp system 'relative-pathname) 8141 (slot-value system 'relative-pathname)) 8142 :want-relative t 8143 :type :directory 8144 :ensure-absolute t 8145 :defaults (system-source-directory system))) 8146 8147 ;; A system has no parent; if some method wants to make a path "relative to its parent", 8148 ;; it will instead be relative to the system itself. 8149 (defmethod component-parent-pathname ((system system)) 8150 (system-source-directory system)) 8151 8152 ;; Most components don't have a specified component-build-pathname, and therefore 8153 ;; no magic redirection of their output that disregards the output-translations. 8154 (defmethod component-build-pathname ((c component)) 8155 nil)) 8156 8157;;;; ------------------------------------------------------------------------- 8158;;;; Finding systems 8159 8160(uiop/package:define-package :asdf/find-system 8161 (:recycle :asdf/find-system :asdf) 8162 (:use :uiop/common-lisp :uiop :asdf/upgrade 8163 :asdf/cache :asdf/component :asdf/system) 8164 (:export 8165 #:remove-entry-from-registry #:coerce-entry-to-directory 8166 #:coerce-name #:primary-system-name #:coerce-filename 8167 #:find-system #:locate-system #:load-asd 8168 #:system-registered-p #:registered-system #:register-system 8169 #:registered-systems* #:registered-systems 8170 #:clear-system #:map-systems 8171 #:missing-component #:missing-requires #:missing-parent 8172 #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error 8173 #:load-system-definition-error #:error-name #:error-pathname #:error-condition 8174 #:*system-definition-search-functions* #:search-for-system-definition 8175 #:*central-registry* #:probe-asd #:sysdef-central-registry-search 8176 #:find-system-if-being-defined 8177 #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed 8178 #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* 8179 #:mark-component-preloaded ;; forward reference to asdf/operate 8180 #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* 8181 #:*defined-systems* #:clear-defined-systems 8182 ;; defined in source-registry, but specially mentioned here: 8183 #:initialize-source-registry #:sysdef-source-registry-search)) 8184(in-package :asdf/find-system) 8185 8186(with-upgradability () 8187 (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference 8188 8189 (define-condition missing-component (system-definition-error) 8190 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) 8191 (parent :initform nil :reader missing-parent :initarg :parent))) 8192 8193 (define-condition formatted-system-definition-error (system-definition-error) 8194 ((format-control :initarg :format-control :reader format-control) 8195 (format-arguments :initarg :format-arguments :reader format-arguments)) 8196 (:report (lambda (c s) 8197 (apply 'format s (format-control c) (format-arguments c))))) 8198 8199 (define-condition load-system-definition-error (system-definition-error) 8200 ((name :initarg :name :reader error-name) 8201 (pathname :initarg :pathname :reader error-pathname) 8202 (condition :initarg :condition :reader error-condition)) 8203 (:report (lambda (c s) 8204 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") 8205 (error-name c) (error-pathname c) (error-condition c))))) 8206 8207 (defun sysdef-error (format &rest arguments) 8208 (error 'formatted-system-definition-error :format-control 8209 format :format-arguments arguments)) 8210 8211 8212 ;;; Canonicalizing system names 8213 8214 (defun coerce-name (name) 8215 "Given a designator for a component NAME, return the name as a string. 8216The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), 8217a SYMBOL (designing its name, downcased), or a STRING (designing itself)." 8218 (typecase name 8219 (component (component-name name)) 8220 (symbol (string-downcase name)) 8221 (string name) 8222 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) 8223 8224 (defun primary-system-name (name) 8225 "Given a system designator NAME, return the name of the corresponding primary system, 8226after which the .asd file is named. That's the first component when dividing the name 8227as a string by / slashes." 8228 (first (split-string (coerce-name name) :separator "/"))) 8229 8230 (defun coerce-filename (name) 8231 "Coerce a system designator NAME into a string suitable as a filename component. 8232The (current) transformation is to replace characters /:\\ each by --, 8233the former being forbidden in a filename component. 8234NB: The onus is unhappily on the user to avoid clashes." 8235 (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) 8236 8237 8238 ;;; Registry of Defined Systems 8239 8240 (defvar *defined-systems* (make-hash-table :test 'equal) 8241 "This is a hash table whose keys are strings -- the 8242names of systems -- and whose values are pairs, the first 8243element of which is a universal-time indicating when the 8244system definition was last updated, and the second element 8245of which is a system object. 8246 A system is referred to as \"registered\" if it is present 8247in this table.") 8248 8249 (defun system-registered-p (name) 8250 "Return a generalized boolean that is true if a system of given NAME was registered already. 8251NAME is a system designator, to be normalized by COERCE-NAME. 8252The value returned if true is a pair of a timestamp and a system object." 8253 (gethash (coerce-name name) *defined-systems*)) 8254 8255 (defun registered-system (name) 8256 "Return a system of given NAME that was registered already, 8257if such a system exists. NAME is a system designator, to be 8258normalized by COERCE-NAME. The value returned is a system object, 8259or NIL if not found." 8260 (cdr (system-registered-p name))) 8261 8262 (defun registered-systems* () 8263 "Return a list containing every registered system (as a system object)." 8264 (loop :for registered :being :the :hash-values :of *defined-systems* 8265 :collect (cdr registered))) 8266 8267 (defun registered-systems () 8268 "Return a list of the names of every registered system." 8269 (mapcar 'coerce-name (registered-systems*))) 8270 8271 (defun register-system (system) 8272 "Given a SYSTEM object, register it." 8273 (check-type system system) 8274 (let ((name (component-name system))) 8275 (check-type name string) 8276 (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) 8277 (unless (eq system (registered-system name)) 8278 (setf (gethash name *defined-systems*) 8279 (cons (ignore-errors (get-file-stamp (system-source-file system))) 8280 system))))) 8281 8282 (defun map-systems (fn) 8283 "Apply FN to each defined system. 8284 8285FN should be a function of one argument. It will be 8286called with an object of type asdf:system." 8287 (loop :for registered :being :the :hash-values :of *defined-systems* 8288 :do (funcall fn (cdr registered)))) 8289 8290 8291 ;;; Preloaded systems: in the image even if you can't find source files backing them. 8292 8293 (defvar *preloaded-systems* (make-hash-table :test 'equal) 8294 "Registration table for preloaded systems.") 8295 8296 (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/operate 8297 8298 (defun make-preloaded-system (name keys) 8299 "Make a preloaded system of given NAME with build information from KEYS" 8300 (let ((system (apply 'make-instance (getf keys :class 'system) 8301 :name name :source-file (getf keys :source-file) 8302 (remove-plist-keys '(:class :name :source-file) keys)))) 8303 (mark-component-preloaded system) 8304 system)) 8305 8306 (defun sysdef-preloaded-system-search (requested) 8307 "If REQUESTED names a system registered as preloaded, return a new system 8308with its registration information." 8309 (let ((name (coerce-name requested))) 8310 (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) 8311 (when foundp 8312 (make-preloaded-system name keys))))) 8313 8314 (defun ensure-preloaded-system-registered (name) 8315 "If there isn't a registered _defined_ system of given NAME, 8316and a there is a registered _preloaded_ system of given NAME, 8317then define and register said preloaded system." 8318 (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) 8319 (register-system system))) 8320 8321 (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) 8322 "Register a system as being preloaded. If the system has not been loaded from the filesystem 8323yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be 8324registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). 8325If VERSION is the default T, and a system was already loaded, then its version will be preserved." 8326 (let ((name (coerce-name system-name))) 8327 (when (eql version t) 8328 (if-let (system (registered-system name)) 8329 (setf (getf keys :version) (component-version system)))) 8330 (setf (gethash name *preloaded-systems*) keys) 8331 (ensure-preloaded-system-registered system-name))) 8332 8333 8334 ;;; Immutable systems: in the image and can't be reloaded from source. 8335 8336 (defvar *immutable-systems* nil 8337 "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, 8338i.e. already loaded in memory and not to be refreshed from the filesystem. 8339They will be treated specially by find-system, and passed as :force-not argument to make-plan. 8340 8341For instance, to can deliver an image with many systems precompiled, that *will not* check the 8342filesystem for them every time a user loads an extension, what more risk a problematic upgrade 8343 or catastrophic downgrade, before you dump an image, you may use: 8344 (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) 8345 8346Note that direct access to this variable from outside ASDF is not supported. 8347Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and 8348contact maintainers if you need a stable API to do more than that.") 8349 8350 (defun sysdef-immutable-system-search (requested) 8351 (let ((name (coerce-name requested))) 8352 (when (and *immutable-systems* (gethash name *immutable-systems*)) 8353 (or (registered-system requested) 8354 (error 'formatted-system-definition-error 8355 :format-control "Requested system ~A registered as an immutable-system, ~ 8356but not even registered as defined" 8357 :format-arguments (list name)))))) 8358 8359 (defun register-immutable-system (system-name &rest keys) 8360 "Register SYSTEM-NAME as preloaded and immutable. 8361It will automatically be considered as passed to FORCE-NOT in a plan." 8362 (let ((system-name (coerce-name system-name))) 8363 (apply 'register-preloaded-system system-name keys) 8364 (unless *immutable-systems* 8365 (setf *immutable-systems* (list-to-hash-set nil))) 8366 (setf (gethash system-name *immutable-systems*) t))) 8367 8368 8369 ;;; Making systems undefined. 8370 8371 (defun clear-system (system) 8372 "Clear the entry for a SYSTEM in the database of systems previously defined. 8373However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), 8374then a new system with the same name will be defined and registered in its place 8375from which build details will have been cleared. 8376Note that this does NOT in any way cause any of the code of the system to be unloaded. 8377Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." 8378 ;; There is no "unload" operation in Common Lisp, and 8379 ;; a general such operation cannot be portably written, 8380 ;; considering how much CL relies on side-effects to global data structures. 8381 (let ((name (coerce-name system))) 8382 (remhash name *defined-systems*) 8383 (unset-asdf-cache-entry `(find-system ,name)) 8384 (not (ensure-preloaded-system-registered name)))) 8385 8386 (defun clear-defined-systems () 8387 "Clear all currently registered defined systems. 8388Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." 8389 (loop :for name :being :the :hash-keys :of *defined-systems* 8390 :unless (member name '("asdf" "uiop") :test 'equal) :do (clear-system name))) 8391 8392 8393 ;;; Searching for system definitions 8394 8395 ;; For the sake of keeping things reasonably neat, we adopt a convention that 8396 ;; only symbols are to be pushed to this list (rather than e.g. function objects), 8397 ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- 8398 (defvar *system-definition-search-functions* '() 8399 "A list that controls the ways that ASDF looks for system definitions. 8400It contains symbols to be funcalled in order, with a requested system name as argument, 8401until one returns a non-NIL result (if any), which must then be a fully initialized system object 8402with that name.") 8403 8404 ;; Initialize and/or upgrade the *system-definition-search-functions* 8405 ;; so it doesn't contain obsolete symbols, and does contain the current ones. 8406 (defun cleanup-system-definition-search-functions () 8407 (setf *system-definition-search-functions* 8408 (append 8409 ;; Remove known-incompatible sysdef functions from old versions of asdf. 8410 ;; Order matters, so we can't just use set-difference. 8411 (let ((obsolete 8412 '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) 8413 (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) 8414 ;; Tuck our defaults at the end of the list if they were absent. 8415 ;; This is imperfect, in case they were removed on purpose, 8416 ;; but then it will be the responsibility of whoever removes these symmbols 8417 ;; to upgrade asdf before he does such a thing rather than after. 8418 (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) 8419 '(sysdef-central-registry-search 8420 sysdef-source-registry-search))))) 8421 (cleanup-system-definition-search-functions) 8422 8423 ;; This (private) function does the search for a system definition using *s-d-s-f*; 8424 ;; it is to be called by locate-system. 8425 (defun search-for-system-definition (system) 8426 ;; Search for valid definitions of the system available in the current session. 8427 ;; Previous definitions as registered in *defined-systems* MUST NOT be considered; 8428 ;; they will be reconciled by locate-system then find-system. 8429 ;; There are two special treatments: first, specially search for objects being defined 8430 ;; in the current session, to avoid definition races between several files; 8431 ;; second, specially search for immutable systems, so they cannot be redefined. 8432 ;; Finally, use the search functions specified in *system-definition-search-functions*. 8433 (let ((name (coerce-name system))) 8434 (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) 8435 (try 'find-system-if-being-defined) 8436 (try 'sysdef-immutable-system-search) 8437 (map () #'try *system-definition-search-functions*)))) 8438 8439 8440 ;;; The legacy way of finding a system: the *central-registry* 8441 8442 ;; This variable contains a list of directories to be lazily searched for the requested asd 8443 ;; by sysdef-central-registry-search. 8444 (defvar *central-registry* nil 8445 "A list of 'system directory designators' ASDF uses to find systems. 8446 8447A 'system directory designator' is a pathname or an expression 8448which evaluates to a pathname. For example: 8449 8450 (setf asdf:*central-registry* 8451 (list '*default-pathname-defaults* 8452 #p\"/home/me/cl/systems/\" 8453 #p\"/usr/share/common-lisp/systems/\")) 8454 8455This variable is for backward compatibility. 8456Going forward, we recommend new users should be using the source-registry.") 8457 8458 ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. 8459 ;; Return the truename of that file if it is found and TRUENAME is true. 8460 ;; Return NIL if the file is not found. 8461 ;; On Windows, follow shortcuts to .asd files. 8462 (defun probe-asd (name defaults &key truename) 8463 (block nil 8464 (when (directory-pathname-p defaults) 8465 (if-let (file (probe-file* 8466 (ensure-absolute-pathname 8467 (parse-unix-namestring name :type "asd") 8468 #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) 8469 nil) 8470 :truename truename)) 8471 (return file)) 8472 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) 8473 (os-cond 8474 ((os-windows-p) 8475 (when (physical-pathname-p defaults) 8476 (let ((shortcut 8477 (make-pathname 8478 :defaults defaults :case :local 8479 :name (strcat name ".asd") 8480 :type "lnk"))) 8481 (when (probe-file* shortcut) 8482 (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) 8483 8484 ;; Function to push onto *s-d-s-f* to use the *central-registry* 8485 (defun sysdef-central-registry-search (system) 8486 (let ((name (primary-system-name system)) 8487 (to-remove nil) 8488 (to-replace nil)) 8489 (block nil 8490 (unwind-protect 8491 (dolist (dir *central-registry*) 8492 (let ((defaults (eval dir)) 8493 directorized) 8494 (when defaults 8495 (cond ((directory-pathname-p defaults) 8496 (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) 8497 (when file 8498 (return file)))) 8499 (t 8500 (restart-case 8501 (let* ((*print-circle* nil) 8502 (message 8503 (format nil 8504 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>") 8505 system dir defaults))) 8506 (error message)) 8507 (remove-entry-from-registry () 8508 :report "Remove entry from *central-registry* and continue" 8509 (push dir to-remove)) 8510 (coerce-entry-to-directory () 8511 :test (lambda (c) (declare (ignore c)) 8512 (and (not (directory-pathname-p defaults)) 8513 (directory-pathname-p 8514 (setf directorized 8515 (ensure-directory-pathname defaults))))) 8516 :report (lambda (s) 8517 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") 8518 directorized dir)) 8519 (push (cons dir directorized) to-replace)))))))) 8520 ;; cleanup 8521 (dolist (dir to-remove) 8522 (setf *central-registry* (remove dir *central-registry*))) 8523 (dolist (pair to-replace) 8524 (let* ((current (car pair)) 8525 (new (cdr pair)) 8526 (position (position current *central-registry*))) 8527 (setf *central-registry* 8528 (append (subseq *central-registry* 0 position) 8529 (list new) 8530 (subseq *central-registry* (1+ position)))))))))) 8531 8532 8533 ;;; Methods for find-system 8534 8535 ;; Reject NIL as a system designator. 8536 (defmethod find-system ((name null) &optional (error-p t)) 8537 (when error-p 8538 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) 8539 8540 ;; Default method for find-system: resolve the argument using COERCE-NAME. 8541 (defmethod find-system (name &optional (error-p t)) 8542 (find-system (coerce-name name) error-p)) 8543 8544 (defun find-system-if-being-defined (name) 8545 ;; This function finds systems being defined *in the current ASDF session*, as embodied by 8546 ;; its session cache, even before they are fully defined and registered in *defined-systems*. 8547 ;; The purpose of this function is to prevent races between two files that might otherwise 8548 ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. 8549 ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. 8550 ;; NB: this function depends on a corresponding side-effect in parse-defsystem; 8551 ;; the precise protocol between the two functions may change in the future (or not). 8552 (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) 8553 8554 (defun load-asd (pathname 8555 &key name (external-format (encoding-external-format (detect-encoding pathname))) 8556 &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) 8557 "Load system definitions from PATHNAME. 8558NAME if supplied is the name of a system expected to be defined in that file. 8559 8560Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." 8561 (with-asdf-cache () 8562 (with-standard-io-syntax 8563 (let ((*package* (find-package :asdf-user)) 8564 ;; Note that our backward-compatible *readtable* is 8565 ;; a global readtable that gets globally side-effected. Ouch. 8566 ;; Same for the *print-pprint-dispatch* table. 8567 ;; We should do something about that for ASDF3 if possible, or else ASDF4. 8568 (*readtable* readtable) 8569 (*print-pprint-dispatch* print-pprint-dispatch) 8570 (*print-readably* nil) 8571 (*default-pathname-defaults* 8572 ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. 8573 (pathname-directory-pathname (physicalize-pathname pathname)))) 8574 (handler-bind 8575 (((and error (not missing-component)) 8576 #'(lambda (condition) 8577 (error 'load-system-definition-error 8578 :name name :pathname pathname :condition condition)))) 8579 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") 8580 name pathname) 8581 (load* pathname :external-format external-format)))))) 8582 8583 (defvar *old-asdf-systems* (make-hash-table :test 'equal)) 8584 8585 ;; (Private) function to check that a system that was found isn't an asdf downgrade. 8586 ;; Returns T if everything went right, NIL if the system was an ASDF of the same or older version, 8587 ;; that shall not be loaded. Also issue a warning if it was a strictly older version of ASDF. 8588 (defun check-not-old-asdf-system (name pathname) 8589 (or (not (equal name "asdf")) 8590 (null pathname) 8591 (let* ((version-pathname (subpathname pathname "version.lisp-expr")) 8592 (version (and (probe-file* version-pathname :truename nil) 8593 (read-file-form version-pathname))) 8594 (old-version (asdf-version))) 8595 (cond 8596 ((version< old-version version) t) ;; newer version: good! 8597 ((equal old-version version) nil) ;; same version: don't load, but don't warn 8598 (t ;; old version: bad 8599 (ensure-gethash 8600 (list (namestring pathname) version) *old-asdf-systems* 8601 #'(lambda () 8602 (let ((old-pathname (system-source-file (registered-system "asdf")))) 8603 (warn "~@<~ 8604 You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ 8605 or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ 8606 ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ 8607 Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ 8608 and having an old version registered is a configuration error. ~ 8609 ASDF will ignore this configured system rather than downgrade itself. ~ 8610 In the future, you may want to either: ~ 8611 (a) upgrade this configured ASDF to a newer version, ~ 8612 (b) install a newer ASDF and register it in front of the former in your configuration, or ~ 8613 (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ 8614 Note that the older ASDF might be registered implicitly through configuration inherited ~ 8615 from your system installation, in which case you might have to specify ~ 8616 :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ 8617 or other source-registry configuration file, environment variable or lisp parameter. ~ 8618 Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ 8619 that you might want to upgrade (if a recent enough version is available) ~ 8620 or else remove altogether (since most implementations ship with a recent asdf); ~ 8621 if you lack the system administration rights to upgrade or remove this package, ~ 8622 then you might indeed want to either install and register a more recent version, ~ 8623 or use :ignore-inherited-configuration to avoid registering the old one. ~ 8624 Please consult ASDF documentation and/or experts.~@:>~%" 8625 old-version old-pathname version pathname)))) 8626 nil))))) ;; only issue the warning the first time, but always return nil 8627 8628 (defun locate-system (name) 8629 "Given a system NAME designator, try to locate where to load the system from. 8630Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME 8631FOUNDP is true when a system was found, 8632either a new unregistered one or a previously registered one. 8633FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. 8634PATHNAME when not null is a path from which to load the system, 8635either associated with FOUND-SYSTEM, or with the PREVIOUS system. 8636PREVIOUS when not null is a previously loaded SYSTEM object of same name. 8637PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." 8638 (with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful, 8639 ;; and keeping a negative cache was a bug (see lp#1335323), which required 8640 ;; explicit invalidation in clear-system and find-system (when unsucccessful). 8641 (let* ((name (coerce-name name)) 8642 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk 8643 (previous (cdr in-memory)) 8644 (previous (and (typep previous 'system) previous)) 8645 (previous-time (car in-memory)) 8646 (found (search-for-system-definition name)) 8647 (found-system (and (typep found 'system) found)) 8648 (pathname (ensure-pathname 8649 (or (and (typep found '(or pathname string)) (pathname found)) 8650 (system-source-file found-system) 8651 (system-source-file previous)) 8652 :want-absolute t :resolve-symlinks *resolve-symlinks*)) 8653 (foundp (and (or found-system pathname previous) t))) 8654 (check-type found (or null pathname system)) 8655 (unless (check-not-old-asdf-system name pathname) 8656 (check-type previous system) ;; asdf is preloaded, so there should be a previous one. 8657 (setf found-system nil pathname nil)) 8658 (values foundp found-system pathname previous previous-time)))) 8659 8660 ;; Main method for find-system: first, make sure the computation is memoized in a session cache. 8661 ;; unless the system is immutable, use locate-system to find the primary system; 8662 ;; reconcile the finding (if any) with any previous definition (in a previous session, 8663 ;; preloaded, with a previous configuration, or before filesystem changes), and 8664 ;; load a found .asd if appropriate. Finally, update registration table and return results. 8665 (defmethod find-system ((name string) &optional (error-p t)) 8666 (with-asdf-cache (:key `(find-system ,name)) 8667 (let ((primary-name (primary-system-name name))) 8668 (unless (equal name primary-name) 8669 (find-system primary-name nil))) 8670 (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)) 8671 (multiple-value-bind (foundp found-system pathname previous previous-time) 8672 (locate-system name) 8673 (assert (eq foundp (and (or found-system pathname previous) t))) 8674 (let ((previous-pathname (system-source-file previous)) 8675 (system (or previous found-system))) 8676 (when (and found-system (not previous)) 8677 (register-system found-system)) 8678 (when (and system pathname) 8679 (setf (system-source-file system) pathname)) 8680 (when (and pathname 8681 (let ((stamp (get-file-stamp pathname))) 8682 (and stamp 8683 (not (and previous 8684 (or (pathname-equal pathname previous-pathname) 8685 (and pathname previous-pathname 8686 (pathname-equal 8687 (physicalize-pathname pathname) 8688 (physicalize-pathname previous-pathname)))) 8689 (stamp<= stamp previous-time)))))) 8690 ;; Only load when it's a pathname that is different or has newer content. 8691 (load-asd pathname :name name))) 8692 ;; Try again after having loaded from disk if needed 8693 (let ((in-memory (system-registered-p name))) 8694 (cond 8695 (in-memory 8696 (when pathname 8697 (setf (car in-memory) (get-file-stamp pathname))) 8698 (cdr in-memory)) 8699 (error-p 8700 (error 'missing-component :requires name)) 8701 (t 8702 (return-from find-system nil))))))))) 8703;;;; ------------------------------------------------------------------------- 8704;;;; Finding components 8705 8706(uiop/package:define-package :asdf/find-component 8707 (:recycle :asdf/find-component :asdf) 8708 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache 8709 :asdf/component :asdf/system :asdf/find-system) 8710 (:export 8711 #:find-component 8712 #:resolve-dependency-name #:resolve-dependency-spec 8713 #:resolve-dependency-combination 8714 ;; Conditions 8715 #:missing-component #:missing-component-of-version #:retry 8716 #:missing-dependency #:missing-dependency-of-version 8717 #:missing-requires #:missing-parent 8718 #:missing-required-by #:missing-version)) 8719(in-package :asdf/find-component) 8720 8721;;;; Missing component conditions 8722 8723(with-upgradability () 8724 (define-condition missing-component-of-version (missing-component) 8725 ((version :initform nil :reader missing-version :initarg :version))) 8726 8727 (define-condition missing-dependency (missing-component) 8728 ((required-by :initarg :required-by :reader missing-required-by))) 8729 8730 (defmethod print-object ((c missing-dependency) s) 8731 (format s (compatfmt "~@<~A, required by ~A~@:>") 8732 (call-next-method c nil) (missing-required-by c))) 8733 8734 (define-condition missing-dependency-of-version (missing-dependency 8735 missing-component-of-version) 8736 ()) 8737 8738 (defmethod print-object ((c missing-component) s) 8739 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") 8740 (missing-requires c) 8741 (when (missing-parent c) 8742 (coerce-name (missing-parent c))))) 8743 8744 (defmethod print-object ((c missing-component-of-version) s) 8745 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") 8746 (missing-requires c) 8747 (missing-version c) 8748 (when (missing-parent c) 8749 (coerce-name (missing-parent c)))))) 8750 8751 8752;;;; Finding components 8753 8754(with-upgradability () 8755 (defgeneric find-component (base path &key registered) 8756 (:documentation "Find a component by resolving the PATH starting from BASE parent. 8757If REGISTERED is true, only search currently registered systems.")) 8758 (defgeneric resolve-dependency-combination (component combinator arguments) 8759 (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) 8760in the context of COMPONENT")) 8761 8762 ;; Methods for find-component 8763 8764 ;; If the base component is a string, resolve it as a system, then if not nil follow the path. 8765 (defmethod find-component ((base string) path &key registered) 8766 (if-let ((s (if registered 8767 (registered-system base) 8768 (find-system base nil)))) 8769 (find-component s path :registered registered))) 8770 8771 ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that. 8772 ;; If nil, use the path as base if not nil, or else return nil. 8773 (defmethod find-component ((base symbol) path &key registered) 8774 (cond 8775 (base (find-component (coerce-name base) path :registered registered)) 8776 (path (find-component path nil :registered registered)) 8777 (t nil))) 8778 8779 ;; If the base component is a cons cell, resolve its car, and add its cdr to the path. 8780 (defmethod find-component ((base cons) path &key registered) 8781 (find-component (car base) (cons (cdr base) path) :registered registered)) 8782 8783 ;; If the base component is a parent-component and the path a string, find the named child. 8784 (defmethod find-component ((parent parent-component) (name string) &key registered) 8785 (declare (ignorable registered)) 8786 (compute-children-by-name parent :only-if-needed-p t) 8787 (values (gethash name (component-children-by-name parent)))) 8788 8789 ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base. 8790 (defmethod find-component (base (name symbol) &key registered) 8791 (if name 8792 (find-component base (coerce-name name) :registered registered) 8793 base)) 8794 8795 ;; If the path is a cons, first resolve its car as path, then its cdr. 8796 (defmethod find-component ((c component) (name cons) &key registered) 8797 (find-component (find-component c (car name) :registered registered) 8798 (cdr name) :registered registered)) 8799 8800 ;; If the path is a component, return it, disregarding the base. 8801 (defmethod find-component ((base t) (actual component) &key registered) 8802 (declare (ignorable registered)) 8803 actual) 8804 8805 ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint. 8806 ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec. 8807 (defun resolve-dependency-name (component name &optional version) 8808 (loop 8809 (restart-case 8810 (return 8811 (let ((comp (find-component (component-parent component) name))) 8812 (unless comp 8813 (error 'missing-dependency 8814 :required-by component 8815 :requires name)) 8816 (when version 8817 (unless (version-satisfies comp version) 8818 (error 'missing-dependency-of-version 8819 :required-by component 8820 :version version 8821 :requires name))) 8822 comp)) 8823 (retry () 8824 :report (lambda (s) 8825 (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name)) 8826 :test 8827 (lambda (c) 8828 (or (null c) 8829 (and (typep c 'missing-dependency) 8830 (eq (missing-required-by c) component) 8831 (equal (missing-requires c) name)))) 8832 (unless (component-parent component) 8833 (let ((name (coerce-name name))) 8834 (unset-asdf-cache-entry `(find-system ,name)))))))) 8835 8836 ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. 8837 ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON 8838 ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON. 8839 (defun resolve-dependency-spec (component dep-spec) 8840 (let ((component (find-component () component))) 8841 (if (atom dep-spec) 8842 (resolve-dependency-name component dep-spec) 8843 (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) 8844 8845 ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications. 8846 (defmethod resolve-dependency-combination (component combinator arguments) 8847 (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>") 8848 'resolve-dependency-combination (cons combinator arguments) component)) 8849 8850 (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) 8851 (when (featurep (first arguments)) 8852 (resolve-dependency-spec component (second arguments)))) 8853 8854 (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) 8855 (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788 8856 8857;;;; ------------------------------------------------------------------------- 8858;;;; Operations 8859 8860(uiop/package:define-package :asdf/operation 8861 (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. 8862 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) 8863 (:export 8864 #:operation 8865 #:*operations* #:make-operation #:find-operation 8866 #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature. 8867(in-package :asdf/operation) 8868 8869;;; Operation Classes 8870(when-upgrading (:version "2.27" :when (find-class 'operation nil)) 8871 ;; override any obsolete shared-initialize method when upgrading from ASDF2. 8872 (defmethod shared-initialize :after ((o operation) (slot-names t) &key) 8873 (values))) 8874 8875(with-upgradability () 8876 (defclass operation () 8877 () 8878 (:documentation "The base class for all ASDF operations. 8879 8880ASDF does NOT and never did distinguish between multiple operations of the same class. 8881Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions. 8882")) 8883 8884 (defvar *in-make-operation* nil) 8885 8886 (defun check-operation-constructor () 8887 "Enforce that OPERATION instances must be created with MAKE-OPERATION." 8888 (unless *in-make-operation* 8889 (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION."))) 8890 8891 (defmethod print-object ((o operation) stream) 8892 (print-unreadable-object (o stream :type t :identity nil))) 8893 8894 ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking. 8895 (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys) 8896 (unless (null initargs) 8897 (parameter-error "~S does not accept initargs" 'operation)))) 8898 8899 8900;;; make-operation, find-operation 8901 8902(with-upgradability () 8903 ;; A table to memoize instances of a given operation. There shall be only one. 8904 (defparameter* *operations* (make-hash-table :test 'equal)) 8905 8906 ;; A memoizing way of creating instances of operation. 8907 (defun make-operation (operation-class) 8908 "This function creates and memoizes an instance of OPERATION-CLASS. 8909All operation instances MUST be created through this function. 8910 8911Use of INITARGS is not supported at this time." 8912 (let ((class (coerce-class operation-class 8913 :package :asdf/interface :super 'operation :error 'sysdef-error)) 8914 (*in-make-operation* t)) 8915 (ensure-gethash class *operations* `(make-instance ,class)))) 8916 8917 ;; This function is mostly for backward and forward compatibility: 8918 ;; operations used to preserve the operation-original-initargs of the context, 8919 ;; and may in the future preserve some operation-canonical-initargs. 8920 ;; Still, the treatment of NIL as a disabling context is useful in some cases. 8921 (defgeneric find-operation (context spec) 8922 (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) 8923 (defmethod find-operation ((context t) (spec operation)) 8924 spec) 8925 (defmethod find-operation ((context t) (spec symbol)) 8926 (when spec ;; NIL designates itself, i.e. absence of operation 8927 (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) 8928 (defmethod find-operation ((context t) (spec string)) 8929 (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) 8930 8931;;;; ------------------------------------------------------------------------- 8932;;;; Actions 8933 8934(uiop/package:define-package :asdf/action 8935 (:nicknames :asdf-action) 8936 (:recycle :asdf/action :asdf) 8937 (:use :uiop/common-lisp :uiop :asdf/upgrade 8938 :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) 8939 (:import-from :asdf/operation #:check-operation-constructor) 8940 #-clisp (:unintern #:required-components #:traverse-action #:traverse-sub-actions) 8941 (:export 8942 #:action #:define-convenience-action-methods 8943 #:action-description 8944 #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-operation 8945 #:component-depends-on 8946 #:input-files #:output-files #:output-file #:operation-done-p 8947 #:action-status #:action-stamp #:action-done-p 8948 #:action-operation #:action-component #:make-action 8949 #:component-operation-time #:mark-operation-done #:compute-action-stamp 8950 #:perform #:perform-with-restarts #:retry #:accept 8951 #:action-path #:find-action #:stamp #:done-p 8952 #:operation-definition-warning #:operation-definition-error ;; condition 8953 )) 8954(in-package :asdf/action) 8955 8956(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning 8957 8958 (deftype action () 8959 "A pair of operation and component uniquely identifies a node in the dependency graph 8960of steps to be performed while building a system." 8961 '(cons operation component)) 8962 8963 (deftype operation-designator () 8964 "An operation designates itself. NIL designates a context-dependent current operation, 8965and a class-name or class designates the canonical instance of the designated class." 8966 '(or operation null symbol class))) 8967 8968;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan 8969;;; actions. 8970(with-upgradability () 8971 (defun make-action (operation component) 8972 (cons operation component)) 8973 (defun action-operation (action) 8974 (car action)) 8975 (defun action-component (action) 8976 (cdr action))) 8977 8978;;;; Reified representation for storage or debugging. Note: an action is identified by its class. 8979(with-upgradability () 8980 (defun action-path (action) 8981 "A readable data structure that identifies the action." 8982 (let ((o (action-operation action)) 8983 (c (action-component action))) 8984 (cons (type-of o) (component-find-path c)))) 8985 (defun find-action (path) 8986 "Reconstitute an action from its action-path" 8987 (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) 8988 8989;;;; Convenience methods 8990(with-upgradability () 8991 ;; A macro that defines convenience methods for a generic function (gf) that 8992 ;; dispatches on operation and component. The convenience methods allow users 8993 ;; to call the gf with operation and/or component designators, that the 8994 ;; methods will resolve into actual operation and component objects, so that 8995 ;; the users can interact using readable designators, but developers only have 8996 ;; to write methods that handle operation and component objects. 8997 ;; FUNCTION is the generic function name 8998 ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT. 8999 ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found. 9000 ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found. 9001 (defmacro define-convenience-action-methods 9002 (function formals &key if-no-operation if-no-component) 9003 (let* ((rest (gensym "REST")) 9004 (found (gensym "FOUND")) 9005 (keyp (equal (last formals) '(&key))) 9006 (formals-no-key (if keyp (butlast formals) formals)) 9007 (len (length formals-no-key)) 9008 (operation 'operation) 9009 (component 'component) 9010 (opix (position operation formals)) 9011 (coix (position component formals)) 9012 (prefix (subseq formals 0 opix)) 9013 (suffix (subseq formals (1+ coix) len)) 9014 (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) 9015 (assert (and (integerp opix) (integerp coix) (= coix (1+ opix)))) 9016 (flet ((next-method (o c) 9017 (if keyp 9018 `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) 9019 `(,function ,@prefix ,o ,c ,@suffix)))) 9020 `(progn 9021 (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args) 9022 (declare (notinline ,function)) 9023 (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on 9024 ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) 9025 (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) 9026 (declare (notinline ,function)) 9027 (if ,operation 9028 ,(next-method 9029 `(make-operation ,operation) 9030 `(or (find-component () ,component) ,if-no-component)) 9031 ,if-no-operation)) 9032 (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) 9033 (declare (notinline ,function)) 9034 (if (typep ,component 'component) 9035 (error "No defined method for ~S on ~/asdf-action:format-action/" 9036 ',function (make-action ,operation ,component)) 9037 (if-let (,found (find-component () ,component)) 9038 ,(next-method operation found) 9039 ,if-no-component)))))))) 9040 9041 9042;;;; self-description 9043(with-upgradability () 9044 (defgeneric action-description (operation component) 9045 (:documentation "returns a phrase that describes performing this operation 9046on this component, e.g. \"loading /a/b/c\". 9047You can put together sentences using this phrase.")) 9048 (defmethod action-description (operation component) 9049 (format nil (compatfmt "~@<~A on ~A~@:>") 9050 operation component)) 9051 9052 (defun format-action (stream action &optional colon-p at-sign-p) 9053 "FORMAT helper to display an action's action-description. 9054Use it in FORMAT control strings as ~/asdf-action:format-action/" 9055 (assert (null colon-p)) (assert (null at-sign-p)) 9056 (destructuring-bind (operation . component) action 9057 (princ (action-description operation component) stream)))) 9058 9059 9060;;;; Dependencies 9061(with-upgradability () 9062 (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies 9063 (:documentation 9064 "Returns a list of dependencies needed by the component to perform 9065 the operation. A dependency has one of the following forms: 9066 9067 (<operation> <component>*), where <operation> is an operation designator 9068 with respect to FIND-OPERATION in the context of the OPERATION argument, 9069 and each <component> is a component designator with respect to 9070 FIND-COMPONENT in the context of the COMPONENT argument, 9071 and means that the component depends on 9072 <operation> having been performed on each <component>; 9073 9074 [Note: an <operation> is an operation designator -- it can be either an 9075 operation name or an operation object. Similarly, a <component> may be 9076 a component name or a component object. Also note that, the degenerate 9077 case of (<operation>) is a no-op.] 9078 9079 Methods specialized on subclasses of existing component types 9080 should usually append the results of CALL-NEXT-METHOD to the list.")) 9081 (define-convenience-action-methods component-depends-on (operation component)) 9082 9083 (defmethod component-depends-on :around ((o operation) (c component)) 9084 (do-asdf-cache `(component-depends-on ,o ,c) 9085 (call-next-method)))) 9086 9087 9088;;;; upward-operation, downward-operation, sideway-operation, selfward-operation 9089;; These together handle actions that propagate along the component hierarchy or operation universe. 9090(with-upgradability () 9091 (defclass downward-operation (operation) 9092 ((downward-operation 9093 :initform nil :reader downward-operation 9094 :type operation-designator :allocation :class)) 9095 (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy. 9096I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then 9097the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M. 9098The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. 9099E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the 9100children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) 9101 (defun downward-operation-depends-on (o c) 9102 `((,(or (downward-operation o) o) ,@(component-children c)))) 9103 (defmethod component-depends-on ((o downward-operation) (c parent-component)) 9104 `(,@(downward-operation-depends-on o c) ,@(call-next-method))) 9105 9106 (defclass upward-operation (operation) 9107 ((upward-operation 9108 :initform nil :reader upward-operation 9109 :type operation-designator :allocation :class)) 9110 (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy. 9111I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U, 9112then the action (O . C) of O on a component C that has the parent P will depends on (U . P). 9113The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself. 9114E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT 9115must first be prepared for loading or compiling with PREPARE-OP.")) 9116 ;; For backward-compatibility reasons, a system inherits from module and is a child-component 9117 ;; so we must guard against this case. ASDF4: remove that. 9118 (defun upward-operation-depends-on (o c) 9119 (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) 9120 (defmethod component-depends-on ((o upward-operation) (c child-component)) 9121 `(,@(upward-operation-depends-on o c) ,@(call-next-method))) 9122 9123 (defclass sideway-operation (operation) 9124 ((sideway-operation 9125 :initform nil :reader sideway-operation 9126 :type operation-designator :allocation :class)) 9127 (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings 9128that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot 9129designates operation S (where NIL designates O itself), then the action (O . C) of O on component C 9130depends on each of (S . D) where D is a declared dependency of C. 9131E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, 9132each of its declared dependencies must first be loaded as by LOAD-OP.")) 9133 (defun sideway-operation-depends-on (o c) 9134 `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) 9135 (defmethod component-depends-on ((o sideway-operation) (c component)) 9136 `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) 9137 9138 (defclass selfward-operation (operation) 9139 ((selfward-operation 9140 ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which 9141 :type (or operation-designator list) :reader selfward-operation :allocation :class)) 9142 (:documentation "A SELFWARD-OPERATION depends on another operation on the same component. 9143I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L, 9144then the action (O . C) of O on component C depends on each (S . C) for S in L. 9145E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP. 9146A operation-designator designates a singleton list of the designated operation; 9147a list of operation-designators designates the list of designated operations; 9148NIL is not a valid operation designator in that context. Note that any dependency 9149ordering between the operations in a list of SELFWARD-OPERATION should be specified separately 9150in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly.")) 9151 (defun selfward-operation-depends-on (o c) 9152 (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) 9153 (defmethod component-depends-on ((o selfward-operation) (c component)) 9154 `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) 9155 9156 (defclass non-propagating-operation (operation) 9157 () 9158 (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates 9159no dependencies whatsoever. It is supplied in order that the programmer be able 9160to specify that s/he is intentionally specifying an operation which invokes no 9161dependencies."))) 9162 9163 9164;;;--------------------------------------------------------------------------- 9165;;; Help programmers catch obsolete OPERATION subclasses 9166;;;--------------------------------------------------------------------------- 9167(with-upgradability () 9168 (define-condition operation-definition-warning (simple-warning) 9169 () 9170 (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) 9171 9172 (define-condition operation-definition-error (simple-error) 9173 () 9174 (:documentation "Error condition related to definition of incorrect OPERATION objects.")) 9175 9176 (defmethod initialize-instance :before ((o operation) &key) 9177 (check-operation-constructor) 9178 (unless (typep o '(or downward-operation upward-operation sideway-operation 9179 selfward-operation non-propagating-operation)) 9180 (warn 'operation-definition-warning 9181 :format-control 9182 "No dependency propagating scheme specified for operation class ~S. 9183The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." 9184 :format-arguments (list (type-of o))))) 9185 9186 (defmethod initialize-instance :before ((o non-propagating-operation) &key) 9187 (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) 9188 (error 'operation-definition-error 9189 :format-control 9190 "Inconsistent class: ~S 9191 NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." 9192 :format-arguments 9193 (list (type-of o))))) 9194 9195 (defun backward-compatible-depends-on (o c) 9196 "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of 9197 DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION. 9198 The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that 9199 don't. In the future this functionality will be removed, and the default will be no propagation." 9200 (uiop/version::notify-deprecated-function 9201 (version-deprecation *asdf-version* :style-warning "3.2") 9202 'backward-compatible-depends-on) 9203 `(,@(sideway-operation-depends-on o c) 9204 ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))) 9205 9206 (defmethod component-depends-on ((o operation) (c component)) 9207 `(;; Normal behavior, to allow user-specified in-order-to dependencies 9208 ,@(cdr (assoc (type-of o) (component-in-order-to c))) 9209 ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation 9210 ;; or non-propagation through an appropriate mixin will be downward and sideway. 9211 ,@(unless (typep o '(or downward-operation upward-operation sideway-operation 9212 selfward-operation non-propagating-operation)) 9213 (backward-compatible-depends-on o c)))) 9214 9215 (defmethod downward-operation ((o operation)) nil) 9216 (defmethod sideway-operation ((o operation)) nil)) 9217 9218 9219;;;--------------------------------------------------------------------------- 9220;;; End of OPERATION class checking 9221;;;--------------------------------------------------------------------------- 9222 9223 9224;;;; Inputs, Outputs, and invisible dependencies 9225(with-upgradability () 9226 (defgeneric output-files (operation component) 9227 (:documentation "Methods for this function return two values: a list of output files 9228corresponding to this action, and a boolean indicating if they have already been subjected 9229to relevant output translations and should not be further translated. 9230 9231Methods on PERFORM *must* call this function to determine where their outputs are to be located. 9232They may rely on the order of the files to discriminate between outputs. 9233")) 9234 (defgeneric input-files (operation component) 9235 (:documentation "A list of input files corresponding to this action. 9236 9237Methods on PERFORM *must* call this function to determine where their inputs are located. 9238They may rely on the order of the files to discriminate between inputs. 9239")) 9240 (defgeneric operation-done-p (operation component) 9241 (:documentation "Returns a boolean which is NIL if the action must be performed (again).")) 9242 (define-convenience-action-methods output-files (operation component)) 9243 (define-convenience-action-methods input-files (operation component)) 9244 (define-convenience-action-methods operation-done-p (operation component)) 9245 9246 (defmethod operation-done-p ((o operation) (c component)) 9247 t) 9248 9249 ;; Translate output files, unless asked not to. Memoize the result. 9250 (defmethod output-files :around ((operation t) (component t)) 9251 (do-asdf-cache `(output-files ,operation ,component) 9252 (values 9253 (multiple-value-bind (pathnames fixedp) (call-next-method) 9254 ;; 1- Make sure we have absolute pathnames 9255 (let* ((directory (pathname-directory-pathname 9256 (component-pathname (find-component () component)))) 9257 (absolute-pathnames 9258 (loop 9259 :for pathname :in pathnames 9260 :collect (ensure-absolute-pathname pathname directory)))) 9261 ;; 2- Translate those pathnames as required 9262 (if fixedp 9263 absolute-pathnames 9264 (mapcar *output-translation-function* absolute-pathnames)))) 9265 t))) 9266 (defmethod output-files ((o operation) (c component)) 9267 nil) 9268 (defun output-file (operation component) 9269 "The unique output file of performing OPERATION on COMPONENT" 9270 (let ((files (output-files operation component))) 9271 (assert (length=n-p files 1)) 9272 (first files))) 9273 9274 ;; Memoize input files. 9275 (defmethod input-files :around (operation component) 9276 (do-asdf-cache `(input-files ,operation ,component) 9277 (call-next-method))) 9278 9279 ;; By default an action has no input-files. 9280 (defmethod input-files ((o operation) (c component)) 9281 nil) 9282 9283 ;; An action with a selfward-operation by default gets its input-files from the output-files of 9284 ;; the actions using selfward-operations it depends on (and the same component), 9285 ;; or if there are none, on the component-pathname of the component if it's a file 9286 ;; -- and then on the results of the next-method. 9287 (defmethod input-files ((o selfward-operation) (c component)) 9288 `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) 9289 :append (or (output-files dep-o c) (input-files dep-o c))) 9290 (if-let ((pathname (component-pathname c))) 9291 (and (file-pathname-p pathname) (list pathname)))) 9292 ,@(call-next-method)))) 9293 9294 9295;;;; Done performing 9296(with-upgradability () 9297 ;; ASDF4: hide it behind plan-action-stamp 9298 (defgeneric component-operation-time (operation component) 9299 (:documentation "Return the timestamp for when an action was last performed")) 9300 (defgeneric (setf component-operation-time) (time operation component) 9301 (:documentation "Update the timestamp for when an action was last performed")) 9302 (define-convenience-action-methods component-operation-time (operation component)) 9303 9304 ;; ASDF4: hide it behind (setf plan-action-stamp) 9305 (defgeneric mark-operation-done (operation component) 9306 (:documentation "Mark a action as having been just done. 9307 9308Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP 9309using the JUST-DONE flag.")) 9310 (defgeneric compute-action-stamp (plan operation component &key just-done) 9311 (:documentation "Has this action been successfully done already, 9312and at what known timestamp has it been done at or will it be done at? 9313* PLAN is a plan object modelling future effects of actions, 9314 or NIL to denote what actually happened. 9315* OPERATION and COMPONENT denote the action. 9316Takes keyword JUST-DONE: 9317* JUST-DONE is a boolean that is true if the action was just successfully performed, 9318 at which point we want compute the actual stamp and warn if files are missing; 9319 otherwise we are making plans, anticipating the effects of the action. 9320Returns two values: 9321* a STAMP saying when it was done or will be done, 9322 or T if the action involves files that need to be recomputed. 9323* a boolean DONE-P that indicates whether the action has actually been done, 9324 and both its output-files and its in-image side-effects are up to date.")) 9325 9326 (defclass action-status () 9327 ((stamp 9328 :initarg :stamp :reader action-stamp 9329 :documentation "STAMP associated with the ACTION if it has been completed already 9330in some previous image, or T if it needs to be done.") 9331 (done-p 9332 :initarg :done-p :reader action-done-p 9333 :documentation "a boolean, true iff the action was already done (before any planned action).")) 9334 (:documentation "Status of an action")) 9335 9336 (defmethod print-object ((status action-status) stream) 9337 (print-unreadable-object (status stream :type t) 9338 (with-slots (stamp done-p) status 9339 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p)))) 9340 9341 (defmethod component-operation-time ((o operation) (c component)) 9342 (gethash o (component-operation-times c))) 9343 9344 (defmethod (setf component-operation-time) (stamp (o operation) (c component)) 9345 (setf (gethash o (component-operation-times c)) stamp)) 9346 9347 (defmethod mark-operation-done ((o operation) (c component)) 9348 (setf (component-operation-time o c) (compute-action-stamp nil o c :just-done t)))) 9349 9350 9351;;;; Perform 9352(with-upgradability () 9353 (defgeneric perform (operation component) 9354 (:documentation "PERFORM an action, consuming its input-files and building its output-files")) 9355 (define-convenience-action-methods perform (operation component)) 9356 9357 (defmethod perform :before ((o operation) (c component)) 9358 (ensure-all-directories-exist (output-files o c))) 9359 (defmethod perform :after ((o operation) (c component)) 9360 (mark-operation-done o c)) 9361 (defmethod perform ((o operation) (c parent-component)) 9362 nil) 9363 (defmethod perform ((o operation) (c source-file)) 9364 ;; For backward compatibility, don't error on operations that don't specify propagation. 9365 (when (typep o '(or downward-operation upward-operation sideway-operation 9366 selfward-operation non-propagating-operation)) 9367 (sysdef-error 9368 (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>") 9369 'perform (make-action o c)))) 9370 9371 ;; The restarts of the perform-with-restarts variant matter in an interactive context. 9372 ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build 9373 ;; may call perform directly rather than call p-w-r. 9374 (defgeneric perform-with-restarts (operation component) 9375 (:documentation "PERFORM an action in a context where suitable restarts are in place.")) 9376 (defmethod perform-with-restarts (operation component) 9377 (perform operation component)) 9378 (defmethod perform-with-restarts :around (operation component) 9379 (loop 9380 (restart-case 9381 (return (call-next-method)) 9382 (retry () 9383 :report 9384 (lambda (s) 9385 (format s (compatfmt "~@<Retry ~A.~@:>") 9386 (action-description operation component)))) 9387 (accept () 9388 :report 9389 (lambda (s) 9390 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") 9391 (action-description operation component))) 9392 (mark-operation-done operation component) 9393 (return)))))) 9394;;;; ------------------------------------------------------------------------- 9395;;;; Actions to build Common Lisp software 9396 9397(uiop/package:define-package :asdf/lisp-action 9398 (:recycle :asdf/lisp-action :asdf) 9399 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache 9400 :asdf/component :asdf/system :asdf/find-component :asdf/find-system 9401 :asdf/operation :asdf/action) 9402 (:export 9403 #:try-recompiling 9404 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp 9405 #:basic-load-op #:basic-compile-op 9406 #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op 9407 #:call-with-around-compile-hook 9408 #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source 9409 #:lisp-compilation-output-files)) 9410(in-package :asdf/lisp-action) 9411 9412 9413;;;; Component classes 9414(with-upgradability () 9415 (defclass cl-source-file (source-file) 9416 ((type :initform "lisp")) 9417 (:documentation "Component class for a Common Lisp source file (using type \"lisp\")")) 9418 (defclass cl-source-file.cl (cl-source-file) 9419 ((type :initform "cl")) 9420 (:documentation "Component class for a Common Lisp source file using type \"cl\"")) 9421 (defclass cl-source-file.lsp (cl-source-file) 9422 ((type :initform "lsp")) 9423 (:documentation "Component class for a Common Lisp source file using type \"lsp\""))) 9424 9425 9426;;;; Operation classes 9427(with-upgradability () 9428 (defclass basic-load-op (operation) () 9429 (:documentation "Base class for operations that apply the load-time effects of a file")) 9430 (defclass basic-compile-op (operation) () 9431 (:documentation "Base class for operations that apply the compile-time effects of a file"))) 9432 9433 9434;;; Our default operations: loading into the current lisp image 9435(with-upgradability () 9436 (defclass prepare-op (upward-operation sideway-operation) 9437 ((sideway-operation :initform 'load-op :allocation :class)) 9438 (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT.")) 9439 (defclass load-op (basic-load-op downward-operation selfward-operation) 9440 ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, 9441 ;; so we need to directly depend on prepare-op for its side-effects in the current image. 9442 ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)) 9443 (:documentation "Operation for loading the compiled FASL for a Lisp file")) 9444 (defclass compile-op (basic-compile-op downward-operation selfward-operation) 9445 ((selfward-operation :initform 'prepare-op :allocation :class)) 9446 (:documentation "Operation for compiling a Lisp file to a FASL")) 9447 9448 9449 (defclass prepare-source-op (upward-operation sideway-operation) 9450 ((sideway-operation :initform 'load-source-op :allocation :class)) 9451 (:documentation "Operation for loading the dependencies of a Lisp file as source.")) 9452 (defclass load-source-op (basic-load-op downward-operation selfward-operation) 9453 ((selfward-operation :initform 'prepare-source-op :allocation :class)) 9454 (:documentation "Operation for loading a Lisp file as source.")) 9455 9456 (defclass test-op (selfward-operation) 9457 ((selfward-operation :initform 'load-op :allocation :class)) 9458 (:documentation "Operation for running the tests for system. 9459If the tests fail, an error will be signaled."))) 9460 9461 9462;;;; Methods for prepare-op, compile-op and load-op 9463 9464;;; prepare-op 9465(with-upgradability () 9466 (defmethod action-description ((o prepare-op) (c component)) 9467 (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) 9468 (defmethod perform ((o prepare-op) (c component)) 9469 nil) 9470 (defmethod input-files ((o prepare-op) (s system)) 9471 (if-let (it (system-source-file s)) (list it)))) 9472 9473;;; compile-op 9474(with-upgradability () 9475 (defmethod action-description ((o compile-op) (c component)) 9476 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c)) 9477 (defmethod action-description ((o compile-op) (c parent-component)) 9478 (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c)) 9479 (defgeneric call-with-around-compile-hook (component thunk) 9480 (:documentation "A method to be called around the PERFORM'ing of actions that apply the 9481compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used 9482to setup readtables and other variables that control reading, macroexpanding, and compiling, etc. 9483Note that it will NOT be called around the performing of LOAD-OP.")) 9484 (defmethod call-with-around-compile-hook ((c component) function) 9485 (call-around-hook (around-compile-hook c) function)) 9486 (defun perform-lisp-compilation (o c) 9487 "Perform the compilation of the Lisp file associated to the specified action (O . C)." 9488 (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, 9489 ;; we consult input-files, the first of which should be the one to compile-file 9490 (input-file (first (input-files o c))) 9491 ;; On some implementations, there are more than one output-file, 9492 ;; but the first one should always be the primary fasl that gets loaded. 9493 (outputs (output-files o c))) 9494 (multiple-value-bind (output warnings-p failure-p) 9495 (destructuring-bind 9496 (output-file 9497 &optional 9498 #+(or clasp ecl mkcl) object-file 9499 #+clisp lib-file 9500 warnings-file &rest rest) outputs 9501 ;; Allow for extra outputs that are not of type warnings-file 9502 ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. 9503 (declare (ignore rest)) 9504 (when warnings-file 9505 (unless (equal (pathname-type warnings-file) (warnings-file-type)) 9506 (setf warnings-file nil))) 9507 (call-with-around-compile-hook 9508 c #'(lambda (&rest flags) 9509 (apply 'compile-file* input-file 9510 :output-file output-file 9511 :external-format (component-external-format c) 9512 :warnings-file warnings-file 9513 (append 9514 #+clisp (list :lib-file lib-file) 9515 #+(or clasp ecl mkcl) (list :object-file object-file) 9516 flags))))) 9517 (check-lisp-compile-results output warnings-p failure-p 9518 "~/asdf-action::format-action/" (list (cons o c)))))) 9519 (defun report-file-p (f) 9520 "Is F a build report file containing, e.g., warnings to check?" 9521 (equalp (pathname-type f) "build-report")) 9522 (defun perform-lisp-warnings-check (o c) 9523 "Check the warnings associated with the dependencies of an action." 9524 (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) 9525 (actual-warnings-files (loop :for w :in expected-warnings-files 9526 :when (get-file-stamp w) 9527 :collect w 9528 :else :do (warn "Missing warnings file ~S while ~A" 9529 w (action-description o c))))) 9530 (check-deferred-warnings actual-warnings-files) 9531 (let* ((output (output-files o c)) 9532 (report (find-if #'report-file-p output))) 9533 (when report 9534 (with-open-file (s report :direction :output :if-exists :supersede) 9535 (format s ":success~%")))))) 9536 (defmethod perform ((o compile-op) (c cl-source-file)) 9537 (perform-lisp-compilation o c)) 9538 (defun lisp-compilation-output-files (o c) 9539 "Compute the output-files for compiling the Lisp file for the specified action (O . C), 9540an OPERATION and a COMPONENT." 9541 (let* ((i (first (input-files o c))) 9542 (f (compile-file-pathname 9543 i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl 9544 #+mkcl :fasl-p #+mkcl t))) 9545 `(,f ;; the fasl is the primary output, in first position 9546 #+clasp 9547 ,@(unless nil ;; was (use-ecl-byte-compiler-p) 9548 `(,(compile-file-pathname i :output-type :object))) 9549 #+clisp 9550 ,@`(,(make-pathname :type "lib" :defaults f)) 9551 #+ecl 9552 ,@(unless (use-ecl-byte-compiler-p) 9553 `(,(compile-file-pathname i :type :object))) 9554 #+mkcl 9555 ,(compile-file-pathname i :fasl-p nil) ;; object file 9556 ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) 9557 `(,(make-pathname :type *warnings-file-type* :defaults f)))))) 9558 (defmethod output-files ((o compile-op) (c cl-source-file)) 9559 (lisp-compilation-output-files o c)) 9560 (defmethod perform ((o compile-op) (c static-file)) 9561 nil) 9562 9563 ;; Performing compile-op on a system will check the deferred warnings for the system 9564 (defmethod perform ((o compile-op) (c system)) 9565 (when (and *warnings-file-type* (not (builtin-system-p c))) 9566 (perform-lisp-warnings-check o c))) 9567 (defmethod input-files ((o compile-op) (c system)) 9568 (when (and *warnings-file-type* (not (builtin-system-p c))) 9569 ;; The most correct way to do it would be to use: 9570 ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) 9571 ;; but it's expensive and we don't care too much about file order or ASDF extensions. 9572 (loop :for sub :in (sub-components c :type 'cl-source-file) 9573 :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) 9574 (defmethod output-files ((o compile-op) (c system)) 9575 (when (and *warnings-file-type* (not (builtin-system-p c))) 9576 (if-let ((pathname (component-pathname c))) 9577 (list (subpathname pathname (coerce-filename c) :type "build-report")))))) 9578 9579;;; load-op 9580(with-upgradability () 9581 (defmethod action-description ((o load-op) (c cl-source-file)) 9582 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c)) 9583 (defmethod action-description ((o load-op) (c parent-component)) 9584 (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c)) 9585 (defmethod action-description ((o load-op) (c component)) 9586 (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c)) 9587 (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) 9588 (loop 9589 (restart-case 9590 (return (call-next-method)) 9591 (try-recompiling () 9592 :report (lambda (s) 9593 (format s "Recompile ~a and try loading it again" 9594 (component-name c))) 9595 (perform (find-operation o 'compile-op) c))))) 9596 (defun perform-lisp-load-fasl (o c) 9597 "Perform the loading of a FASL associated to specified action (O . C), 9598an OPERATION and a COMPONENT." 9599 (if-let (fasl (first (input-files o c))) 9600 (load* fasl))) 9601 (defmethod perform ((o load-op) (c cl-source-file)) 9602 (perform-lisp-load-fasl o c)) 9603 (defmethod perform ((o load-op) (c static-file)) 9604 nil)) 9605 9606 9607;;;; prepare-source-op, load-source-op 9608 9609;;; prepare-source-op 9610(with-upgradability () 9611 (defmethod action-description ((o prepare-source-op) (c component)) 9612 (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) 9613 (defmethod input-files ((o prepare-source-op) (s system)) 9614 (if-let (it (system-source-file s)) (list it))) 9615 (defmethod perform ((o prepare-source-op) (c component)) 9616 nil)) 9617 9618;;; load-source-op 9619(with-upgradability () 9620 (defmethod action-description ((o load-source-op) (c component)) 9621 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c)) 9622 (defmethod action-description ((o load-source-op) (c parent-component)) 9623 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) 9624 (defun perform-lisp-load-source (o c) 9625 "Perform the loading of a Lisp file as associated to specified action (O . C)" 9626 (call-with-around-compile-hook 9627 c #'(lambda () 9628 (load* (first (input-files o c)) 9629 :external-format (component-external-format c))))) 9630 9631 (defmethod perform ((o load-source-op) (c cl-source-file)) 9632 (perform-lisp-load-source o c)) 9633 (defmethod perform ((o load-source-op) (c static-file)) 9634 nil)) 9635 9636 9637;;;; test-op 9638(with-upgradability () 9639 (defmethod perform ((o test-op) (c component)) 9640 nil) 9641 (defmethod operation-done-p ((o test-op) (c system)) 9642 "Testing a system is _never_ done." 9643 nil)) 9644;;;; ------------------------------------------------------------------------- 9645;;;; Plan 9646 9647(uiop/package:define-package :asdf/plan 9648 ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions 9649 ;; that used to live there before 3.2.0. 9650 (:recycle :asdf/plan :asdf) 9651 (:use :uiop/common-lisp :uiop :asdf/upgrade 9652 :asdf/component :asdf/operation :asdf/system 9653 :asdf/cache :asdf/find-system :asdf/find-component 9654 :asdf/operation :asdf/action :asdf/lisp-action) 9655 (:export 9656 #:component-operation-time 9657 #:plan #:plan-traversal #:sequential-plan #:*default-plan-class* 9658 #:planned-action-status #:plan-action-status #:action-already-done-p 9659 #:circular-dependency #:circular-dependency-actions 9660 #:needed-in-image-p 9661 #:action-index #:action-planned-p #:action-valid-p 9662 #:plan-record-dependency 9663 #:normalize-forced-systems #:action-forced-p #:action-forced-not-p 9664 #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies 9665 #:compute-action-stamp #:traverse-action 9666 #:circular-dependency #:circular-dependency-actions 9667 #:call-while-visiting-action #:while-visiting-action 9668 #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p 9669 #:planned-p #:index #:forced #:forced-not #:total-action-count 9670 #:planned-action-count #:planned-output-action-count #:visited-actions 9671 #:visiting-action-set #:visiting-action-list #:plan-actions-r 9672 #:required-components #:filtered-sequential-plan 9673 #:plan-system 9674 #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component 9675 #:traverse-actions #:traverse-sub-actions)) 9676(in-package :asdf/plan) 9677 9678;;;; Generic plan traversal class 9679(with-upgradability () 9680 (defclass plan () () 9681 (:documentation "Base class for a plan based on which ASDF can build a system")) 9682 (defclass plan-traversal (plan) 9683 (;; The system for which the plan is computed 9684 (system :initform nil :initarg :system :accessor plan-system) 9685 ;; Table of systems specified via :force arguments 9686 (forced :initform nil :initarg :force :accessor plan-forced) 9687 ;; Table of systems specified via :force-not argument (and/or immutable) 9688 (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) 9689 ;; Counts of total actions in plan 9690 (total-action-count :initform 0 :accessor plan-total-action-count) 9691 ;; Count of actions that need to be performed 9692 (planned-action-count :initform 0 :accessor plan-planned-action-count) 9693 ;; Count of actions that need to be performed that have a non-empty list of output-files. 9694 (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count) 9695 ;; Table that to actions already visited while walking the dependencies associates status 9696 (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions) 9697 ;; Actions that depend on those being currently walked through, to detect circularities 9698 (visiting-action-set ;; as a set 9699 :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set) 9700 (visiting-action-list :initform () :accessor plan-visiting-action-list)) ;; as a list 9701 (:documentation "Base class for plans that simply traverse dependencies"))) 9702 9703 9704;;;; Planned action status 9705(with-upgradability () 9706 (defgeneric plan-action-status (plan operation component) 9707 (:documentation "Returns the ACTION-STATUS associated to 9708the action of OPERATION on COMPONENT in the PLAN")) 9709 9710 (defgeneric (setf plan-action-status) (new-status plan operation component) 9711 (:documentation "Sets the ACTION-STATUS associated to 9712the action of OPERATION on COMPONENT in the PLAN")) 9713 9714 (defclass planned-action-status (action-status) 9715 ((planned-p 9716 :initarg :planned-p :reader action-planned-p 9717 :documentation "a boolean, true iff the action was included in the plan.") 9718 (index 9719 :initarg :index :reader action-index 9720 :documentation "an integer, counting all traversed actions in traversal order.")) 9721 (:documentation "Status of an action in a plan")) 9722 9723 (defmethod print-object ((status planned-action-status) stream) 9724 (print-unreadable-object (status stream :type t :identity nil) 9725 (with-slots (stamp done-p planned-p index) status 9726 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index)))) 9727 9728 (defmethod action-planned-p ((action-status t)) 9729 t) ; default method for non planned-action-status objects 9730 9731 (defun action-already-done-p (plan operation component) 9732 "According to this plan, is this action already done and up to date?" 9733 (action-done-p (plan-action-status plan operation component))) 9734 9735 (defmethod plan-action-status ((plan null) (o operation) (c component)) 9736 (multiple-value-bind (stamp done-p) (component-operation-time o c) 9737 (make-instance 'action-status :stamp stamp :done-p done-p))) 9738 9739 (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) 9740 (let ((times (component-operation-times c))) 9741 (if (action-done-p new-status) 9742 (remhash o times) 9743 (setf (gethash o times) (action-stamp new-status)))) 9744 new-status)) 9745 9746 9747;;;; forcing 9748(with-upgradability () 9749 (defgeneric action-forced-p (plan operation component) 9750 (:documentation "Is this action forced to happen in this plan?")) 9751 (defgeneric action-forced-not-p (plan operation component) 9752 (:documentation "Is this action forced to not happen in this plan? 9753Takes precedence over action-forced-p.")) 9754 9755 (defun normalize-forced-systems (force system) 9756 "Given a SYSTEM on which operate is called and the specified FORCE argument, 9757extract a hash-set of systems that are forced, or a predicate on system names, 9758or NIL if none are forced, or :ALL if all are." 9759 (etypecase force 9760 ((or (member nil :all) hash-table function) force) 9761 (cons (list-to-hash-set (mapcar #'coerce-name force))) 9762 ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) 9763 9764 (defun normalize-forced-not-systems (force-not system) 9765 "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, 9766and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, 9767or predicate on system names, or NIL if none are forced, or :ALL if all are." 9768 (let ((requested 9769 (etypecase force-not 9770 ((or (member nil :all) hash-table function) force-not) 9771 (cons (list-to-hash-set (mapcar #'coerce-name force-not))) 9772 ((eql t) (if system (let ((name (coerce-name system))) 9773 #'(lambda (x) (not (equal x name)))) 9774 :all))))) 9775 (if (and *immutable-systems* requested) 9776 #'(lambda (x) (or (call-function requested x) 9777 (call-function *immutable-systems* x))) 9778 (or *immutable-systems* requested)))) 9779 9780 ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? 9781 (defun action-override-p (plan operation component override-accessor) 9782 "Given a plan, an action, and a function that given the plan accesses a set of overrides 9783(i.e. force or force-not), see if the override applies to the current action." 9784 (declare (ignore operation)) 9785 (call-function (funcall override-accessor plan) 9786 (coerce-name (component-system (find-component () component))))) 9787 9788 (defmethod action-forced-p (plan operation component) 9789 (and 9790 ;; Did the user ask us to re-perform the action? 9791 (action-override-p plan operation component 'plan-forced) 9792 ;; You really can't force a builtin system and :all doesn't apply to it, 9793 ;; except if it's the specifically the system currently being built. 9794 (not (let ((system (component-system component))) 9795 (and (builtin-system-p system) 9796 (not (eq system (plan-system plan)))))))) 9797 9798 (defmethod action-forced-not-p (plan operation component) 9799 ;; Did the user ask us to not re-perform the action? 9800 ;; NB: force-not takes precedence over force, as it should 9801 (action-override-p plan operation component 'plan-forced-not)) 9802 9803 (defmethod action-forced-p ((plan null) (operation operation) (component component)) 9804 nil) 9805 9806 (defmethod action-forced-not-p ((plan null) (operation operation) (component component)) 9807 nil)) 9808 9809 9810;;;; action-valid-p 9811(with-upgradability () 9812 (defgeneric action-valid-p (plan operation component) 9813 (:documentation "Is this action valid to include amongst dependencies?")) 9814 ;; :if-feature will invalidate actions on components for which the features don't apply. 9815 (defmethod action-valid-p ((plan t) (o operation) (c component)) 9816 (if-let (it (component-if-feature c)) (featurep it) t)) 9817 ;; If either the operation or component was resolved to nil, the action is invalid. 9818 (defmethod action-valid-p ((plan t) (o null) (c t)) nil) 9819 (defmethod action-valid-p ((plan t) (o t) (c null)) nil) 9820 ;; If the plan is null, i.e., we're looking at reality, 9821 ;; then any action with actual operation and component objects is valid. 9822 (defmethod action-valid-p ((plan null) (o operation) (c component)) t)) 9823 9824;;;; Is the action needed in this image? 9825(with-upgradability () 9826 (defgeneric needed-in-image-p (operation component) 9827 (:documentation "Is the action of OPERATION on COMPONENT needed in the current image 9828to be meaningful, or could it just as well have been done in another Lisp image?")) 9829 9830 (defmethod needed-in-image-p ((o operation) (c component)) 9831 ;; We presume that actions that modify the filesystem don't need be run 9832 ;; in the current image if they have already been done in another, 9833 ;; and can be run in another process (e.g. a fork), 9834 ;; whereas those that don't are meant to side-effect the current image and can't. 9835 (not (output-files o c)))) 9836 9837 9838;;;; Visiting dependencies of an action and computing action stamps 9839(with-upgradability () 9840 (defun* (map-direct-dependencies) (plan operation component fun) 9841 "Call FUN on all the valid dependencies of the given action in the given plan" 9842 (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) 9843 :for dep-o = (find-operation operation dep-o-spec) 9844 :when dep-o 9845 :do (loop :for dep-c-spec :in dep-c-specs 9846 :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) 9847 :when (and dep-c (action-valid-p plan dep-o dep-c)) 9848 :do (funcall fun dep-o dep-c)))) 9849 9850 (defun* (reduce-direct-dependencies) (plan operation component combinator seed) 9851 "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR 9852for each dependency action on the dependency's operation and component and an accumulator 9853initialized with SEED." 9854 (map-direct-dependencies 9855 plan operation component 9856 #'(lambda (dep-o dep-c) 9857 (setf seed (funcall combinator dep-o dep-c seed)))) 9858 seed) 9859 9860 (defun* (direct-dependencies) (plan operation component) 9861 "Compute a list of the direct dependencies of the action within the plan" 9862 (reverse (reduce-direct-dependencies plan operation component #'acons nil))) 9863 9864 ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp 9865 ;; shall also be parametrized by the plan, or by a second model object, 9866 ;; so they need not refer to the state of the filesystem, 9867 ;; and the stamps could be cryptographic checksums rather than timestamps. 9868 ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP. 9869 9870 (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) 9871 ;; Given an action, figure out at what time in the past it has been done, 9872 ;; or if it has just been done, return the time that it has. 9873 ;; Returns two values: 9874 ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, 9875 ;; or T is either hasn't been done or is out of date. 9876 ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done 9877 ;; in the current image, or NIL if it hasn't. 9878 ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but 9879 ;; hasn't been done in the current image yet, then it can have a non-T timestamp, 9880 ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, 9881 ;; i.e. that of the input-files. 9882 (nest 9883 (block ()) 9884 (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) 9885 (reduce-direct-dependencies 9886 plan o c 9887 #'(lambda (o c stamp) 9888 (if-let (it (plan-action-status plan o c)) 9889 (latest-stamp stamp (action-stamp it)) 9890 t)) 9891 nil))) 9892 ;; out-of-date dependency: don't bother expensively querying the filesystem 9893 (when (and (eq dep-stamp t) (not just-done)) (return (values t nil)))) 9894 ;; collect timestamps from inputs, and exit early if any is missing 9895 (let* ((in-files (input-files o c)) 9896 (in-stamps (mapcar #'get-file-stamp in-files)) 9897 (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) 9898 (latest-in (stamps-latest (cons dep-stamp in-stamps)))) 9899 (when (and missing-in (not just-done)) (return (values t nil)))) 9900 ;; collect timestamps from outputs, and exit early if any is missing 9901 (let* ((out-files (remove-if 'null (output-files o c))) 9902 (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) 9903 (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) 9904 (earliest-out (stamps-earliest out-stamps))) 9905 (when (and missing-out (not just-done)) (return (values t nil)))) 9906 (let* (;; There are three kinds of actions: 9907 (out-op (and out-files t)) ; those that create files on the filesystem 9908 ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image 9909 ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing 9910 ;; When was the thing last actually done? (Now, or ask.) 9911 (op-time (or just-done (component-operation-time o c))) 9912 ;; Time stamps from the files at hand, and whether any is missing 9913 (all-present (not (or missing-in missing-out))) 9914 ;; Has any input changed since we last generated the files? 9915 (up-to-date-p (stamp<= latest-in earliest-out)) 9916 ;; If everything is up to date, the latest of inputs and outputs is our stamp 9917 (done-stamp (stamps-latest (cons latest-in out-stamps)))) 9918 ;; Warn if some files are missing: 9919 ;; either our model is wrong or some other process is messing with our files. 9920 (when (and just-done (not all-present)) 9921 (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ 9922 ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" 9923 (action-description o c) 9924 missing-in (length missing-in) (and missing-in missing-out) 9925 missing-out (length missing-out)))) 9926 ;; Note that we use stamp<= instead of stamp< to play nice with generated files. 9927 ;; Any race condition is intrinsic to the limited timestamp resolution. 9928 (if (or just-done ;; The done-stamp is valid: if we're just done, or 9929 ;; if all filesystem effects are up-to-date and there's no invalidating reason. 9930 (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) 9931 (values done-stamp ;; return the hard-earned timestamp 9932 (or just-done 9933 out-op ;; a file-creating op is done when all files are up to date 9934 ;; a image-effecting a placeholder op is done when it was actually run, 9935 (and op-time (eql op-time done-stamp)))) ;; with the matching stamp 9936 ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet 9937 (values t nil))))) 9938 9939 9940;;;; Generic support for plan-traversal 9941(with-upgradability () 9942 (defmethod initialize-instance :after ((plan plan-traversal) 9943 &key force force-not system 9944 &allow-other-keys) 9945 (with-slots (forced forced-not) plan 9946 (setf forced (normalize-forced-systems force system)) 9947 (setf forced-not (normalize-forced-not-systems force-not system)))) 9948 9949 (defgeneric plan-actions (plan) 9950 (:documentation "Extract from a plan a list of actions to perform in sequence")) 9951 (defmethod plan-actions ((plan list)) 9952 plan) 9953 9954 (defmethod (setf plan-action-status) (new-status (p plan-traversal) (o operation) (c component)) 9955 (setf (gethash (cons o c) (plan-visited-actions p)) new-status)) 9956 9957 (defmethod plan-action-status ((p plan-traversal) (o operation) (c component)) 9958 (or (and (action-forced-not-p p o c) (plan-action-status nil o c)) 9959 (values (gethash (cons o c) (plan-visited-actions p))))) 9960 9961 (defmethod action-valid-p ((p plan-traversal) (o operation) (s system)) 9962 (and (not (action-forced-not-p p o s)) (call-next-method))) 9963 9964 (defgeneric plan-record-dependency (plan operation component) 9965 (:documentation "Record an action as a dependency in the current plan"))) 9966 9967 9968;;;; Detection of circular dependencies 9969(with-upgradability () 9970 (define-condition circular-dependency (system-definition-error) 9971 ((actions :initarg :actions :reader circular-dependency-actions)) 9972 (:report (lambda (c s) 9973 (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") 9974 (circular-dependency-actions c))))) 9975 9976 (defgeneric call-while-visiting-action (plan operation component function) 9977 (:documentation "Detect circular dependencies")) 9978 9979 (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun) 9980 (with-accessors ((action-set plan-visiting-action-set) 9981 (action-list plan-visiting-action-list)) plan 9982 (let ((action (make-action operation component))) 9983 (when (gethash action action-set) 9984 (error 'circular-dependency :actions 9985 (member action (reverse action-list) :test 'equal))) 9986 (setf (gethash action action-set) t) 9987 (push action action-list) 9988 (unwind-protect 9989 (funcall fun) 9990 (pop action-list) 9991 (setf (gethash action action-set) nil))))) 9992 9993 ;; Syntactic sugar for call-while-visiting-action 9994 (defmacro while-visiting-action ((p o c) &body body) 9995 `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))) 9996 9997 9998;;;; Actual traversal: traverse-action 9999(with-upgradability () 10000 (defgeneric traverse-action (plan operation component needed-in-image-p)) 10001 10002 ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, 10003 ;; visits the action defined by its OPERATION and COMPONENT arguments, 10004 ;; and all its transitive dependencies (unless already visited), 10005 ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, 10006 ;; i.e. needs to be done in the current image vs merely have been done in a previous image. 10007 ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action 10008 ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension), 10009 ;; or T if the action needs to be done again. 10010 ;; 10011 ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, 10012 ;; the below method would be insufficient, since it assumes a single image 10013 ;; to traverse each node at most twice; non-niip actions would be traversed only once, 10014 ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. 10015 10016 (defmethod traverse-action (plan operation component needed-in-image-p) 10017 (block nil 10018 ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT, 10019 ;; and IF-FEATURE filtering. 10020 (unless (action-valid-p plan operation component) (return nil)) 10021 ;; the following hook is needed by POIU, which tracks a full dependency graph, 10022 ;; instead of just a dependency order as in vanilla ASDF 10023 (plan-record-dependency plan operation component) 10024 ;; needed in image distinguishes b/w things that must happen in the 10025 ;; current image and those things that simply need to have been done in a previous one. 10026 (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image 10027 ;; effective niip: meaningful for the action and required by the plan as traversed 10028 (eniip (and aniip needed-in-image-p)) 10029 ;; status: have we traversed that action previously, and if so what was its status? 10030 (status (plan-action-status plan operation component))) 10031 (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) 10032 (return (action-stamp status))) ; Already visited with sufficient need-in-image level! 10033 (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T 10034 (map-direct-dependencies ; recursively traverse dependencies 10035 plan operation component #'(lambda (o c) (traverse-action plan o c niip))) 10036 (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed, 10037 (compute-action-stamp plan operation component) ; compute action stamp 10038 (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) 10039 (cond ; it needs be done if it's out of date or needed in image but absent 10040 ((and add-to-plan-p (not niip)) ; if we need to do it, 10041 (visit-action t)) ; then we need to do it *in the (current) image*! 10042 (t 10043 (setf (plan-action-status plan operation component) ; update status: 10044 (make-instance 10045 'planned-action-status 10046 :stamp stamp ; computed stamp 10047 :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date? 10048 :planned-p add-to-plan-p ; included in list of things to be done? 10049 :index (if status ; index of action amongst all nodes in traversal 10050 (action-index status) ;; if already visited, keep index 10051 (incf (plan-total-action-count plan))))) ; else new index 10052 (when (and done-p (not add-to-plan-p)) 10053 (setf (component-operation-time operation component) stamp)) 10054 (when add-to-plan-p ; if it needs to be added to the plan, 10055 (incf (plan-planned-action-count plan)) ; count it 10056 (unless aniip ; if it's output-producing, 10057 (incf (plan-planned-output-action-count plan)))) ; count it 10058 stamp)))))) ; return the stamp 10059 (while-visiting-action (plan operation component) ; maintain context, handle circularity. 10060 (visit-action eniip))))))) ; visit the action 10061 10062 10063;;;; Sequential plans (the default) 10064(with-upgradability () 10065 (defclass sequential-plan (plan-traversal) 10066 ((actions-r :initform nil :accessor plan-actions-r)) 10067 (:documentation "Simplest, default plan class, accumulating a sequence of actions")) 10068 10069 (defmethod plan-actions ((plan sequential-plan)) 10070 (reverse (plan-actions-r plan))) 10071 10072 ;; No need to record a dependency to build a full graph, just accumulate nodes in order. 10073 (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component)) 10074 (values)) 10075 10076 (defmethod (setf plan-action-status) :after 10077 (new-status (p sequential-plan) (o operation) (c component)) 10078 (when (action-planned-p new-status) 10079 (push (make-action o c) (plan-actions-r p))))) 10080 10081 10082;;;; High-level interface: traverse, perform-plan, plan-operates-on-p 10083(with-upgradability () 10084 (defgeneric make-plan (plan-class operation component &key &allow-other-keys) 10085 (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) 10086 (define-convenience-action-methods make-plan (plan-class operation component &key)) 10087 10088 (defgeneric perform-plan (plan &key) 10089 (:documentation "Actually perform a plan and build the requested actions")) 10090 (defgeneric plan-operates-on-p (plan component) 10091 (:documentation "Does this PLAN include any operation on given COMPONENT?")) 10092 10093 (defvar *default-plan-class* 'sequential-plan 10094 "The default plan class to use when building with ASDF") 10095 10096 (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) 10097 (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) 10098 :system (component-system c) keys))) 10099 (traverse-action plan o c t) 10100 plan)) 10101 10102 (defmethod perform-plan :around ((plan t) &key) 10103 #+xcl (declare (ignorable plan)) 10104 (let ((*package* *package*) 10105 (*readtable* *readtable*)) 10106 (with-compilation-unit () ;; backward-compatibility. 10107 (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. 10108 10109 (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys) 10110 (apply 'perform-plan (plan-actions plan) keys)) 10111 10112 (defmethod perform-plan ((steps list) &key force &allow-other-keys) 10113 (loop* :for action :in steps 10114 :as o = (action-operation action) 10115 :as c = (action-component action) 10116 :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) 10117 :do (perform-with-restarts o c))) 10118 10119 (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) 10120 (plan-operates-on-p (plan-actions plan) component-path)) 10121 10122 (defmethod plan-operates-on-p ((plan list) (component-path list)) 10123 (find component-path (mapcar 'action-component plan) 10124 :test 'equal :key 'component-find-path))) 10125 10126 10127;;;; Incidental traversals 10128 10129;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source 10130;;; files required by a bundling operation. 10131(with-upgradability () 10132 (defclass filtered-sequential-plan (sequential-plan) 10133 ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) 10134 (component-type :initform t :initarg :component-type :reader plan-component-type) 10135 (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) 10136 (keep-component :initform t :initarg :keep-component :reader plan-keep-component)) 10137 (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) 10138 10139 (defmethod initialize-instance :after ((plan filtered-sequential-plan) 10140 &key force force-not 10141 other-systems) 10142 (declare (ignore force force-not)) 10143 ;; Ignore force and force-not, rely on other-systems: 10144 ;; force traversal of what we're interested in, i.e. current system or also others; 10145 ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. 10146 (with-slots (forced forced-not action-filter system) plan 10147 (setf forced (normalize-forced-systems (if other-systems :all t) system)) 10148 (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system)) 10149 (setf action-filter (ensure-function action-filter)))) 10150 10151 (defmethod action-valid-p ((plan filtered-sequential-plan) o c) 10152 (and (funcall (plan-action-filter plan) o c) 10153 (typep c (plan-component-type plan)) 10154 (call-next-method))) 10155 10156 (defun* (traverse-actions) (actions &rest keys &key plan-class &allow-other-keys) 10157 "Given a list of actions, build a plan with these actions as roots." 10158 (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) 10159 (loop* :for action :in actions 10160 :as o = (action-operation action) 10161 :as c = (action-component action) 10162 :do (traverse-action plan o c t)) 10163 plan)) 10164 10165 (defgeneric traverse-sub-actions (operation component &key &allow-other-keys)) 10166 (define-convenience-action-methods traverse-sub-actions (operation component &key)) 10167 (defmethod traverse-sub-actions ((operation operation) (component component) 10168 &rest keys &key &allow-other-keys) 10169 (apply 'traverse-actions (direct-dependencies t operation component) 10170 :system (component-system component) keys)) 10171 10172 (defmethod plan-actions ((plan filtered-sequential-plan)) 10173 (with-slots (keep-operation keep-component) plan 10174 (loop* :for action :in (call-next-method) 10175 :as o = (action-operation action) 10176 :as c = (action-component action) 10177 :when (and (typep o keep-operation) (typep c keep-component)) 10178 :collect (make-action o c)))) 10179 10180 (defun* (required-components) (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) 10181 "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and 10182return a list of the components involved in building the desired action." 10183 (remove-duplicates 10184 (mapcar 'action-component 10185 (plan-actions 10186 (apply 'traverse-sub-actions goal-operation system 10187 (remove-plist-key :goal-operation keys)))) 10188 :from-end t))) 10189 10190;;;; ------------------------------------------------------------------------- 10191;;;; Invoking Operations 10192 10193(uiop/package:define-package :asdf/operate 10194 (:recycle :asdf/operate :asdf) 10195 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache 10196 :asdf/component :asdf/system :asdf/operation :asdf/action 10197 :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) 10198 (:export 10199 #:operate #:oos 10200 #:build-op #:make 10201 #:load-system #:load-systems #:load-systems* 10202 #:compile-system #:test-system #:require-system 10203 #:module-provide-asdf 10204 #:component-loaded-p #:already-loaded-systems)) 10205(in-package :asdf/operate) 10206 10207(with-upgradability () 10208 (defgeneric operate (operation component &key &allow-other-keys) 10209 (:documentation 10210 "Operate does mainly four things for the user: 10211 102121. Resolves the OPERATION designator into an operation object. 10213 OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION. 102142. Resolves the COMPONENT designator into a component object. 10215 COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM. 102163. It then calls MAKE-PLAN with the operation and system as arguments. 102174. Finally calls PERFORM-PLAN on the resulting plan to actually build the system. 10218 10219The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code. 10220If a VERSION argument is supplied, then operate also ensures that the system found satisfies it 10221using the VERSION-SATISFIES method. 10222If a PLAN-CLASS argument is supplied, that class is used for the plan. 10223 10224The :FORCE or :FORCE-NOT argument to OPERATE can be: 10225 T to force the inside of the specified system to be rebuilt (resp. not), 10226 without recursively forcing the other systems we depend on. 10227 :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). 10228 (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list 10229:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced. 10230 10231For backward compatibility, all keyword arguments are passed to MAKE-OPERATION 10232when instantiating a new operation, that will in turn be inherited by new operations. 10233But do NOT depend on it, for this is deprecated behavior.")) 10234 10235 (define-convenience-action-methods operate (operation component &key) 10236 :if-no-component (error 'missing-component :requires component)) 10237 10238 (defvar *in-operate* nil 10239 "Are we in operate?") 10240 10241 ;; This method ensures that an ASDF upgrade is attempted as the very first thing, 10242 ;; with suitable state preservation in case in case it actually happens, 10243 ;; and that a few suitable dynamic bindings are established. 10244 (defmethod operate :around (operation component &rest keys 10245 &key verbose 10246 (on-warnings *compile-file-warnings-behaviour*) 10247 (on-failure *compile-file-failure-behaviour*) &allow-other-keys) 10248 (nest 10249 (with-asdf-cache ()) 10250 (let ((in-operate *in-operate*) 10251 (*in-operate* t) 10252 (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) 10253 (etypecase operation 10254 (operation (let ((name (type-of operation))) 10255 #'(lambda () (make-operation name)))) 10256 ((or symbol string) (constantly operation)))) 10257 (component-path (typecase component ;; to remake the component after ASDF upgrade 10258 (component (component-find-path component)) 10259 (t component))))) 10260 ;; Before we operate on any system, make sure ASDF is up-to-date, 10261 ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. 10262 (progn 10263 (unless in-operate 10264 (when (upgrade-asdf) 10265 ;; If we were upgraded, restart OPERATE the hardest of ways, for 10266 ;; its function may have been redefined. 10267 (return-from operate 10268 (apply 'operate (funcall operation-remaker) component-path keys))))) 10269 ;; Setup proper bindings around any operate call. 10270 (let* ((*verbose-out* (and verbose *standard-output*)) 10271 (*compile-file-warnings-behaviour* on-warnings) 10272 (*compile-file-failure-behaviour* on-failure)) 10273 (call-next-method)))) 10274 10275 (defmethod operate :before ((operation operation) (component component) 10276 &key version &allow-other-keys) 10277 (unless (version-satisfies component version) 10278 (error 'missing-component-of-version :requires component :version version))) 10279 10280 (defmethod operate ((operation operation) (component component) 10281 &rest keys &key plan-class &allow-other-keys) 10282 (let ((plan (apply 'make-plan plan-class operation component keys))) 10283 (apply 'perform-plan plan keys) 10284 (values operation plan))) 10285 10286 (defun oos (operation component &rest args &key &allow-other-keys) 10287 (apply 'operate operation component args)) 10288 10289 (setf (documentation 'oos 'function) 10290 (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" 10291 (documentation 'operate 'function)))) 10292 10293 10294;;;; Common operations 10295(when-upgrading () 10296 (defmethod component-depends-on ((o prepare-op) (s system)) 10297 (call-next-method))) 10298(with-upgradability () 10299 (defclass build-op (non-propagating-operation) () 10300 (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, 10301to operate by default on a system or component, via the function BUILD. 10302Its meaning is configurable via the :BUILD-OPERATION option of a component. 10303which typically specifies the name of a specific operation to which to delegate the build, 10304as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); 10305if NIL is specified (the default), BUILD-OP falls back to LOAD-OP, 10306that will load the system in the current image.")) 10307 (defmethod component-depends-on ((o build-op) (c component)) 10308 `((,(or (component-build-operation c) 'load-op) ,c) 10309 ,@(call-next-method))) 10310 10311 (defun make (system &rest keys) 10312 "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). 10313It will build system FOO using the operation BUILD-OP, 10314the meaning of which is configurable by the system, and 10315defaults to LOAD-OP, to load it in current image." 10316 (apply 'operate 'build-op system keys) 10317 t) 10318 10319 (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys) 10320 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." 10321 (declare (ignore force force-not verbose version)) 10322 (apply 'operate 'load-op system keys) 10323 t) 10324 10325 (defun load-systems* (systems &rest keys) 10326 "Loading multiple systems at once." 10327 (dolist (s systems) (apply 'load-system s keys))) 10328 10329 (defun load-systems (&rest systems) 10330 "Loading multiple systems at once." 10331 (load-systems* systems)) 10332 10333 (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys) 10334 "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." 10335 (declare (ignore force force-not verbose version)) 10336 (apply 'operate 'compile-op system args) 10337 t) 10338 10339 (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys) 10340 "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." 10341 (declare (ignore force force-not verbose version)) 10342 (apply 'operate 'test-op system args) 10343 t)) 10344 10345;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE, 10346;; only tries to load its specified target if it's not loaded yet. 10347(with-upgradability () 10348 (defun component-loaded-p (component) 10349 "Has the given COMPONENT been successfully loaded in the current image (yet)? 10350Note that this returns true even if the component is not up to date." 10351 (if-let ((component (find-component component () :registered t))) 10352 (action-already-done-p nil (make-operation 'load-op) component))) 10353 10354 (defun already-loaded-systems () 10355 "return a list of the names of the systems that have been successfully loaded so far" 10356 (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))) 10357 10358 (defun require-system (system &rest keys &key &allow-other-keys) 10359 "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the 10360system or its dependencies if they have already been loaded." 10361 (unless (component-loaded-p system) 10362 (apply 'load-system system :force-not (already-loaded-systems) keys)))) 10363 10364 10365;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, 10366;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL 10367;; Note that despite the two being homonyms, the _function_ require-system 10368;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes. 10369(with-upgradability () 10370 (defvar *modules-being-required* nil) 10371 10372 (defclass require-system (system) 10373 ((module :initarg :module :initform nil :accessor required-module)) 10374 (:documentation "A SYSTEM subclass whose processing is handled by 10375the implementation's REQUIRE rather than by internal ASDF mechanisms.")) 10376 10377 (defmethod perform ((o compile-op) (c require-system)) 10378 nil) 10379 10380 (defmethod perform ((o load-op) (s require-system)) 10381 (let* ((module (or (required-module s) (coerce-name s))) 10382 (*modules-being-required* (cons module *modules-being-required*))) 10383 (assert (null (component-children s))) 10384 (require module))) 10385 10386 (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) 10387 (unless (and (length=n-p arguments 1) 10388 (typep (car arguments) '(or string (and symbol (not null))))) 10389 (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>") 10390 'resolve-dependency-combination 10391 (cons combinator arguments) component combinator)) 10392 ;; :require must be prepared for some implementations providing modules using ASDF, 10393 ;; as SBCL used to do, and others may might do. Thus, the system provided in the end 10394 ;; would be a downcased name as per module-provide-asdf above. For the same reason, 10395 ;; we cannot assume that the system in the end will be of type require-system, 10396 ;; but must check whether we can use find-system and short-circuit cl:require. 10397 ;; Otherwise, calling cl:require could result in nasty reentrant calls between 10398 ;; cl:require and asdf:operate that could potentially blow up the stack, 10399 ;; all the while defeating the consistency of the dependency graph. 10400 (let* ((module (car arguments)) ;; NB: we already checked that it was not null 10401 ;; CMUCL, MKCL, SBCL like their module names to be all upcase. 10402 (module-name (string module)) 10403 (system-name (string-downcase module)) 10404 (system (find-system system-name nil))) 10405 (or system (let ((system (make-instance 'require-system :name system-name :module module-name))) 10406 (register-system system) 10407 system)))) 10408 10409 (defun module-provide-asdf (name) 10410 ;; We must use string-downcase, because modules are traditionally specified as symbols, 10411 ;; that implementations traditionally normalize as uppercase, for which we seek a system 10412 ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine. 10413 ;; We could make complex, non-portable rules to try to preserve case, and just documenting 10414 ;; them would be a hell that it would be a disservice to inflict on users. 10415 (let ((module-name (string name)) 10416 (system-name (string-downcase name))) 10417 (unless (member module-name *modules-being-required* :test 'equal) 10418 (let ((*modules-being-required* (cons module-name *modules-being-required*)) 10419 #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal))) 10420 (handler-bind 10421 ((style-warning #'muffle-warning) 10422 (missing-component (constantly nil)) 10423 (fatal-condition 10424 #'(lambda (e) 10425 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") 10426 name e)))) 10427 (let ((*verbose-out* (make-broadcast-stream))) 10428 (let ((system (find-system system-name nil))) 10429 (when system 10430 (require-system system-name :verbose nil) 10431 t))))))))) 10432 10433 10434;;;; Some upgrade magic 10435(with-upgradability () 10436 (defun restart-upgraded-asdf () 10437 ;; If we're in the middle of something, restart it. 10438 (let ((systems-being-defined 10439 (when *asdf-cache* 10440 (prog1 10441 (loop :for k :being :the hash-keys :of *asdf-cache* 10442 :when (eq (first k) 'find-system) :collect (second k)) 10443 (clrhash *asdf-cache*))))) 10444 ;; Regardless, clear defined systems, since they might be invalid 10445 ;; after an incompatible ASDF upgrade. 10446 (clear-defined-systems) 10447 ;; The configuration also may have to be upgraded. 10448 (upgrade-configuration) 10449 ;; If we were in the middle of an operation, be sure to restore the system being defined. 10450 (dolist (s systems-being-defined) (find-system s nil)))) 10451 (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf) 10452 10453 ;; The following function's symbol is from asdf/find-system. 10454 ;; It is defined here to resolve what would otherwise be forward package references. 10455 (defun mark-component-preloaded (component) 10456 "Mark a component as preloaded." 10457 (let ((component (find-component component nil :registered t))) 10458 ;; Recurse to children, so asdf/plan will hopefully be happy. 10459 (map () 'mark-component-preloaded (component-children component)) 10460 ;; Mark the timestamps of the common lisp-action operations as 0. 10461 (let ((times (component-operation-times component))) 10462 (dolist (o '(load-op compile-op prepare-op)) 10463 (setf (gethash (make-operation o) times) 0)))))) 10464 10465;;;; ------------------------------------------------------------------------- 10466;;;; Defsystem 10467 10468(uiop/package:define-package :asdf/parse-defsystem 10469 (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) 10470 (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares 10471 (:use :uiop/common-lisp :asdf/driver :asdf/upgrade 10472 :asdf/cache :asdf/component :asdf/system 10473 :asdf/find-system :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) 10474 (:import-from :asdf/system #:depends-on #:weakly-depends-on) 10475 (:export 10476 #:defsystem #:register-system-definition 10477 #:class-for-type #:*default-component-class* 10478 #:determine-system-directory #:parse-component-form 10479 #:non-toplevel-system #:non-system-system #:bad-system-name 10480 #:sysdef-error-component #:check-component-input)) 10481(in-package :asdf/parse-defsystem) 10482 10483;;; Pathname 10484(with-upgradability () 10485 (defun determine-system-directory (pathname) 10486 ;; The defsystem macro calls this function to determine the pathname of a system as follows: 10487 ;; 1. If the pathname argument is an pathname object (NOT a namestring), 10488 ;; that is already an absolute pathname, return it. 10489 ;; 2. Otherwise, the directory containing the LOAD-PATHNAME 10490 ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and 10491 ;; if it is indeed available and an absolute pathname, then 10492 ;; the PATHNAME argument is normalized to a relative pathname 10493 ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) 10494 ;; and merged into that DIRECTORY as per SUBPATHNAME. 10495 ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source, 10496 ;; but may be from within the EVAL-WHEN of a file compilation. 10497 ;; If no absolute pathname was found, we return NIL. 10498 (check-type pathname (or null string pathname)) 10499 (pathname-directory-pathname 10500 (resolve-symlinks* 10501 (ensure-absolute-pathname 10502 (parse-unix-namestring pathname :type :directory) 10503 #'(lambda () (ensure-absolute-pathname 10504 (load-pathname) 'get-pathname-defaults nil)) 10505 nil))))) 10506 10507 10508;;; Component class 10509(with-upgradability () 10510 ;; What :file gets interpreted as, unless overridden by a :default-component-class 10511 (defvar *default-component-class* 'cl-source-file) 10512 10513 (defun class-for-type (parent type) 10514 (or (coerce-class type :package :asdf/interface :super 'component :error nil) 10515 (and (eq type :file) 10516 (coerce-class 10517 (or (loop :for p = parent :then (component-parent p) :while p 10518 :thereis (module-default-component-class p)) 10519 *default-component-class*) 10520 :package :asdf/interface :super 'component :error nil)) 10521 (sysdef-error "don't recognize component type ~S" type)))) 10522 10523 10524;;; Check inputs 10525(with-upgradability () 10526 (define-condition non-system-system (system-definition-error) 10527 ((name :initarg :name :reader non-system-system-name) 10528 (class-name :initarg :class-name :reader non-system-system-class-name)) 10529 (:report (lambda (c s) 10530 (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>") 10531 (non-system-system-name c) (non-system-system-class-name c) 'system)))) 10532 10533 (define-condition non-toplevel-system (system-definition-error) 10534 ((parent :initarg :parent :reader non-toplevel-system-parent) 10535 (name :initarg :name :reader non-toplevel-system-name)) 10536 (:report (lambda (c s) 10537 (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>") 10538 (non-toplevel-system-parent c) (non-toplevel-system-name c))))) 10539 10540 (define-condition bad-system-name (warning) 10541 ((name :initarg :name :reader component-name) 10542 (source-file :initarg :source-file :reader system-source-file)) 10543 (:report (lambda (c s) 10544 (let* ((file (system-source-file c)) 10545 (name (component-name c)) 10546 (asd (pathname-name file))) 10547 (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~ 10548Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>") 10549 file name asd (strcat asd "/") (strcat asd "/test")))))) 10550 10551 (defun sysdef-error-component (msg type name value) 10552 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) 10553 type name value)) 10554 10555 (defun check-component-input (type name weakly-depends-on 10556 depends-on components) 10557 "A partial test of the values of a component." 10558 (unless (listp depends-on) 10559 (sysdef-error-component ":depends-on must be a list." 10560 type name depends-on)) 10561 (unless (listp weakly-depends-on) 10562 (sysdef-error-component ":weakly-depends-on must be a list." 10563 type name weakly-depends-on)) 10564 (unless (listp components) 10565 (sysdef-error-component ":components must be NIL or a list of components." 10566 type name components))) 10567 10568 ;; Given a form used as :version specification, in the context of a system definition 10569 ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form 10570 ;; to an acceptable ASDF-format version. 10571 (defun* (normalize-version) (form &key pathname component parent) 10572 (labels ((invalid (&optional (continuation "using NIL instead")) 10573 (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>") 10574 form component parent pathname continuation)) 10575 (invalid-parse (control &rest args) 10576 (unless (if-let (target (find-component parent component)) (builtin-system-p target)) 10577 (apply 'warn control args) 10578 (invalid)))) 10579 (if-let (v (typecase form 10580 ((or string null) form) 10581 (real 10582 (invalid "Substituting a string") 10583 (format nil "~D" form)) ;; 1.0 becomes "1.0" 10584 (cons 10585 (case (first form) 10586 ((:read-file-form) 10587 (destructuring-bind (subpath &key (at 0)) (rest form) 10588 (safe-read-file-form (subpathname pathname subpath) 10589 :at at :package :asdf-user))) 10590 ((:read-file-line) 10591 (destructuring-bind (subpath &key (at 0)) (rest form) 10592 (safe-read-file-line (subpathname pathname subpath) 10593 :at at))) 10594 (otherwise 10595 (invalid)))) 10596 (t 10597 (invalid)))) 10598 (if-let (pv (parse-version v #'invalid-parse)) 10599 (unparse-version pv) 10600 (invalid)))))) 10601 10602 10603;;; "inline methods" 10604(with-upgradability () 10605 (defparameter* +asdf-methods+ 10606 '(perform-with-restarts perform explain output-files operation-done-p)) 10607 10608 (defun %remove-component-inline-methods (component) 10609 (dolist (name +asdf-methods+) 10610 (map () 10611 ;; this is inefficient as most of the stored 10612 ;; methods will not be for this particular gf 10613 ;; But this is hardly performance-critical 10614 #'(lambda (m) 10615 (remove-method (symbol-function name) m)) 10616 (component-inline-methods component))) 10617 (component-inline-methods component) nil) 10618 10619 (defun %define-component-inline-methods (ret rest) 10620 (loop* :for (key value) :on rest :by #'cddr 10621 :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) 10622 :when name :do 10623 (destructuring-bind (op &rest body) value 10624 (loop :for arg = (pop body) 10625 :while (atom arg) 10626 :collect arg :into qualifiers 10627 :finally 10628 (destructuring-bind (o c) arg 10629 (pushnew 10630 (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body)) 10631 (component-inline-methods ret))))))) 10632 10633 (defun %refresh-component-inline-methods (component rest) 10634 ;; clear methods, then add the new ones 10635 (%remove-component-inline-methods component) 10636 (%define-component-inline-methods component rest))) 10637 10638 10639;;; Main parsing function 10640(with-upgradability () 10641 (defun parse-dependency-def (dd) 10642 (if (listp dd) 10643 (case (first dd) 10644 (:feature 10645 (unless (= (length dd) 3) 10646 (sysdef-error "Ill-formed feature dependency: ~s" dd)) 10647 (let ((embedded (parse-dependency-def (third dd)))) 10648 `(:feature ,(second dd) ,embedded))) 10649 (feature 10650 (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd)) 10651 (:require 10652 (unless (= (length dd) 2) 10653 (sysdef-error "Ill-formed require dependency: ~s" dd)) 10654 dd) 10655 (:version 10656 (unless (= (length dd) 3) 10657 (sysdef-error "Ill-formed version dependency: ~s" dd)) 10658 `(:version ,(coerce-name (second dd)) ,(third dd))) 10659 (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) 10660 (coerce-name dd))) 10661 10662 (defun parse-dependency-defs (dd-list) 10663 "Parse the dependency defs in DD-LIST into canonical form by translating all 10664system names contained using COERCE-NAME. Return the result." 10665 (mapcar 'parse-dependency-def dd-list)) 10666 10667 (defun* (parse-component-form) (parent options &key previous-serial-component) 10668 (destructuring-bind 10669 (type name &rest rest &key 10670 (builtin-system-p () bspp) 10671 ;; the following list of keywords is reproduced below in the 10672 ;; remove-plist-keys form. important to keep them in sync 10673 components pathname perform explain output-files operation-done-p 10674 weakly-depends-on depends-on serial 10675 do-first if-component-dep-fails version 10676 ;; list ends 10677 &allow-other-keys) options 10678 (declare (ignore perform explain output-files operation-done-p builtin-system-p)) 10679 (check-component-input type name weakly-depends-on depends-on components) 10680 (when (and parent 10681 (find-component parent name) 10682 (not ;; ignore the same object when rereading the defsystem 10683 (typep (find-component parent name) 10684 (class-for-type parent type)))) 10685 (error 'duplicate-names :name name)) 10686 (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) 10687 (let* ((name (coerce-name name)) 10688 (args `(:name ,name 10689 :pathname ,pathname 10690 ,@(when parent `(:parent ,parent)) 10691 ,@(remove-plist-keys 10692 '(:components :pathname :if-component-dep-fails :version 10693 :perform :explain :output-files :operation-done-p 10694 :weakly-depends-on :depends-on :serial) 10695 rest))) 10696 (component (find-component parent name)) 10697 (class (class-for-type parent type))) 10698 (when (and parent (subtypep class 'system)) 10699 (error 'non-toplevel-system :parent parent :name name)) 10700 (if component ; preserve identity 10701 (apply 'reinitialize-instance component args) 10702 (setf component (apply 'make-instance class args))) 10703 (component-pathname component) ; eagerly compute the absolute pathname 10704 (when (typep component 'system) 10705 ;; cache information for introspection 10706 (setf (slot-value component 'depends-on) 10707 (parse-dependency-defs depends-on) 10708 (slot-value component 'weakly-depends-on) 10709 ;; these must be a list of systems, cannot be features or versioned systems 10710 (mapcar 'coerce-name weakly-depends-on))) 10711 (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous 10712 (when (and (typep component 'system) (not bspp)) 10713 (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) 10714 (setf version (normalize-version version :component name :parent parent :pathname sysfile))) 10715 ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. 10716 ;; A better fix is required. 10717 (setf (slot-value component 'version) version) 10718 (when (typep component 'parent-component) 10719 (setf (component-children component) 10720 (loop 10721 :with previous-component = nil 10722 :for c-form :in components 10723 :for c = (parse-component-form component c-form 10724 :previous-serial-component previous-component) 10725 :for name = (component-name c) 10726 :collect c 10727 :when serial :do (setf previous-component name))) 10728 (compute-children-by-name component)) 10729 (when previous-serial-component 10730 (push previous-serial-component depends-on)) 10731 (when weakly-depends-on 10732 ;; ASDF4: deprecate this feature and remove it. 10733 (appendf depends-on 10734 (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) 10735 ;; Used by POIU. ASDF4: rename to component-depends-on? 10736 (setf (component-sideway-dependencies component) depends-on) 10737 (%refresh-component-inline-methods component rest) 10738 (when if-component-dep-fails 10739 (error "The system definition for ~S uses deprecated ~ 10740 ASDF option :IF-COMPONENT-DEP-FAILS. ~ 10741 Starting with ASDF 3, please use :IF-FEATURE instead" 10742 (coerce-name (component-system component)))) 10743 component))) 10744 10745 (defun register-system-definition 10746 (name &rest options &key pathname (class 'system) (source-file () sfp) 10747 defsystem-depends-on &allow-other-keys) 10748 ;; The system must be registered before we parse the body, 10749 ;; otherwise we recur when trying to find an existing system 10750 ;; of the same name to reuse options (e.g. pathname) from. 10751 ;; To avoid infinite recursion in cases where you defsystem a system 10752 ;; that is registered to a different location to find-system, 10753 ;; we also need to remember it in the asdf-cache. 10754 (nest 10755 (with-asdf-cache ()) 10756 (let* ((name (coerce-name name)) 10757 (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) 10758 (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) 10759 (let* ((asd-name (and source-file 10760 (equal "asd" (fix-case (pathname-type source-file))) 10761 (fix-case (pathname-name source-file)))) 10762 (primary-name (primary-system-name name))) 10763 (when (and asd-name (not (equal asd-name primary-name))) 10764 (warn (make-condition 'bad-system-name :source-file source-file :name name)))) 10765 (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, 10766 ;; so that in case it fails, there is no incomplete object polluting the build. 10767 (checked-defsystem-depends-on 10768 (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) 10769 (deps (loop :for spec :in dep-forms 10770 :when (resolve-dependency-spec nil spec) 10771 :collect :it))) 10772 (load-systems* deps) 10773 dep-forms)) 10774 (registered (system-registered-p name)) 10775 (registered! (if registered 10776 (rplaca registered (get-file-stamp source-file)) 10777 (register-system 10778 (make-instance 'system :name name :source-file source-file)))) 10779 (system (reset-system (cdr registered!) 10780 :name name :source-file source-file)) 10781 (component-options 10782 (append 10783 (remove-plist-keys '(:defsystem-depends-on :class) options) 10784 ;; cache defsystem-depends-on in canonical form 10785 (when checked-defsystem-depends-on 10786 `(:defsystem-depends-on ,checked-defsystem-depends-on)))) 10787 (directory (determine-system-directory pathname))) 10788 ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: 10789 (set-asdf-cache-entry `(find-system ,name) (list system))) 10790 ;; We change-class AFTER we loaded the defsystem-depends-on 10791 ;; since the class might be defined as part of those. 10792 (let ((class (class-for-type nil class))) 10793 (unless (subtypep class 'system) 10794 (error 'non-system-system :name name :class-name (class-name class))) 10795 (unless (eq (type-of system) class) 10796 (change-class system class))) 10797 (parse-component-form nil (list* :module name :pathname directory component-options)))) 10798 10799 (defmacro defsystem (name &body options) 10800 `(apply 'register-system-definition ',name ',options))) 10801;;;; ------------------------------------------------------------------------- 10802;;;; ASDF-Bundle 10803 10804(uiop/package:define-package :asdf/bundle 10805 (:recycle :asdf/bundle :asdf) 10806 (:use :uiop/common-lisp :uiop :asdf/upgrade 10807 :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation 10808 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) 10809 (:export 10810 #:bundle-op #:bundle-type #:program-system 10811 #:bundle-system #:bundle-pathname-type #:direct-dependency-files 10812 #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p 10813 #:basic-compile-bundle-op #:prepare-bundle-op 10814 #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op 10815 #:lib-op #:monolithic-lib-op 10816 #:dll-op #:monolithic-dll-op 10817 #:deliver-asd-op #:monolithic-deliver-asd-op 10818 #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system 10819 #:user-system-p #:user-system #:trivial-system-p 10820 #:prologue-code #:epilogue-code #:static-library)) 10821(in-package :asdf/bundle) 10822 10823(with-upgradability () 10824 (defclass bundle-op (operation) 10825 ;; NB: use of instance-allocated slots for operations is DEPRECATED 10826 ;; and only supported in a temporary fashion for backward compatibility. 10827 ;; Supported replacement: Define slots on program-system instead. 10828 ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class)) 10829 (:documentation "base class for operations that bundle outputs from multiple components")) 10830 10831 (defclass monolithic-op (operation) () 10832 (:documentation "A MONOLITHIC operation operates on a system *and all of its 10833dependencies*. So, for example, a monolithic concatenate operation will 10834concatenate together a system's components and all of its dependencies, but a 10835simple concatenate operation will concatenate only the components of the system 10836itself.")) 10837 10838 (defclass monolithic-bundle-op (bundle-op monolithic-op) 10839 ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. 10840 ;; DEPRECATED. Supported replacement: Define slots on program-system instead. 10841 ((prologue-code :initform nil :accessor prologue-code) 10842 (epilogue-code :initform nil :accessor epilogue-code)) 10843 (:documentation "operations that are both monolithic-op and bundle-op")) 10844 10845 (defclass program-system (system) 10846 ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system 10847 ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) 10848 (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) 10849 (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) 10850 (prefix-lisp-object-files :initarg :prefix-lisp-object-files 10851 :initform nil :accessor prefix-lisp-object-files) 10852 (postfix-lisp-object-files :initarg :postfix-lisp-object-files 10853 :initform nil :accessor postfix-lisp-object-files) 10854 (extra-object-files :initarg :extra-object-files 10855 :initform nil :accessor extra-object-files) 10856 (extra-build-args :initarg :extra-build-args 10857 :initform nil :accessor extra-build-args))) 10858 10859 (defmethod prologue-code ((x system)) nil) 10860 (defmethod epilogue-code ((x system)) nil) 10861 (defmethod no-uiop ((x system)) nil) 10862 (defmethod prefix-lisp-object-files ((x system)) nil) 10863 (defmethod postfix-lisp-object-files ((x system)) nil) 10864 (defmethod extra-object-files ((x system)) nil) 10865 (defmethod extra-build-args ((x system)) nil) 10866 10867 (defclass link-op (bundle-op) () 10868 (:documentation "Abstract operation for linking files together")) 10869 10870 (defclass gather-operation (bundle-op) 10871 ((gather-operation :initform nil :allocation :class :reader gather-operation) 10872 (gather-type :initform :no-output-file :allocation :class :reader gather-type)) 10873 (:documentation "Abstract operation for gathering many input files from a system")) 10874 10875 (defun operation-monolithic-p (op) 10876 (typep op 'monolithic-op)) 10877 10878 ;; Dependencies of a gather-op are the actions of the dependent operation 10879 ;; for all the (sorted) required components for loading the system. 10880 ;; Monolithic operations typically use lib-op as the dependent operation, 10881 ;; and all system-level dependencies as required components. 10882 ;; Non-monolithic operations typically use compile-op as the dependent operation, 10883 ;; and all transitive sub-components as required components (excluding other systems). 10884 (defmethod component-depends-on ((o gather-operation) (s system)) 10885 (let* ((mono (operation-monolithic-p o)) 10886 (go (make-operation (or (gather-operation o) 'compile-op))) 10887 (bundle-p (typep go 'bundle-op)) 10888 ;; In a non-mono operation, don't recurse to other systems. 10889 ;; In a mono operation gathering bundles, don't recurse inside systems. 10890 (component-type (if mono (if bundle-p 'system t) '(not system))) 10891 ;; In the end, only keep system bundles or non-system bundles, depending. 10892 (keep-component (if bundle-p 'system '(not system))) 10893 (deps 10894 ;; Required-components only looks at the dependencies of an action, excluding the action 10895 ;; itself, so it may be safely used by an action recursing on its dependencies (which 10896 ;; may or may not be an overdesigned API, since in practice we never use it that way). 10897 ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks 10898 ;; cleaner, we will miss the load-op on the requested system itself, which doesn't 10899 ;; matter for a regular system, but matters, a lot, for a package-inferred-system. 10900 ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works 10901 ;; for our needs of gathering all the files we want to include in a bundle. 10902 ;; Note that we use basic-compile-op rather than compile-op so it will still work on 10903 ;; systems that would somehow load dependencies with load-bundle-op. 10904 (required-components 10905 s :other-systems mono :component-type component-type :keep-component keep-component 10906 :goal-operation 'load-op :keep-operation 'basic-compile-op))) 10907 `((,go ,@deps) ,@(call-next-method)))) 10908 10909 ;; Create a single fasl for the entire library 10910 (defclass basic-compile-bundle-op (bundle-op basic-compile-op) 10911 ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object 10912 :allocation :class) 10913 (bundle-type :initform :fasb :allocation :class)) 10914 (:documentation "Base class for compiling into a bundle")) 10915 10916 ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op 10917 (defclass prepare-bundle-op (sideway-operation) 10918 ((sideway-operation 10919 :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op 10920 :allocation :class)) 10921 (:documentation "Operation class for loading the bundles of a system's dependencies")) 10922 10923 (defclass lib-op (link-op gather-operation non-propagating-operation) 10924 ((gather-type :initform :object :allocation :class) 10925 (bundle-type :initform :lib :allocation :class)) 10926 (:documentation "Compile the system and produce a linkable static library (.a/.lib) 10927for all the linkable object files associated with the system. Compare with DLL-OP. 10928 10929On most implementations, these object files only include extensions to the runtime 10930written in C or another language with a compiler producing linkable object files. 10931On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files 10932themselves. In any case, this operation will produce what you need to further build 10933a static runtime for your system, or a dynamic library to load in an existing runtime.")) 10934 10935 ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so; 10936 ;; on other implementations, we combine (usually concatenate) the .fasl files into one. 10937 (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation 10938 #+(or clasp ecl mkcl) link-op) 10939 ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) 10940 (:documentation "This operator is an alternative to COMPILE-OP. Build a system 10941and all of its dependencies, but build only a single (\"monolithic\") FASL, instead 10942of one per source file, which may be more resource efficient. That monolithic 10943FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) 10944 10945 (defclass load-bundle-op (basic-load-op selfward-operation) 10946 ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) 10947 (:documentation "This operator is an alternative to LOAD-OP. Build a system 10948and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with 10949respect to LOAD-OP is that it builds only a single FASL, which may be 10950faster and more resource efficient.")) 10951 10952 ;; NB: since the monolithic-op's can't be sideway-operation's, 10953 ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, 10954 ;; we'd have to have the monolithic-op not inherit from the main op, 10955 ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. 10956 10957 (defclass dll-op (link-op gather-operation non-propagating-operation) 10958 ((gather-type :initform :object :allocation :class) 10959 (bundle-type :initform :dll :allocation :class)) 10960 (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) 10961for all the linkable object files associated with the system. Compare with LIB-OP.")) 10962 10963 (defclass deliver-asd-op (basic-compile-op selfward-operation) 10964 ((selfward-operation 10965 ;; TODO: implement link-op on all implementations, and make that 10966 ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) 10967 :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) 10968 :allocation :class)) 10969 (:documentation "produce an asd file for delivering the system as a single fasl")) 10970 10971 10972 (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op) 10973 ((selfward-operation 10974 ;; TODO: implement link-op on all implementations, and make that 10975 ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) 10976 :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) 10977 :allocation :class)) 10978 (:documentation "produce fasl and asd files for combined system and dependencies.")) 10979 10980 (defclass monolithic-compile-bundle-op 10981 (basic-compile-bundle-op monolithic-bundle-op 10982 #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) 10983 () 10984 (:documentation "Create a single fasl for the system and its dependencies.")) 10985 10986 (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op) 10987 ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) 10988 (:documentation "Load a single fasl for the system and its dependencies.")) 10989 10990 (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) 10991 ((gather-type :initform :object :allocation :class)) 10992 (:documentation "Compile the system and produce a linkable static library (.a/.lib) 10993for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) 10994 10995 (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) 10996 ((gather-type :initform :object :allocation :class)) 10997 (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) 10998for all the linkable object files associated with the system or its dependencies. See LIB-OP")) 10999 11000 (defclass image-op (monolithic-bundle-op selfward-operation 11001 #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) 11002 ((bundle-type :initform :image :allocation :class) 11003 (gather-operation :initform 'lib-op :allocation :class) 11004 #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class) 11005 (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) 11006 (:documentation "create an image file from the system and its dependencies")) 11007 11008 (defclass program-op (image-op) 11009 ((bundle-type :initform :program :allocation :class)) 11010 (:documentation "create an executable file from the system and its dependencies")) 11011 11012 ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. 11013 (defun bundle-pathname-type (bundle-type) 11014 (etypecase bundle-type 11015 ((or null string) ;; pass through nil or string literal 11016 bundle-type) 11017 ((eql :no-output-file) ;; marker for a bundle-type that has NO output file 11018 (error "No output file, therefore no pathname type")) 11019 ((eql :fasl) ;; the type of a fasl 11020 (compile-file-type)) ; on image-based platforms, used as input and output 11021 ((eql :fasb) ;; the type of a fasl 11022 #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output 11023 #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles 11024 ((member :image) 11025 #+allegro "dxl" 11026 #+(and clisp os-windows) "exe" 11027 #-(or allegro (and clisp os-windows)) "image") 11028 ;; NB: on CLASP and ECL these implementations, we better agree with 11029 ;; (compile-file-type :type bundle-type)) 11030 ((eql :object) ;; the type of a linkable object file 11031 (os-cond ((os-unix-p) "o") 11032 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) 11033 ((member :lib :static-library) ;; the type of a linkable library 11034 (os-cond ((os-unix-p) "a") 11035 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) 11036 ((member :dll :shared-library) ;; the type of a shared library 11037 (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) 11038 ((eql :program) ;; the type of an executable program 11039 (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) 11040 11041 ;; Compute the output-files for a given bundle action 11042 (defun bundle-output-files (o c) 11043 (let ((bundle-type (bundle-type o))) 11044 (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. 11045 (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) 11046 (let ((name (or (component-build-pathname c) 11047 (let ((suffix 11048 (unless (typep o 'program-op) 11049 ;; "." is no good separator for Logical Pathnames, so we use "--" 11050 (if (operation-monolithic-p o) 11051 "--all-systems" 11052 ;; These use a different type .fasb or .a instead of .fasl 11053 #-(or clasp ecl mkcl) "--system")))) 11054 (format nil "~A~@[~A~]" (component-name c) suffix)))) 11055 (type (bundle-pathname-type bundle-type))) 11056 (values (list (subpathname (component-pathname c) name :type type)) 11057 (eq (class-of o) (coerce-class (component-build-operation c) 11058 :package :asdf/interface 11059 :super 'operation 11060 :error nil))))))) 11061 11062 (defmethod output-files ((o bundle-op) (c system)) 11063 (bundle-output-files o c)) 11064 11065 #-(or clasp ecl mkcl) 11066 (progn 11067 (defmethod perform ((o image-op) (c system)) 11068 (dump-image (output-file o c) :executable (typep o 'program-op))) 11069 (defmethod perform :before ((o program-op) (c system)) 11070 (setf *image-entry-point* (ensure-function (component-entry-point c))))) 11071 11072 (defclass compiled-file (file-component) 11073 ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) 11074 (:documentation "Class for a file that is already compiled, 11075e.g. as part of the implementation, of an outer build system that calls into ASDF, 11076or of opaque libraries shipped along the source code.")) 11077 11078 (defclass precompiled-system (system) 11079 ((build-pathname :initarg :fasb :initarg :fasl)) 11080 (:documentation "Class For a system that is delivered as a precompiled fasl")) 11081 11082 (defclass prebuilt-system (system) 11083 ((build-pathname :initarg :static-library :initarg :lib 11084 :accessor prebuilt-system-static-library)) 11085 (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) 11086 11087 11088;;; 11089;;; BUNDLE-OP 11090;;; 11091;;; This operation takes all components from one or more systems and 11092;;; creates a single output file, which may be 11093;;; a FASL, a statically linked library, a shared library, etc. 11094;;; The different targets are defined by specialization. 11095;;; 11096(when-upgrading (:version "3.2.0") 11097 ;; Cancel any previously defined method 11098 (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) 11099 (declare (ignore initargs)))) 11100 11101(with-upgradability () 11102 (defgeneric trivial-system-p (component)) 11103 11104 (defun user-system-p (s) 11105 (and (typep s 'system) 11106 (not (builtin-system-p s)) 11107 (not (trivial-system-p s))))) 11108 11109(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) 11110 (deftype user-system () '(and system (satisfies user-system-p)))) 11111 11112;;; 11113;;; First we handle monolithic bundles. 11114;;; These are standalone systems which contain everything, 11115;;; including other ASDF systems required by the current one. 11116;;; A PROGRAM is always monolithic. 11117;;; 11118;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL 11119;;; 11120(with-upgradability () 11121 (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) 11122 ;; This function selects output files from direct dependencies; 11123 ;; your component-depends-on method must gather the correct dependencies in the correct order. 11124 (while-collecting (collect) 11125 (map-direct-dependencies 11126 t o c #'(lambda (sub-o sub-c) 11127 (loop :for f :in (funcall key sub-o sub-c) 11128 :when (funcall test f) :do (collect f)))))) 11129 11130 (defun pathname-type-equal-function (type) 11131 #'(lambda (p) (equalp (pathname-type p) type))) 11132 11133 (defmethod input-files ((o gather-operation) (c system)) 11134 (unless (eq (bundle-type o) :no-output-file) 11135 (direct-dependency-files 11136 o c :key 'output-files 11137 :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) 11138 11139 ;; Find the operation that produces a given bundle-type 11140 (defun select-bundle-operation (type &optional monolithic) 11141 (ecase type 11142 ((:dll :shared-library) 11143 (if monolithic 'monolithic-dll-op 'dll-op)) 11144 ((:lib :static-library) 11145 (if monolithic 'monolithic-lib-op 'lib-op)) 11146 ((:fasb) 11147 (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) 11148 ((:image) 11149 'image-op) 11150 ((:program) 11151 'program-op)))) 11152 11153;;; 11154;;; LOAD-BUNDLE-OP 11155;;; 11156;;; This is like ASDF's LOAD-OP, but using bundle fasl files. 11157;;; 11158(with-upgradability () 11159 (defmethod component-depends-on ((o load-bundle-op) (c system)) 11160 `((,o ,@(component-sideway-dependencies c)) 11161 (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) 11162 ,@(call-next-method))) 11163 11164 (defmethod input-files ((o load-bundle-op) (c system)) 11165 (when (user-system-p c) 11166 (output-files (find-operation o 'compile-bundle-op) c))) 11167 11168 (defmethod perform ((o load-bundle-op) (c system)) 11169 (when (input-files o c) 11170 (perform-lisp-load-fasl o c))) 11171 11172 (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) 11173 (mark-operation-done (find-operation o 'load-op) c))) 11174 11175;;; 11176;;; PRECOMPILED FILES 11177;;; 11178;;; This component can be used to distribute ASDF systems in precompiled form. 11179;;; Only useful when the dependencies have also been precompiled. 11180;;; 11181(with-upgradability () 11182 (defmethod trivial-system-p ((s system)) 11183 (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) 11184 11185 (defmethod input-files ((o operation) (c compiled-file)) 11186 (list (component-pathname c))) 11187 (defmethod perform ((o load-op) (c compiled-file)) 11188 (perform-lisp-load-fasl o c)) 11189 (defmethod perform ((o load-source-op) (c compiled-file)) 11190 (perform (find-operation o 'load-op) c)) 11191 (defmethod perform ((o operation) (c compiled-file)) 11192 nil)) 11193 11194;;; 11195;;; Pre-built systems 11196;;; 11197(with-upgradability () 11198 (defmethod trivial-system-p ((s prebuilt-system)) 11199 t) 11200 11201 (defmethod perform ((o link-op) (c prebuilt-system)) 11202 nil) 11203 11204 (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) 11205 nil) 11206 11207 (defmethod perform ((o lib-op) (c prebuilt-system)) 11208 nil) 11209 11210 (defmethod perform ((o dll-op) (c prebuilt-system)) 11211 nil) 11212 11213 (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) 11214 nil) 11215 11216 (defmethod output-files ((o lib-op) (c prebuilt-system)) 11217 (values (list (prebuilt-system-static-library c)) t))) 11218 11219 11220;;; 11221;;; PREBUILT SYSTEM CREATOR 11222;;; 11223(with-upgradability () 11224 (defmethod output-files ((o deliver-asd-op) (s system)) 11225 (list (make-pathname :name (component-name s) :type "asd" 11226 :defaults (component-pathname s)))) 11227 11228 (defmethod perform ((o deliver-asd-op) (s system)) 11229 (let* ((inputs (input-files o s)) 11230 (fasl (first inputs)) 11231 (library (second inputs)) 11232 (asd (first (output-files o s))) 11233 (name (if (and fasl asd) (pathname-name asd) (return-from perform))) 11234 (version (component-version s)) 11235 (dependencies 11236 (if (operation-monolithic-p o) 11237 ;; We want only dependencies, and we use basic-load-op rather than load-op so that 11238 ;; this will keep working on systems that load dependencies with load-bundle-op 11239 (remove-if-not 'builtin-system-p 11240 (required-components s :component-type 'system 11241 :keep-operation 'basic-load-op)) 11242 (while-collecting (x) ;; resolve the sideway-dependencies of s 11243 (map-direct-dependencies 11244 t 'load-op s 11245 #'(lambda (o c) 11246 (when (and (typep o 'load-op) (typep c 'system)) 11247 (x c))))))) 11248 (depends-on (mapcar 'coerce-name dependencies))) 11249 (when (pathname-equal asd (system-source-file s)) 11250 (cerror "overwrite the asd file" 11251 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~ 11252which is probably not what you want; you probably need to tweak your output translations." 11253 (cons o s) asd)) 11254 (with-open-file (s asd :direction :output :if-exists :supersede 11255 :if-does-not-exist :create) 11256 (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" 11257 (operation-monolithic-p o) name) 11258 (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" 11259 (lisp-implementation-type) 11260 (lisp-implementation-version) 11261 (software-type) 11262 (machine-type) 11263 (software-version)) 11264 (let ((*package* (find-package :asdf-user))) 11265 (pprint `(defsystem ,name 11266 :class prebuilt-system 11267 :version ,version 11268 :depends-on ,depends-on 11269 :components ((:compiled-file ,(pathname-name fasl))) 11270 ,@(when library `(:lib ,(file-namestring library)))) 11271 s) 11272 (terpri s))))) 11273 11274 #-(or clasp ecl mkcl) 11275 (defmethod perform ((o basic-compile-bundle-op) (c system)) 11276 (let* ((input-files (input-files o c)) 11277 (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) 11278 (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) 11279 (output-files (output-files o c)) 11280 (output-file (first output-files))) 11281 (assert (eq (not input-files) (not output-files))) 11282 (when input-files 11283 (when non-fasl-files 11284 (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" 11285 (implementation-type) non-fasl-files)) 11286 (when (or (prologue-code c) (epilogue-code c)) 11287 (error "prologue-code and epilogue-code are not supported on ~A" 11288 (implementation-type))) 11289 (with-staging-pathname (output-file) 11290 (combine-fasls fasl-files output-file))))) 11291 11292 (defmethod input-files ((o load-op) (s precompiled-system)) 11293 (bundle-output-files (find-operation o 'compile-bundle-op) s)) 11294 11295 (defmethod perform ((o load-op) (s precompiled-system)) 11296 (perform-lisp-load-fasl o s)) 11297 11298 (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) 11299 #+xcl (declare (ignorable o)) 11300 `((load-op ,s) ,@(call-next-method)))) 11301 11302#| ;; Example use: 11303(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) 11304(asdf:load-system :precompiled-asdf-utils) 11305|# 11306 11307#+(or clasp ecl mkcl) 11308(with-upgradability () 11309 (defun system-module-pathname (module) 11310 (let ((name (coerce-name module))) 11311 (some 11312 'file-exists-p 11313 (list 11314 #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) 11315 #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) 11316 #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib) 11317 #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) 11318 #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") 11319 #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) 11320 11321 (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) 11322 "Creates a prebuilt-system if PATHNAME isn't NIL." 11323 (when pathname 11324 (make-instance 'prebuilt-system 11325 :name (coerce-name name) 11326 :static-library (resolve-symlinks* pathname)))) 11327 11328 (defun linkable-system (x) 11329 (or (if-let (s (find-system x)) 11330 (and (system-source-file x) s)) 11331 (if-let (p (system-module-pathname (coerce-name x))) 11332 (make-prebuilt-system x p)))) 11333 11334 (defmethod component-depends-on :around ((o image-op) (c system)) 11335 (let* ((next (call-next-method)) 11336 (deps (make-hash-table :test 'equal)) 11337 (linkable (loop* :for (do . dcs) :in next :collect 11338 (cons do 11339 (loop :for dc :in dcs 11340 :for dep = (and dc (resolve-dependency-spec c dc)) 11341 :when dep 11342 :do (setf (gethash (coerce-name (component-system dep)) deps) t) 11343 :collect (or (and (typep dep 'system) (linkable-system dep)) dep)))))) 11344 `((lib-op 11345 ,@(unless (no-uiop c) 11346 (list (linkable-system "cmp") 11347 (unless (or (gethash "uiop" deps) (gethash "asdf" deps)) 11348 (or (linkable-system "uiop") 11349 (linkable-system "asdf") 11350 "asdf"))))) 11351 ,@linkable))) 11352 11353 (defmethod perform ((o link-op) (c system)) 11354 (let* ((object-files (input-files o c)) 11355 (output (output-files o c)) 11356 (bundle (first output)) 11357 (programp (typep o 'program-op)) 11358 (kind (bundle-type o))) 11359 (when output 11360 (apply 'create-image 11361 bundle (append 11362 (when programp (prefix-lisp-object-files c)) 11363 object-files 11364 (when programp (postfix-lisp-object-files c))) 11365 :kind kind 11366 :prologue-code (when programp (prologue-code c)) 11367 :epilogue-code (when programp (epilogue-code c)) 11368 :build-args (when programp (extra-build-args c)) 11369 :extra-object-files (when programp (extra-object-files c)) 11370 :no-uiop (no-uiop c) 11371 (when programp `(:entry-point ,(component-entry-point c)))))))) 11372;;;; ------------------------------------------------------------------------- 11373;;;; Concatenate-source 11374 11375(uiop/package:define-package :asdf/concatenate-source 11376 (:recycle :asdf/concatenate-source :asdf) 11377 (:use :uiop/common-lisp :uiop :asdf/upgrade 11378 :asdf/component :asdf/operation 11379 :asdf/system :asdf/find-system 11380 :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) 11381 (:export 11382 #:concatenate-source-op 11383 #:load-concatenated-source-op 11384 #:compile-concatenated-source-op 11385 #:load-compiled-concatenated-source-op 11386 #:monolithic-concatenate-source-op 11387 #:monolithic-load-concatenated-source-op 11388 #:monolithic-compile-concatenated-source-op 11389 #:monolithic-load-compiled-concatenated-source-op)) 11390(in-package :asdf/concatenate-source) 11391 11392;;; 11393;;; Concatenate sources 11394;;; 11395(with-upgradability () 11396 ;; Base classes for both regular and monolithic concatenate-source operations 11397 (defclass basic-concatenate-source-op (bundle-op) 11398 ((bundle-type :initform "lisp" :allocation :class))) 11399 (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) 11400 (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) 11401 (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) 11402 11403 ;; Regular concatenate-source operations 11404 (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) () 11405 (:documentation "Operation to concatenate all sources in a system into a single file")) 11406 (defclass load-concatenated-source-op (basic-load-concatenated-source-op) 11407 ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) 11408 (:documentation "Operation to load the result of concatenate-source-op as source")) 11409 (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) 11410 ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) 11411 (:documentation "Operation to compile the result of concatenate-source-op")) 11412 (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) 11413 ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)) 11414 (:documentation "Operation to load the result of compile-concatenated-source-op")) 11415 11416 (defclass monolithic-concatenate-source-op 11417 (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) () 11418 (:documentation "Operation to concatenate all sources in a system and its dependencies 11419into a single file")) 11420 (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) 11421 ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) 11422 (:documentation "Operation to load the result of monolithic-concatenate-source-op as source")) 11423 (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) 11424 ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) 11425 (:documentation "Operation to compile the result of monolithic-concatenate-source-op")) 11426 (defclass monolithic-load-compiled-concatenated-source-op 11427 (basic-load-compiled-concatenated-source-op) 11428 ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)) 11429 (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op")) 11430 11431 (defmethod input-files ((operation basic-concatenate-source-op) (s system)) 11432 (loop :with encoding = (or (component-encoding s) *default-encoding*) 11433 :with other-encodings = '() 11434 :with around-compile = (around-compile-hook s) 11435 :with other-around-compile = '() 11436 :for c :in (required-components ;; see note about similar call to required-components 11437 s :goal-operation 'load-op ;; in bundle.lisp 11438 :keep-operation 'basic-compile-op 11439 :other-systems (operation-monolithic-p operation)) 11440 :append 11441 (when (typep c 'cl-source-file) 11442 (let ((e (component-encoding c))) 11443 (unless (equal e encoding) 11444 (let ((a (assoc e other-encodings))) 11445 (if a (push (component-find-path c) (cdr a)) 11446 (push (list a (component-find-path c)) other-encodings))))) 11447 (unless (equal around-compile (around-compile-hook c)) 11448 (push (component-find-path c) other-around-compile)) 11449 (input-files (make-operation 'compile-op) c)) :into inputs 11450 :finally 11451 (when other-encodings 11452 (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}" 11453 operation encoding 11454 (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) 11455 other-encodings))) 11456 (when other-around-compile 11457 (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" 11458 operation around-compile other-around-compile)) 11459 (return inputs))) 11460 (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) 11461 (lisp-compilation-output-files o s)) 11462 11463 (defmethod perform ((o basic-concatenate-source-op) (s system)) 11464 (let* ((ins (input-files o s)) 11465 (out (output-file o s)) 11466 (tmp (tmpize-pathname out))) 11467 (concatenate-files ins tmp) 11468 (rename-file-overwriting-target tmp out))) 11469 (defmethod perform ((o basic-load-concatenated-source-op) (s system)) 11470 (perform-lisp-load-source o s)) 11471 (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) 11472 (perform-lisp-compilation o s)) 11473 (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) 11474 (perform-lisp-load-fasl o s))) 11475 11476;;;; --------------------------------------------------------------------------- 11477;;;; asdf-output-translations 11478 11479(uiop/package:define-package :asdf/output-translations 11480 (:recycle :asdf/output-translations :asdf) 11481 (:use :uiop/common-lisp :uiop :asdf/upgrade) 11482 (:export 11483 #:*output-translations* #:*output-translations-parameter* 11484 #:invalid-output-translation 11485 #:output-translations #:output-translations-initialized-p 11486 #:initialize-output-translations #:clear-output-translations 11487 #:disable-output-translations #:ensure-output-translations 11488 #:apply-output-translations 11489 #:validate-output-translations-directive #:validate-output-translations-form 11490 #:validate-output-translations-file #:validate-output-translations-directory 11491 #:parse-output-translations-string #:wrapping-output-translations 11492 #:user-output-translations-pathname #:system-output-translations-pathname 11493 #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname 11494 #:environment-output-translations #:process-output-translations 11495 #:compute-output-translations 11496 #+abcl #:translate-jar-pathname 11497 )) 11498(in-package :asdf/output-translations) 11499 11500;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro 11501;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us. 11502(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations))) 11503 11504(with-upgradability () 11505 (define-condition invalid-output-translation (invalid-configuration warning) 11506 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) 11507 11508 (defvar *output-translations* () 11509 "Either NIL (for uninitialized), or a list of one element, 11510said element itself being a sorted list of mappings. 11511Each mapping is a pair of a source pathname and destination pathname, 11512and the order is by decreasing length of namestring of the source pathname.") 11513 11514 (defun output-translations () 11515 "Return the configured output-translations, if any" 11516 (car *output-translations*)) 11517 11518 ;; Set the output-translations, by sorting the provided new-value. 11519 (defun set-output-translations (new-value) 11520 (setf *output-translations* 11521 (list 11522 (stable-sort (copy-list new-value) #'> 11523 :key #'(lambda (x) 11524 (etypecase (car x) 11525 ((eql t) -1) 11526 (pathname 11527 (let ((directory 11528 (normalize-pathname-directory-component 11529 (pathname-directory (car x))))) 11530 (if (listp directory) (length directory) 0)))))))) 11531 new-value) 11532 (defun (setf output-translations) (new-value) (set-output-translations new-value)) 11533 11534 (defun output-translations-initialized-p () 11535 "Have the output-translations been initialized yet?" 11536 (and *output-translations* t)) 11537 11538 (defun clear-output-translations () 11539 "Undoes any initialization of the output translations." 11540 (setf *output-translations* '()) 11541 (values)) 11542 (register-clear-configuration-hook 'clear-output-translations) 11543 11544 11545 ;;; Validation of the configuration directives... 11546 11547 (defun validate-output-translations-directive (directive) 11548 (or (member directive '(:enable-user-cache :disable-cache nil)) 11549 (and (consp directive) 11550 (or (and (length=n-p directive 2) 11551 (or (and (eq (first directive) :include) 11552 (typep (second directive) '(or string pathname null))) 11553 (and (location-designator-p (first directive)) 11554 (or (location-designator-p (second directive)) 11555 (location-function-p (second directive)))))) 11556 (and (length=n-p directive 1) 11557 (location-designator-p (first directive))))))) 11558 11559 (defun validate-output-translations-form (form &key location) 11560 (validate-configuration-form 11561 form 11562 :output-translations 11563 'validate-output-translations-directive 11564 :location location :invalid-form-reporter 'invalid-output-translation)) 11565 11566 (defun validate-output-translations-file (file) 11567 (validate-configuration-file 11568 file 'validate-output-translations-form :description "output translations")) 11569 11570 (defun validate-output-translations-directory (directory) 11571 (validate-configuration-directory 11572 directory :output-translations 'validate-output-translations-directive 11573 :invalid-form-reporter 'invalid-output-translation)) 11574 11575 11576 ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents 11577 (defun parse-output-translations-string (string &key location) 11578 (cond 11579 ((or (null string) (equal string "")) 11580 '(:output-translations :inherit-configuration)) 11581 ((not (stringp string)) 11582 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) 11583 ((eql (char string 0) #\") 11584 (parse-output-translations-string (read-from-string string) :location location)) 11585 ((eql (char string 0) #\() 11586 (validate-output-translations-form (read-from-string string) :location location)) 11587 (t 11588 (loop 11589 :with inherit = nil 11590 :with directives = () 11591 :with start = 0 11592 :with end = (length string) 11593 :with source = nil 11594 :with separator = (inter-directory-separator) 11595 :for i = (or (position separator string :start start) end) :do 11596 (let ((s (subseq string start i))) 11597 (cond 11598 (source 11599 (push (list source (if (equal "" s) nil s)) directives) 11600 (setf source nil)) 11601 ((equal "" s) 11602 (when inherit 11603 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") 11604 string)) 11605 (setf inherit t) 11606 (push :inherit-configuration directives)) 11607 (t 11608 (setf source s))) 11609 (setf start (1+ i)) 11610 (when (> start end) 11611 (when source 11612 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") 11613 string)) 11614 (unless inherit 11615 (push :ignore-inherited-configuration directives)) 11616 (return `(:output-translations ,@(nreverse directives))))))))) 11617 11618 11619 ;; The default sources of configuration for output-translations 11620 (defparameter* *default-output-translations* 11621 '(environment-output-translations 11622 user-output-translations-pathname 11623 user-output-translations-directory-pathname 11624 system-output-translations-pathname 11625 system-output-translations-directory-pathname)) 11626 11627 ;; Compulsory implementation-dependent wrapping for the translations: 11628 ;; handle implementation-provided systems. 11629 (defun wrapping-output-translations () 11630 `(:output-translations 11631 ;; Some implementations have precompiled ASDF systems, 11632 ;; so we must disable translations for implementation paths. 11633 #+(or clasp #|clozure|# ecl mkcl sbcl) 11634 ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) 11635 (when h `(((,h ,*wild-path*) ())))) 11636 #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) 11637 ;; All-import, here is where we want user stuff to be: 11638 :inherit-configuration 11639 ;; These are for convenience, and can be overridden by the user: 11640 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) 11641 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) 11642 ;; We enable the user cache by default, and here is the place we do: 11643 :enable-user-cache)) 11644 11645 ;; Relative pathnames of output-translations configuration to XDG configuration directory 11646 (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf")) 11647 (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/")) 11648 11649 ;; Locating various configuration pathnames, depending on input or output intent. 11650 (defun user-output-translations-pathname (&key (direction :input)) 11651 (xdg-config-pathname *output-translations-file* direction)) 11652 (defun system-output-translations-pathname (&key (direction :input)) 11653 (find-preferred-file (system-config-pathnames *output-translations-file*) 11654 :direction direction)) 11655 (defun user-output-translations-directory-pathname (&key (direction :input)) 11656 (xdg-config-pathname *output-translations-directory* direction)) 11657 (defun system-output-translations-directory-pathname (&key (direction :input)) 11658 (find-preferred-file (system-config-pathnames *output-translations-directory*) 11659 :direction direction)) 11660 (defun environment-output-translations () 11661 (getenv "ASDF_OUTPUT_TRANSLATIONS")) 11662 11663 11664 ;;; Processing the configuration. 11665 11666 (defgeneric process-output-translations (spec &key inherit collect)) 11667 11668 (defun inherit-output-translations (inherit &key collect) 11669 (when inherit 11670 (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) 11671 11672 (defun* (process-output-translations-directive) (directive &key inherit collect) 11673 (if (atom directive) 11674 (ecase directive 11675 ((:enable-user-cache) 11676 (process-output-translations-directive '(t :user-cache) :collect collect)) 11677 ((:disable-cache) 11678 (process-output-translations-directive '(t t) :collect collect)) 11679 ((:inherit-configuration) 11680 (inherit-output-translations inherit :collect collect)) 11681 ((:ignore-inherited-configuration :ignore-invalid-entries nil) 11682 nil)) 11683 (let ((src (first directive)) 11684 (dst (second directive))) 11685 (if (eq src :include) 11686 (when dst 11687 (process-output-translations (pathname dst) :inherit nil :collect collect)) 11688 (when src 11689 (let ((trusrc (or (eql src t) 11690 (let ((loc (resolve-location src :ensure-directory t :wilden t))) 11691 (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) 11692 (cond 11693 ((location-function-p dst) 11694 (funcall collect 11695 (list trusrc (ensure-function (second dst))))) 11696 ((typep dst 'boolean) 11697 (funcall collect (list trusrc t))) 11698 (t 11699 (let* ((trudst (resolve-location dst :ensure-directory t :wilden t))) 11700 (funcall collect (list trudst t)) 11701 (funcall collect (list trusrc trudst))))))))))) 11702 11703 (defmethod process-output-translations ((x symbol) &key 11704 (inherit *default-output-translations*) 11705 collect) 11706 (process-output-translations (funcall x) :inherit inherit :collect collect)) 11707 (defmethod process-output-translations ((pathname pathname) &key inherit collect) 11708 (cond 11709 ((directory-pathname-p pathname) 11710 (process-output-translations (validate-output-translations-directory pathname) 11711 :inherit inherit :collect collect)) 11712 ((probe-file* pathname :truename *resolve-symlinks*) 11713 (process-output-translations (validate-output-translations-file pathname) 11714 :inherit inherit :collect collect)) 11715 (t 11716 (inherit-output-translations inherit :collect collect)))) 11717 (defmethod process-output-translations ((string string) &key inherit collect) 11718 (process-output-translations (parse-output-translations-string string) 11719 :inherit inherit :collect collect)) 11720 (defmethod process-output-translations ((x null) &key inherit collect) 11721 (inherit-output-translations inherit :collect collect)) 11722 (defmethod process-output-translations ((form cons) &key inherit collect) 11723 (dolist (directive (cdr (validate-output-translations-form form))) 11724 (process-output-translations-directive directive :inherit inherit :collect collect))) 11725 11726 11727 ;;; Top-level entry-points to configure output-translations 11728 11729 (defun compute-output-translations (&optional parameter) 11730 "read the configuration, return it" 11731 (remove-duplicates 11732 (while-collecting (c) 11733 (inherit-output-translations 11734 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) 11735 :test 'equal :from-end t)) 11736 11737 ;; Saving the user-provided parameter to output-translations, if any, 11738 ;; so we can recompute the translations after code upgrade. 11739 (defvar *output-translations-parameter* nil) 11740 11741 ;; Main entry-point for users. 11742 (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) 11743 "read the configuration, initialize the internal configuration variable, 11744return the configuration" 11745 (setf *output-translations-parameter* parameter 11746 (output-translations) (compute-output-translations parameter))) 11747 11748 (defun disable-output-translations () 11749 "Initialize output translations in a way that maps every file to itself, 11750effectively disabling the output translation facility." 11751 (initialize-output-translations 11752 '(:output-translations :disable-cache :ignore-inherited-configuration))) 11753 11754 ;; checks an initial variable to see whether the state is initialized 11755 ;; or cleared. In the former case, return current configuration; in 11756 ;; the latter, initialize. ASDF will call this function at the start 11757 ;; of (asdf:find-system). 11758 (defun ensure-output-translations () 11759 (if (output-translations-initialized-p) 11760 (output-translations) 11761 (initialize-output-translations))) 11762 11763 11764 ;; Top-level entry-point to _use_ output-translations 11765 (defun* (apply-output-translations) (path) 11766 (etypecase path 11767 (logical-pathname 11768 path) 11769 ((or pathname string) 11770 (ensure-output-translations) 11771 (loop* :with p = (resolve-symlinks* path) 11772 :for (source destination) :in (car *output-translations*) 11773 :for root = (when (or (eq source t) 11774 (and (pathnamep source) 11775 (not (absolute-pathname-p source)))) 11776 (pathname-root p)) 11777 :for absolute-source = (cond 11778 ((eq source t) (wilden root)) 11779 (root (merge-pathnames* source root)) 11780 (t source)) 11781 :when (or (eq source t) (pathname-match-p p absolute-source)) 11782 :return (translate-pathname* p absolute-source destination root source) 11783 :finally (return p))))) 11784 11785 11786 ;; Hook into uiop's output-translation mechanism 11787 #-cormanlisp 11788 (setf *output-translation-function* 'apply-output-translations) 11789 11790 11791 ;;; Implementation-dependent hacks 11792 #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar. 11793 (defun translate-jar-pathname (source wildcard) 11794 (declare (ignore wildcard)) 11795 (flet ((normalize-device (pathname) 11796 (if (find :windows *features*) 11797 pathname 11798 (make-pathname :defaults pathname :device :unspecific)))) 11799 (let* ((jar 11800 (pathname (first (pathname-device source)))) 11801 (target-root-directory-namestring 11802 (format nil "/___jar___file___root___/~@[~A/~]" 11803 (and (find :windows *features*) 11804 (pathname-device jar)))) 11805 (relative-source 11806 (relativize-pathname-directory source)) 11807 (relative-jar 11808 (relativize-pathname-directory (ensure-directory-pathname jar))) 11809 (target-root-directory 11810 (normalize-device 11811 (pathname-directory-pathname 11812 (parse-namestring target-root-directory-namestring)))) 11813 (target-root 11814 (merge-pathnames* relative-jar target-root-directory)) 11815 (target 11816 (merge-pathnames* relative-source target-root))) 11817 (normalize-device (apply-output-translations target)))))) 11818 11819;;;; ----------------------------------------------------------------- 11820;;;; Source Registry Configuration, by Francois-Rene Rideau 11821;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 11822 11823(uiop/package:define-package :asdf/source-registry 11824 (:recycle :asdf/source-registry :asdf) 11825 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) 11826 (:export 11827 #:*source-registry-parameter* #:*default-source-registries* 11828 #:invalid-source-registry 11829 #:source-registry-initialized-p 11830 #:initialize-source-registry #:clear-source-registry #:*source-registry* 11831 #:ensure-source-registry #:*source-registry-parameter* 11832 #:*default-source-registry-exclusions* #:*source-registry-exclusions* 11833 #:*wild-asd* #:directory-asd-files #:register-asd-directory 11834 #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files 11835 #:validate-source-registry-directive #:validate-source-registry-form 11836 #:validate-source-registry-file #:validate-source-registry-directory 11837 #:parse-source-registry-string #:wrapping-source-registry 11838 #:default-user-source-registry #:default-system-source-registry 11839 #:user-source-registry #:system-source-registry 11840 #:user-source-registry-directory #:system-source-registry-directory 11841 #:environment-source-registry #:process-source-registry #:inherit-source-registry 11842 #:compute-source-registry #:flatten-source-registry 11843 #:sysdef-source-registry-search)) 11844(in-package :asdf/source-registry) 11845 11846(with-upgradability () 11847 (define-condition invalid-source-registry (invalid-configuration warning) 11848 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) 11849 11850 ;; Default list of directories under which the source-registry tree search won't recurse 11851 (defvar *default-source-registry-exclusions* 11852 '(;;-- Using ack 1.2 exclusions 11853 ".bzr" ".cdv" 11854 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards 11855 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" 11856 "_sgbak" "autom4te.cache" "cover_db" "_build" 11857 ;;-- debian often builds stuff under the debian directory... BAD. 11858 "debian")) 11859 11860 ;; Actual list of directories under which the source-registry tree search won't recurse 11861 (defvar *source-registry-exclusions* *default-source-registry-exclusions*) 11862 11863 ;; The state of the source-registry after search in configured locations 11864 (defvar *source-registry* nil 11865 "Either NIL (for uninitialized), or an equal hash-table, mapping 11866system names to pathnames of .asd files") 11867 11868 ;; Saving the user-provided parameter to the source-registry, if any, 11869 ;; so we can recompute the source-registry after code upgrade. 11870 (defvar *source-registry-parameter* nil) 11871 11872 (defun source-registry-initialized-p () 11873 (typep *source-registry* 'hash-table)) 11874 11875 (defun clear-source-registry () 11876 "Undoes any initialization of the source registry." 11877 (setf *source-registry* nil) 11878 (values)) 11879 (register-clear-configuration-hook 'clear-source-registry) 11880 11881 (defparameter *wild-asd* 11882 (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) 11883 11884 (defun directory-asd-files (directory) 11885 (directory-files directory *wild-asd*)) 11886 11887 (defun collect-asds-in-directory (directory collect) 11888 (let ((asds (directory-asd-files directory))) 11889 (map () collect asds) 11890 asds)) 11891 11892 (defvar *recurse-beyond-asds* t 11893 "Should :tree entries of the source-registry recurse in subdirectories 11894after having found a .asd file? True by default.") 11895 11896 ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache, 11897 ;; read its contents instead of further recursively querying the filesystem. 11898 (defun process-source-registry-cache (directory collect) 11899 (let ((cache (ignore-errors 11900 (safe-read-file-form (subpathname directory ".cl-source-registry.cache"))))) 11901 (when (and (listp cache) (eq :source-registry-cache (first cache))) 11902 (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s))) 11903 t))) 11904 11905 (defun collect-sub*directories-asd-files 11906 (directory &key (exclude *default-source-registry-exclusions*) collect 11907 (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) 11908 (let ((visited (make-hash-table :test 'equalp))) 11909 (flet ((collectp (dir) 11910 (unless (and (not ignore-cache) (process-source-registry-cache directory collect)) 11911 (let ((asds (collect-asds-in-directory dir collect))) 11912 (or recurse-beyond-asds (not asds))))) 11913 (recursep (x) ; x will be a directory pathname 11914 (and 11915 (not (member (car (last (pathname-directory x))) exclude :test #'equal)) 11916 (flet ((pathname-key (x) 11917 (namestring (truename* x)))) 11918 (let ((visitedp (gethash (pathname-key x) visited))) 11919 (if visitedp nil 11920 (setf (gethash (pathname-key x) visited) t))))))) 11921 (collect-sub*directories directory #'collectp #'recursep (constantly nil))))) 11922 11923 11924 ;;; Validate the configuration forms 11925 11926 (defun validate-source-registry-directive (directive) 11927 (or (member directive '(:default-registry)) 11928 (and (consp directive) 11929 (let ((rest (rest directive))) 11930 (case (first directive) 11931 ((:include :directory :tree) 11932 (and (length=n-p rest 1) 11933 (location-designator-p (first rest)))) 11934 ((:exclude :also-exclude) 11935 (every #'stringp rest)) 11936 ((:default-registry) 11937 (null rest))))))) 11938 11939 (defun validate-source-registry-form (form &key location) 11940 (validate-configuration-form 11941 form :source-registry 'validate-source-registry-directive 11942 :location location :invalid-form-reporter 'invalid-source-registry)) 11943 11944 (defun validate-source-registry-file (file) 11945 (validate-configuration-file 11946 file 'validate-source-registry-form :description "a source registry")) 11947 11948 (defun validate-source-registry-directory (directory) 11949 (validate-configuration-directory 11950 directory :source-registry 'validate-source-registry-directive 11951 :invalid-form-reporter 'invalid-source-registry)) 11952 11953 11954 ;;; Parse the configuration string 11955 11956 (defun parse-source-registry-string (string &key location) 11957 (cond 11958 ((or (null string) (equal string "")) 11959 '(:source-registry :inherit-configuration)) 11960 ((not (stringp string)) 11961 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) 11962 ((find (char string 0) "\"(") 11963 (validate-source-registry-form (read-from-string string) :location location)) 11964 (t 11965 (loop 11966 :with inherit = nil 11967 :with directives = () 11968 :with start = 0 11969 :with end = (length string) 11970 :with separator = (inter-directory-separator) 11971 :for pos = (position separator string :start start) :do 11972 (let ((s (subseq string start (or pos end)))) 11973 (flet ((check (dir) 11974 (unless (absolute-pathname-p dir) 11975 (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) 11976 dir)) 11977 (cond 11978 ((equal "" s) ; empty element: inherit 11979 (when inherit 11980 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") 11981 string)) 11982 (setf inherit t) 11983 (push ':inherit-configuration directives)) 11984 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? 11985 (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) 11986 (t 11987 (push `(:directory ,(check s)) directives)))) 11988 (cond 11989 (pos 11990 (setf start (1+ pos))) 11991 (t 11992 (unless inherit 11993 (push '(:ignore-inherited-configuration) directives)) 11994 (return `(:source-registry ,@(nreverse directives)))))))))) 11995 11996 (defun register-asd-directory (directory &key recurse exclude collect) 11997 (if (not recurse) 11998 (collect-asds-in-directory directory collect) 11999 (collect-sub*directories-asd-files 12000 directory :exclude exclude :collect collect))) 12001 12002 (defparameter* *default-source-registries* 12003 '(environment-source-registry 12004 user-source-registry 12005 user-source-registry-directory 12006 default-user-source-registry 12007 system-source-registry 12008 system-source-registry-directory 12009 default-system-source-registry) 12010 "List of default source registries" "3.1.0.102") 12011 12012 (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf")) 12013 (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/")) 12014 12015 (defun wrapping-source-registry () 12016 `(:source-registry 12017 #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) 12018 :inherit-configuration 12019 #+mkcl (:tree ,(translate-logical-pathname "SYS:")) 12020 #+cmucl (:tree #p"modules:") 12021 #+scl (:tree #p"file://modules/"))) 12022 (defun default-user-source-registry () 12023 `(:source-registry 12024 (:tree (:home "common-lisp/")) 12025 #+sbcl (:directory (:home ".sbcl/systems/")) 12026 (:directory ,(xdg-data-home "common-lisp/systems/")) 12027 (:tree ,(xdg-data-home "common-lisp/source/")) 12028 :inherit-configuration)) 12029 (defun default-system-source-registry () 12030 `(:source-registry 12031 ,@(loop :for dir :in (xdg-data-dirs "common-lisp/") 12032 :collect `(:directory (,dir "systems/")) 12033 :collect `(:tree (,dir "source/"))) 12034 :inherit-configuration)) 12035 (defun user-source-registry (&key (direction :input)) 12036 (xdg-config-pathname *source-registry-file* direction)) 12037 (defun system-source-registry (&key (direction :input)) 12038 (find-preferred-file (system-config-pathnames *source-registry-file*) 12039 :direction direction)) 12040 (defun user-source-registry-directory (&key (direction :input)) 12041 (xdg-config-pathname *source-registry-directory* direction)) 12042 (defun system-source-registry-directory (&key (direction :input)) 12043 (find-preferred-file (system-config-pathnames *source-registry-directory*) 12044 :direction direction)) 12045 (defun environment-source-registry () 12046 (getenv "CL_SOURCE_REGISTRY")) 12047 12048 12049 ;;; Process the source-registry configuration 12050 12051 (defgeneric process-source-registry (spec &key inherit register)) 12052 12053 (defun* (inherit-source-registry) (inherit &key register) 12054 (when inherit 12055 (process-source-registry (first inherit) :register register :inherit (rest inherit)))) 12056 12057 (defun* (process-source-registry-directive) (directive &key inherit register) 12058 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) 12059 (ecase kw 12060 ((:include) 12061 (destructuring-bind (pathname) rest 12062 (process-source-registry (resolve-location pathname) :inherit nil :register register))) 12063 ((:directory) 12064 (destructuring-bind (pathname) rest 12065 (when pathname 12066 (funcall register (resolve-location pathname :ensure-directory t))))) 12067 ((:tree) 12068 (destructuring-bind (pathname) rest 12069 (when pathname 12070 (funcall register (resolve-location pathname :ensure-directory t) 12071 :recurse t :exclude *source-registry-exclusions*)))) 12072 ((:exclude) 12073 (setf *source-registry-exclusions* rest)) 12074 ((:also-exclude) 12075 (appendf *source-registry-exclusions* rest)) 12076 ((:default-registry) 12077 (inherit-source-registry 12078 '(default-user-source-registry default-system-source-registry) :register register)) 12079 ((:inherit-configuration) 12080 (inherit-source-registry inherit :register register)) 12081 ((:ignore-inherited-configuration) 12082 nil))) 12083 nil) 12084 12085 (defmethod process-source-registry ((x symbol) &key inherit register) 12086 (process-source-registry (funcall x) :inherit inherit :register register)) 12087 (defmethod process-source-registry ((pathname pathname) &key inherit register) 12088 (cond 12089 ((directory-pathname-p pathname) 12090 (let ((*here-directory* (resolve-symlinks* pathname))) 12091 (process-source-registry (validate-source-registry-directory pathname) 12092 :inherit inherit :register register))) 12093 ((probe-file* pathname :truename *resolve-symlinks*) 12094 (let ((*here-directory* (pathname-directory-pathname pathname))) 12095 (process-source-registry (validate-source-registry-file pathname) 12096 :inherit inherit :register register))) 12097 (t 12098 (inherit-source-registry inherit :register register)))) 12099 (defmethod process-source-registry ((string string) &key inherit register) 12100 (process-source-registry (parse-source-registry-string string) 12101 :inherit inherit :register register)) 12102 (defmethod process-source-registry ((x null) &key inherit register) 12103 (inherit-source-registry inherit :register register)) 12104 (defmethod process-source-registry ((form cons) &key inherit register) 12105 (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) 12106 (dolist (directive (cdr (validate-source-registry-form form))) 12107 (process-source-registry-directive directive :inherit inherit :register register)))) 12108 12109 12110 ;; Flatten the user-provided configuration into an ordered list of directories and trees 12111 (defun flatten-source-registry (&optional (parameter *source-registry-parameter*)) 12112 (remove-duplicates 12113 (while-collecting (collect) 12114 (with-pathname-defaults () ;; be location-independent 12115 (inherit-source-registry 12116 `(wrapping-source-registry 12117 ,parameter 12118 ,@*default-source-registries*) 12119 :register #'(lambda (directory &key recurse exclude) 12120 (collect (list directory :recurse recurse :exclude exclude)))))) 12121 :test 'equal :from-end t)) 12122 12123 ;; MAYBE: move this utility function to uiop/pathname and export it? 12124 (defun pathname-directory-depth (p) 12125 (length (normalize-pathname-directory-component (pathname-directory p)))) 12126 12127 (defun preferred-source-path-p (x y) 12128 "Return T iff X is to be preferred over Y as a source path" 12129 (let ((lx (pathname-directory-depth x)) 12130 (ly (pathname-directory-depth y))) 12131 (or (< lx ly) 12132 (and (= lx ly) 12133 (string< (namestring x) 12134 (namestring y)))))) 12135 12136 ;; Will read the configuration and initialize all internal variables. 12137 (defun compute-source-registry (&optional (parameter *source-registry-parameter*) 12138 (registry *source-registry*)) 12139 (dolist (entry (flatten-source-registry parameter)) 12140 (destructuring-bind (directory &key recurse exclude) entry 12141 (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates 12142 (register-asd-directory 12143 directory :recurse recurse :exclude exclude :collect 12144 #'(lambda (asd) 12145 (let* ((name (pathname-name asd)) 12146 (name (if (typep asd 'logical-pathname) 12147 ;; logical pathnames are upper-case, 12148 ;; at least in the CLHS and on SBCL, 12149 ;; yet (coerce-name :foo) is lower-case. 12150 ;; won't work well with (load-system "Foo") 12151 ;; instead of (load-system 'foo) 12152 (string-downcase name) 12153 name))) 12154 (unless (gethash name registry) ; already shadowed by something else 12155 (if-let (old (gethash name h)) 12156 ;; If the name appears multiple times, 12157 ;; prefer the one with the shallowest directory, 12158 ;; or if they have same depth, compare unix-namestring with string< 12159 (multiple-value-bind (better worse) 12160 (if (preferred-source-path-p asd old) 12161 (progn (setf (gethash name h) asd) (values asd old)) 12162 (values old asd)) 12163 (when *verbose-out* 12164 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ 12165 found several entries for ~A - picking ~S over ~S~:>") 12166 directory recurse name better worse))) 12167 (setf (gethash name h) asd)))))) 12168 (maphash #'(lambda (k v) (setf (gethash k registry) v)) h)))) 12169 (values)) 12170 12171 (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) 12172 ;; Record the parameter used to configure the registry 12173 (setf *source-registry-parameter* parameter) 12174 ;; Clear the previous registry database: 12175 (setf *source-registry* (make-hash-table :test 'equal)) 12176 ;; Do it! 12177 (compute-source-registry parameter)) 12178 12179 ;; Checks an initial variable to see whether the state is initialized 12180 ;; or cleared. In the former case, return current configuration; in 12181 ;; the latter, initialize. ASDF will call this function at the start 12182 ;; of (asdf:find-system) to make sure the source registry is initialized. 12183 ;; However, it will do so *without* a parameter, at which point it 12184 ;; will be too late to provide a parameter to this function, though 12185 ;; you may override the configuration explicitly by calling 12186 ;; initialize-source-registry directly with your parameter. 12187 (defun ensure-source-registry (&optional parameter) 12188 (unless (source-registry-initialized-p) 12189 (initialize-source-registry parameter)) 12190 (values)) 12191 12192 (defun sysdef-source-registry-search (system) 12193 (ensure-source-registry) 12194 (values (gethash (primary-system-name system) *source-registry*)))) 12195 12196 12197;;;; ------------------------------------------------------------------------- 12198;;;; Package systems in the style of quick-build or faslpath 12199 12200(uiop:define-package :asdf/package-inferred-system 12201 (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) 12202 (:use :uiop/common-lisp :uiop 12203 :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility 12204 :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action) 12205 (:export 12206 #:package-inferred-system #:sysdef-package-inferred-system-search 12207 #:package-system ;; backward compatibility only. To be removed. 12208 #:register-system-packages 12209 #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) 12210(in-package :asdf/package-inferred-system) 12211 12212(with-upgradability () 12213 ;; The names of the recognized defpackage forms. 12214 (defparameter *defpackage-forms* '(defpackage define-package)) 12215 12216 (defun initial-package-inferred-systems-table () 12217 ;; Mark all existing packages are preloaded. 12218 (let ((h (make-hash-table :test 'equal))) 12219 (dolist (p (list-all-packages)) 12220 (dolist (n (package-names p)) 12221 (setf (gethash n h) t))) 12222 h)) 12223 12224 ;; Mapping from package names to systems that provide them. 12225 (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) 12226 12227 (defclass package-inferred-system (system) 12228 () 12229 (:documentation "Class for primary systems for which secondary systems are automatically 12230in the one-file, one-file, one-system style: system names are mapped to files under the primary 12231system's system-source-directory, dependencies are inferred from the first defpackage form in 12232every such file")) 12233 12234 ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release: 12235 (defclass package-system (package-inferred-system) ()) 12236 12237 ;; Is a given form recognizable as a defpackage form? 12238 (defun defpackage-form-p (form) 12239 (and (consp form) 12240 (member (car form) *defpackage-forms*))) 12241 12242 ;; Find the first defpackage form in a stream, if any 12243 (defun stream-defpackage-form (stream) 12244 (loop :for form = (read stream nil nil) :while form 12245 :when (defpackage-form-p form) :return form)) 12246 12247 (defun file-defpackage-form (file) 12248 "Return the first DEFPACKAGE form in FILE." 12249 (with-input-file (f file) 12250 (stream-defpackage-form f))) 12251 12252 (define-condition package-inferred-system-missing-package-error (system-definition-error) 12253 ((system :initarg :system :reader error-system) 12254 (pathname :initarg :pathname :reader error-pathname)) 12255 (:report (lambda (c s) 12256 (format s (compatfmt "~@<No package form found while ~ 12257 trying to define package-inferred-system ~A from file ~A~>") 12258 (error-system c) (error-pathname c))))) 12259 12260 (defun package-dependencies (defpackage-form) 12261 "Return a list of packages depended on by the package 12262defined in DEFPACKAGE-FORM. A package is depended upon if 12263the DEFPACKAGE-FORM uses it or imports a symbol from it." 12264 (assert (defpackage-form-p defpackage-form)) 12265 (remove-duplicates 12266 (while-collecting (dep) 12267 (loop* :for (option . arguments) :in (cddr defpackage-form) :do 12268 (ecase option 12269 ((:use :mix :reexport :use-reexport :mix-reexport) 12270 (dolist (p arguments) (dep (string p)))) 12271 ((:import-from :shadowing-import-from) 12272 (dep (string (first arguments)))) 12273 ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) 12274 :from-end t :test 'equal)) 12275 12276 (defun package-designator-name (package) 12277 "Normalize a package designator to a string" 12278 (etypecase package 12279 (package (package-name package)) 12280 (string package) 12281 (symbol (string package)))) 12282 12283 (defun register-system-packages (system packages) 12284 "Register SYSTEM as providing PACKAGES." 12285 (let ((name (or (eq system t) (coerce-name system)))) 12286 (dolist (p (ensure-list packages)) 12287 (setf (gethash (package-designator-name p) *package-inferred-systems*) name)))) 12288 12289 (defun package-name-system (package-name) 12290 "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists, 12291otherwise return a default system name computed from PACKAGE-NAME." 12292 (check-type package-name string) 12293 (or (gethash package-name *package-inferred-systems*) 12294 (string-downcase package-name))) 12295 12296 ;; Given a file in package-inferred-system style, find its dependencies 12297 (defun package-inferred-system-file-dependencies (file &optional system) 12298 (if-let (defpackage-form (file-defpackage-form file)) 12299 (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) 12300 (error 'package-inferred-system-missing-package-error :system system :pathname file))) 12301 12302 ;; Given package-inferred-system object, check whether its specification matches 12303 ;; the provided parameters 12304 (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) 12305 (and (eq (type-of system) 'package-inferred-system) 12306 (equal (component-name system) name) 12307 (pathname-equal directory (component-pathname system)) 12308 (equal dependencies (component-sideway-dependencies system)) 12309 (equal around-compile (around-compile-hook system)) 12310 (let ((children (component-children system))) 12311 (and (length=n-p children 1) 12312 (let ((child (first children))) 12313 (and (eq (type-of child) 'cl-source-file) 12314 (equal (component-name child) "lisp") 12315 (and (slot-boundp child 'relative-pathname) 12316 (equal (slot-value child 'relative-pathname) subpath)))))))) 12317 12318 ;; sysdef search function to push into *system-definition-search-functions* 12319 (defun sysdef-package-inferred-system-search (system) 12320 (let ((primary (primary-system-name system))) 12321 (unless (equal primary system) 12322 (let ((top (find-system primary nil))) 12323 (when (typep top 'package-inferred-system) 12324 (if-let (dir (component-pathname top)) 12325 (let* ((sub (subseq system (1+ (length primary)))) 12326 (f (probe-file* (subpathname dir sub :type "lisp") 12327 :truename *resolve-symlinks*))) 12328 (when (file-pathname-p f) 12329 (let ((dependencies (package-inferred-system-file-dependencies f system)) 12330 (previous (registered-system system)) 12331 (around-compile (around-compile-hook top))) 12332 (if (same-package-inferred-system-p previous system dir sub around-compile dependencies) 12333 previous 12334 (eval `(defsystem ,system 12335 :class package-inferred-system 12336 :source-file nil 12337 :pathname ,dir 12338 :depends-on ,dependencies 12339 :around-compile ,around-compile 12340 :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) 12341 12342(with-upgradability () 12343 (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*) 12344 (setf *system-definition-search-functions* 12345 (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil) 12346 *system-definition-search-functions*))) 12347;;;; ------------------------------------------------------------------------- 12348;;; Backward-compatible interfaces 12349 12350(uiop/package:define-package :asdf/backward-interface 12351 (:recycle :asdf/backward-interface :asdf) 12352 (:use :uiop/common-lisp :uiop :asdf/upgrade 12353 :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action 12354 :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) 12355 (:export 12356 #:*asdf-verbose* 12357 #:operation-error #:compile-error #:compile-failed #:compile-warned 12358 #:error-component #:error-operation #:traverse 12359 #:component-load-dependencies 12360 #:enable-asdf-binary-locations-compatibility 12361 #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings 12362 #:component-property 12363 #:run-shell-command 12364 #:system-definition-pathname 12365 #:explain)) 12366(in-package :asdf/backward-interface) 12367 12368;; NB: the warning status of these functions may have to be distinguished later, 12369;; as some get removed faster than the others in client code. 12370(with-asdf-deprecation (:style-warning "3.2") 12371 12372 ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; 12373 ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition 12374 ;; that do not involve ASDF actions. 12375 ;; TODO: find the offenders and stop them. 12376 (progn 12377 (define-condition operation-error (error) ;; Bad, backward-compatible name 12378 ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel 12379 ((component :reader error-component :initarg :component) 12380 (operation :reader error-operation :initarg :operation)) 12381 (:report (lambda (c s) 12382 (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") 12383 (type-of c) (error-operation c) (error-component c))))) 12384 (define-condition compile-error (operation-error) ()) 12385 (define-condition compile-failed (compile-error) ()) 12386 (define-condition compile-warned (compile-error) ())) 12387 12388 ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi 12389 (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26 12390 "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better, 12391define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION, 12392or define methods on PREPARE-OP, etc." 12393 ;; Old deprecated name for the same thing. Please update your software. 12394 (component-sideway-dependencies component)) 12395 12396 ;; These old interfaces from ASDF1 have never been very meaningful 12397 ;; but are still used in obscure places. 12398 ;; In Quicklisp 2015-05, still used by cl-protobufs and clx. 12399 (defgeneric operation-on-warnings (operation) 12400 (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) 12401 (defgeneric operation-on-failure (operation) 12402 (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) 12403 (defgeneric (setf operation-on-warnings) (x operation) 12404 (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) 12405 (defgeneric (setf operation-on-failure) (x operation) 12406 (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) 12407 (progn 12408 (defmethod operation-on-warnings ((o operation)) 12409 *compile-file-warnings-behaviour*) 12410 (defmethod operation-on-failure ((o operation)) 12411 *compile-file-failure-behaviour*) 12412 (defmethod (setf operation-on-warnings) (x (o operation)) 12413 (setf *compile-file-warnings-behaviour* x)) 12414 (defmethod (setf operation-on-failure) (x (o operation)) 12415 (setf *compile-file-failure-behaviour* x))) 12416 12417 ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat, 12418 ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject, 12419 ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel, 12420 ;; cl-glfw, cffi, jwacs, montezuma 12421 (defun system-definition-pathname (x) 12422 ;; As of 2.014.8, we mean to make this function obsolete, 12423 ;; but that won't happen until all clients have been updated. 12424 "DEPRECATED. This function used to expose ASDF internals with subtle 12425differences with respect to user expectations, that have been refactored 12426away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a 12427mostly compatible replacement that we're supporting, or even 12428ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME 12429if that's whay you mean." ;;) 12430 (system-source-file x)) 12431 12432 ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. 12433 ;; It was never officially exposed but some people still used it. 12434 (defgeneric traverse (operation component &key &allow-other-keys) 12435 (:documentation 12436 "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS, 12437or some other supported interface instead. 12438 12439Generate and return a plan for performing OPERATION on COMPONENT. 12440 12441The plan returned is a list of dotted-pairs. Each pair is the CONS 12442of ASDF operation object and a COMPONENT object. The pairs will be 12443processed in order by OPERATE.")) 12444 (progn 12445 (define-convenience-action-methods traverse (operation component &key))) 12446 (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) 12447 (plan-actions (apply 'make-plan plan-class o c keys))) 12448 12449 12450 ;; ASDF-Binary-Locations compatibility 12451 ;; This remains supported for legacy user, but not recommended for new users. 12452 ;; We suspect there are no more legacy users in 2016. 12453 (defun enable-asdf-binary-locations-compatibility 12454 (&key 12455 (centralize-lisp-binaries nil) 12456 (default-toplevel-directory 12457 ;; Use ".cache/common-lisp/" instead ??? 12458 (subpathname (user-homedir-pathname) ".fasls/")) 12459 (include-per-user-information nil) 12460 (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) 12461 (source-to-target-mappings nil) 12462 (file-types `(,(compile-file-type) 12463 "build-report" 12464 #+clasp (compile-file-type :output-type :object) 12465 #+ecl (compile-file-type :type :object) 12466 #+mkcl (compile-file-type :fasl-p nil) 12467 #+clisp "lib" #+sbcl "cfasl" 12468 #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) 12469 "DEPRECATED. Use asdf-output-translations instead." 12470 #+(or clasp clisp ecl mkcl) 12471 (when (null map-all-source-files) 12472 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) 12473 (let* ((patterns (if map-all-source-files (list *wild-file*) 12474 (loop :for type :in file-types 12475 :collect (make-pathname :type type :defaults *wild-file*)))) 12476 (destination-directory 12477 (if centralize-lisp-binaries 12478 `(,default-toplevel-directory 12479 ,@(when include-per-user-information 12480 (cdr (pathname-directory (user-homedir-pathname)))) 12481 :implementation ,*wild-inferiors*) 12482 `(:root ,*wild-inferiors* :implementation)))) 12483 (initialize-output-translations 12484 `(:output-translations 12485 ,@source-to-target-mappings 12486 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) 12487 #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) 12488 ,@(loop :for pattern :in patterns 12489 :collect `((:root ,*wild-inferiors* ,pattern) 12490 (,@destination-directory ,pattern))) 12491 (t t) 12492 :ignore-inherited-configuration)))) 12493 (progn 12494 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) 12495 (declare (ignore operation-class system args)) 12496 (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) 12497 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. 12498ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, 12499which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, 12500and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. 12501In case you insist on preserving your previous A-B-L configuration, but 12502do not know how to achieve the same effect with A-O-T, you may use function 12503ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; 12504call that function where you would otherwise have loaded and configured A-B-L.")))) 12505 12506 12507 ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die! 12508 (defun run-shell-command (control-string &rest args) 12509 "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional. 12510Please use UIOP:RUN-PROGRAM instead." 12511 #-(and ecl os-windows) 12512 (let ((command (apply 'format nil control-string args))) 12513 (asdf-message "; $ ~A~%" command) 12514 (let ((exit-code 12515 (ignore-errors 12516 (nth-value 2 (run-program command :force-shell t :ignore-error-status t 12517 :output *verbose-out*))))) 12518 (typecase exit-code 12519 ((integer 0 255) exit-code) 12520 (t 255)))) 12521 #+(and ecl os-windows) 12522 (not-implemented-error "run-shell-command" "for ECL on Windows.")) 12523 12524 ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning? 12525 ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version. 12526 (progn 12527 (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. 12528 12529 ;; Do NOT use in new code. NOT SUPPORTED. 12530 ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT. 12531 ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy. 12532 ;; See TODO for further cleanups required before to get rid of it. 12533 (defgeneric component-property (component property)) 12534 (defgeneric (setf component-property) (new-value component property)) 12535 12536 (defmethod component-property ((c component) property) 12537 (cdr (assoc property (slot-value c 'properties) :test #'equal))) 12538 12539 (defmethod (setf component-property) (new-value (c component) property) 12540 (let ((a (assoc property (slot-value c 'properties) :test #'equal))) 12541 (if a 12542 (setf (cdr a) new-value) 12543 (setf (slot-value c 'properties) 12544 (acons property new-value (slot-value c 'properties))))) 12545 new-value) 12546 12547 12548 ;; This method survives from ASDF 1, but really it is superseded by action-description. 12549 (defgeneric explain (operation component) 12550 (:documentation "Display a message describing an action. 12551 12552DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) 12553 (progn 12554 (define-convenience-action-methods explain (operation component))) 12555 (defmethod explain ((o operation) (c component)) 12556 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) 12557;;;; ------------------------------------------------------------------------- 12558;;; Internal hacks for backward-compatibility 12559 12560(uiop/package:define-package :asdf/backward-internals 12561 (:recycle :asdf/backward-internals :asdf) 12562 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) 12563 (:export #:load-sysdef)) 12564(in-package :asdf/backward-internals) 12565 12566(with-asdf-deprecation (:style-warning "3.2") 12567 (defun load-sysdef (name pathname) 12568 (declare (ignore name pathname)) 12569 ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. 12570 (error "Use asdf:load-asd instead of asdf::load-sysdef"))) 12571;;;; --------------------------------------------------------------------------- 12572;;;; Handle ASDF package upgrade, including implementation-dependent magic. 12573 12574(uiop/package:define-package :asdf/interface 12575 (:nicknames :asdf :asdf-utilities) 12576 (:recycle :asdf/interface :asdf) 12577 (:unintern 12578 #:loaded-systems ; makes for annoying SLIME completion 12579 #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL 12580 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache 12581 :asdf/component :asdf/system :asdf/find-system :asdf/find-component 12582 :asdf/operation :asdf/action :asdf/lisp-action 12583 :asdf/output-translations :asdf/source-registry 12584 :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source 12585 :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) 12586 ;; Note: (1) we are NOT automatically reexporting everything from previous packages. 12587 ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. 12588 (:export 12589 #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name #:primary-system-name 12590 #:oos #:operate #:make-plan #:perform-plan #:sequential-plan 12591 #:system-definition-pathname 12592 #:search-for-system-definition #:find-component #:component-find-path 12593 #:compile-system #:load-system #:load-systems #:load-systems* 12594 #:require-system #:test-system #:clear-system 12595 #:operation #:make-operation #:find-operation 12596 #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation 12597 #:non-propagating-operation 12598 #:build-op #:make 12599 #:load-op #:prepare-op #:compile-op 12600 #:prepare-source-op #:load-source-op #:test-op 12601 #:feature #:version #:version-satisfies #:upgrade-asdf 12602 #:implementation-identifier #:implementation-type #:hostname 12603 #:input-files #:output-files #:output-file #:perform #:perform-with-restarts 12604 #:operation-done-p #:explain #:action-description #:component-sideway-dependencies 12605 #:needed-in-image-p 12606 #:component-load-dependencies #:run-shell-command ; deprecated, do not use 12607 #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system 12608 #:program-system 12609 #:basic-compile-bundle-op #:prepare-bundle-op 12610 #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op 12611 #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op 12612 #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op 12613 #:concatenate-source-op 12614 #:load-concatenated-source-op 12615 #:compile-concatenated-source-op 12616 #:load-compiled-concatenated-source-op 12617 #:monolithic-concatenate-source-op 12618 #:monolithic-load-concatenated-source-op 12619 #:monolithic-compile-concatenated-source-op 12620 #:monolithic-load-compiled-concatenated-source-op 12621 #:operation-monolithic-p 12622 #:required-components 12623 #:component-loaded-p 12624 12625 #:component #:parent-component #:child-component #:system #:module 12626 #:file-component #:source-file #:c-source-file #:java-source-file 12627 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp 12628 #:static-file #:doc-file #:html-file 12629 #:file-type #:source-file-type 12630 12631 #:register-preloaded-system #:sysdef-preloaded-system-search 12632 #:register-immutable-system #:sysdef-immutable-system-search 12633 12634 #:package-inferred-system #:register-system-packages 12635 #:package-system ;; backward-compatibility during migration, to be removed in a further release. 12636 12637 #:component-children ; component accessors 12638 #:component-children-by-name 12639 #:component-pathname 12640 #:component-relative-pathname 12641 #:component-name 12642 #:component-version 12643 #:component-parent 12644 #:component-system 12645 #:component-encoding 12646 #:component-external-format 12647 12648 #:component-depends-on ; backward-compatible name rather than action-depends-on 12649 #:module-components ; backward-compatibility 12650 #:operation-on-warnings #:operation-on-failure ; backward-compatibility 12651 #:component-property ; backward-compatibility 12652 #:traverse ; backward-compatibility 12653 12654 #:system-description 12655 #:system-long-description 12656 #:system-author 12657 #:system-maintainer 12658 #:system-license 12659 #:system-licence 12660 #:system-source-file 12661 #:system-source-directory 12662 #:system-relative-pathname 12663 #:system-homepage 12664 #:system-mailto 12665 #:system-bug-tracker 12666 #:system-long-name 12667 #:system-source-control 12668 #:map-systems 12669 #:system-defsystem-depends-on 12670 #:system-depends-on 12671 #:system-weakly-depends-on 12672 12673 #:*system-definition-search-functions* ; variables 12674 #:*central-registry* 12675 #:*compile-file-warnings-behaviour* 12676 #:*compile-file-failure-behaviour* 12677 #:*resolve-symlinks* 12678 #:*asdf-verbose* ;; unused. For backward-compatibility only. 12679 #:*verbose-out* 12680 12681 #:asdf-version 12682 12683 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error 12684 #:compile-warned-warning #:compile-failed-warning 12685 #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility 12686 #:error-name 12687 #:error-pathname 12688 #:load-system-definition-error 12689 #:error-component #:error-operation 12690 #:system-definition-error 12691 #:missing-component 12692 #:missing-component-of-version 12693 #:missing-dependency 12694 #:missing-dependency-of-version 12695 #:circular-dependency ; errors 12696 #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name 12697 #:package-inferred-system-missing-package-error 12698 #:operation-definition-warning #:operation-definition-error 12699 12700 #:try-recompiling ; restarts 12701 #:retry 12702 #:accept 12703 #:coerce-entry-to-directory 12704 #:remove-entry-from-registry 12705 #:clear-configuration-and-retry 12706 12707 12708 #:*encoding-detection-hook* 12709 #:*encoding-external-format-hook* 12710 #:*default-encoding* 12711 #:*utf-8-external-format* 12712 12713 #:clear-configuration 12714 #:*output-translations-parameter* 12715 #:initialize-output-translations 12716 #:disable-output-translations 12717 #:clear-output-translations 12718 #:ensure-output-translations 12719 #:apply-output-translations 12720 #:compile-file* 12721 #:compile-file-pathname* 12722 #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check 12723 #:enable-asdf-binary-locations-compatibility 12724 #:*default-source-registries* 12725 #:*source-registry-parameter* 12726 #:initialize-source-registry 12727 #:compute-source-registry 12728 #:clear-source-registry 12729 #:ensure-source-registry 12730 #:process-source-registry 12731 #:system-registered-p #:registered-systems #:already-loaded-systems 12732 #:resolve-location 12733 #:asdf-message 12734 #:*user-cache* 12735 #:user-output-translations-pathname 12736 #:system-output-translations-pathname 12737 #:user-output-translations-directory-pathname 12738 #:system-output-translations-directory-pathname 12739 #:user-source-registry 12740 #:system-source-registry 12741 #:user-source-registry-directory 12742 #:system-source-registry-directory 12743 )) 12744 12745;;;; --------------------------------------------------------------------------- 12746;;;; ASDF-USER, where the action happens. 12747 12748(uiop/package:define-package :asdf/user 12749 (:nicknames :asdf-user) 12750 ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below. 12751 ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. 12752 ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. 12753 ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package 12754 ;; that only :use's :cl and :asdf 12755 (:use :uiop/common-lisp :uiop :asdf/interface)) 12756;;;; ----------------------------------------------------------------------- 12757;;;; ASDF Footer: last words and cleanup 12758 12759(uiop/package:define-package :asdf/footer 12760 (:recycle :asdf/footer :asdf) 12761 (:use :uiop/common-lisp :uiop 12762 :asdf/upgrade :asdf/find-system :asdf/operate :asdf/bundle) 12763 ;; Happily, all those implementations all have the same module-provider hook interface. 12764 #+(or abcl clasp cmucl clozure ecl mkcl sbcl) 12765 (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext 12766 #:*module-provider-functions* 12767 #+ecl #:*load-hooks*) 12768 #+(or clasp mkcl) (:import-from :si #:*load-hooks*)) 12769 12770(in-package :asdf/footer) 12771 12772;;;; Register ASDF itself and all its subsystems as preloaded. 12773(with-upgradability () 12774 (dolist (s '("asdf" "uiop" "asdf-package-system")) 12775 ;; Don't bother with these system names, no one relies on them anymore: 12776 ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem" 12777 (register-preloaded-system s :version *asdf-version*))) 12778 12779 12780;;;; Hook ASDF into the implementation's REQUIRE and other entry points. 12781#+(or abcl clasp clisp clozure cmucl ecl mkcl sbcl) 12782(with-upgradability () 12783 ;; Hook into CL:REQUIRE. 12784 #-clisp (pushnew 'module-provide-asdf *module-provider-functions*) 12785 #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil)) 12786 (eval `(pushnew 'module-provide-asdf ,x))) 12787 12788 #+(or clasp ecl mkcl) 12789 (progn 12790 (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car) 12791 12792 #+os-windows 12793 (unless (assoc "asd" *load-hooks* :test 'equal) 12794 (appendf *load-hooks* '(("asd" . si::load-source)))) 12795 12796 ;; Wrap module provider functions in an idempotent, upgrade friendly way 12797 (defvar *wrapped-module-provider* (make-hash-table)) 12798 (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf) 12799 (defun wrap-module-provider (provider name) 12800 (let ((results (multiple-value-list (funcall provider name)))) 12801 (when (first results) (register-preloaded-system (coerce-name name))) 12802 (values-list results))) 12803 (defun wrap-module-provider-function (provider) 12804 (ensure-gethash provider *wrapped-module-provider* 12805 (constantly 12806 #'(lambda (module-name) 12807 (wrap-module-provider provider module-name))))) 12808 (setf *module-provider-functions* 12809 (mapcar #'wrap-module-provider-function *module-provider-functions*)))) 12810 12811#+cmucl ;; Hook into the CMUCL herald. 12812(with-upgradability () 12813 (defun herald-asdf (stream) 12814 (format stream " ASDF ~A" (asdf-version))) 12815 (setf (getf ext:*herald-items* :asdf) '(herald-asdf))) 12816 12817 12818;;;; Done! 12819(with-upgradability () 12820 #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp 12821 (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 12822 (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) 12823 12824 ;; Advertise the features we provide. 12825 (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf-package-system)) (pushnew f *features*)) 12826 12827 ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. 12828 (provide "asdf") (provide "ASDF") 12829 12830 ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF. 12831 (cleanup-upgraded-asdf)) 12832 12833(when *load-verbose* 12834 (asdf-message ";; ASDF, version ~a~%" (asdf-version))) 12835