| 1 | ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- |
|---|
| 2 | ;;; This is ASDF 2.017.22: 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-2011 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 | #+xcvb (module ()) |
|---|
| 49 | |
|---|
| 50 | (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) |
|---|
| 51 | |
|---|
| 52 | #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) |
|---|
| 53 | (error "ASDF is not supported on your implementation. Please help us port it.") |
|---|
| 54 | |
|---|
| 55 | #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this |
|---|
| 56 | |
|---|
| 57 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|---|
| 58 | ;;; Implementation-dependent tweaks |
|---|
| 59 | ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. |
|---|
| 60 | #+allegro |
|---|
| 61 | (setf excl::*autoload-package-name-alist* |
|---|
| 62 | (remove "asdf" excl::*autoload-package-name-alist* |
|---|
| 63 | :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below |
|---|
| 64 | #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp)) |
|---|
| 65 | #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 |
|---|
| 66 | (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all |
|---|
| 67 | (and (= system::*gcl-major-version* 2) |
|---|
| 68 | (< system::*gcl-minor-version* 7))) |
|---|
| 69 | (pushnew :gcl-pre2.7 *features*)) |
|---|
| 70 | ;;; make package if it doesn't exist yet. |
|---|
| 71 | ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. |
|---|
| 72 | (unless (find-package :asdf) |
|---|
| 73 | (make-package :asdf :use '(:common-lisp)))) |
|---|
| 74 | |
|---|
| 75 | (in-package :asdf) |
|---|
| 76 | |
|---|
| 77 | ;;;; Create packages in a way that is compatible with hot-upgrade. |
|---|
| 78 | ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 |
|---|
| 79 | ;;;; See more near the end of the file. |
|---|
| 80 | |
|---|
| 81 | (eval-when (:load-toplevel :compile-toplevel :execute) |
|---|
| 82 | (defvar *asdf-version* nil) |
|---|
| 83 | (defvar *upgraded-p* nil) |
|---|
| 84 | (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12. |
|---|
| 85 | (defun find-symbol* (s p) |
|---|
| 86 | (find-symbol (string s) p)) |
|---|
| 87 | ;; Strip out formatting that is not supported on Genera. |
|---|
| 88 | ;; Has to be inside the eval-when to make Lispworks happy (!) |
|---|
| 89 | (defmacro compatfmt (format) |
|---|
| 90 | #-(or gcl genera) format |
|---|
| 91 | #+(or gcl genera) |
|---|
| 92 | (loop :for (unsupported . replacement) :in |
|---|
| 93 | `(("~3i~_" . "") |
|---|
| 94 | #+genera |
|---|
| 95 | ,@(("~@<" . "") |
|---|
| 96 | ("; ~@;" . "; ") |
|---|
| 97 | ("~@:>" . "") |
|---|
| 98 | ("~:>" . ""))) :do |
|---|
| 99 | (loop :for found = (search unsupported format) :while found :do |
|---|
| 100 | (setf format |
|---|
| 101 | (concatenate 'simple-string |
|---|
| 102 | (subseq format 0 found) replacement |
|---|
| 103 | (subseq format (+ found (length unsupported))))))) |
|---|
| 104 | format) |
|---|
| 105 | (let* (;; For bug reporting sanity, please always bump this version when you modify this file. |
|---|
| 106 | ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version |
|---|
| 107 | ;; can help you do these changes in synch (look at the source for documentation). |
|---|
| 108 | ;; Relying on its automation, the version is now redundantly present on top of this file. |
|---|
| 109 | ;; "2.345" would be an official release |
|---|
| 110 | ;; "2.345.6" would be a development version in the official upstream |
|---|
| 111 | ;; "2.345.0.7" would be your seventh local modification of official release 2.345 |
|---|
| 112 | ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 |
|---|
| 113 | (asdf-version "2.017.22") |
|---|
| 114 | (existing-asdf (find-class 'component nil)) |
|---|
| 115 | (existing-version *asdf-version*) |
|---|
| 116 | (already-there (equal asdf-version existing-version))) |
|---|
| 117 | (unless (and existing-asdf already-there) |
|---|
| 118 | (when (and existing-asdf *asdf-verbose*) |
|---|
| 119 | (format *trace-output* |
|---|
| 120 | (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") |
|---|
| 121 | existing-version asdf-version)) |
|---|
| 122 | (labels |
|---|
| 123 | ((present-symbol-p (symbol package) |
|---|
| 124 | (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external))) |
|---|
| 125 | (present-symbols (package) |
|---|
| 126 | ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera |
|---|
| 127 | (let (l) |
|---|
| 128 | (do-symbols (s package) |
|---|
| 129 | (when (present-symbol-p s package) (push s l))) |
|---|
| 130 | (reverse l))) |
|---|
| 131 | (unlink-package (package) |
|---|
| 132 | (let ((u (find-package package))) |
|---|
| 133 | (when u |
|---|
| 134 | (ensure-unintern u (present-symbols u)) |
|---|
| 135 | (loop :for p :in (package-used-by-list u) :do |
|---|
| 136 | (unuse-package u p)) |
|---|
| 137 | (delete-package u)))) |
|---|
| 138 | (ensure-exists (name nicknames use) |
|---|
| 139 | (let ((previous |
|---|
| 140 | (remove-duplicates |
|---|
| 141 | (mapcar #'find-package (cons name nicknames)) |
|---|
| 142 | :from-end t))) |
|---|
| 143 | ;; do away with packages with conflicting (nick)names |
|---|
| 144 | (map () #'unlink-package (cdr previous)) |
|---|
| 145 | ;; reuse previous package with same name |
|---|
| 146 | (let ((p (car previous))) |
|---|
| 147 | (cond |
|---|
| 148 | (p |
|---|
| 149 | (rename-package p name nicknames) |
|---|
| 150 | (ensure-use p use) |
|---|
| 151 | p) |
|---|
| 152 | (t |
|---|
| 153 | (make-package name :nicknames nicknames :use use)))))) |
|---|
| 154 | (intern* (symbol package) |
|---|
| 155 | (intern (string symbol) package)) |
|---|
| 156 | (remove-symbol (symbol package) |
|---|
| 157 | (let ((sym (find-symbol* symbol package))) |
|---|
| 158 | (when sym |
|---|
| 159 | #-cormanlisp (unexport sym package) |
|---|
| 160 | (unintern sym package) |
|---|
| 161 | sym))) |
|---|
| 162 | (ensure-unintern (package symbols) |
|---|
| 163 | (loop :with packages = (list-all-packages) |
|---|
| 164 | :for sym :in symbols |
|---|
| 165 | :for removed = (remove-symbol sym package) |
|---|
| 166 | :when removed :do |
|---|
| 167 | (loop :for p :in packages :do |
|---|
| 168 | (when (eq removed (find-symbol* sym p)) |
|---|
| 169 | (unintern removed p))))) |
|---|
| 170 | (ensure-shadow (package symbols) |
|---|
| 171 | (shadow symbols package)) |
|---|
| 172 | (ensure-use (package use) |
|---|
| 173 | (dolist (used (reverse use)) |
|---|
| 174 | (do-external-symbols (sym used) |
|---|
| 175 | (unless (eq sym (find-symbol* sym package)) |
|---|
| 176 | (remove-symbol sym package))) |
|---|
| 177 | (use-package used package))) |
|---|
| 178 | (ensure-fmakunbound (package symbols) |
|---|
| 179 | (loop :for name :in symbols |
|---|
| 180 | :for sym = (find-symbol* name package) |
|---|
| 181 | :when sym :do (fmakunbound sym))) |
|---|
| 182 | (ensure-export (package export) |
|---|
| 183 | (let ((formerly-exported-symbols nil) |
|---|
| 184 | (bothly-exported-symbols nil) |
|---|
| 185 | (newly-exported-symbols nil)) |
|---|
| 186 | (do-external-symbols (sym package) |
|---|
| 187 | (if (member sym export :test 'string-equal) |
|---|
| 188 | (push sym bothly-exported-symbols) |
|---|
| 189 | (push sym formerly-exported-symbols))) |
|---|
| 190 | (loop :for sym :in export :do |
|---|
| 191 | (unless (member sym bothly-exported-symbols :test 'string-equal) |
|---|
| 192 | (push sym newly-exported-symbols))) |
|---|
| 193 | (loop :for user :in (package-used-by-list package) |
|---|
| 194 | :for shadowing = (package-shadowing-symbols user) :do |
|---|
| 195 | (loop :for new :in newly-exported-symbols |
|---|
| 196 | :for old = (find-symbol* new user) |
|---|
| 197 | :when (and old (not (member old shadowing))) |
|---|
| 198 | :do (unintern old user))) |
|---|
| 199 | (loop :for x :in newly-exported-symbols :do |
|---|
| 200 | (export (intern* x package))))) |
|---|
| 201 | (ensure-package (name &key nicknames use unintern |
|---|
| 202 | shadow export redefined-functions) |
|---|
| 203 | (let* ((p (ensure-exists name nicknames use))) |
|---|
| 204 | (ensure-unintern p unintern) |
|---|
| 205 | (ensure-shadow p shadow) |
|---|
| 206 | (ensure-export p export) |
|---|
| 207 | (ensure-fmakunbound p redefined-functions) |
|---|
| 208 | p))) |
|---|
| 209 | (macrolet |
|---|
| 210 | ((pkgdcl (name &key nicknames use export |
|---|
| 211 | redefined-functions unintern shadow) |
|---|
| 212 | `(ensure-package |
|---|
| 213 | ',name :nicknames ',nicknames :use ',use :export ',export |
|---|
| 214 | :shadow ',shadow |
|---|
| 215 | :unintern ',unintern |
|---|
| 216 | :redefined-functions ',redefined-functions))) |
|---|
| 217 | (pkgdcl |
|---|
| 218 | :asdf |
|---|
| 219 | :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. |
|---|
| 220 | :use (:common-lisp) |
|---|
| 221 | :redefined-functions |
|---|
| 222 | (#:perform #:explain #:output-files #:operation-done-p |
|---|
| 223 | #:perform-with-restarts #:component-relative-pathname |
|---|
| 224 | #:system-source-file #:operate #:find-component #:find-system |
|---|
| 225 | #:apply-output-translations #:translate-pathname* #:resolve-location |
|---|
| 226 | #:system-relative-pathname |
|---|
| 227 | #:inherit-source-registry #:process-source-registry |
|---|
| 228 | #:process-source-registry-directive |
|---|
| 229 | #:compile-file* #:source-file-type) |
|---|
| 230 | :unintern |
|---|
| 231 | (#:*asdf-revision* #:around #:asdf-method-combination |
|---|
| 232 | #:split #:make-collector |
|---|
| 233 | #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function |
|---|
| 234 | :export |
|---|
| 235 | (#:defsystem #:oos #:operate #:find-system #:run-shell-command |
|---|
| 236 | #:system-definition-pathname #:with-system-definitions |
|---|
| 237 | #:search-for-system-definition #:find-component ; miscellaneous |
|---|
| 238 | #:compile-system #:load-system #:test-system #:clear-system |
|---|
| 239 | #:compile-op #:load-op #:load-source-op |
|---|
| 240 | #:test-op |
|---|
| 241 | #:operation ; operations |
|---|
| 242 | #:feature ; sort-of operation |
|---|
| 243 | #:version ; metaphorically sort-of an operation |
|---|
| 244 | #:version-satisfies |
|---|
| 245 | #:upgrade-asdf |
|---|
| 246 | #:implementation-identifier #:implementation-type |
|---|
| 247 | |
|---|
| 248 | #:input-files #:output-files #:output-file #:perform ; operation methods |
|---|
| 249 | #:operation-done-p #:explain |
|---|
| 250 | |
|---|
| 251 | #:component #:source-file |
|---|
| 252 | #:c-source-file #:cl-source-file #:java-source-file |
|---|
| 253 | #:cl-source-file.cl #:cl-source-file.lsp |
|---|
| 254 | #:static-file |
|---|
| 255 | #:doc-file |
|---|
| 256 | #:html-file |
|---|
| 257 | #:text-file |
|---|
| 258 | #:source-file-type |
|---|
| 259 | #:module ; components |
|---|
| 260 | #:system |
|---|
| 261 | #:unix-dso |
|---|
| 262 | |
|---|
| 263 | #:module-components ; component accessors |
|---|
| 264 | #:module-components-by-name ; component accessors |
|---|
| 265 | #:component-pathname |
|---|
| 266 | #:component-relative-pathname |
|---|
| 267 | #:component-name |
|---|
| 268 | #:component-version |
|---|
| 269 | #:component-parent |
|---|
| 270 | #:component-property |
|---|
| 271 | #:component-system |
|---|
| 272 | |
|---|
| 273 | #:component-depends-on |
|---|
| 274 | |
|---|
| 275 | #:system-description |
|---|
| 276 | #:system-long-description |
|---|
| 277 | #:system-author |
|---|
| 278 | #:system-maintainer |
|---|
| 279 | #:system-license |
|---|
| 280 | #:system-licence |
|---|
| 281 | #:system-source-file |
|---|
| 282 | #:system-source-directory |
|---|
| 283 | #:system-relative-pathname |
|---|
| 284 | #:map-systems |
|---|
| 285 | |
|---|
| 286 | #:operation-description |
|---|
| 287 | #:operation-on-warnings |
|---|
| 288 | #:operation-on-failure |
|---|
| 289 | #:component-visited-p |
|---|
| 290 | ;;#:*component-parent-pathname* |
|---|
| 291 | #:*system-definition-search-functions* |
|---|
| 292 | #:*central-registry* ; variables |
|---|
| 293 | #:*compile-file-warnings-behaviour* |
|---|
| 294 | #:*compile-file-failure-behaviour* |
|---|
| 295 | #:*resolve-symlinks* |
|---|
| 296 | #:*require-asdf-operator* |
|---|
| 297 | #:*asdf-verbose* |
|---|
| 298 | #:*verbose-out* |
|---|
| 299 | |
|---|
| 300 | #:asdf-version |
|---|
| 301 | |
|---|
| 302 | #:operation-error #:compile-failed #:compile-warned #:compile-error |
|---|
| 303 | #:error-name |
|---|
| 304 | #:error-pathname |
|---|
| 305 | #:load-system-definition-error |
|---|
| 306 | #:error-component #:error-operation |
|---|
| 307 | #:system-definition-error |
|---|
| 308 | #:missing-component |
|---|
| 309 | #:missing-component-of-version |
|---|
| 310 | #:missing-dependency |
|---|
| 311 | #:missing-dependency-of-version |
|---|
| 312 | #:circular-dependency ; errors |
|---|
| 313 | #:duplicate-names |
|---|
| 314 | |
|---|
| 315 | #:try-recompiling |
|---|
| 316 | #:retry |
|---|
| 317 | #:accept ; restarts |
|---|
| 318 | #:coerce-entry-to-directory |
|---|
| 319 | #:remove-entry-from-registry |
|---|
| 320 | |
|---|
| 321 | #:clear-configuration |
|---|
| 322 | #:*output-translations-parameter* |
|---|
| 323 | #:initialize-output-translations |
|---|
| 324 | #:disable-output-translations |
|---|
| 325 | #:clear-output-translations |
|---|
| 326 | #:ensure-output-translations |
|---|
| 327 | #:apply-output-translations |
|---|
| 328 | #:compile-file* |
|---|
| 329 | #:compile-file-pathname* |
|---|
| 330 | #:enable-asdf-binary-locations-compatibility |
|---|
| 331 | #:*default-source-registries* |
|---|
| 332 | #:*source-registry-parameter* |
|---|
| 333 | #:initialize-source-registry |
|---|
| 334 | #:compute-source-registry |
|---|
| 335 | #:clear-source-registry |
|---|
| 336 | #:ensure-source-registry |
|---|
| 337 | #:process-source-registry |
|---|
| 338 | #:system-registered-p |
|---|
| 339 | #:asdf-message |
|---|
| 340 | |
|---|
| 341 | ;; Utilities |
|---|
| 342 | #:absolute-pathname-p |
|---|
| 343 | ;; #:aif #:it |
|---|
| 344 | ;; #:appendf |
|---|
| 345 | #:coerce-name |
|---|
| 346 | #:directory-pathname-p |
|---|
| 347 | ;; #:ends-with |
|---|
| 348 | #:ensure-directory-pathname |
|---|
| 349 | #:getenv |
|---|
| 350 | ;; #:length=n-p |
|---|
| 351 | ;; #:find-symbol* |
|---|
| 352 | #:merge-pathnames* |
|---|
| 353 | #:coerce-pathname |
|---|
| 354 | #:pathname-directory-pathname |
|---|
| 355 | #:read-file-forms |
|---|
| 356 | ;; #:remove-keys |
|---|
| 357 | ;; #:remove-keyword |
|---|
| 358 | #:resolve-symlinks |
|---|
| 359 | #:split-string |
|---|
| 360 | #:component-name-to-pathname-components |
|---|
| 361 | #:split-name-type |
|---|
| 362 | #:subdirectories |
|---|
| 363 | #:truenamize |
|---|
| 364 | #:while-collecting))) |
|---|
| 365 | #+genera (import 'scl:boolean :asdf) |
|---|
| 366 | (setf *asdf-version* asdf-version |
|---|
| 367 | *upgraded-p* (if existing-version |
|---|
| 368 | (cons existing-version *upgraded-p*) |
|---|
| 369 | *upgraded-p*)))))) |
|---|
| 370 | |
|---|
| 371 | ;;;; ------------------------------------------------------------------------- |
|---|
| 372 | ;;;; User-visible parameters |
|---|
| 373 | ;;;; |
|---|
| 374 | (defvar *resolve-symlinks* t |
|---|
| 375 | "Determine whether or not ASDF resolves symlinks when defining systems. |
|---|
| 376 | |
|---|
| 377 | Defaults to T.") |
|---|
| 378 | |
|---|
| 379 | (defvar *compile-file-warnings-behaviour* |
|---|
| 380 | (or #+clisp :ignore :warn) |
|---|
| 381 | "How should ASDF react if it encounters a warning when compiling a file? |
|---|
| 382 | Valid values are :error, :warn, and :ignore.") |
|---|
| 383 | |
|---|
| 384 | (defvar *compile-file-failure-behaviour* |
|---|
| 385 | (or #+sbcl :error #+clisp :ignore :warn) |
|---|
| 386 | "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) |
|---|
| 387 | when compiling a file? Valid values are :error, :warn, and :ignore. |
|---|
| 388 | Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") |
|---|
| 389 | |
|---|
| 390 | (defvar *verbose-out* nil) |
|---|
| 391 | |
|---|
| 392 | (defparameter +asdf-methods+ |
|---|
| 393 | '(perform-with-restarts perform explain output-files operation-done-p)) |
|---|
| 394 | |
|---|
| 395 | #+allegro |
|---|
| 396 | (eval-when (:compile-toplevel :execute) |
|---|
| 397 | (defparameter *acl-warn-save* |
|---|
| 398 | (when (boundp 'excl:*warn-on-nested-reader-conditionals*) |
|---|
| 399 | excl:*warn-on-nested-reader-conditionals*)) |
|---|
| 400 | (when (boundp 'excl:*warn-on-nested-reader-conditionals*) |
|---|
| 401 | (setf excl:*warn-on-nested-reader-conditionals* nil))) |
|---|
| 402 | |
|---|
| 403 | ;;;; ------------------------------------------------------------------------- |
|---|
| 404 | ;;;; Resolve forward references |
|---|
| 405 | |
|---|
| 406 | (declaim (ftype (function (t) t) |
|---|
| 407 | format-arguments format-control |
|---|
| 408 | error-name error-pathname error-condition |
|---|
| 409 | duplicate-names-name |
|---|
| 410 | error-component error-operation |
|---|
| 411 | module-components module-components-by-name |
|---|
| 412 | circular-dependency-components |
|---|
| 413 | condition-arguments condition-form |
|---|
| 414 | condition-format condition-location |
|---|
| 415 | coerce-name) |
|---|
| 416 | #-(or cormanlisp gcl-pre2.7) |
|---|
| 417 | (ftype (function (t t) t) (setf module-components-by-name))) |
|---|
| 418 | |
|---|
| 419 | ;;;; ------------------------------------------------------------------------- |
|---|
| 420 | ;;;; Compatibility various implementations |
|---|
| 421 | #+cormanlisp |
|---|
| 422 | (progn |
|---|
| 423 | (deftype logical-pathname () nil) |
|---|
| 424 | (defun* make-broadcast-stream () *error-output*) |
|---|
| 425 | (defun* file-namestring (p) |
|---|
| 426 | (setf p (pathname p)) |
|---|
| 427 | (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) |
|---|
| 428 | |
|---|
| 429 | #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl |
|---|
| 430 | (read-from-string |
|---|
| 431 | "(eval-when (:compile-toplevel :load-toplevel :execute) |
|---|
| 432 | (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) |
|---|
| 433 | (ccl:define-entry-point (_system \"system\") ((name :string)) :int) |
|---|
| 434 | ;; Note: ASDF may expect user-homedir-pathname to provide |
|---|
| 435 | ;; the pathname of the current user's home directory, whereas |
|---|
| 436 | ;; MCL by default provides the directory from which MCL was started. |
|---|
| 437 | ;; See http://code.google.com/p/mcl/wiki/Portability |
|---|
| 438 | (defun current-user-homedir-pathname () |
|---|
| 439 | (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) |
|---|
| 440 | (defun probe-posix (posix-namestring) |
|---|
| 441 | \"If a file exists for the posix namestring, return the pathname\" |
|---|
| 442 | (ccl::with-cstrs ((cpath posix-namestring)) |
|---|
| 443 | (ccl::rlet ((is-dir :boolean) |
|---|
| 444 | (fsref :fsref)) |
|---|
| 445 | (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) |
|---|
| 446 | (ccl::%path-from-fsref fsref is-dir))))))")) |
|---|
| 447 | |
|---|
| 448 | ;;;; ------------------------------------------------------------------------- |
|---|
| 449 | ;;;; General Purpose Utilities |
|---|
| 450 | |
|---|
| 451 | (macrolet |
|---|
| 452 | ((defdef (def* def) |
|---|
| 453 | `(defmacro ,def* (name formals &rest rest) |
|---|
| 454 | `(progn |
|---|
| 455 | #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name) |
|---|
| 456 | #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( |
|---|
| 457 | ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl |
|---|
| 458 | `(declaim (notinline ,name))) |
|---|
| 459 | (,',def ,name ,formals ,@rest))))) |
|---|
| 460 | (defdef defgeneric* defgeneric) |
|---|
| 461 | (defdef defun* defun)) |
|---|
| 462 | |
|---|
| 463 | (defmacro while-collecting ((&rest collectors) &body body) |
|---|
| 464 | "COLLECTORS should be a list of names for collections. A collector |
|---|
| 465 | defines a function that, when applied to an argument inside BODY, will |
|---|
| 466 | add its argument to the corresponding collection. Returns multiple values, |
|---|
| 467 | a list for each collection, in order. |
|---|
| 468 | E.g., |
|---|
| 469 | \(while-collecting \(foo bar\) |
|---|
| 470 | \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) |
|---|
| 471 | \(foo \(first x\)\) |
|---|
| 472 | \(bar \(second x\)\)\)\) |
|---|
| 473 | Returns two values: \(A B C\) and \(1 2 3\)." |
|---|
| 474 | (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) |
|---|
| 475 | (initial-values (mapcar (constantly nil) collectors))) |
|---|
| 476 | `(let ,(mapcar #'list vars initial-values) |
|---|
| 477 | (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) |
|---|
| 478 | ,@body |
|---|
| 479 | (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) |
|---|
| 480 | |
|---|
| 481 | (defmacro aif (test then &optional else) |
|---|
| 482 | `(let ((it ,test)) (if it ,then ,else))) |
|---|
| 483 | |
|---|
| 484 | (defun* pathname-directory-pathname (pathname) |
|---|
| 485 | "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, |
|---|
| 486 | and NIL NAME, TYPE and VERSION components" |
|---|
| 487 | (when pathname |
|---|
| 488 | (make-pathname :name nil :type nil :version nil :defaults pathname))) |
|---|
| 489 | |
|---|
| 490 | (defun* normalize-pathname-directory-component (directory) |
|---|
| 491 | (cond |
|---|
| 492 | #-(or cmu sbcl scl) |
|---|
| 493 | ((stringp directory) `(:absolute ,directory) directory) |
|---|
| 494 | #+gcl |
|---|
| 495 | ((and (consp directory) (stringp (first directory))) |
|---|
| 496 | `(:absolute ,@directory)) |
|---|
| 497 | ((or (null directory) |
|---|
| 498 | (and (consp directory) (member (first directory) '(:absolute :relative)))) |
|---|
| 499 | directory) |
|---|
| 500 | (t |
|---|
| 501 | (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) |
|---|
| 502 | |
|---|
| 503 | (defun* merge-pathname-directory-components (specified defaults) |
|---|
| 504 | (let ((directory (normalize-pathname-directory-component specified))) |
|---|
| 505 | (ecase (first directory) |
|---|
| 506 | ((nil) defaults) |
|---|
| 507 | (:absolute specified) |
|---|
| 508 | (:relative |
|---|
| 509 | (let ((defdir (normalize-pathname-directory-component defaults)) |
|---|
| 510 | (reldir (cdr directory))) |
|---|
| 511 | (cond |
|---|
| 512 | ((null defdir) |
|---|
| 513 | directory) |
|---|
| 514 | ((not (eq :back (first reldir))) |
|---|
| 515 | (append defdir reldir)) |
|---|
| 516 | (t |
|---|
| 517 | (loop :with defabs = (first defdir) |
|---|
| 518 | :with defrev = (reverse (rest defdir)) |
|---|
| 519 | :while (and (eq :back (car reldir)) |
|---|
| 520 | (or (and (eq :absolute defabs) (null defrev)) |
|---|
| 521 | (stringp (car defrev)))) |
|---|
| 522 | :do (pop reldir) (pop defrev) |
|---|
| 523 | :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) |
|---|
| 524 | |
|---|
| 525 | (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) |
|---|
| 526 | "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that |
|---|
| 527 | if the SPECIFIED pathname does not have an absolute directory, |
|---|
| 528 | then the HOST and DEVICE both come from the DEFAULTS, whereas |
|---|
| 529 | if the SPECIFIED pathname does have an absolute directory, |
|---|
| 530 | then the HOST and DEVICE both come from the SPECIFIED. |
|---|
| 531 | Also, if either argument is NIL, then the other argument is returned unmodified." |
|---|
| 532 | (when (null specified) (return-from merge-pathnames* defaults)) |
|---|
| 533 | (when (null defaults) (return-from merge-pathnames* specified)) |
|---|
| 534 | #+scl |
|---|
| 535 | (ext:resolve-pathname specified defaults) |
|---|
| 536 | #-scl |
|---|
| 537 | (let* ((specified (pathname specified)) |
|---|
| 538 | (defaults (pathname defaults)) |
|---|
| 539 | (directory (normalize-pathname-directory-component (pathname-directory specified))) |
|---|
| 540 | (name (or (pathname-name specified) (pathname-name defaults))) |
|---|
| 541 | (type (or (pathname-type specified) (pathname-type defaults))) |
|---|
| 542 | (version (or (pathname-version specified) (pathname-version defaults)))) |
|---|
| 543 | (labels ((ununspecific (x) |
|---|
| 544 | (if (eq x :unspecific) nil x)) |
|---|
| 545 | (unspecific-handler (p) |
|---|
| 546 | (if (typep p 'logical-pathname) #'ununspecific #'identity))) |
|---|
| 547 | (multiple-value-bind (host device directory unspecific-handler) |
|---|
| 548 | (ecase (first directory) |
|---|
| 549 | ((:absolute) |
|---|
| 550 | (values (pathname-host specified) |
|---|
| 551 | (pathname-device specified) |
|---|
| 552 | directory |
|---|
| 553 | (unspecific-handler specified))) |
|---|
| 554 | ((nil :relative) |
|---|
| 555 | (values (pathname-host defaults) |
|---|
| 556 | (pathname-device defaults) |
|---|
| 557 | (merge-pathname-directory-components directory (pathname-directory defaults)) |
|---|
| 558 | (unspecific-handler defaults)))) |
|---|
| 559 | (make-pathname :host host :device device :directory directory |
|---|
| 560 | :name (funcall unspecific-handler name) |
|---|
| 561 | :type (funcall unspecific-handler type) |
|---|
| 562 | :version (funcall unspecific-handler version)))))) |
|---|
| 563 | |
|---|
| 564 | (defun* pathname-parent-directory-pathname (pathname) |
|---|
| 565 | "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, |
|---|
| 566 | and NIL NAME, TYPE and VERSION components" |
|---|
| 567 | (when pathname |
|---|
| 568 | (make-pathname :name nil :type nil :version nil |
|---|
| 569 | :directory (merge-pathname-directory-components |
|---|
| 570 | '(:relative :back) (pathname-directory pathname)) |
|---|
| 571 | :defaults pathname))) |
|---|
| 572 | |
|---|
| 573 | (define-modify-macro appendf (&rest args) |
|---|
| 574 | append "Append onto list") ;; only to be used on short lists. |
|---|
| 575 | |
|---|
| 576 | (define-modify-macro orf (&rest args) |
|---|
| 577 | or "or a flag") |
|---|
| 578 | |
|---|
| 579 | (defun* first-char (s) |
|---|
| 580 | (and (stringp s) (plusp (length s)) (char s 0))) |
|---|
| 581 | |
|---|
| 582 | (defun* last-char (s) |
|---|
| 583 | (and (stringp s) (plusp (length s)) (char s (1- (length s))))) |
|---|
| 584 | |
|---|
| 585 | |
|---|
| 586 | (defun* asdf-message (format-string &rest format-args) |
|---|
| 587 | (declare (dynamic-extent format-args)) |
|---|
| 588 | (apply 'format *verbose-out* format-string format-args)) |
|---|
| 589 | |
|---|
| 590 | (defun* split-string (string &key max (separator '(#\Space #\Tab))) |
|---|
| 591 | "Split STRING into a list of components separated by |
|---|
| 592 | any of the characters in the sequence SEPARATOR. |
|---|
| 593 | If MAX is specified, then no more than max(1,MAX) components will be returned, |
|---|
| 594 | starting the separation from the end, e.g. when called with arguments |
|---|
| 595 | \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." |
|---|
| 596 | (catch nil |
|---|
| 597 | (let ((list nil) (words 0) (end (length string))) |
|---|
| 598 | (flet ((separatorp (char) (find char separator)) |
|---|
| 599 | (done () (throw nil (cons (subseq string 0 end) list)))) |
|---|
| 600 | (loop |
|---|
| 601 | :for start = (if (and max (>= words (1- max))) |
|---|
| 602 | (done) |
|---|
| 603 | (position-if #'separatorp string :end end :from-end t)) :do |
|---|
| 604 | (when (null start) |
|---|
| 605 | (done)) |
|---|
| 606 | (push (subseq string (1+ start) end) list) |
|---|
| 607 | (incf words) |
|---|
| 608 | (setf end start)))))) |
|---|
| 609 | |
|---|
| 610 | (defun* split-name-type (filename) |
|---|
| 611 | (let ((unspecific |
|---|
| 612 | ;; Giving :unspecific as argument to make-pathname is not portable. |
|---|
| 613 | ;; See CLHS make-pathname and 19.2.2.2.3. |
|---|
| 614 | ;; We only use it on implementations that support it. |
|---|
| 615 | (or #+(or clozure gcl lispworks sbcl) :unspecific))) |
|---|
| 616 | (destructuring-bind (name &optional (type unspecific)) |
|---|
| 617 | (split-string filename :max 2 :separator ".") |
|---|
| 618 | (if (equal name "") |
|---|
| 619 | (values filename unspecific) |
|---|
| 620 | (values name type))))) |
|---|
| 621 | |
|---|
| 622 | (defun* component-name-to-pathname-components (s &key force-directory force-relative) |
|---|
| 623 | "Splits the path string S, returning three values: |
|---|
| 624 | A flag that is either :absolute or :relative, indicating |
|---|
| 625 | how the rest of the values are to be interpreted. |
|---|
| 626 | A directory path --- a list of strings, suitable for |
|---|
| 627 | use with MAKE-PATHNAME when prepended with the flag |
|---|
| 628 | value. |
|---|
| 629 | A filename with type extension, possibly NIL in the |
|---|
| 630 | case of a directory pathname. |
|---|
| 631 | FORCE-DIRECTORY forces S to be interpreted as a directory |
|---|
| 632 | pathname \(third return value will be NIL, final component |
|---|
| 633 | of S will be treated as part of the directory path. |
|---|
| 634 | |
|---|
| 635 | The intention of this function is to support structured component names, |
|---|
| 636 | e.g., \(:file \"foo/bar\"\), which will be unpacked to relative |
|---|
| 637 | pathnames." |
|---|
| 638 | (check-type s string) |
|---|
| 639 | (when (find #\: s) |
|---|
| 640 | (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s)) |
|---|
| 641 | (let* ((components (split-string s :separator "/")) |
|---|
| 642 | (last-comp (car (last components)))) |
|---|
| 643 | (multiple-value-bind (relative components) |
|---|
| 644 | (if (equal (first components) "") |
|---|
| 645 | (if (equal (first-char s) #\/) |
|---|
| 646 | (progn |
|---|
| 647 | (when force-relative |
|---|
| 648 | (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s)) |
|---|
| 649 | (values :absolute (cdr components))) |
|---|
| 650 | (values :relative nil)) |
|---|
| 651 | (values :relative components)) |
|---|
| 652 | (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components)) |
|---|
| 653 | (setf components (substitute :back ".." components :test #'equal)) |
|---|
| 654 | (cond |
|---|
| 655 | ((equal last-comp "") |
|---|
| 656 | (values relative components nil)) ; "" already removed |
|---|
| 657 | (force-directory |
|---|
| 658 | (values relative components nil)) |
|---|
| 659 | (t |
|---|
| 660 | (values relative (butlast components) last-comp)))))) |
|---|
| 661 | |
|---|
| 662 | (defun* remove-keys (key-names args) |
|---|
| 663 | (loop :for (name val) :on args :by #'cddr |
|---|
| 664 | :unless (member (symbol-name name) key-names |
|---|
| 665 | :key #'symbol-name :test 'equal) |
|---|
| 666 | :append (list name val))) |
|---|
| 667 | |
|---|
| 668 | (defun* remove-keyword (key args) |
|---|
| 669 | (loop :for (k v) :on args :by #'cddr |
|---|
| 670 | :unless (eq k key) |
|---|
| 671 | :append (list k v))) |
|---|
| 672 | |
|---|
| 673 | (defun* getenv (x) |
|---|
| 674 | (declare (ignorable x)) |
|---|
| 675 | #+(or abcl clisp ecl xcl) (ext:getenv x) |
|---|
| 676 | #+allegro (sys:getenv x) |
|---|
| 677 | #+clozure (ccl:getenv x) |
|---|
| 678 | #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=)) |
|---|
| 679 | #+cormanlisp |
|---|
| 680 | (let* ((buffer (ct:malloc 1)) |
|---|
| 681 | (cname (ct:lisp-string-to-c-string x)) |
|---|
| 682 | (needed-size (win:getenvironmentvariable cname buffer 0)) |
|---|
| 683 | (buffer1 (ct:malloc (1+ needed-size)))) |
|---|
| 684 | (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) |
|---|
| 685 | nil |
|---|
| 686 | (ct:c-string-to-lisp-string buffer1)) |
|---|
| 687 | (ct:free buffer) |
|---|
| 688 | (ct:free buffer1))) |
|---|
| 689 | #+gcl (system:getenv x) |
|---|
| 690 | #+genera nil |
|---|
| 691 | #+lispworks (lispworks:environment-variable x) |
|---|
| 692 | #+mcl (ccl:with-cstrs ((name x)) |
|---|
| 693 | (let ((value (_getenv name))) |
|---|
| 694 | (unless (ccl:%null-ptr-p value) |
|---|
| 695 | (ccl:%get-cstring value)))) |
|---|
| 696 | #+sbcl (sb-ext:posix-getenv x) |
|---|
| 697 | #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) |
|---|
| 698 | (error "~S is not supported on your implementation" 'getenv)) |
|---|
| 699 | |
|---|
| 700 | (defun* directory-pathname-p (pathname) |
|---|
| 701 | "Does PATHNAME represent a directory? |
|---|
| 702 | |
|---|
| 703 | A directory-pathname is a pathname _without_ a filename. The three |
|---|
| 704 | ways that the filename components can be missing are for it to be NIL, |
|---|
| 705 | :UNSPECIFIC or the empty string. |
|---|
| 706 | |
|---|
| 707 | Note that this does _not_ check to see that PATHNAME points to an |
|---|
| 708 | actually-existing directory." |
|---|
| 709 | (when pathname |
|---|
| 710 | (let ((pathname (pathname pathname))) |
|---|
| 711 | (flet ((check-one (x) |
|---|
| 712 | (member x '(nil :unspecific "") :test 'equal))) |
|---|
| 713 | (and (not (wild-pathname-p pathname)) |
|---|
| 714 | (check-one (pathname-name pathname)) |
|---|
| 715 | (check-one (pathname-type pathname)) |
|---|
| 716 | t))))) |
|---|
| 717 | |
|---|
| 718 | (defun* ensure-directory-pathname (pathspec) |
|---|
| 719 | "Converts the non-wild pathname designator PATHSPEC to directory form." |
|---|
| 720 | (cond |
|---|
| 721 | ((stringp pathspec) |
|---|
| 722 | (ensure-directory-pathname (pathname pathspec))) |
|---|
| 723 | ((not (pathnamep pathspec)) |
|---|
| 724 | (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec)) |
|---|
| 725 | ((wild-pathname-p pathspec) |
|---|
| 726 | (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec)) |
|---|
| 727 | ((directory-pathname-p pathspec) |
|---|
| 728 | pathspec) |
|---|
| 729 | (t |
|---|
| 730 | (make-pathname :directory (append (or (pathname-directory pathspec) |
|---|
| 731 | (list :relative)) |
|---|
| 732 | (list (file-namestring pathspec))) |
|---|
| 733 | :name nil :type nil :version nil |
|---|
| 734 | :defaults pathspec)))) |
|---|
| 735 | |
|---|
| 736 | #+genera |
|---|
| 737 | (unless (fboundp 'ensure-directories-exist) |
|---|
| 738 | (defun* ensure-directories-exist (path) |
|---|
| 739 | (fs:create-directories-recursively (pathname path)))) |
|---|
| 740 | |
|---|
| 741 | (defun* absolute-pathname-p (pathspec) |
|---|
| 742 | (and (typep pathspec '(or pathname string)) |
|---|
| 743 | (eq :absolute (car (pathname-directory (pathname pathspec)))))) |
|---|
| 744 | |
|---|
| 745 | (defun* length=n-p (x n) ;is it that (= (length x) n) ? |
|---|
| 746 | (check-type n (integer 0 *)) |
|---|
| 747 | (loop |
|---|
| 748 | :for l = x :then (cdr l) |
|---|
| 749 | :for i :downfrom n :do |
|---|
| 750 | (cond |
|---|
| 751 | ((zerop i) (return (null l))) |
|---|
| 752 | ((not (consp l)) (return nil))))) |
|---|
| 753 | |
|---|
| 754 | (defun* ends-with (s suffix) |
|---|
| 755 | (check-type s string) |
|---|
| 756 | (check-type suffix string) |
|---|
| 757 | (let ((start (- (length s) (length suffix)))) |
|---|
| 758 | (and (<= 0 start) |
|---|
| 759 | (string-equal s suffix :start1 start)))) |
|---|
| 760 | |
|---|
| 761 | (defun* read-file-forms (file) |
|---|
| 762 | (with-open-file (in file) |
|---|
| 763 | (loop :with eof = (list nil) |
|---|
| 764 | :for form = (read in nil eof) |
|---|
| 765 | :until (eq form eof) |
|---|
| 766 | :collect form))) |
|---|
| 767 | |
|---|
| 768 | (defun* pathname-root (pathname) |
|---|
| 769 | (make-pathname :directory '(:absolute) |
|---|
| 770 | :name nil :type nil :version nil |
|---|
| 771 | :defaults pathname ;; host device, and on scl, *some* |
|---|
| 772 | ;; scheme-specific parts: port username password, not others: |
|---|
| 773 | . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) |
|---|
| 774 | |
|---|
| 775 | (defun* probe-file* (p) |
|---|
| 776 | "when given a pathname P, probes the filesystem for a file or directory |
|---|
| 777 | with given pathname and if it exists return its truename." |
|---|
| 778 | (etypecase p |
|---|
| 779 | (null nil) |
|---|
| 780 | (string (probe-file* (parse-namestring p))) |
|---|
| 781 | (pathname (unless (wild-pathname-p p) |
|---|
| 782 | #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl) |
|---|
| 783 | '(probe-file p) |
|---|
| 784 | #+clisp (aif (find-symbol* '#:probe-pathname :ext) |
|---|
| 785 | `(ignore-errors (,it p))) |
|---|
| 786 | '(ignore-errors (truename p))))))) |
|---|
| 787 | |
|---|
| 788 | (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) |
|---|
| 789 | "Resolve as much of a pathname as possible" |
|---|
| 790 | (block nil |
|---|
| 791 | (when (typep pathname '(or null logical-pathname)) (return pathname)) |
|---|
| 792 | (let ((p (merge-pathnames* pathname defaults))) |
|---|
| 793 | (when (typep p 'logical-pathname) (return p)) |
|---|
| 794 | (let ((found (probe-file* p))) |
|---|
| 795 | (when found (return found))) |
|---|
| 796 | (unless (absolute-pathname-p p) |
|---|
| 797 | (let ((true-defaults (ignore-errors (truename defaults)))) |
|---|
| 798 | (when true-defaults |
|---|
| 799 | (setf p (merge-pathnames pathname true-defaults))))) |
|---|
| 800 | (unless (absolute-pathname-p p) (return p)) |
|---|
| 801 | (let ((sofar (probe-file* (pathname-root p)))) |
|---|
| 802 | (unless sofar (return p)) |
|---|
| 803 | (flet ((solution (directories) |
|---|
| 804 | (merge-pathnames* |
|---|
| 805 | (make-pathname :host nil :device nil |
|---|
| 806 | :directory `(:relative ,@directories) |
|---|
| 807 | :name (pathname-name p) |
|---|
| 808 | :type (pathname-type p) |
|---|
| 809 | :version (pathname-version p)) |
|---|
| 810 | sofar))) |
|---|
| 811 | (loop :with directory = (normalize-pathname-directory-component |
|---|
| 812 | (pathname-directory p)) |
|---|
| 813 | :for component :in (cdr directory) |
|---|
| 814 | :for rest :on (cdr directory) |
|---|
| 815 | :for more = (probe-file* |
|---|
| 816 | (merge-pathnames* |
|---|
| 817 | (make-pathname :directory `(:relative ,component)) |
|---|
| 818 | sofar)) :do |
|---|
| 819 | (if more |
|---|
| 820 | (setf sofar more) |
|---|
| 821 | (return (solution rest))) |
|---|
| 822 | :finally |
|---|
| 823 | (return (solution nil)))))))) |
|---|
| 824 | |
|---|
| 825 | (defun* resolve-symlinks (path) |
|---|
| 826 | #-allegro (truenamize path) |
|---|
| 827 | #+allegro (if (typep path 'logical-pathname) |
|---|
| 828 | path |
|---|
| 829 | (excl:pathname-resolve-symbolic-links path))) |
|---|
| 830 | |
|---|
| 831 | (defun* resolve-symlinks* (path) |
|---|
| 832 | (if *resolve-symlinks* |
|---|
| 833 | (and path (resolve-symlinks path)) |
|---|
| 834 | path)) |
|---|
| 835 | |
|---|
| 836 | (defun* ensure-pathname-absolute (path) |
|---|
| 837 | (cond |
|---|
| 838 | ((absolute-pathname-p path) path) |
|---|
| 839 | ((stringp path) (ensure-pathname-absolute (pathname path))) |
|---|
| 840 | ((not (pathnamep path)) (error "not a valid pathname designator ~S" path)) |
|---|
| 841 | (t (let ((resolved (resolve-symlinks path))) |
|---|
| 842 | (assert (absolute-pathname-p resolved)) |
|---|
| 843 | resolved)))) |
|---|
| 844 | |
|---|
| 845 | (defun* default-directory () |
|---|
| 846 | (truenamize (pathname-directory-pathname *default-pathname-defaults*))) |
|---|
| 847 | |
|---|
| 848 | (defun* lispize-pathname (input-file) |
|---|
| 849 | (make-pathname :type "lisp" :defaults input-file)) |
|---|
| 850 | |
|---|
| 851 | (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*") |
|---|
| 852 | (defparameter *wild-file* |
|---|
| 853 | (make-pathname :name *wild* :type *wild* |
|---|
| 854 | :version (or #-(or abcl xcl) *wild*) :directory nil)) |
|---|
| 855 | (defparameter *wild-directory* |
|---|
| 856 | (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil)) |
|---|
| 857 | (defparameter *wild-inferiors* |
|---|
| 858 | (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil)) |
|---|
| 859 | (defparameter *wild-path* |
|---|
| 860 | (merge-pathnames *wild-file* *wild-inferiors*)) |
|---|
| 861 | |
|---|
| 862 | (defun* wilden (path) |
|---|
| 863 | (merge-pathnames* *wild-path* path)) |
|---|
| 864 | |
|---|
| 865 | #-scl |
|---|
| 866 | (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) |
|---|
| 867 | (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) |
|---|
| 868 | (last-char (namestring foo)))) |
|---|
| 869 | |
|---|
| 870 | #-scl |
|---|
| 871 | (defun* directorize-pathname-host-device (pathname) |
|---|
| 872 | (let* ((root (pathname-root pathname)) |
|---|
| 873 | (wild-root (wilden root)) |
|---|
| 874 | (absolute-pathname (merge-pathnames* pathname root)) |
|---|
| 875 | (separator (directory-separator-for-host root)) |
|---|
| 876 | (root-namestring (namestring root)) |
|---|
| 877 | (root-string |
|---|
| 878 | (substitute-if #\/ |
|---|
| 879 | #'(lambda (x) (or (eql x #\:) |
|---|
| 880 | (eql x separator))) |
|---|
| 881 | root-namestring))) |
|---|
| 882 | (multiple-value-bind (relative path filename) |
|---|
| 883 | (component-name-to-pathname-components root-string :force-directory t) |
|---|
| 884 | (declare (ignore relative filename)) |
|---|
| 885 | (let ((new-base |
|---|
| 886 | (make-pathname :defaults root |
|---|
| 887 | :directory `(:absolute ,@path)))) |
|---|
| 888 | (translate-pathname absolute-pathname wild-root (wilden new-base)))))) |
|---|
| 889 | |
|---|
| 890 | #+scl |
|---|
| 891 | (defun* directorize-pathname-host-device (pathname) |
|---|
| 892 | (let ((scheme (ext:pathname-scheme pathname)) |
|---|
| 893 | (host (pathname-host pathname)) |
|---|
| 894 | (port (ext:pathname-port pathname)) |
|---|
| 895 | (directory (pathname-directory pathname))) |
|---|
| 896 | (flet ((not-unspecific (component) |
|---|
| 897 | (and (not (eq component :unspecific)) component))) |
|---|
| 898 | (cond ((or (not-unspecific port) |
|---|
| 899 | (and (not-unspecific host) (plusp (length host))) |
|---|
| 900 | (not-unspecific scheme)) |
|---|
| 901 | (let ((prefix "")) |
|---|
| 902 | (when (not-unspecific port) |
|---|
| 903 | (setf prefix (format nil ":~D" port))) |
|---|
| 904 | (when (and (not-unspecific host) (plusp (length host))) |
|---|
| 905 | (setf prefix (concatenate 'string host prefix))) |
|---|
| 906 | (setf prefix (concatenate 'string ":" prefix)) |
|---|
| 907 | (when (not-unspecific scheme) |
|---|
| 908 | (setf prefix (concatenate 'string scheme prefix))) |
|---|
| 909 | (assert (and directory (eq (first directory) :absolute))) |
|---|
| 910 | (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) |
|---|
| 911 | :defaults pathname))) |
|---|
| 912 | (t |
|---|
| 913 | pathname))))) |
|---|
| 914 | |
|---|
| 915 | ;;;; ------------------------------------------------------------------------- |
|---|
| 916 | ;;;; ASDF Interface, in terms of generic functions. |
|---|
| 917 | (defgeneric* find-system (system &optional error-p)) |
|---|
| 918 | (defgeneric* perform-with-restarts (operation component)) |
|---|
| 919 | (defgeneric* perform (operation component)) |
|---|
| 920 | (defgeneric* operation-done-p (operation component)) |
|---|
| 921 | (defgeneric* mark-operation-done (operation component)) |
|---|
| 922 | (defgeneric* explain (operation component)) |
|---|
| 923 | (defgeneric* output-files (operation component)) |
|---|
| 924 | (defgeneric* input-files (operation component)) |
|---|
| 925 | (defgeneric* component-operation-time (operation component)) |
|---|
| 926 | (defgeneric* operation-description (operation component) |
|---|
| 927 | (:documentation "returns a phrase that describes performing this operation |
|---|
| 928 | on this component, e.g. \"loading /a/b/c\". |
|---|
| 929 | You can put together sentences using this phrase.")) |
|---|
| 930 | |
|---|
| 931 | (defgeneric* system-source-file (system) |
|---|
| 932 | (:documentation "Return the source file in which system is defined.")) |
|---|
| 933 | |
|---|
| 934 | (defgeneric* component-system (component) |
|---|
| 935 | (:documentation "Find the top-level system containing COMPONENT")) |
|---|
| 936 | |
|---|
| 937 | (defgeneric* component-pathname (component) |
|---|
| 938 | (:documentation "Extracts the pathname applicable for a particular component.")) |
|---|
| 939 | |
|---|
| 940 | (defgeneric* component-relative-pathname (component) |
|---|
| 941 | (:documentation "Returns a pathname for the component argument intended to be |
|---|
| 942 | interpreted relative to the pathname of that component's parent. |
|---|
| 943 | Despite the function's name, the return value may be an absolute |
|---|
| 944 | pathname, because an absolute pathname may be interpreted relative to |
|---|
| 945 | another pathname in a degenerate way.")) |
|---|
| 946 | |
|---|
| 947 | (defgeneric* component-property (component property)) |
|---|
| 948 | |
|---|
| 949 | (defgeneric* (setf component-property) (new-value component property)) |
|---|
| 950 | |
|---|
| 951 | (eval-when (#-gcl :compile-toplevel :load-toplevel :execute) |
|---|
| 952 | (defgeneric* (setf module-components-by-name) (new-value module))) |
|---|
| 953 | |
|---|
| 954 | (defgeneric* version-satisfies (component version)) |
|---|
| 955 | |
|---|
| 956 | (defgeneric* find-component (base path) |
|---|
| 957 | (:documentation "Finds the component with PATH starting from BASE module; |
|---|
| 958 | if BASE is nil, then the component is assumed to be a system.")) |
|---|
| 959 | |
|---|
| 960 | (defgeneric* source-file-type (component system)) |
|---|
| 961 | |
|---|
| 962 | (defgeneric* operation-ancestor (operation) |
|---|
| 963 | (:documentation |
|---|
| 964 | "Recursively chase the operation's parent pointer until we get to |
|---|
| 965 | the head of the tree")) |
|---|
| 966 | |
|---|
| 967 | (defgeneric* component-visited-p (operation component) |
|---|
| 968 | (:documentation "Returns the value stored by a call to |
|---|
| 969 | VISIT-COMPONENT, if that has been called, otherwise NIL. |
|---|
| 970 | This value stored will be a cons cell, the first element |
|---|
| 971 | of which is a computed key, so not interesting. The |
|---|
| 972 | CDR wil be the DATA value stored by VISIT-COMPONENT; recover |
|---|
| 973 | it as (cdr (component-visited-p op c)). |
|---|
| 974 | In the current form of ASDF, the DATA value retrieved is |
|---|
| 975 | effectively a boolean, indicating whether some operations are |
|---|
| 976 | to be performed in order to do OPERATION X COMPONENT. If the |
|---|
| 977 | data value is NIL, the combination had been explored, but no |
|---|
| 978 | operations needed to be performed.")) |
|---|
| 979 | |
|---|
| 980 | (defgeneric* visit-component (operation component data) |
|---|
| 981 | (:documentation "Record DATA as being associated with OPERATION |
|---|
| 982 | and COMPONENT. This is a side-effecting function: the association |
|---|
| 983 | will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the |
|---|
| 984 | OPERATION\). |
|---|
| 985 | No evidence that DATA is ever interesting, beyond just being |
|---|
| 986 | non-NIL. Using the data field is probably very risky; if there is |
|---|
| 987 | already a record for OPERATION X COMPONENT, DATA will be quietly |
|---|
| 988 | discarded instead of recorded. |
|---|
| 989 | Starting with 2.006, TRAVERSE will store an integer in data, |
|---|
| 990 | so that nodes can be sorted in decreasing order of traversal.")) |
|---|
| 991 | |
|---|
| 992 | |
|---|
| 993 | (defgeneric* (setf visiting-component) (new-value operation component)) |
|---|
| 994 | |
|---|
| 995 | (defgeneric* component-visiting-p (operation component)) |
|---|
| 996 | |
|---|
| 997 | (defgeneric* component-depends-on (operation component) |
|---|
| 998 | (:documentation |
|---|
| 999 | "Returns a list of dependencies needed by the component to perform |
|---|
| 1000 | the operation. A dependency has one of the following forms: |
|---|
| 1001 | |
|---|
| 1002 | (<operation> <component>*), where <operation> is a class |
|---|
| 1003 | designator and each <component> is a component |
|---|
| 1004 | designator, which means that the component depends on |
|---|
| 1005 | <operation> having been performed on each <component>; or |
|---|
| 1006 | |
|---|
| 1007 | (FEATURE <feature>), which means that the component depends |
|---|
| 1008 | on <feature>'s presence in *FEATURES*. |
|---|
| 1009 | |
|---|
| 1010 | Methods specialized on subclasses of existing component types |
|---|
| 1011 | should usually append the results of CALL-NEXT-METHOD to the |
|---|
| 1012 | list.")) |
|---|
| 1013 | |
|---|
| 1014 | (defgeneric* component-self-dependencies (operation component)) |
|---|
| 1015 | |
|---|
| 1016 | (defgeneric* traverse (operation component) |
|---|
| 1017 | (:documentation |
|---|
| 1018 | "Generate and return a plan for performing OPERATION on COMPONENT. |
|---|
| 1019 | |
|---|
| 1020 | The plan returned is a list of dotted-pairs. Each pair is the CONS |
|---|
| 1021 | of ASDF operation object and a COMPONENT object. The pairs will be |
|---|
| 1022 | processed in order by OPERATE.")) |
|---|
| 1023 | |
|---|
| 1024 | |
|---|
| 1025 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1026 | ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 |
|---|
| 1027 | (when *upgraded-p* |
|---|
| 1028 | (when (find-class 'module nil) |
|---|
| 1029 | (eval |
|---|
| 1030 | '(defmethod update-instance-for-redefined-class :after |
|---|
| 1031 | ((m module) added deleted plist &key) |
|---|
| 1032 | (declare (ignorable deleted plist)) |
|---|
| 1033 | (when *asdf-verbose* |
|---|
| 1034 | (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%") |
|---|
| 1035 | m (asdf-version))) |
|---|
| 1036 | (when (member 'components-by-name added) |
|---|
| 1037 | (compute-module-components-by-name m)) |
|---|
| 1038 | (when (typep m 'system) |
|---|
| 1039 | (when (member 'source-file added) |
|---|
| 1040 | (%set-system-source-file |
|---|
| 1041 | (probe-asd (component-name m) (component-pathname m)) m) |
|---|
| 1042 | (when (equal (component-name m) "asdf") |
|---|
| 1043 | (setf (component-version m) *asdf-version*)))))))) |
|---|
| 1044 | |
|---|
| 1045 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1046 | ;;;; Classes, Conditions |
|---|
| 1047 | |
|---|
| 1048 | (define-condition system-definition-error (error) () |
|---|
| 1049 | ;; [this use of :report should be redundant, but unfortunately it's not. |
|---|
| 1050 | ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function |
|---|
| 1051 | ;; over print-object; this is always conditions::%print-condition for |
|---|
| 1052 | ;; condition objects, which in turn does inheritance of :report options at |
|---|
| 1053 | ;; run-time. fortunately, inheritance means we only need this kludge here in |
|---|
| 1054 | ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] |
|---|
| 1055 | #+cmu (:report print-object)) |
|---|
| 1056 | |
|---|
| 1057 | (define-condition formatted-system-definition-error (system-definition-error) |
|---|
| 1058 | ((format-control :initarg :format-control :reader format-control) |
|---|
| 1059 | (format-arguments :initarg :format-arguments :reader format-arguments)) |
|---|
| 1060 | (:report (lambda (c s) |
|---|
| 1061 | (apply 'format s (format-control c) (format-arguments c))))) |
|---|
| 1062 | |
|---|
| 1063 | (define-condition load-system-definition-error (system-definition-error) |
|---|
| 1064 | ((name :initarg :name :reader error-name) |
|---|
| 1065 | (pathname :initarg :pathname :reader error-pathname) |
|---|
| 1066 | (condition :initarg :condition :reader error-condition)) |
|---|
| 1067 | (:report (lambda (c s) |
|---|
| 1068 | (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>") |
|---|
| 1069 | (error-name c) (error-pathname c) (error-condition c))))) |
|---|
| 1070 | |
|---|
| 1071 | (define-condition circular-dependency (system-definition-error) |
|---|
| 1072 | ((components :initarg :components :reader circular-dependency-components)) |
|---|
| 1073 | (:report (lambda (c s) |
|---|
| 1074 | (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>") |
|---|
| 1075 | (circular-dependency-components c))))) |
|---|
| 1076 | |
|---|
| 1077 | (define-condition duplicate-names (system-definition-error) |
|---|
| 1078 | ((name :initarg :name :reader duplicate-names-name)) |
|---|
| 1079 | (:report (lambda (c s) |
|---|
| 1080 | (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>") |
|---|
| 1081 | (duplicate-names-name c))))) |
|---|
| 1082 | |
|---|
| 1083 | (define-condition missing-component (system-definition-error) |
|---|
| 1084 | ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) |
|---|
| 1085 | (parent :initform nil :reader missing-parent :initarg :parent))) |
|---|
| 1086 | |
|---|
| 1087 | (define-condition missing-component-of-version (missing-component) |
|---|
| 1088 | ((version :initform nil :reader missing-version :initarg :version))) |
|---|
| 1089 | |
|---|
| 1090 | (define-condition missing-dependency (missing-component) |
|---|
| 1091 | ((required-by :initarg :required-by :reader missing-required-by))) |
|---|
| 1092 | |
|---|
| 1093 | (define-condition missing-dependency-of-version (missing-dependency |
|---|
| 1094 | missing-component-of-version) |
|---|
| 1095 | ()) |
|---|
| 1096 | |
|---|
| 1097 | (define-condition operation-error (error) |
|---|
| 1098 | ((component :reader error-component :initarg :component) |
|---|
| 1099 | (operation :reader error-operation :initarg :operation)) |
|---|
| 1100 | (:report (lambda (c s) |
|---|
| 1101 | (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>") |
|---|
| 1102 | (error-operation c) (error-component c))))) |
|---|
| 1103 | (define-condition compile-error (operation-error) ()) |
|---|
| 1104 | (define-condition compile-failed (compile-error) ()) |
|---|
| 1105 | (define-condition compile-warned (compile-error) ()) |
|---|
| 1106 | |
|---|
| 1107 | (define-condition invalid-configuration () |
|---|
| 1108 | ((form :reader condition-form :initarg :form) |
|---|
| 1109 | (location :reader condition-location :initarg :location) |
|---|
| 1110 | (format :reader condition-format :initarg :format) |
|---|
| 1111 | (arguments :reader condition-arguments :initarg :arguments :initform nil)) |
|---|
| 1112 | (:report (lambda (c s) |
|---|
| 1113 | (format s (compatfmt "~@<~? (will be skipped)~@:>") |
|---|
| 1114 | (condition-format c) |
|---|
| 1115 | (list* (condition-form c) (condition-location c) |
|---|
| 1116 | (condition-arguments c)))))) |
|---|
| 1117 | (define-condition invalid-source-registry (invalid-configuration warning) |
|---|
| 1118 | ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) |
|---|
| 1119 | (define-condition invalid-output-translation (invalid-configuration warning) |
|---|
| 1120 | ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) |
|---|
| 1121 | |
|---|
| 1122 | (defclass component () |
|---|
| 1123 | ((name :accessor component-name :initarg :name :type string :documentation |
|---|
| 1124 | "Component name: designator for a string composed of portable pathname characters") |
|---|
| 1125 | ;; We might want to constrain version with |
|---|
| 1126 | ;; :type (and string (satisfies parse-version)) |
|---|
| 1127 | ;; but we cannot until we fix all systems that don't use it correctly! |
|---|
| 1128 | (version :accessor component-version :initarg :version) |
|---|
| 1129 | (description :accessor component-description :initarg :description) |
|---|
| 1130 | (long-description :accessor component-long-description :initarg :long-description) |
|---|
| 1131 | ;; This one below is used by POIU - http://www.cliki.net/poiu |
|---|
| 1132 | ;; a parallelizing extension of ASDF that compiles in multiple parallel |
|---|
| 1133 | ;; slave processes (forked on demand) and loads in the master process. |
|---|
| 1134 | ;; Maybe in the future ASDF may use it internally instead of in-order-to. |
|---|
| 1135 | (load-dependencies :accessor component-load-dependencies :initform nil) |
|---|
| 1136 | ;; In the ASDF object model, dependencies exist between *actions* |
|---|
| 1137 | ;; (an action is a pair of operation and component). They are represented |
|---|
| 1138 | ;; alists of operations to dependencies (other actions) in each component. |
|---|
| 1139 | ;; There are two kinds of dependencies, each stored in its own slot: |
|---|
| 1140 | ;; in-order-to and do-first dependencies. These two kinds are related to |
|---|
| 1141 | ;; the fact that some actions modify the filesystem, |
|---|
| 1142 | ;; whereas other actions modify the current image, and |
|---|
| 1143 | ;; this implies a difference in how to interpret timestamps. |
|---|
| 1144 | ;; in-order-to dependencies will trigger re-performing the action |
|---|
| 1145 | ;; when the timestamp of some dependency |
|---|
| 1146 | ;; makes the timestamp of current action out-of-date; |
|---|
| 1147 | ;; do-first dependencies do not trigger such re-performing. |
|---|
| 1148 | ;; Therefore, a FASL must be recompiled if it is obsoleted |
|---|
| 1149 | ;; by any of its FASL dependencies (in-order-to); but |
|---|
| 1150 | ;; it needn't be recompiled just because one of these dependencies |
|---|
| 1151 | ;; hasn't yet been loaded in the current image (do-first). |
|---|
| 1152 | ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! |
|---|
| 1153 | ;; See our ASDF 2 paper for more complete explanations. |
|---|
| 1154 | (in-order-to :initform nil :initarg :in-order-to |
|---|
| 1155 | :accessor component-in-order-to) |
|---|
| 1156 | (do-first :initform nil :initarg :do-first |
|---|
| 1157 | :accessor component-do-first) |
|---|
| 1158 | ;; methods defined using the "inline" style inside a defsystem form: |
|---|
| 1159 | ;; need to store them somewhere so we can delete them when the system |
|---|
| 1160 | ;; is re-evaluated |
|---|
| 1161 | (inline-methods :accessor component-inline-methods :initform nil) |
|---|
| 1162 | (parent :initarg :parent :initform nil :reader component-parent) |
|---|
| 1163 | ;; no direct accessor for pathname, we do this as a method to allow |
|---|
| 1164 | ;; it to default in funky ways if not supplied |
|---|
| 1165 | (relative-pathname :initarg :pathname) |
|---|
| 1166 | ;; the absolute-pathname is computed based on relative-pathname... |
|---|
| 1167 | (absolute-pathname) |
|---|
| 1168 | (operation-times :initform (make-hash-table) |
|---|
| 1169 | :accessor component-operation-times) |
|---|
| 1170 | (around-compile :initarg :around-compile) |
|---|
| 1171 | ;; XXX we should provide some atomic interface for updating the |
|---|
| 1172 | ;; component properties |
|---|
| 1173 | (properties :accessor component-properties :initarg :properties |
|---|
| 1174 | :initform nil))) |
|---|
| 1175 | |
|---|
| 1176 | ;;; I believe that the following could probably be more efficiently done |
|---|
| 1177 | ;;; by a primary method that invokes SHARED-INITIALIZE in a way that would |
|---|
| 1178 | ;;; appropriately pass the slots to have their initforms re-applied, but I |
|---|
| 1179 | ;;; do not know how to write such a method. [2011/09/02:rpg] |
|---|
| 1180 | (defmethod reinitialize-instance :after ((obj component) &rest initargs |
|---|
| 1181 | &key (version nil version-suppliedp) |
|---|
| 1182 | (description nil description-suppliedp) |
|---|
| 1183 | (long-description nil |
|---|
| 1184 | long-description-suppliedp) |
|---|
| 1185 | (load-dependencies nil |
|---|
| 1186 | ld-suppliedp) |
|---|
| 1187 | in-order-to |
|---|
| 1188 | do-first |
|---|
| 1189 | inline-methods |
|---|
| 1190 | parent |
|---|
| 1191 | properties) |
|---|
| 1192 | "We reuse component objects from previously-existing systems, so we need to |
|---|
| 1193 | make sure we clear them thoroughly." |
|---|
| 1194 | (declare (ignore initargs load-dependencies |
|---|
| 1195 | long-description description version)) |
|---|
| 1196 | ;; this is a cache and should be cleared |
|---|
| 1197 | (slot-makunbound obj 'absolute-pathname) |
|---|
| 1198 | ;; component operation times are no longer valid when the component changes |
|---|
| 1199 | (clrhash (component-operation-times obj)) |
|---|
| 1200 | (unless version-suppliedp (slot-makunbound obj 'version)) |
|---|
| 1201 | (unless description-suppliedp |
|---|
| 1202 | (slot-makunbound obj 'description)) |
|---|
| 1203 | (unless long-description-suppliedp |
|---|
| 1204 | (slot-makunbound obj 'long-description)) |
|---|
| 1205 | ;; replicate the logic of the initforms... |
|---|
| 1206 | (unless ld-suppliedp |
|---|
| 1207 | (setf (component-load-dependencies obj) nil)) |
|---|
| 1208 | (setf (component-in-order-to obj) in-order-to |
|---|
| 1209 | (component-do-first obj) do-first |
|---|
| 1210 | (component-inline-methods obj) inline-methods |
|---|
| 1211 | (slot-value obj 'parent) parent |
|---|
| 1212 | (slot-value obj 'properties) properties)) |
|---|
| 1213 | |
|---|
| 1214 | |
|---|
| 1215 | (defun* component-find-path (component) |
|---|
| 1216 | (reverse |
|---|
| 1217 | (loop :for c = component :then (component-parent c) |
|---|
| 1218 | :while c :collect (component-name c)))) |
|---|
| 1219 | |
|---|
| 1220 | (defmethod print-object ((c component) stream) |
|---|
| 1221 | (print-unreadable-object (c stream :type t :identity nil) |
|---|
| 1222 | (format stream "~{~S~^ ~}" (component-find-path c)))) |
|---|
| 1223 | |
|---|
| 1224 | |
|---|
| 1225 | ;;;; methods: conditions |
|---|
| 1226 | |
|---|
| 1227 | (defmethod print-object ((c missing-dependency) s) |
|---|
| 1228 | (format s (compatfmt "~@<~A, required by ~A~@:>") |
|---|
| 1229 | (call-next-method c nil) (missing-required-by c))) |
|---|
| 1230 | |
|---|
| 1231 | (defun* sysdef-error (format &rest arguments) |
|---|
| 1232 | (error 'formatted-system-definition-error :format-control |
|---|
| 1233 | format :format-arguments arguments)) |
|---|
| 1234 | |
|---|
| 1235 | ;;;; methods: components |
|---|
| 1236 | |
|---|
| 1237 | (defmethod print-object ((c missing-component) s) |
|---|
| 1238 | (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>") |
|---|
| 1239 | (missing-requires c) |
|---|
| 1240 | (when (missing-parent c) |
|---|
| 1241 | (coerce-name (missing-parent c))))) |
|---|
| 1242 | |
|---|
| 1243 | (defmethod print-object ((c missing-component-of-version) s) |
|---|
| 1244 | (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>") |
|---|
| 1245 | (missing-requires c) |
|---|
| 1246 | (missing-version c) |
|---|
| 1247 | (when (missing-parent c) |
|---|
| 1248 | (coerce-name (missing-parent c))))) |
|---|
| 1249 | |
|---|
| 1250 | (defmethod component-system ((component component)) |
|---|
| 1251 | (aif (component-parent component) |
|---|
| 1252 | (component-system it) |
|---|
| 1253 | component)) |
|---|
| 1254 | |
|---|
| 1255 | (defvar *default-component-class* 'cl-source-file) |
|---|
| 1256 | |
|---|
| 1257 | (defun* compute-module-components-by-name (module) |
|---|
| 1258 | (let ((hash (make-hash-table :test 'equal))) |
|---|
| 1259 | (setf (module-components-by-name module) hash) |
|---|
| 1260 | (loop :for c :in (module-components module) |
|---|
| 1261 | :for name = (component-name c) |
|---|
| 1262 | :for previous = (gethash name (module-components-by-name module)) |
|---|
| 1263 | :do |
|---|
| 1264 | (when previous |
|---|
| 1265 | (error 'duplicate-names :name name)) |
|---|
| 1266 | :do (setf (gethash name (module-components-by-name module)) c)) |
|---|
| 1267 | hash)) |
|---|
| 1268 | |
|---|
| 1269 | (defclass module (component) |
|---|
| 1270 | ((components |
|---|
| 1271 | :initform nil |
|---|
| 1272 | :initarg :components |
|---|
| 1273 | :accessor module-components) |
|---|
| 1274 | (components-by-name |
|---|
| 1275 | :accessor module-components-by-name) |
|---|
| 1276 | ;; What to do if we can't satisfy a dependency of one of this module's |
|---|
| 1277 | ;; components. This allows a limited form of conditional processing. |
|---|
| 1278 | (if-component-dep-fails |
|---|
| 1279 | :initform :fail |
|---|
| 1280 | :initarg :if-component-dep-fails |
|---|
| 1281 | :accessor module-if-component-dep-fails) |
|---|
| 1282 | (default-component-class |
|---|
| 1283 | :initform *default-component-class* |
|---|
| 1284 | :initarg :default-component-class |
|---|
| 1285 | :accessor module-default-component-class))) |
|---|
| 1286 | |
|---|
| 1287 | ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT |
|---|
| 1288 | ;;; [2011/09/02:rpg] |
|---|
| 1289 | (defmethod reinitialize-instance :after ((obj module) &rest initargs &key) |
|---|
| 1290 | "Clear MODULE's slots so it can be reused." |
|---|
| 1291 | (slot-makunbound obj 'components-by-name) |
|---|
| 1292 | ;; this may be a more elegant approach than in the |
|---|
| 1293 | ;; COMPONENT method [2011/09/02:rpg] |
|---|
| 1294 | (loop :for (initarg slot-name default) :in |
|---|
| 1295 | `((:components components nil) |
|---|
| 1296 | (:if-component-dep-fails if-component-dep-fails :fail) |
|---|
| 1297 | (:default-component-class default-component-class |
|---|
| 1298 | ,*default-component-class*)) |
|---|
| 1299 | :unless (member initarg initargs) |
|---|
| 1300 | :do (setf (slot-value obj slot-name) default))) |
|---|
| 1301 | |
|---|
| 1302 | (defun* component-parent-pathname (component) |
|---|
| 1303 | ;; No default anymore (in particular, no *default-pathname-defaults*). |
|---|
| 1304 | ;; If you force component to have a NULL pathname, you better arrange |
|---|
| 1305 | ;; for any of its children to explicitly provide a proper absolute pathname |
|---|
| 1306 | ;; wherever a pathname is actually wanted. |
|---|
| 1307 | (let ((parent (component-parent component))) |
|---|
| 1308 | (when parent |
|---|
| 1309 | (component-pathname parent)))) |
|---|
| 1310 | |
|---|
| 1311 | (defmethod component-pathname ((component component)) |
|---|
| 1312 | (if (slot-boundp component 'absolute-pathname) |
|---|
| 1313 | (slot-value component 'absolute-pathname) |
|---|
| 1314 | (let ((pathname |
|---|
| 1315 | (merge-pathnames* |
|---|
| 1316 | (component-relative-pathname component) |
|---|
| 1317 | (pathname-directory-pathname (component-parent-pathname component))))) |
|---|
| 1318 | (unless (or (null pathname) (absolute-pathname-p pathname)) |
|---|
| 1319 | (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>") |
|---|
| 1320 | pathname (component-find-path component))) |
|---|
| 1321 | (setf (slot-value component 'absolute-pathname) pathname) |
|---|
| 1322 | pathname))) |
|---|
| 1323 | |
|---|
| 1324 | (defmethod component-property ((c component) property) |
|---|
| 1325 | (cdr (assoc property (slot-value c 'properties) :test #'equal))) |
|---|
| 1326 | |
|---|
| 1327 | (defmethod (setf component-property) (new-value (c component) property) |
|---|
| 1328 | (let ((a (assoc property (slot-value c 'properties) :test #'equal))) |
|---|
| 1329 | (if a |
|---|
| 1330 | (setf (cdr a) new-value) |
|---|
| 1331 | (setf (slot-value c 'properties) |
|---|
| 1332 | (acons property new-value (slot-value c 'properties))))) |
|---|
| 1333 | new-value) |
|---|
| 1334 | |
|---|
| 1335 | (defclass system (module) |
|---|
| 1336 | (;; description and long-description are now available for all component's, |
|---|
| 1337 | ;; but now also inherited from component, but we add the legacy accessor |
|---|
| 1338 | (description :accessor system-description :initarg :description) |
|---|
| 1339 | (long-description :accessor system-long-description :initarg :long-description) |
|---|
| 1340 | (author :accessor system-author :initarg :author) |
|---|
| 1341 | (maintainer :accessor system-maintainer :initarg :maintainer) |
|---|
| 1342 | (licence :accessor system-licence :initarg :licence |
|---|
| 1343 | :accessor system-license :initarg :license) |
|---|
| 1344 | (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade |
|---|
| 1345 | :writer %set-system-source-file) |
|---|
| 1346 | (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) |
|---|
| 1347 | |
|---|
| 1348 | ;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT |
|---|
| 1349 | ;;; [2011/09/02:rpg] |
|---|
| 1350 | (defmethod reinitialize-instance :after ((obj system) &rest initargs &key) |
|---|
| 1351 | "Clear SYSTEM's slots so it can be reused." |
|---|
| 1352 | ;; note that SYSTEM-SOURCE-FILE is very specially handled, |
|---|
| 1353 | ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and |
|---|
| 1354 | ;; not squash it. SYSTEM COMPONENTS are handled very specially, |
|---|
| 1355 | ;; because they are always, effectively, reused, since the system component |
|---|
| 1356 | ;; is made early in DO-DEFSYSTEM, instead of being made later, in |
|---|
| 1357 | ;; PARSE-COMPONENT-FORM [2011/09/02:rpg] |
|---|
| 1358 | (loop :for (initarg slot-name) :in |
|---|
| 1359 | `((:author author) |
|---|
| 1360 | (:maintainer maintainer) |
|---|
| 1361 | (:licence licence) |
|---|
| 1362 | (:defsystem-depends-on defsystem-depends-on)) |
|---|
| 1363 | :unless (member initarg initargs) |
|---|
| 1364 | :do (slot-makunbound obj slot-name))) |
|---|
| 1365 | |
|---|
| 1366 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1367 | ;;;; version-satisfies |
|---|
| 1368 | |
|---|
| 1369 | (defmethod version-satisfies ((c component) version) |
|---|
| 1370 | (unless (and version (slot-boundp c 'version)) |
|---|
| 1371 | (when version |
|---|
| 1372 | (warn "Requested version ~S but component ~S has no version" version c)) |
|---|
| 1373 | (return-from version-satisfies t)) |
|---|
| 1374 | (version-satisfies (component-version c) version)) |
|---|
| 1375 | |
|---|
| 1376 | (defun* asdf-version () |
|---|
| 1377 | "Exported interface to the version of ASDF currently installed. A string. |
|---|
| 1378 | You can compare this string with e.g.: |
|---|
| 1379 | (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." |
|---|
| 1380 | *asdf-version*) |
|---|
| 1381 | |
|---|
| 1382 | (defun* parse-version (string &optional on-error) |
|---|
| 1383 | "Parse a version string as a series of natural integers separated by dots. |
|---|
| 1384 | Return a (non-null) list of integers if the string is valid, NIL otherwise. |
|---|
| 1385 | If on-error is error, warn, or designates a function of compatible signature, |
|---|
| 1386 | the function is called with an explanation of what is wrong with the argument. |
|---|
| 1387 | NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" |
|---|
| 1388 | (and |
|---|
| 1389 | (or (stringp string) |
|---|
| 1390 | (when on-error |
|---|
| 1391 | (funcall on-error "~S: ~S is not a string" |
|---|
| 1392 | 'parse-version string)) nil) |
|---|
| 1393 | (or (loop :for prev = nil :then c :for c :across string |
|---|
| 1394 | :always (or (digit-char-p c) |
|---|
| 1395 | (and (eql c #\.) prev (not (eql prev #\.)))) |
|---|
| 1396 | :finally (return (and c (digit-char-p c)))) |
|---|
| 1397 | (when on-error |
|---|
| 1398 | (funcall on-error "~S: ~S doesn't follow asdf version numbering convention" |
|---|
| 1399 | 'parse-version string)) nil) |
|---|
| 1400 | (mapcar #'parse-integer (split-string string :separator ".")))) |
|---|
| 1401 | |
|---|
| 1402 | (defmethod version-satisfies ((cver string) version) |
|---|
| 1403 | (let ((x (parse-version cver 'warn)) |
|---|
| 1404 | (y (parse-version version 'warn))) |
|---|
| 1405 | (labels ((bigger (x y) |
|---|
| 1406 | (cond ((not y) t) |
|---|
| 1407 | ((not x) nil) |
|---|
| 1408 | ((> (car x) (car y)) t) |
|---|
| 1409 | ((= (car x) (car y)) |
|---|
| 1410 | (bigger (cdr x) (cdr y)))))) |
|---|
| 1411 | (and x y (= (car x) (car y)) |
|---|
| 1412 | (or (not (cdr y)) (bigger (cdr x) (cdr y))))))) |
|---|
| 1413 | |
|---|
| 1414 | ;;;; ----------------------------------------------------------------- |
|---|
| 1415 | ;;;; Windows shortcut support. Based on: |
|---|
| 1416 | ;;;; |
|---|
| 1417 | ;;;; Jesse Hager: The Windows Shortcut File Format. |
|---|
| 1418 | ;;;; http://www.wotsit.org/list.asp?fc=13 |
|---|
| 1419 | |
|---|
| 1420 | #-clisp |
|---|
| 1421 | (progn |
|---|
| 1422 | (defparameter *link-initial-dword* 76) |
|---|
| 1423 | (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) |
|---|
| 1424 | |
|---|
| 1425 | (defun* read-null-terminated-string (s) |
|---|
| 1426 | (with-output-to-string (out) |
|---|
| 1427 | (loop :for code = (read-byte s) |
|---|
| 1428 | :until (zerop code) |
|---|
| 1429 | :do (write-char (code-char code) out)))) |
|---|
| 1430 | |
|---|
| 1431 | (defun* read-little-endian (s &optional (bytes 4)) |
|---|
| 1432 | (loop :for i :from 0 :below bytes |
|---|
| 1433 | :sum (ash (read-byte s) (* 8 i)))) |
|---|
| 1434 | |
|---|
| 1435 | (defun* parse-file-location-info (s) |
|---|
| 1436 | (let ((start (file-position s)) |
|---|
| 1437 | (total-length (read-little-endian s)) |
|---|
| 1438 | (end-of-header (read-little-endian s)) |
|---|
| 1439 | (fli-flags (read-little-endian s)) |
|---|
| 1440 | (local-volume-offset (read-little-endian s)) |
|---|
| 1441 | (local-offset (read-little-endian s)) |
|---|
| 1442 | (network-volume-offset (read-little-endian s)) |
|---|
| 1443 | (remaining-offset (read-little-endian s))) |
|---|
| 1444 | (declare (ignore total-length end-of-header local-volume-offset)) |
|---|
| 1445 | (unless (zerop fli-flags) |
|---|
| 1446 | (cond |
|---|
| 1447 | ((logbitp 0 fli-flags) |
|---|
| 1448 | (file-position s (+ start local-offset))) |
|---|
| 1449 | ((logbitp 1 fli-flags) |
|---|
| 1450 | (file-position s (+ start |
|---|
| 1451 | network-volume-offset |
|---|
| 1452 | #x14)))) |
|---|
| 1453 | (concatenate 'string |
|---|
| 1454 | (read-null-terminated-string s) |
|---|
| 1455 | (progn |
|---|
| 1456 | (file-position s (+ start remaining-offset)) |
|---|
| 1457 | (read-null-terminated-string s)))))) |
|---|
| 1458 | |
|---|
| 1459 | (defun* parse-windows-shortcut (pathname) |
|---|
| 1460 | (with-open-file (s pathname :element-type '(unsigned-byte 8)) |
|---|
| 1461 | (handler-case |
|---|
| 1462 | (when (and (= (read-little-endian s) *link-initial-dword*) |
|---|
| 1463 | (let ((header (make-array (length *link-guid*)))) |
|---|
| 1464 | (read-sequence header s) |
|---|
| 1465 | (equalp header *link-guid*))) |
|---|
| 1466 | (let ((flags (read-little-endian s))) |
|---|
| 1467 | (file-position s 76) ;skip rest of header |
|---|
| 1468 | (when (logbitp 0 flags) |
|---|
| 1469 | ;; skip shell item id list |
|---|
| 1470 | (let ((length (read-little-endian s 2))) |
|---|
| 1471 | (file-position s (+ length (file-position s))))) |
|---|
| 1472 | (cond |
|---|
| 1473 | ((logbitp 1 flags) |
|---|
| 1474 | (parse-file-location-info s)) |
|---|
| 1475 | (t |
|---|
| 1476 | (when (logbitp 2 flags) |
|---|
| 1477 | ;; skip description string |
|---|
| 1478 | (let ((length (read-little-endian s 2))) |
|---|
| 1479 | (file-position s (+ length (file-position s))))) |
|---|
| 1480 | (when (logbitp 3 flags) |
|---|
| 1481 | ;; finally, our pathname |
|---|
| 1482 | (let* ((length (read-little-endian s 2)) |
|---|
| 1483 | (buffer (make-array length))) |
|---|
| 1484 | (read-sequence buffer s) |
|---|
| 1485 | (map 'string #'code-char buffer))))))) |
|---|
| 1486 | (end-of-file () |
|---|
| 1487 | nil))))) |
|---|
| 1488 | |
|---|
| 1489 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1490 | ;;;; Finding systems |
|---|
| 1491 | |
|---|
| 1492 | (defun* make-defined-systems-table () |
|---|
| 1493 | (make-hash-table :test 'equal)) |
|---|
| 1494 | |
|---|
| 1495 | (defvar *defined-systems* (make-defined-systems-table) |
|---|
| 1496 | "This is a hash table whose keys are strings, being the |
|---|
| 1497 | names of the systems, and whose values are pairs, the first |
|---|
| 1498 | element of which is a universal-time indicating when the |
|---|
| 1499 | system definition was last updated, and the second element |
|---|
| 1500 | of which is a system object.") |
|---|
| 1501 | |
|---|
| 1502 | (defun* coerce-name (name) |
|---|
| 1503 | (typecase name |
|---|
| 1504 | (component (component-name name)) |
|---|
| 1505 | (symbol (string-downcase (symbol-name name))) |
|---|
| 1506 | (string name) |
|---|
| 1507 | (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) |
|---|
| 1508 | |
|---|
| 1509 | (defun* system-registered-p (name) |
|---|
| 1510 | (gethash (coerce-name name) *defined-systems*)) |
|---|
| 1511 | |
|---|
| 1512 | (defun* register-system (system) |
|---|
| 1513 | (check-type system system) |
|---|
| 1514 | (let ((name (component-name system))) |
|---|
| 1515 | (check-type name string) |
|---|
| 1516 | (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system) |
|---|
| 1517 | (unless (eq system (cdr (gethash name *defined-systems*))) |
|---|
| 1518 | (setf (gethash name *defined-systems*) |
|---|
| 1519 | (cons (get-universal-time) system))))) |
|---|
| 1520 | |
|---|
| 1521 | (defun* clear-system (name) |
|---|
| 1522 | "Clear the entry for a system in the database of systems previously loaded. |
|---|
| 1523 | Note that this does NOT in any way cause the code of the system to be unloaded." |
|---|
| 1524 | ;; There is no "unload" operation in Common Lisp, and |
|---|
| 1525 | ;; a general such operation cannot be portably written, |
|---|
| 1526 | ;; considering how much CL relies on side-effects to global data structures. |
|---|
| 1527 | (remhash (coerce-name name) *defined-systems*)) |
|---|
| 1528 | |
|---|
| 1529 | (defun* map-systems (fn) |
|---|
| 1530 | "Apply FN to each defined system. |
|---|
| 1531 | |
|---|
| 1532 | FN should be a function of one argument. It will be |
|---|
| 1533 | called with an object of type asdf:system." |
|---|
| 1534 | (maphash #'(lambda (_ datum) |
|---|
| 1535 | (declare (ignore _)) |
|---|
| 1536 | (destructuring-bind (_ . def) datum |
|---|
| 1537 | (declare (ignore _)) |
|---|
| 1538 | (funcall fn def))) |
|---|
| 1539 | *defined-systems*)) |
|---|
| 1540 | |
|---|
| 1541 | ;;; for the sake of keeping things reasonably neat, we adopt a |
|---|
| 1542 | ;;; convention that functions in this list are prefixed SYSDEF- |
|---|
| 1543 | |
|---|
| 1544 | (defparameter *system-definition-search-functions* |
|---|
| 1545 | '(sysdef-central-registry-search |
|---|
| 1546 | sysdef-source-registry-search |
|---|
| 1547 | sysdef-find-asdf)) |
|---|
| 1548 | |
|---|
| 1549 | (defun* search-for-system-definition (system) |
|---|
| 1550 | (let ((system-name (coerce-name system))) |
|---|
| 1551 | (some #'(lambda (x) (funcall x system-name)) |
|---|
| 1552 | (cons 'find-system-if-being-defined *system-definition-search-functions*)))) |
|---|
| 1553 | |
|---|
| 1554 | (defvar *central-registry* nil |
|---|
| 1555 | "A list of 'system directory designators' ASDF uses to find systems. |
|---|
| 1556 | |
|---|
| 1557 | A 'system directory designator' is a pathname or an expression |
|---|
| 1558 | which evaluates to a pathname. For example: |
|---|
| 1559 | |
|---|
| 1560 | (setf asdf:*central-registry* |
|---|
| 1561 | (list '*default-pathname-defaults* |
|---|
| 1562 | #p\"/home/me/cl/systems/\" |
|---|
| 1563 | #p\"/usr/share/common-lisp/systems/\")) |
|---|
| 1564 | |
|---|
| 1565 | This is for backward compatibilily. |
|---|
| 1566 | Going forward, we recommend new users should be using the source-registry. |
|---|
| 1567 | ") |
|---|
| 1568 | |
|---|
| 1569 | (defun* featurep (x &optional (features *features*)) |
|---|
| 1570 | (cond |
|---|
| 1571 | ((atom x) |
|---|
| 1572 | (and (member x features) t)) |
|---|
| 1573 | ((eq 'not (car x)) |
|---|
| 1574 | (assert (null (cddr x))) |
|---|
| 1575 | (not (featurep (cadr x) features))) |
|---|
| 1576 | ((eq 'or (car x)) |
|---|
| 1577 | (some #'(lambda (x) (featurep x features)) (cdr x))) |
|---|
| 1578 | ((eq 'and (car x)) |
|---|
| 1579 | (every #'(lambda (x) (featurep x features)) (cdr x))) |
|---|
| 1580 | (t |
|---|
| 1581 | (error "Malformed feature specification ~S" x)))) |
|---|
| 1582 | |
|---|
| 1583 | (defun* os-unix-p () |
|---|
| 1584 | (featurep '(or :unix :cygwin :darwin))) |
|---|
| 1585 | |
|---|
| 1586 | (defun* os-windows-p () |
|---|
| 1587 | (and (not (os-unix-p)) (featurep '(or :win32 :windows :mswindows :mingw32)))) |
|---|
| 1588 | |
|---|
| 1589 | (defun* probe-asd (name defaults) |
|---|
| 1590 | (block nil |
|---|
| 1591 | (when (directory-pathname-p defaults) |
|---|
| 1592 | (let ((file (make-pathname |
|---|
| 1593 | :defaults defaults :name name |
|---|
| 1594 | :version :newest :case :local :type "asd"))) |
|---|
| 1595 | (when (probe-file* file) |
|---|
| 1596 | (return file))) |
|---|
| 1597 | #-clisp |
|---|
| 1598 | (when (os-windows-p) |
|---|
| 1599 | (let ((shortcut |
|---|
| 1600 | (make-pathname |
|---|
| 1601 | :defaults defaults :version :newest :case :local |
|---|
| 1602 | :name (concatenate 'string name ".asd") |
|---|
| 1603 | :type "lnk"))) |
|---|
| 1604 | (when (probe-file* shortcut) |
|---|
| 1605 | (let ((target (parse-windows-shortcut shortcut))) |
|---|
| 1606 | (when target |
|---|
| 1607 | (return (pathname target)))))))))) |
|---|
| 1608 | |
|---|
| 1609 | (defun* sysdef-central-registry-search (system) |
|---|
| 1610 | (let ((name (coerce-name system)) |
|---|
| 1611 | (to-remove nil) |
|---|
| 1612 | (to-replace nil)) |
|---|
| 1613 | (block nil |
|---|
| 1614 | (unwind-protect |
|---|
| 1615 | (dolist (dir *central-registry*) |
|---|
| 1616 | (let ((defaults (eval dir))) |
|---|
| 1617 | (when defaults |
|---|
| 1618 | (cond ((directory-pathname-p defaults) |
|---|
| 1619 | (let ((file (probe-asd name defaults))) |
|---|
| 1620 | (when file |
|---|
| 1621 | (return file)))) |
|---|
| 1622 | (t |
|---|
| 1623 | (restart-case |
|---|
| 1624 | (let* ((*print-circle* nil) |
|---|
| 1625 | (message |
|---|
| 1626 | (format nil |
|---|
| 1627 | (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>") |
|---|
| 1628 | system dir defaults))) |
|---|
| 1629 | (error message)) |
|---|
| 1630 | (remove-entry-from-registry () |
|---|
| 1631 | :report "Remove entry from *central-registry* and continue" |
|---|
| 1632 | (push dir to-remove)) |
|---|
| 1633 | (coerce-entry-to-directory () |
|---|
| 1634 | :report (lambda (s) |
|---|
| 1635 | (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>") |
|---|
| 1636 | (ensure-directory-pathname defaults) dir)) |
|---|
| 1637 | (push (cons dir (ensure-directory-pathname defaults)) to-replace)))))))) |
|---|
| 1638 | ;; cleanup |
|---|
| 1639 | (dolist (dir to-remove) |
|---|
| 1640 | (setf *central-registry* (remove dir *central-registry*))) |
|---|
| 1641 | (dolist (pair to-replace) |
|---|
| 1642 | (let* ((current (car pair)) |
|---|
| 1643 | (new (cdr pair)) |
|---|
| 1644 | (position (position current *central-registry*))) |
|---|
| 1645 | (setf *central-registry* |
|---|
| 1646 | (append (subseq *central-registry* 0 position) |
|---|
| 1647 | (list new) |
|---|
| 1648 | (subseq *central-registry* (1+ position)))))))))) |
|---|
| 1649 | |
|---|
| 1650 | (defun* make-temporary-package () |
|---|
| 1651 | (flet ((try (counter) |
|---|
| 1652 | (ignore-errors |
|---|
| 1653 | (make-package (format nil "~A~D" :asdf counter) |
|---|
| 1654 | :use '(:cl :asdf))))) |
|---|
| 1655 | (do* ((counter 0 (+ counter 1)) |
|---|
| 1656 | (package (try counter) (try counter))) |
|---|
| 1657 | (package package)))) |
|---|
| 1658 | |
|---|
| 1659 | (defun* safe-file-write-date (pathname) |
|---|
| 1660 | ;; If FILE-WRITE-DATE returns NIL, it's possible that |
|---|
| 1661 | ;; the user or some other agent has deleted an input file. |
|---|
| 1662 | ;; Also, generated files will not exist at the time planning is done |
|---|
| 1663 | ;; and calls operation-done-p which calls safe-file-write-date. |
|---|
| 1664 | ;; So it is very possible that we can't get a valid file-write-date, |
|---|
| 1665 | ;; and we can survive and we will continue the planning |
|---|
| 1666 | ;; as if the file were very old. |
|---|
| 1667 | ;; (or should we treat the case in a different, special way?) |
|---|
| 1668 | (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname))) |
|---|
| 1669 | (progn |
|---|
| 1670 | (when (and pathname *asdf-verbose*) |
|---|
| 1671 | (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>") |
|---|
| 1672 | pathname)) |
|---|
| 1673 | 0))) |
|---|
| 1674 | |
|---|
| 1675 | (defmethod find-system ((name null) &optional (error-p t)) |
|---|
| 1676 | (when error-p |
|---|
| 1677 | (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) |
|---|
| 1678 | |
|---|
| 1679 | (defmethod find-system (name &optional (error-p t)) |
|---|
| 1680 | (find-system (coerce-name name) error-p)) |
|---|
| 1681 | |
|---|
| 1682 | (defvar *systems-being-defined* nil |
|---|
| 1683 | "A hash-table of systems currently being defined keyed by name, or NIL") |
|---|
| 1684 | |
|---|
| 1685 | (defun* find-system-if-being-defined (name) |
|---|
| 1686 | (when *systems-being-defined* |
|---|
| 1687 | (gethash (coerce-name name) *systems-being-defined*))) |
|---|
| 1688 | |
|---|
| 1689 | (defun* call-with-system-definitions (thunk) |
|---|
| 1690 | (if *systems-being-defined* |
|---|
| 1691 | (funcall thunk) |
|---|
| 1692 | (let ((*systems-being-defined* (make-hash-table :test 'equal))) |
|---|
| 1693 | (funcall thunk)))) |
|---|
| 1694 | |
|---|
| 1695 | (defmacro with-system-definitions (() &body body) |
|---|
| 1696 | `(call-with-system-definitions #'(lambda () ,@body))) |
|---|
| 1697 | |
|---|
| 1698 | (defun* load-sysdef (name pathname) |
|---|
| 1699 | ;; Tries to load system definition with canonical NAME from PATHNAME. |
|---|
| 1700 | (with-system-definitions () |
|---|
| 1701 | (let ((package (make-temporary-package))) |
|---|
| 1702 | (unwind-protect |
|---|
| 1703 | (handler-bind |
|---|
| 1704 | ((error #'(lambda (condition) |
|---|
| 1705 | (error 'load-system-definition-error |
|---|
| 1706 | :name name :pathname pathname |
|---|
| 1707 | :condition condition)))) |
|---|
| 1708 | (let ((*package* package) |
|---|
| 1709 | (*default-pathname-defaults* |
|---|
| 1710 | (pathname-directory-pathname pathname))) |
|---|
| 1711 | (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") |
|---|
| 1712 | pathname package) |
|---|
| 1713 | (load pathname))) |
|---|
| 1714 | (delete-package package))))) |
|---|
| 1715 | |
|---|
| 1716 | (defmethod find-system ((name string) &optional (error-p t)) |
|---|
| 1717 | (with-system-definitions () |
|---|
| 1718 | (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk |
|---|
| 1719 | (previous (cdr in-memory)) |
|---|
| 1720 | (previous (and (typep previous 'system) previous)) |
|---|
| 1721 | (previous-time (car in-memory)) |
|---|
| 1722 | (found (search-for-system-definition name)) |
|---|
| 1723 | (found-system (and (typep found 'system) found)) |
|---|
| 1724 | (pathname (or (and (typep found '(or pathname string)) (pathname found)) |
|---|
| 1725 | (and found-system (system-source-file found-system)) |
|---|
| 1726 | (and previous (system-source-file previous))))) |
|---|
| 1727 | (setf pathname (resolve-symlinks* pathname)) |
|---|
| 1728 | (when (and pathname (not (absolute-pathname-p pathname))) |
|---|
| 1729 | (setf pathname (ensure-pathname-absolute pathname)) |
|---|
| 1730 | (when found-system |
|---|
| 1731 | (%set-system-source-file pathname found-system))) |
|---|
| 1732 | (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp |
|---|
| 1733 | (system-source-file previous) pathname))) |
|---|
| 1734 | (%set-system-source-file pathname previous) |
|---|
| 1735 | (setf previous-time nil)) |
|---|
| 1736 | (when (and found-system (not previous)) |
|---|
| 1737 | (register-system found-system)) |
|---|
| 1738 | (when (and pathname |
|---|
| 1739 | (or (not previous-time) |
|---|
| 1740 | ;; don't reload if it's already been loaded, |
|---|
| 1741 | ;; or its filestamp is in the future which means some clock is skewed |
|---|
| 1742 | ;; and trying to load might cause an infinite loop. |
|---|
| 1743 | (< previous-time (safe-file-write-date pathname) (get-universal-time)))) |
|---|
| 1744 | (load-sysdef name pathname)) |
|---|
| 1745 | (let ((in-memory (system-registered-p name))) ; try again after loading from disk |
|---|
| 1746 | (cond |
|---|
| 1747 | (in-memory |
|---|
| 1748 | (when pathname |
|---|
| 1749 | (setf (car in-memory) (safe-file-write-date pathname))) |
|---|
| 1750 | (cdr in-memory)) |
|---|
| 1751 | (error-p |
|---|
| 1752 | (error 'missing-component :requires name))))))) |
|---|
| 1753 | |
|---|
| 1754 | (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) |
|---|
| 1755 | (setf fallback (coerce-name fallback) |
|---|
| 1756 | requested (coerce-name requested)) |
|---|
| 1757 | (when (equal requested fallback) |
|---|
| 1758 | (let ((registered (cdr (gethash fallback *defined-systems*)))) |
|---|
| 1759 | (or registered |
|---|
| 1760 | (apply 'make-instance 'system |
|---|
| 1761 | :name fallback :source-file source-file keys))))) |
|---|
| 1762 | |
|---|
| 1763 | (defun* sysdef-find-asdf (name) |
|---|
| 1764 | ;; Bug: :version *asdf-version* won't be updated when ASDF is updated. |
|---|
| 1765 | (find-system-fallback name "asdf" :version *asdf-version*)) |
|---|
| 1766 | |
|---|
| 1767 | |
|---|
| 1768 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1769 | ;;;; Finding components |
|---|
| 1770 | |
|---|
| 1771 | (defmethod find-component ((base string) path) |
|---|
| 1772 | (let ((s (find-system base nil))) |
|---|
| 1773 | (and s (find-component s path)))) |
|---|
| 1774 | |
|---|
| 1775 | (defmethod find-component ((base symbol) path) |
|---|
| 1776 | (cond |
|---|
| 1777 | (base (find-component (coerce-name base) path)) |
|---|
| 1778 | (path (find-component path nil)) |
|---|
| 1779 | (t nil))) |
|---|
| 1780 | |
|---|
| 1781 | (defmethod find-component ((base cons) path) |
|---|
| 1782 | (find-component (car base) (cons (cdr base) path))) |
|---|
| 1783 | |
|---|
| 1784 | (defmethod find-component ((module module) (name string)) |
|---|
| 1785 | (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!! |
|---|
| 1786 | (compute-module-components-by-name module)) |
|---|
| 1787 | (values (gethash name (module-components-by-name module)))) |
|---|
| 1788 | |
|---|
| 1789 | (defmethod find-component ((component component) (name symbol)) |
|---|
| 1790 | (if name |
|---|
| 1791 | (find-component component (coerce-name name)) |
|---|
| 1792 | component)) |
|---|
| 1793 | |
|---|
| 1794 | (defmethod find-component ((module module) (name cons)) |
|---|
| 1795 | (find-component (find-component module (car name)) (cdr name))) |
|---|
| 1796 | |
|---|
| 1797 | |
|---|
| 1798 | ;;; component subclasses |
|---|
| 1799 | |
|---|
| 1800 | (defclass source-file (component) |
|---|
| 1801 | ((type :accessor source-file-explicit-type :initarg :type :initform nil))) |
|---|
| 1802 | |
|---|
| 1803 | (defclass cl-source-file (source-file) |
|---|
| 1804 | ((type :initform "lisp"))) |
|---|
| 1805 | (defclass cl-source-file.cl (cl-source-file) |
|---|
| 1806 | ((type :initform "cl"))) |
|---|
| 1807 | (defclass cl-source-file.lsp (cl-source-file) |
|---|
| 1808 | ((type :initform "lsp"))) |
|---|
| 1809 | (defclass c-source-file (source-file) |
|---|
| 1810 | ((type :initform "c"))) |
|---|
| 1811 | (defclass java-source-file (source-file) |
|---|
| 1812 | ((type :initform "java"))) |
|---|
| 1813 | (defclass static-file (source-file) ()) |
|---|
| 1814 | (defclass doc-file (static-file) ()) |
|---|
| 1815 | (defclass html-file (doc-file) |
|---|
| 1816 | ((type :initform "html"))) |
|---|
| 1817 | |
|---|
| 1818 | (defmethod source-file-type ((component module) (s module)) |
|---|
| 1819 | (declare (ignorable component s)) |
|---|
| 1820 | :directory) |
|---|
| 1821 | (defmethod source-file-type ((component source-file) (s module)) |
|---|
| 1822 | (declare (ignorable s)) |
|---|
| 1823 | (source-file-explicit-type component)) |
|---|
| 1824 | |
|---|
| 1825 | (defun* coerce-pathname (name &key type defaults) |
|---|
| 1826 | "coerce NAME into a PATHNAME. |
|---|
| 1827 | When given a string, portably decompose it into a relative pathname: |
|---|
| 1828 | #\\/ separates subdirectories. The last #\\/-separated string is as follows: |
|---|
| 1829 | if TYPE is NIL, its last #\\. if any separates name and type from from type; |
|---|
| 1830 | if TYPE is a string, it is the type, and the whole string is the name; |
|---|
| 1831 | if TYPE is :DIRECTORY, the string is a directory component; |
|---|
| 1832 | if the string is empty, it's a directory. |
|---|
| 1833 | Any directory named .. is read as :BACK. |
|---|
| 1834 | Host, device and version components are taken from DEFAULTS." |
|---|
| 1835 | ;; The defaults are required notably because they provide the default host |
|---|
| 1836 | ;; to the below make-pathname, which may crucially matter to people using |
|---|
| 1837 | ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames. |
|---|
| 1838 | ;; NOTE that the host and device slots will be taken from the defaults, |
|---|
| 1839 | ;; but that should only matter if you later merge relative pathnames with |
|---|
| 1840 | ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES* |
|---|
| 1841 | (etypecase name |
|---|
| 1842 | ((or null pathname) |
|---|
| 1843 | name) |
|---|
| 1844 | (symbol |
|---|
| 1845 | (coerce-pathname (string-downcase name) :type type :defaults defaults)) |
|---|
| 1846 | (string |
|---|
| 1847 | (multiple-value-bind (relative path filename) |
|---|
| 1848 | (component-name-to-pathname-components name :force-directory (eq type :directory) |
|---|
| 1849 | :force-relative t) |
|---|
| 1850 | (multiple-value-bind (name type) |
|---|
| 1851 | (cond |
|---|
| 1852 | ((or (eq type :directory) (null filename)) |
|---|
| 1853 | (values nil nil)) |
|---|
| 1854 | (type |
|---|
| 1855 | (values filename type)) |
|---|
| 1856 | (t |
|---|
| 1857 | (split-name-type filename))) |
|---|
| 1858 | (apply 'make-pathname :directory (cons relative path) :name name :type type |
|---|
| 1859 | (when defaults `(:defaults ,defaults)))))))) |
|---|
| 1860 | |
|---|
| 1861 | (defun* merge-component-name-type (name &key type defaults) |
|---|
| 1862 | ;; For backwards compatibility only, for people using internals. |
|---|
| 1863 | ;; Will be removed in a future release, e.g. 2.016. |
|---|
| 1864 | (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.") |
|---|
| 1865 | (coerce-pathname name :type type :defaults defaults)) |
|---|
| 1866 | |
|---|
| 1867 | (defmethod component-relative-pathname ((component component)) |
|---|
| 1868 | (coerce-pathname |
|---|
| 1869 | (or (slot-value component 'relative-pathname) |
|---|
| 1870 | (component-name component)) |
|---|
| 1871 | :type (source-file-type component (component-system component)) |
|---|
| 1872 | :defaults (component-parent-pathname component))) |
|---|
| 1873 | |
|---|
| 1874 | ;;;; ------------------------------------------------------------------------- |
|---|
| 1875 | ;;;; Operations |
|---|
| 1876 | |
|---|
| 1877 | ;;; one of these is instantiated whenever #'operate is called |
|---|
| 1878 | |
|---|
| 1879 | (defclass operation () |
|---|
| 1880 | (;; as of danb's 2003-03-16 commit e0d02781, :force can be: |
|---|
| 1881 | ;; T to force the inside of the specified system, |
|---|
| 1882 | ;; but not recurse to other systems we depend on. |
|---|
| 1883 | ;; :ALL (or any other atom) to force all systems |
|---|
| 1884 | ;; including other systems we depend on. |
|---|
| 1885 | ;; (SYSTEM1 SYSTEM2 ... SYSTEMN) |
|---|
| 1886 | ;; to force systems named in a given list |
|---|
| 1887 | ;; However, but this feature has only ever worked but starting with ASDF 2.014.5 |
|---|
| 1888 | (forced :initform nil :initarg :force :accessor operation-forced) |
|---|
| 1889 | (original-initargs :initform nil :initarg :original-initargs |
|---|
| 1890 | :accessor operation-original-initargs) |
|---|
| 1891 | (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes) |
|---|
| 1892 | (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes) |
|---|
| 1893 | (parent :initform nil :initarg :parent :accessor operation-parent))) |
|---|
| 1894 | |
|---|
| 1895 | (defmethod print-object ((o operation) stream) |
|---|
| 1896 | (print-unreadable-object (o stream :type t :identity t) |
|---|
| 1897 | (ignore-errors |
|---|
| 1898 | (prin1 (operation-original-initargs o) stream)))) |
|---|
| 1899 | |
|---|
| 1900 | (defmethod shared-initialize :after ((operation operation) slot-names |
|---|
| 1901 | &key force |
|---|
| 1902 | &allow-other-keys) |
|---|
| 1903 | (declare (ignorable operation slot-names force)) |
|---|
| 1904 | ;; empty method to disable initarg validity checking |
|---|
| 1905 | (values)) |
|---|
| 1906 | |
|---|
| 1907 | (defun* node-for (o c) |
|---|
| 1908 | (cons (class-name (class-of o)) c)) |
|---|
| 1909 | |
|---|
| 1910 | (defmethod operation-ancestor ((operation operation)) |
|---|
| 1911 | (aif (operation-parent operation) |
|---|
| 1912 | (operation-ancestor it) |
|---|
| 1913 | operation)) |
|---|
| 1914 | |
|---|
| 1915 | |
|---|
| 1916 | (defun* make-sub-operation (c o dep-c dep-o) |
|---|
| 1917 | "C is a component, O is an operation, DEP-C is another |
|---|
| 1918 | component, and DEP-O, confusingly enough, is an operation |
|---|
| 1919 | class specifier, not an operation." |
|---|
| 1920 | (let* ((args (copy-list (operation-original-initargs o))) |
|---|
| 1921 | (force-p (getf args :force))) |
|---|
| 1922 | ;; note explicit comparison with T: any other non-NIL force value |
|---|
| 1923 | ;; (e.g. :recursive) will pass through |
|---|
| 1924 | (cond ((and (null (component-parent c)) |
|---|
| 1925 | (null (component-parent dep-c)) |
|---|
| 1926 | (not (eql c dep-c))) |
|---|
| 1927 | (when (eql force-p t) |
|---|
| 1928 | (setf (getf args :force) nil)) |
|---|
| 1929 | (apply 'make-instance dep-o |
|---|
| 1930 | :parent o |
|---|
| 1931 | :original-initargs args args)) |
|---|
| 1932 | ((subtypep (type-of o) dep-o) |
|---|
| 1933 | o) |
|---|
| 1934 | (t |
|---|
| 1935 | (apply 'make-instance dep-o |
|---|
| 1936 | :parent o :original-initargs args args))))) |
|---|
| 1937 | |
|---|
| 1938 | |
|---|
| 1939 | (defmethod visit-component ((o operation) (c component) data) |
|---|
| 1940 | (unless (component-visited-p o c) |
|---|
| 1941 | (setf (gethash (node-for o c) |
|---|
| 1942 | (operation-visited-nodes (operation-ancestor o))) |
|---|
| 1943 | (cons t data)))) |
|---|
| 1944 | |
|---|
| 1945 | (defmethod component-visited-p ((o operation) (c component)) |
|---|
| 1946 | (gethash (node-for o c) |
|---|
| 1947 | (operation-visited-nodes (operation-ancestor o)))) |
|---|
| 1948 | |
|---|
| 1949 | (defmethod (setf visiting-component) (new-value operation component) |
|---|
| 1950 | ;; MCL complains about unused lexical variables |
|---|
| 1951 | (declare (ignorable operation component)) |
|---|
| 1952 | new-value) |
|---|
| 1953 | |
|---|
| 1954 | (defmethod (setf visiting-component) (new-value (o operation) (c component)) |
|---|
| 1955 | (let ((node (node-for o c)) |
|---|
| 1956 | (a (operation-ancestor o))) |
|---|
| 1957 | (if new-value |
|---|
| 1958 | (setf (gethash node (operation-visiting-nodes a)) t) |
|---|
| 1959 | (remhash node (operation-visiting-nodes a))) |
|---|
| 1960 | new-value)) |
|---|
| 1961 | |
|---|
| 1962 | (defmethod component-visiting-p ((o operation) (c component)) |
|---|
| 1963 | (let ((node (node-for o c))) |
|---|
| 1964 | (gethash node (operation-visiting-nodes (operation-ancestor o))))) |
|---|
| 1965 | |
|---|
| 1966 | (defmethod component-depends-on ((op-spec symbol) (c component)) |
|---|
| 1967 | ;; Note: we go from op-spec to operation via make-instance |
|---|
| 1968 | ;; to allow for specialization through defmethod's, even though |
|---|
| 1969 | ;; it's a detour in the default case below. |
|---|
| 1970 | (component-depends-on (make-instance op-spec) c)) |
|---|
| 1971 | |
|---|
| 1972 | (defmethod component-depends-on ((o operation) (c component)) |
|---|
| 1973 | (cdr (assoc (type-of o) (component-in-order-to c)))) |
|---|
| 1974 | |
|---|
| 1975 | (defmethod component-self-dependencies ((o operation) (c component)) |
|---|
| 1976 | (let ((all-deps (component-depends-on o c))) |
|---|
| 1977 | (remove-if-not #'(lambda (x) |
|---|
| 1978 | (member (component-name c) (cdr x) :test #'string=)) |
|---|
| 1979 | all-deps))) |
|---|
| 1980 | |
|---|
| 1981 | (defmethod input-files ((operation operation) (c component)) |
|---|
| 1982 | (let ((parent (component-parent c)) |
|---|
| 1983 | (self-deps (component-self-dependencies operation c))) |
|---|
| 1984 | (if self-deps |
|---|
| 1985 | (mapcan #'(lambda (dep) |
|---|
| 1986 | (destructuring-bind (op name) dep |
|---|
| 1987 | (output-files (make-instance op) |
|---|
| 1988 | (find-component parent name)))) |
|---|
| 1989 | self-deps) |
|---|
| 1990 | ;; no previous operations needed? I guess we work with the |
|---|
| 1991 | ;; original source file, then |
|---|
| 1992 | (list (component-pathname c))))) |
|---|
| 1993 | |
|---|
| 1994 | (defmethod input-files ((operation operation) (c module)) |
|---|
| 1995 | (declare (ignorable operation c)) |
|---|
| 1996 | nil) |
|---|
| 1997 | |
|---|
| 1998 | (defmethod component-operation-time (o c) |
|---|
| 1999 | (gethash (type-of o) (component-operation-times c))) |
|---|
| 2000 | |
|---|
| 2001 | (defmethod operation-done-p ((o operation) (c component)) |
|---|
| 2002 | (let ((out-files (output-files o c)) |
|---|
| 2003 | (in-files (input-files o c)) |
|---|
| 2004 | (op-time (component-operation-time o c))) |
|---|
| 2005 | (flet ((earliest-out () |
|---|
| 2006 | (reduce #'min (mapcar #'safe-file-write-date out-files))) |
|---|
| 2007 | (latest-in () |
|---|
| 2008 | (reduce #'max (mapcar #'safe-file-write-date in-files)))) |
|---|
| 2009 | (cond |
|---|
| 2010 | ((and (not in-files) (not out-files)) |
|---|
| 2011 | ;; arbitrary decision: an operation that uses nothing to |
|---|
| 2012 | ;; produce nothing probably isn't doing much. |
|---|
| 2013 | ;; e.g. operations on systems, modules that have no immediate action, |
|---|
| 2014 | ;; but are only meaningful through traversed dependencies |
|---|
| 2015 | t) |
|---|
| 2016 | ((not out-files) |
|---|
| 2017 | ;; an operation without output-files is probably meant |
|---|
| 2018 | ;; for its side-effects in the current image, |
|---|
| 2019 | ;; assumed to be idem-potent, |
|---|
| 2020 | ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE. |
|---|
| 2021 | (and op-time (>= op-time (latest-in)))) |
|---|
| 2022 | ((not in-files) |
|---|
| 2023 | ;; an operation with output-files and no input-files |
|---|
| 2024 | ;; is probably meant for its side-effects on the file-system, |
|---|
| 2025 | ;; assumed to have to be done everytime. |
|---|
| 2026 | ;; (I don't think there is any such case in ASDF unless extended) |
|---|
| 2027 | nil) |
|---|
| 2028 | (t |
|---|
| 2029 | ;; an operation with both input and output files is assumed |
|---|
| 2030 | ;; as computing the latter from the former, |
|---|
| 2031 | ;; assumed to have been done if the latter are all older |
|---|
| 2032 | ;; than the former. |
|---|
| 2033 | ;; e.g. COMPILE-OP of some CL-SOURCE-FILE. |
|---|
| 2034 | ;; We use >= instead of > to play nice with generated files. |
|---|
| 2035 | ;; This opens a race condition if an input file is changed |
|---|
| 2036 | ;; after the output is created but within the same second |
|---|
| 2037 | ;; of filesystem time; but the same race condition exists |
|---|
| 2038 | ;; whenever the computation from input to output takes more |
|---|
| 2039 | ;; than one second of filesystem time (or just crosses the |
|---|
| 2040 | ;; second). So that's cool. |
|---|
| 2041 | (and |
|---|
| 2042 | (every #'probe-file* in-files) |
|---|
| 2043 | (every #'probe-file* out-files) |
|---|
| 2044 | (>= (earliest-out) (latest-in)))))))) |
|---|
| 2045 | |
|---|
| 2046 | |
|---|
| 2047 | |
|---|
| 2048 | ;;; For 1.700 I've done my best to refactor TRAVERSE |
|---|
| 2049 | ;;; by splitting it up in a bunch of functions, |
|---|
| 2050 | ;;; so as to improve the collection and use-detection algorithm. --fare |
|---|
| 2051 | ;;; The protocol is as follows: we pass around operation, dependency, |
|---|
| 2052 | ;;; bunch of other stuff, and a force argument. Return a force flag. |
|---|
| 2053 | ;;; The returned flag is T if anything has changed that requires a rebuild. |
|---|
| 2054 | ;;; The force argument is a list of components that will require a rebuild |
|---|
| 2055 | ;;; if the flag is T, at which point whoever returns the flag has to |
|---|
| 2056 | ;;; mark them all as forced, and whoever recurses again can use a NIL list |
|---|
| 2057 | ;;; as a further argument. |
|---|
| 2058 | |
|---|
| 2059 | (defvar *forcing* nil |
|---|
| 2060 | "This dynamically-bound variable is used to force operations in |
|---|
| 2061 | recursive calls to traverse.") |
|---|
| 2062 | |
|---|
| 2063 | (defgeneric* do-traverse (operation component collect)) |
|---|
| 2064 | |
|---|
| 2065 | (defun* resolve-dependency-name (component name &optional version) |
|---|
| 2066 | (loop |
|---|
| 2067 | (restart-case |
|---|
| 2068 | (return |
|---|
| 2069 | (let ((comp (find-component (component-parent component) name))) |
|---|
| 2070 | (unless comp |
|---|
| 2071 | (error 'missing-dependency |
|---|
| 2072 | :required-by component |
|---|
| 2073 | :requires name)) |
|---|
| 2074 | (when version |
|---|
| 2075 | (unless (version-satisfies comp version) |
|---|
| 2076 | (error 'missing-dependency-of-version |
|---|
| 2077 | :required-by component |
|---|
| 2078 | :version version |
|---|
| 2079 | :requires name))) |
|---|
| 2080 | comp)) |
|---|
| 2081 | (retry () |
|---|
| 2082 | :report (lambda (s) |
|---|
| 2083 | (format s "~@<Retry loading ~3i~_~A.~@:>" name)) |
|---|
| 2084 | :test |
|---|
| 2085 | (lambda (c) |
|---|
| 2086 | (or (null c) |
|---|
| 2087 | (and (typep c 'missing-dependency) |
|---|
| 2088 | (eq (missing-required-by c) component) |
|---|
| 2089 | (equal (missing-requires c) name)))))))) |
|---|
| 2090 | |
|---|
| 2091 | (defun* resolve-dependency-spec (component dep-spec) |
|---|
| 2092 | (cond |
|---|
| 2093 | ((atom dep-spec) |
|---|
| 2094 | (resolve-dependency-name component dep-spec)) |
|---|
| 2095 | ;; Structured dependencies --- this parses keywords. |
|---|
| 2096 | ;; The keywords could conceivably be broken out and cleanly (extensibly) |
|---|
| 2097 | ;; processed by EQL methods. But for now, here's what we've got. |
|---|
| 2098 | ((eq :version (first dep-spec)) |
|---|
| 2099 | ;; https://bugs.launchpad.net/asdf/+bug/527788 |
|---|
| 2100 | (resolve-dependency-name component (second dep-spec) (third dep-spec))) |
|---|
| 2101 | ((eq :feature (first dep-spec)) |
|---|
| 2102 | ;; This particular subform is not documented and |
|---|
| 2103 | ;; has always been broken in the past. |
|---|
| 2104 | ;; Therefore no one uses it, and I'm cerroring it out, |
|---|
| 2105 | ;; after fixing it |
|---|
| 2106 | ;; See https://bugs.launchpad.net/asdf/+bug/518467 |
|---|
| 2107 | (cerror "Continue nonetheless." |
|---|
| 2108 | "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.") |
|---|
| 2109 | (when (find (second dep-spec) *features* :test 'string-equal) |
|---|
| 2110 | (resolve-dependency-name component (third dep-spec)))) |
|---|
| 2111 | (t |
|---|
| 2112 | (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec)))) |
|---|
| 2113 | |
|---|
| 2114 | (defun* do-one-dep (op c collect dep-op dep-c) |
|---|
| 2115 | ;; Collects a partial plan for performing dep-op on dep-c |
|---|
| 2116 | ;; as dependencies of a larger plan involving op and c. |
|---|
| 2117 | ;; Returns t if this should force recompilation of those who depend on us. |
|---|
| 2118 | ;; dep-op is an operation class name (not an operation object), |
|---|
| 2119 | ;; whereas dep-c is a component object.n |
|---|
| 2120 | (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect)) |
|---|
| 2121 | |
|---|
| 2122 | (defun* do-dep (op c collect dep-op-spec dep-c-specs) |
|---|
| 2123 | ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs |
|---|
| 2124 | ;; as dependencies of a larger plan involving op and c. |
|---|
| 2125 | ;; Returns t if this should force recompilation of those who depend on us. |
|---|
| 2126 | ;; dep-op-spec is either an operation class name (not an operation object), |
|---|
| 2127 | ;; or the magic symbol asdf:feature. |
|---|
| 2128 | ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword, |
|---|
| 2129 | ;; and the plan will succeed if that keyword is present in *feature*, |
|---|
| 2130 | ;; or fail if it isn't |
|---|
| 2131 | ;; (at which point c's :if-component-dep-fails will kick in). |
|---|
| 2132 | ;; If dep-op-spec is an operation class name, |
|---|
| 2133 | ;; then dep-c-specs specifies a list of sibling component of c, |
|---|
| 2134 | ;; as per resolve-dependency-spec, such that operating op on c |
|---|
| 2135 | ;; depends on operating dep-op-spec on each of them. |
|---|
| 2136 | (cond ((eq dep-op-spec 'feature) |
|---|
| 2137 | (if (member (car dep-c-specs) *features*) |
|---|
| 2138 | nil |
|---|
| 2139 | (error 'missing-dependency |
|---|
| 2140 | :required-by c |
|---|
| 2141 | :requires (list :feature (car dep-c-specs))))) |
|---|
| 2142 | (t |
|---|
| 2143 | (let ((flag nil)) |
|---|
| 2144 | (dolist (d dep-c-specs) |
|---|
| 2145 | (when (do-one-dep op c collect dep-op-spec |
|---|
| 2146 | (resolve-dependency-spec c d)) |
|---|
| 2147 | (setf flag t))) |
|---|
| 2148 | flag)))) |
|---|
| 2149 | |
|---|
| 2150 | (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes |
|---|
| 2151 | |
|---|
| 2152 | (defun* do-collect (collect x) |
|---|
| 2153 | (funcall collect x)) |
|---|
| 2154 | |
|---|
| 2155 | (defmethod do-traverse ((operation operation) (c component) collect) |
|---|
| 2156 | (let ((*forcing* *forcing*) |
|---|
| 2157 | (flag nil)) ;; return value: must we rebuild this and its dependencies? |
|---|
| 2158 | (labels |
|---|
| 2159 | ((update-flag (x) |
|---|
| 2160 | (orf flag x)) |
|---|
| 2161 | (dep (op comp) |
|---|
| 2162 | (update-flag (do-dep operation c collect op comp)))) |
|---|
| 2163 | ;; Have we been visited yet? If so, just process the result. |
|---|
| 2164 | (aif (component-visited-p operation c) |
|---|
| 2165 | (progn |
|---|
| 2166 | (update-flag (cdr it)) |
|---|
| 2167 | (return-from do-traverse flag))) |
|---|
| 2168 | ;; dependencies |
|---|
| 2169 | (when (component-visiting-p operation c) |
|---|
| 2170 | (error 'circular-dependency :components (list c))) |
|---|
| 2171 | (setf (visiting-component operation c) t) |
|---|
| 2172 | (unwind-protect |
|---|
| 2173 | (progn |
|---|
| 2174 | (let ((f (operation-forced |
|---|
| 2175 | (operation-ancestor operation)))) |
|---|
| 2176 | (when (and f (or (not (consp f)) ;; T or :ALL |
|---|
| 2177 | (and (typep c 'system) ;; list of names of systems to force |
|---|
| 2178 | (member (component-name c) f |
|---|
| 2179 | :test #'string=)))) |
|---|
| 2180 | (setf *forcing* t))) |
|---|
| 2181 | ;; first we check and do all the dependencies for the module. |
|---|
| 2182 | ;; Operations planned in this loop will show up |
|---|
| 2183 | ;; in the results, and are consumed below. |
|---|
| 2184 | (let ((*forcing* nil)) |
|---|
| 2185 | ;; upstream dependencies are never forced to happen just because |
|---|
| 2186 | ;; the things that depend on them are.... |
|---|
| 2187 | (loop |
|---|
| 2188 | :for (required-op . deps) :in (component-depends-on operation c) |
|---|
| 2189 | :do (dep required-op deps))) |
|---|
| 2190 | ;; constituent bits |
|---|
| 2191 | (let ((module-ops |
|---|
| 2192 | (when (typep c 'module) |
|---|
| 2193 | (let ((at-least-one nil) |
|---|
| 2194 | ;; This is set based on the results of the |
|---|
| 2195 | ;; dependencies and whether we are in the |
|---|
| 2196 | ;; context of a *forcing* call... |
|---|
| 2197 | ;; inter-system dependencies do NOT trigger |
|---|
| 2198 | ;; building components |
|---|
| 2199 | (*forcing* |
|---|
| 2200 | (or *forcing* |
|---|
| 2201 | (and flag (not (typep c 'system))))) |
|---|
| 2202 | (error nil)) |
|---|
| 2203 | (while-collecting (internal-collect) |
|---|
| 2204 | (dolist (kid (module-components c)) |
|---|
| 2205 | (handler-case |
|---|
| 2206 | (update-flag |
|---|
| 2207 | (do-traverse operation kid #'internal-collect)) |
|---|
| 2208 | (missing-dependency (condition) |
|---|
| 2209 | (when (eq (module-if-component-dep-fails c) |
|---|
| 2210 | :fail) |
|---|
| 2211 | (error condition)) |
|---|
| 2212 | (setf error condition)) |
|---|
| 2213 | (:no-error (c) |
|---|
| 2214 | (declare (ignore c)) |
|---|
| 2215 | (setf at-least-one t)))) |
|---|
| 2216 | (when (and (eq (module-if-component-dep-fails c) |
|---|
| 2217 | :try-next) |
|---|
| 2218 | (not at-least-one)) |
|---|
| 2219 | (error error))))))) |
|---|
| 2220 | (update-flag (or *forcing* (not (operation-done-p operation c)))) |
|---|
| 2221 | ;; For sub-operations, check whether |
|---|
| 2222 | ;; the original ancestor operation was forced, |
|---|
| 2223 | ;; or names us amongst an explicit list of things to force... |
|---|
| 2224 | ;; except that this check doesn't distinguish |
|---|
| 2225 | ;; between all the things with a given name. Sigh. |
|---|
| 2226 | ;; BROKEN! |
|---|
| 2227 | (when flag |
|---|
| 2228 | (let ((do-first (cdr (assoc (class-name (class-of operation)) |
|---|
| 2229 | (component-do-first c))))) |
|---|
| 2230 | (loop :for (required-op . deps) :in do-first |
|---|
| 2231 | :do (do-dep operation c collect required-op deps))) |
|---|
| 2232 | (do-collect collect (vector module-ops)) |
|---|
| 2233 | (do-collect collect (cons operation c))))) |
|---|
| 2234 | (setf (visiting-component operation c) nil))) |
|---|
| 2235 | (visit-component operation c (when flag (incf *visit-count*))) |
|---|
| 2236 | flag)) |
|---|
| 2237 | |
|---|
| 2238 | (defun* flatten-tree (l) |
|---|
| 2239 | ;; You collected things into a list. |
|---|
| 2240 | ;; Most elements are just things to collect again. |
|---|
| 2241 | ;; A (simple-vector 1) indicate that you should recurse into its contents. |
|---|
| 2242 | ;; This way, in two passes (rather than N being the depth of the tree), |
|---|
| 2243 | ;; you can collect things with marginally constant-time append, |
|---|
| 2244 | ;; achieving linear time collection instead of quadratic time. |
|---|
| 2245 | (while-collecting (c) |
|---|
| 2246 | (labels ((r (x) |
|---|
| 2247 | (if (typep x '(simple-vector 1)) |
|---|
| 2248 | (r* (svref x 0)) |
|---|
| 2249 | (c x))) |
|---|
| 2250 | (r* (l) |
|---|
| 2251 | (dolist (x l) (r x)))) |
|---|
| 2252 | (r* l)))) |
|---|
| 2253 | |
|---|
| 2254 | (defmethod traverse ((operation operation) (c component)) |
|---|
| 2255 | (when (consp (operation-forced operation)) |
|---|
| 2256 | (setf (operation-forced operation) |
|---|
| 2257 | (mapcar #'coerce-name (operation-forced operation)))) |
|---|
| 2258 | (flatten-tree |
|---|
| 2259 | (while-collecting (collect) |
|---|
| 2260 | (let ((*visit-count* 0)) |
|---|
| 2261 | (do-traverse operation c #'collect))))) |
|---|
| 2262 | |
|---|
| 2263 | (defmethod perform ((operation operation) (c source-file)) |
|---|
| 2264 | (sysdef-error |
|---|
| 2265 | (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") |
|---|
| 2266 | (class-of operation) (class-of c))) |
|---|
| 2267 | |
|---|
| 2268 | (defmethod perform ((operation operation) (c module)) |
|---|
| 2269 | (declare (ignorable operation c)) |
|---|
| 2270 | nil) |
|---|
| 2271 | |
|---|
| 2272 | (defmethod mark-operation-done ((operation operation) (c component)) |
|---|
| 2273 | (setf (gethash (type-of operation) (component-operation-times c)) |
|---|
| 2274 | (reduce #'max |
|---|
| 2275 | (cons (get-universal-time) |
|---|
| 2276 | (mapcar #'safe-file-write-date (input-files operation c)))))) |
|---|
| 2277 | |
|---|
| 2278 | (defmethod perform-with-restarts (operation component) |
|---|
| 2279 | ;; TOO verbose, especially as the default. Add your own :before method |
|---|
| 2280 | ;; to perform-with-restart or perform if you want that: |
|---|
| 2281 | #|(when *asdf-verbose* (explain operation component))|# |
|---|
| 2282 | (perform operation component)) |
|---|
| 2283 | |
|---|
| 2284 | (defmethod perform-with-restarts :around (operation component) |
|---|
| 2285 | (loop |
|---|
| 2286 | (restart-case |
|---|
| 2287 | (return (call-next-method)) |
|---|
| 2288 | (retry () |
|---|
| 2289 | :report |
|---|
| 2290 | (lambda (s) |
|---|
| 2291 | (format s (compatfmt "~@<Retry ~A.~@:>") |
|---|
| 2292 | (operation-description operation component)))) |
|---|
| 2293 | (accept () |
|---|
| 2294 | :report |
|---|
| 2295 | (lambda (s) |
|---|
| 2296 | (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>") |
|---|
| 2297 | (operation-description operation component))) |
|---|
| 2298 | (mark-operation-done operation component) |
|---|
| 2299 | (return))))) |
|---|
| 2300 | |
|---|
| 2301 | (defmethod explain ((operation operation) (component component)) |
|---|
| 2302 | (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") |
|---|
| 2303 | (operation-description operation component))) |
|---|
| 2304 | |
|---|
| 2305 | (defmethod operation-description (operation component) |
|---|
| 2306 | (format nil (compatfmt "~@<~A on ~A~@:>") |
|---|
| 2307 | (class-of operation) component)) |
|---|
| 2308 | |
|---|
| 2309 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2310 | ;;;; compile-op |
|---|
| 2311 | |
|---|
| 2312 | (defclass compile-op (operation) |
|---|
| 2313 | ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) |
|---|
| 2314 | (on-warnings :initarg :on-warnings :accessor operation-on-warnings |
|---|
| 2315 | :initform *compile-file-warnings-behaviour*) |
|---|
| 2316 | (on-failure :initarg :on-failure :accessor operation-on-failure |
|---|
| 2317 | :initform *compile-file-failure-behaviour*) |
|---|
| 2318 | (flags :initarg :flags :accessor compile-op-flags |
|---|
| 2319 | :initform nil))) |
|---|
| 2320 | |
|---|
| 2321 | (defun* output-file (operation component) |
|---|
| 2322 | "The unique output file of performing OPERATION on COMPONENT" |
|---|
| 2323 | (let ((files (output-files operation component))) |
|---|
| 2324 | (assert (length=n-p files 1)) |
|---|
| 2325 | (first files))) |
|---|
| 2326 | |
|---|
| 2327 | (defun* ensure-all-directories-exist (pathnames) |
|---|
| 2328 | (loop :for pn :in pathnames |
|---|
| 2329 | :for pathname = (if (typep pn 'logical-pathname) |
|---|
| 2330 | (translate-logical-pathname pn) |
|---|
| 2331 | pn) |
|---|
| 2332 | :do (ensure-directories-exist pathname))) |
|---|
| 2333 | |
|---|
| 2334 | (defmethod perform :before ((operation compile-op) (c source-file)) |
|---|
| 2335 | (ensure-all-directories-exist (asdf:output-files operation c))) |
|---|
| 2336 | |
|---|
| 2337 | (defmethod perform :after ((operation operation) (c component)) |
|---|
| 2338 | (mark-operation-done operation c)) |
|---|
| 2339 | |
|---|
| 2340 | (defgeneric* around-compile-hook (component)) |
|---|
| 2341 | (defgeneric* call-with-around-compile-hook (component thunk)) |
|---|
| 2342 | |
|---|
| 2343 | (defmethod around-compile-hook ((c component)) |
|---|
| 2344 | (cond |
|---|
| 2345 | ((slot-boundp c 'around-compile) |
|---|
| 2346 | (slot-value c 'around-compile)) |
|---|
| 2347 | ((component-parent c) |
|---|
| 2348 | (around-compile-hook (component-parent c))))) |
|---|
| 2349 | |
|---|
| 2350 | (defmethod call-with-around-compile-hook ((c component) thunk) |
|---|
| 2351 | (let ((hook (around-compile-hook c))) |
|---|
| 2352 | (if hook |
|---|
| 2353 | (funcall hook thunk) |
|---|
| 2354 | (funcall thunk)))) |
|---|
| 2355 | |
|---|
| 2356 | (defvar *compile-op-compile-file-function* 'compile-file* |
|---|
| 2357 | "Function used to compile lisp files.") |
|---|
| 2358 | |
|---|
| 2359 | ;;; perform is required to check output-files to find out where to put |
|---|
| 2360 | ;;; its answers, in case it has been overridden for site policy |
|---|
| 2361 | (defmethod perform ((operation compile-op) (c cl-source-file)) |
|---|
| 2362 | #-:broken-fasl-loader |
|---|
| 2363 | (let ((source-file (component-pathname c)) |
|---|
| 2364 | ;; on some implementations, there are more than one output-file, |
|---|
| 2365 | ;; but the first one should always be the primary fasl that gets loaded. |
|---|
| 2366 | (output-file (first (output-files operation c))) |
|---|
| 2367 | (*compile-file-warnings-behaviour* (operation-on-warnings operation)) |
|---|
| 2368 | (*compile-file-failure-behaviour* (operation-on-failure operation))) |
|---|
| 2369 | (multiple-value-bind (output warnings-p failure-p) |
|---|
| 2370 | (call-with-around-compile-hook |
|---|
| 2371 | c (lambda () |
|---|
| 2372 | (apply *compile-op-compile-file-function* source-file |
|---|
| 2373 | :output-file output-file (compile-op-flags operation)))) |
|---|
| 2374 | (unless output |
|---|
| 2375 | (error 'compile-error :component c :operation operation)) |
|---|
| 2376 | (when failure-p |
|---|
| 2377 | (case (operation-on-failure operation) |
|---|
| 2378 | (:warn (warn |
|---|
| 2379 | (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>") |
|---|
| 2380 | operation c)) |
|---|
| 2381 | (:error (error 'compile-failed :component c :operation operation)) |
|---|
| 2382 | (:ignore nil))) |
|---|
| 2383 | (when warnings-p |
|---|
| 2384 | (case (operation-on-warnings operation) |
|---|
| 2385 | (:warn (warn |
|---|
| 2386 | (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>") |
|---|
| 2387 | operation c)) |
|---|
| 2388 | (:error (error 'compile-warned :component c :operation operation)) |
|---|
| 2389 | (:ignore nil)))))) |
|---|
| 2390 | |
|---|
| 2391 | (defmethod output-files ((operation compile-op) (c cl-source-file)) |
|---|
| 2392 | (declare (ignorable operation)) |
|---|
| 2393 | (let ((p (lispize-pathname (component-pathname c)))) |
|---|
| 2394 | #-broken-fasl-loader (list (compile-file-pathname p)) |
|---|
| 2395 | #+broken-fasl-loader (list p))) |
|---|
| 2396 | |
|---|
| 2397 | (defmethod perform ((operation compile-op) (c static-file)) |
|---|
| 2398 | (declare (ignorable operation c)) |
|---|
| 2399 | nil) |
|---|
| 2400 | |
|---|
| 2401 | (defmethod output-files ((operation compile-op) (c static-file)) |
|---|
| 2402 | (declare (ignorable operation c)) |
|---|
| 2403 | nil) |
|---|
| 2404 | |
|---|
| 2405 | (defmethod input-files ((operation compile-op) (c static-file)) |
|---|
| 2406 | (declare (ignorable operation c)) |
|---|
| 2407 | nil) |
|---|
| 2408 | |
|---|
| 2409 | (defmethod operation-description ((operation compile-op) component) |
|---|
| 2410 | (declare (ignorable operation)) |
|---|
| 2411 | (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component)) |
|---|
| 2412 | |
|---|
| 2413 | (defmethod operation-description ((operation compile-op) (component module)) |
|---|
| 2414 | (declare (ignorable operation)) |
|---|
| 2415 | (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component)) |
|---|
| 2416 | |
|---|
| 2417 | |
|---|
| 2418 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2419 | ;;;; load-op |
|---|
| 2420 | |
|---|
| 2421 | (defclass basic-load-op (operation) ()) |
|---|
| 2422 | |
|---|
| 2423 | (defclass load-op (basic-load-op) ()) |
|---|
| 2424 | |
|---|
| 2425 | (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) |
|---|
| 2426 | (loop |
|---|
| 2427 | (restart-case |
|---|
| 2428 | (return (call-next-method)) |
|---|
| 2429 | (try-recompiling () |
|---|
| 2430 | :report (lambda (s) |
|---|
| 2431 | (format s "Recompile ~a and try loading it again" |
|---|
| 2432 | (component-name c))) |
|---|
| 2433 | (perform (make-sub-operation c o c 'compile-op) c))))) |
|---|
| 2434 | |
|---|
| 2435 | (defmethod perform ((o load-op) (c cl-source-file)) |
|---|
| 2436 | (map () #'load (input-files o c))) |
|---|
| 2437 | |
|---|
| 2438 | (defmethod perform ((operation load-op) (c static-file)) |
|---|
| 2439 | (declare (ignorable operation c)) |
|---|
| 2440 | nil) |
|---|
| 2441 | |
|---|
| 2442 | (defmethod operation-done-p ((operation load-op) (c static-file)) |
|---|
| 2443 | (declare (ignorable operation c)) |
|---|
| 2444 | t) |
|---|
| 2445 | |
|---|
| 2446 | (defmethod output-files ((operation operation) (c component)) |
|---|
| 2447 | (declare (ignorable operation c)) |
|---|
| 2448 | nil) |
|---|
| 2449 | |
|---|
| 2450 | (defmethod component-depends-on ((operation load-op) (c component)) |
|---|
| 2451 | (declare (ignorable operation)) |
|---|
| 2452 | (cons (list 'compile-op (component-name c)) |
|---|
| 2453 | (call-next-method))) |
|---|
| 2454 | |
|---|
| 2455 | (defmethod operation-description ((operation load-op) component) |
|---|
| 2456 | (declare (ignorable operation)) |
|---|
| 2457 | (format nil (compatfmt "~@<loading ~3i~_~A~@:>") |
|---|
| 2458 | component)) |
|---|
| 2459 | |
|---|
| 2460 | (defmethod operation-description ((operation load-op) (component cl-source-file)) |
|---|
| 2461 | (declare (ignorable operation)) |
|---|
| 2462 | (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") |
|---|
| 2463 | component)) |
|---|
| 2464 | |
|---|
| 2465 | (defmethod operation-description ((operation load-op) (component module)) |
|---|
| 2466 | (declare (ignorable operation)) |
|---|
| 2467 | (format nil (compatfmt "~@<loaded ~3i~_~A~@:>") |
|---|
| 2468 | component)) |
|---|
| 2469 | |
|---|
| 2470 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2471 | ;;;; load-source-op |
|---|
| 2472 | |
|---|
| 2473 | (defclass load-source-op (basic-load-op) ()) |
|---|
| 2474 | |
|---|
| 2475 | (defmethod perform ((o load-source-op) (c cl-source-file)) |
|---|
| 2476 | (declare (ignorable o)) |
|---|
| 2477 | (let ((source (component-pathname c))) |
|---|
| 2478 | (setf (component-property c 'last-loaded-as-source) |
|---|
| 2479 | (and (call-with-around-compile-hook c (lambda () (load source))) |
|---|
| 2480 | (get-universal-time))))) |
|---|
| 2481 | |
|---|
| 2482 | (defmethod perform ((operation load-source-op) (c static-file)) |
|---|
| 2483 | (declare (ignorable operation c)) |
|---|
| 2484 | nil) |
|---|
| 2485 | |
|---|
| 2486 | (defmethod output-files ((operation load-source-op) (c component)) |
|---|
| 2487 | (declare (ignorable operation c)) |
|---|
| 2488 | nil) |
|---|
| 2489 | |
|---|
| 2490 | ;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right. |
|---|
| 2491 | (defmethod component-depends-on ((o load-source-op) (c component)) |
|---|
| 2492 | (declare (ignorable o)) |
|---|
| 2493 | (loop :with what-would-load-op-do = (component-depends-on 'load-op c) |
|---|
| 2494 | :for (op . co) :in what-would-load-op-do |
|---|
| 2495 | :when (eq op 'load-op) :collect (cons 'load-source-op co))) |
|---|
| 2496 | |
|---|
| 2497 | (defmethod operation-done-p ((o load-source-op) (c source-file)) |
|---|
| 2498 | (declare (ignorable o)) |
|---|
| 2499 | (if (or (not (component-property c 'last-loaded-as-source)) |
|---|
| 2500 | (> (safe-file-write-date (component-pathname c)) |
|---|
| 2501 | (component-property c 'last-loaded-as-source))) |
|---|
| 2502 | nil t)) |
|---|
| 2503 | |
|---|
| 2504 | (defmethod operation-description ((operation load-source-op) component) |
|---|
| 2505 | (declare (ignorable operation)) |
|---|
| 2506 | (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") |
|---|
| 2507 | component)) |
|---|
| 2508 | |
|---|
| 2509 | (defmethod operation-description ((operation load-source-op) (component module)) |
|---|
| 2510 | (declare (ignorable operation)) |
|---|
| 2511 | (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component)) |
|---|
| 2512 | |
|---|
| 2513 | |
|---|
| 2514 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2515 | ;;;; test-op |
|---|
| 2516 | |
|---|
| 2517 | (defclass test-op (operation) ()) |
|---|
| 2518 | |
|---|
| 2519 | (defmethod perform ((operation test-op) (c component)) |
|---|
| 2520 | (declare (ignorable operation c)) |
|---|
| 2521 | nil) |
|---|
| 2522 | |
|---|
| 2523 | (defmethod operation-done-p ((operation test-op) (c system)) |
|---|
| 2524 | "Testing a system is _never_ done." |
|---|
| 2525 | (declare (ignorable operation c)) |
|---|
| 2526 | nil) |
|---|
| 2527 | |
|---|
| 2528 | (defmethod component-depends-on :around ((o test-op) (c system)) |
|---|
| 2529 | (declare (ignorable o)) |
|---|
| 2530 | (cons `(load-op ,(component-name c)) (call-next-method))) |
|---|
| 2531 | |
|---|
| 2532 | |
|---|
| 2533 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2534 | ;;;; Invoking Operations |
|---|
| 2535 | |
|---|
| 2536 | (defgeneric* operate (operation-class system &key &allow-other-keys)) |
|---|
| 2537 | (defgeneric* perform-plan (plan &key)) |
|---|
| 2538 | |
|---|
| 2539 | ;;;; Try to upgrade of ASDF. If a different version was used, return T. |
|---|
| 2540 | ;;;; We need do that before we operate on anything that depends on ASDF. |
|---|
| 2541 | (defun* upgrade-asdf () |
|---|
| 2542 | (let ((version (asdf:asdf-version))) |
|---|
| 2543 | (handler-bind (((or style-warning warning) #'muffle-warning)) |
|---|
| 2544 | (operate 'load-op :asdf :verbose nil)) |
|---|
| 2545 | (let ((new-version (asdf:asdf-version))) |
|---|
| 2546 | (block nil |
|---|
| 2547 | (cond |
|---|
| 2548 | ((equal version new-version) |
|---|
| 2549 | (return nil)) |
|---|
| 2550 | ((version-satisfies new-version version) |
|---|
| 2551 | (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") |
|---|
| 2552 | version new-version)) |
|---|
| 2553 | ((version-satisfies version new-version) |
|---|
| 2554 | (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") |
|---|
| 2555 | version new-version)) |
|---|
| 2556 | (t |
|---|
| 2557 | (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") |
|---|
| 2558 | version new-version))) |
|---|
| 2559 | (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) |
|---|
| 2560 | ;; invalidate all systems but ASDF itself |
|---|
| 2561 | (setf *defined-systems* (make-defined-systems-table)) |
|---|
| 2562 | (register-system asdf) |
|---|
| 2563 | t))))) |
|---|
| 2564 | |
|---|
| 2565 | (defmethod perform-plan ((steps list) &key) |
|---|
| 2566 | (let ((*package* *package*) |
|---|
| 2567 | (*readtable* *readtable*)) |
|---|
| 2568 | (with-compilation-unit () |
|---|
| 2569 | (loop :for (op . component) :in steps :do |
|---|
| 2570 | (perform-with-restarts op component))))) |
|---|
| 2571 | |
|---|
| 2572 | (defmethod operate (operation-class system &rest args |
|---|
| 2573 | &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force |
|---|
| 2574 | &allow-other-keys) |
|---|
| 2575 | (declare (ignore force)) |
|---|
| 2576 | (with-system-definitions () |
|---|
| 2577 | (let* ((op (apply 'make-instance operation-class |
|---|
| 2578 | :original-initargs args |
|---|
| 2579 | args)) |
|---|
| 2580 | (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream))) |
|---|
| 2581 | (system (etypecase system |
|---|
| 2582 | (system system) |
|---|
| 2583 | ((or string symbol) (find-system system))))) |
|---|
| 2584 | (unless (version-satisfies system version) |
|---|
| 2585 | (error 'missing-component-of-version :requires system :version version)) |
|---|
| 2586 | (let ((steps (traverse op system))) |
|---|
| 2587 | (when (and (not (equal '("asdf") (component-find-path system))) |
|---|
| 2588 | (find '("asdf") (mapcar 'cdr steps) |
|---|
| 2589 | :test 'equal :key 'component-find-path) |
|---|
| 2590 | (upgrade-asdf)) |
|---|
| 2591 | ;; If we needed to upgrade ASDF to achieve our goal, |
|---|
| 2592 | ;; then do it specially as the first thing, then |
|---|
| 2593 | ;; invalidate all existing system |
|---|
| 2594 | ;; retry the whole thing with the new OPERATE function, |
|---|
| 2595 | ;; which on some implementations |
|---|
| 2596 | ;; has a new symbol shadowing the current one. |
|---|
| 2597 | (return-from operate |
|---|
| 2598 | (apply (find-symbol* 'operate :asdf) operation-class system args))) |
|---|
| 2599 | (perform-plan steps) |
|---|
| 2600 | (values op steps))))) |
|---|
| 2601 | |
|---|
| 2602 | (defun* oos (operation-class system &rest args &key force verbose version |
|---|
| 2603 | &allow-other-keys) |
|---|
| 2604 | (declare (ignore force verbose version)) |
|---|
| 2605 | (apply 'operate operation-class system args)) |
|---|
| 2606 | |
|---|
| 2607 | (let ((operate-docstring |
|---|
| 2608 | "Operate does three things: |
|---|
| 2609 | |
|---|
| 2610 | 1. It creates an instance of OPERATION-CLASS using any keyword parameters |
|---|
| 2611 | as initargs. |
|---|
| 2612 | 2. It finds the asdf-system specified by SYSTEM (possibly loading |
|---|
| 2613 | it from disk). |
|---|
| 2614 | 3. It then calls TRAVERSE with the operation and system as arguments |
|---|
| 2615 | |
|---|
| 2616 | The traverse operation is wrapped in WITH-COMPILATION-UNIT and error |
|---|
| 2617 | handling code. If a VERSION argument is supplied, then operate also |
|---|
| 2618 | ensures that the system found satisfies it using the VERSION-SATISFIES |
|---|
| 2619 | method. |
|---|
| 2620 | |
|---|
| 2621 | Note that dependencies may cause the operation to invoke other |
|---|
| 2622 | operations on the system or its components: the new operations will be |
|---|
| 2623 | created with the same initargs as the original one. |
|---|
| 2624 | ")) |
|---|
| 2625 | (setf (documentation 'oos 'function) |
|---|
| 2626 | (format nil |
|---|
| 2627 | "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" |
|---|
| 2628 | operate-docstring)) |
|---|
| 2629 | (setf (documentation 'operate 'function) |
|---|
| 2630 | operate-docstring)) |
|---|
| 2631 | |
|---|
| 2632 | (defun* load-system (system &rest args &key force verbose version &allow-other-keys) |
|---|
| 2633 | "Shorthand for `(operate 'asdf:load-op system)`. |
|---|
| 2634 | See OPERATE for details." |
|---|
| 2635 | (declare (ignore force verbose version)) |
|---|
| 2636 | (apply 'operate 'load-op system args) |
|---|
| 2637 | t) |
|---|
| 2638 | |
|---|
| 2639 | (defun* compile-system (system &rest args &key force verbose version |
|---|
| 2640 | &allow-other-keys) |
|---|
| 2641 | "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE |
|---|
| 2642 | for details." |
|---|
| 2643 | (declare (ignore force verbose version)) |
|---|
| 2644 | (apply 'operate 'compile-op system args) |
|---|
| 2645 | t) |
|---|
| 2646 | |
|---|
| 2647 | (defun* test-system (system &rest args &key force verbose version |
|---|
| 2648 | &allow-other-keys) |
|---|
| 2649 | "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for |
|---|
| 2650 | details." |
|---|
| 2651 | (declare (ignore force verbose version)) |
|---|
| 2652 | (apply 'operate 'test-op system args) |
|---|
| 2653 | t) |
|---|
| 2654 | |
|---|
| 2655 | ;;;; ------------------------------------------------------------------------- |
|---|
| 2656 | ;;;; Defsystem |
|---|
| 2657 | |
|---|
| 2658 | (defun* load-pathname () |
|---|
| 2659 | (resolve-symlinks* (or *load-pathname* *compile-file-pathname*))) |
|---|
| 2660 | |
|---|
| 2661 | (defun* determine-system-pathname (pathname pathname-supplied-p) |
|---|
| 2662 | ;; The defsystem macro calls us to determine |
|---|
| 2663 | ;; the pathname of a system as follows: |
|---|
| 2664 | ;; 1. the one supplied, |
|---|
| 2665 | ;; 2. derived from *load-pathname* via load-pathname |
|---|
| 2666 | ;; 3. taken from the *default-pathname-defaults* via default-directory |
|---|
| 2667 | (let* ((file-pathname (load-pathname)) |
|---|
| 2668 | (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname)))) |
|---|
| 2669 | (or (and pathname-supplied-p |
|---|
| 2670 | (merge-pathnames* (coerce-pathname pathname :type :directory) |
|---|
| 2671 | directory-pathname)) |
|---|
| 2672 | directory-pathname |
|---|
| 2673 | (default-directory)))) |
|---|
| 2674 | |
|---|
| 2675 | (defun* class-for-type (parent type) |
|---|
| 2676 | (or (loop :for symbol :in (list |
|---|
| 2677 | type |
|---|
| 2678 | (find-symbol* type *package*) |
|---|
| 2679 | (find-symbol* type :asdf)) |
|---|
| 2680 | :for class = (and symbol (find-class symbol nil)) |
|---|
| 2681 | :when (and class |
|---|
| 2682 | (#-cormanlisp subtypep #+cormanlisp cl::subclassp |
|---|
| 2683 | class (find-class 'component))) |
|---|
| 2684 | :return class) |
|---|
| 2685 | (and (eq type :file) |
|---|
| 2686 | (or (and parent (module-default-component-class parent)) |
|---|
| 2687 | (find-class *default-component-class*))) |
|---|
| 2688 | (sysdef-error "don't recognize component type ~A" type))) |
|---|
| 2689 | |
|---|
| 2690 | (defun* maybe-add-tree (tree op1 op2 c) |
|---|
| 2691 | "Add the node C at /OP1/OP2 in TREE, unless it's there already. |
|---|
| 2692 | Returns the new tree (which probably shares structure with the old one)" |
|---|
| 2693 | (let ((first-op-tree (assoc op1 tree))) |
|---|
| 2694 | (if first-op-tree |
|---|
| 2695 | (progn |
|---|
| 2696 | (aif (assoc op2 (cdr first-op-tree)) |
|---|
| 2697 | (if (find c (cdr it)) |
|---|
| 2698 | nil |
|---|
| 2699 | (setf (cdr it) (cons c (cdr it)))) |
|---|
| 2700 | (setf (cdr first-op-tree) |
|---|
| 2701 | (acons op2 (list c) (cdr first-op-tree)))) |
|---|
| 2702 | tree) |
|---|
| 2703 | (acons op1 (list (list op2 c)) tree)))) |
|---|
| 2704 | |
|---|
| 2705 | (defun* union-of-dependencies (&rest deps) |
|---|
| 2706 | (let ((new-tree nil)) |
|---|
| 2707 | (dolist (dep deps) |
|---|
| 2708 | (dolist (op-tree dep) |
|---|
| 2709 | (dolist (op (cdr op-tree)) |
|---|
| 2710 | (dolist (c (cdr op)) |
|---|
| 2711 | (setf new-tree |
|---|
| 2712 | (maybe-add-tree new-tree (car op-tree) (car op) c)))))) |
|---|
| 2713 | new-tree)) |
|---|
| 2714 | |
|---|
| 2715 | |
|---|
| 2716 | (defvar *serial-depends-on* nil) |
|---|
| 2717 | |
|---|
| 2718 | (defun* sysdef-error-component (msg type name value) |
|---|
| 2719 | (sysdef-error (concatenate 'string msg |
|---|
| 2720 | (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) |
|---|
| 2721 | type name value)) |
|---|
| 2722 | |
|---|
| 2723 | (defun* check-component-input (type name weakly-depends-on |
|---|
| 2724 | depends-on components in-order-to) |
|---|
| 2725 | "A partial test of the values of a component." |
|---|
| 2726 | (unless (listp depends-on) |
|---|
| 2727 | (sysdef-error-component ":depends-on must be a list." |
|---|
| 2728 | type name depends-on)) |
|---|
| 2729 | (unless (listp weakly-depends-on) |
|---|
| 2730 | (sysdef-error-component ":weakly-depends-on must be a list." |
|---|
| 2731 | type name weakly-depends-on)) |
|---|
| 2732 | (unless (listp components) |
|---|
| 2733 | (sysdef-error-component ":components must be NIL or a list of components." |
|---|
| 2734 | type name components)) |
|---|
| 2735 | (unless (and (listp in-order-to) (listp (car in-order-to))) |
|---|
| 2736 | (sysdef-error-component ":in-order-to must be NIL or a list of components." |
|---|
| 2737 | type name in-order-to))) |
|---|
| 2738 | |
|---|
| 2739 | (defun* %remove-component-inline-methods (component) |
|---|
| 2740 | (dolist (name +asdf-methods+) |
|---|
| 2741 | (map () |
|---|
| 2742 | ;; this is inefficient as most of the stored |
|---|
| 2743 | ;; methods will not be for this particular gf |
|---|
| 2744 | ;; But this is hardly performance-critical |
|---|
| 2745 | #'(lambda (m) |
|---|
| 2746 | (remove-method (symbol-function name) m)) |
|---|
| 2747 | (component-inline-methods component))) |
|---|
| 2748 | ;; clear methods, then add the new ones |
|---|
| 2749 | (setf (component-inline-methods component) nil)) |
|---|
| 2750 | |
|---|
| 2751 | (defun* %define-component-inline-methods (ret rest) |
|---|
| 2752 | (dolist (name +asdf-methods+) |
|---|
| 2753 | (let ((keyword (intern (symbol-name name) :keyword))) |
|---|
| 2754 | (loop :for data = rest :then (cddr data) |
|---|
| 2755 | :for key = (first data) |
|---|
| 2756 | :for value = (second data) |
|---|
| 2757 | :while data |
|---|
| 2758 | :when (eq key keyword) :do |
|---|
| 2759 | (destructuring-bind (op qual (o c) &body body) value |
|---|
| 2760 | (pushnew |
|---|
| 2761 | (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret))) |
|---|
| 2762 | ,@body)) |
|---|
| 2763 | (component-inline-methods ret))))))) |
|---|
| 2764 | |
|---|
| 2765 | (defun* %refresh-component-inline-methods (component rest) |
|---|
| 2766 | (%remove-component-inline-methods component) |
|---|
| 2767 | (%define-component-inline-methods component rest)) |
|---|
| 2768 | |
|---|
| 2769 | (defun* parse-component-form (parent options) |
|---|
| 2770 | (destructuring-bind |
|---|
| 2771 | (type name &rest rest &key |
|---|
| 2772 | ;; the following list of keywords is reproduced below in the |
|---|
| 2773 | ;; remove-keys form. important to keep them in sync |
|---|
| 2774 | components pathname default-component-class |
|---|
| 2775 | perform explain output-files operation-done-p |
|---|
| 2776 | weakly-depends-on |
|---|
| 2777 | depends-on serial in-order-to do-first |
|---|
| 2778 | (version nil versionp) |
|---|
| 2779 | ;; list ends |
|---|
| 2780 | &allow-other-keys) options |
|---|
| 2781 | (declare (ignorable perform explain output-files operation-done-p)) |
|---|
| 2782 | (check-component-input type name weakly-depends-on depends-on components in-order-to) |
|---|
| 2783 | |
|---|
| 2784 | (when (and parent |
|---|
| 2785 | (find-component parent name) |
|---|
| 2786 | ;; ignore the same object when rereading the defsystem |
|---|
| 2787 | (not |
|---|
| 2788 | (typep (find-component parent name) |
|---|
| 2789 | (class-for-type parent type)))) |
|---|
| 2790 | (error 'duplicate-names :name name)) |
|---|
| 2791 | |
|---|
| 2792 | (when versionp |
|---|
| 2793 | (unless (parse-version version nil) |
|---|
| 2794 | (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") |
|---|
| 2795 | version name parent))) |
|---|
| 2796 | |
|---|
| 2797 | (let* ((other-args (remove-keys |
|---|
| 2798 | '(components pathname default-component-class |
|---|
| 2799 | perform explain output-files operation-done-p |
|---|
| 2800 | weakly-depends-on |
|---|
| 2801 | depends-on serial in-order-to) |
|---|
| 2802 | rest)) |
|---|
| 2803 | (ret (find-component parent name))) |
|---|
| 2804 | (when weakly-depends-on |
|---|
| 2805 | (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) |
|---|
| 2806 | (when *serial-depends-on* |
|---|
| 2807 | (push *serial-depends-on* depends-on)) |
|---|
| 2808 | (if ret |
|---|
| 2809 | (apply 'reinitialize-instance ret |
|---|
| 2810 | :name (coerce-name name) |
|---|
| 2811 | :pathname pathname |
|---|
| 2812 | :parent parent |
|---|
| 2813 | other-args) |
|---|
| 2814 | (setf ret |
|---|
| 2815 | (apply 'make-instance (class-for-type parent type) |
|---|
| 2816 | :name (coerce-name name) |
|---|
| 2817 | :pathname pathname |
|---|
| 2818 | :parent parent |
|---|
| 2819 | other-args))) |
|---|
| 2820 | (component-pathname ret) ; eagerly compute the absolute pathname |
|---|
| 2821 | (when (typep ret 'module) |
|---|
| 2822 | (setf (module-default-component-class ret) |
|---|
| 2823 | (or default-component-class |
|---|
| 2824 | (and (typep parent 'module) |
|---|
| 2825 | (module-default-component-class parent)))) |
|---|
| 2826 | (let ((*serial-depends-on* nil)) |
|---|
| 2827 | (setf (module-components ret) |
|---|
| 2828 | (loop |
|---|
| 2829 | :for c-form :in components |
|---|
| 2830 | :for c = (parse-component-form ret c-form) |
|---|
| 2831 | :for name = (component-name c) |
|---|
| 2832 | :collect c |
|---|
| 2833 | :when serial :do (setf *serial-depends-on* name)))) |
|---|
| 2834 | (compute-module-components-by-name ret)) |
|---|
| 2835 | |
|---|
| 2836 | (setf (component-load-dependencies ret) depends-on) ;; Used by POIU |
|---|
| 2837 | |
|---|
| 2838 | (setf (component-in-order-to ret) |
|---|
| 2839 | (union-of-dependencies |
|---|
| 2840 | in-order-to |
|---|
| 2841 | `((compile-op (compile-op ,@depends-on)) |
|---|
| 2842 | (load-op (load-op ,@depends-on))))) |
|---|
| 2843 | (setf (component-do-first ret) |
|---|
| 2844 | (union-of-dependencies |
|---|
| 2845 | do-first |
|---|
| 2846 | `((compile-op (load-op ,@depends-on))))) |
|---|
| 2847 | |
|---|
| 2848 | (%refresh-component-inline-methods ret rest) |
|---|
| 2849 | ret))) |
|---|
| 2850 | |
|---|
| 2851 | (defun* do-defsystem (name &rest options |
|---|
| 2852 | &key (pathname nil pathname-arg-p) (class 'system) |
|---|
| 2853 | defsystem-depends-on &allow-other-keys) |
|---|
| 2854 | ;; The system must be registered before we parse the body, |
|---|
| 2855 | ;; otherwise we recur when trying to find an existing system |
|---|
| 2856 | ;; of the same name to reuse options (e.g. pathname) from. |
|---|
| 2857 | ;; To avoid infinite recursion in cases where you defsystem a system |
|---|
| 2858 | ;; that is registered to a different location to find-system, |
|---|
| 2859 | ;; we also need to remember it in a special variable *systems-being-defined*. |
|---|
| 2860 | (with-system-definitions () |
|---|
| 2861 | (let* ((name (coerce-name name)) |
|---|
| 2862 | (registered (system-registered-p name)) |
|---|
| 2863 | (system (cdr (or registered |
|---|
| 2864 | (register-system (make-instance 'system :name name))))) |
|---|
| 2865 | (component-options (remove-keys '(:class) options))) |
|---|
| 2866 | (%set-system-source-file (load-pathname) system) |
|---|
| 2867 | (setf (gethash name *systems-being-defined*) system) |
|---|
| 2868 | (when registered |
|---|
| 2869 | (setf (car registered) (get-universal-time))) |
|---|
| 2870 | (map () 'load-system defsystem-depends-on) |
|---|
| 2871 | ;; We change-class (when necessary) AFTER we load the defsystem-dep's |
|---|
| 2872 | ;; since the class might not be defined as part of those. |
|---|
| 2873 | (let ((class (class-for-type nil class))) |
|---|
| 2874 | (unless (eq (type-of system) class) |
|---|
| 2875 | (change-class system class))) |
|---|
| 2876 | (parse-component-form |
|---|
| 2877 | nil (list* |
|---|
| 2878 | :module name |
|---|
| 2879 | :pathname (determine-system-pathname pathname pathname-arg-p) |
|---|
| 2880 | component-options))))) |
|---|
| 2881 | |
|---|
| 2882 | (defmacro defsystem (name &body options) |
|---|
| 2883 | `(apply 'do-defsystem ',name ',options)) |
|---|
| 2884 | |
|---|
| 2885 | ;;;; --------------------------------------------------------------------------- |
|---|
| 2886 | ;;;; run-shell-command |
|---|
| 2887 | ;;;; |
|---|
| 2888 | ;;;; run-shell-command functions for other lisp implementations will be |
|---|
| 2889 | ;;;; gratefully accepted, if they do the same thing. |
|---|
| 2890 | ;;;; If the docstring is ambiguous, send a bug report. |
|---|
| 2891 | ;;;; |
|---|
| 2892 | ;;;; WARNING! The function below is mostly dysfunctional. |
|---|
| 2893 | ;;;; For instance, it will probably run fine on most implementations on Unix, |
|---|
| 2894 | ;;;; which will hopefully use the shell /bin/sh (which we force in some cases) |
|---|
| 2895 | ;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell. |
|---|
| 2896 | ;;;; But behavior on Windows may vary wildly between implementations, |
|---|
| 2897 | ;;;; either relying on your having installed a POSIX sh, or going through |
|---|
| 2898 | ;;;; the CMD.EXE interpreter, for a totally different meaning, depending on |
|---|
| 2899 | ;;;; what is easily expressible in said implementation. |
|---|
| 2900 | ;;;; |
|---|
| 2901 | ;;;; We probably should move this functionality to its own system and deprecate |
|---|
| 2902 | ;;;; use of it from the asdf package. However, this would break unspecified |
|---|
| 2903 | ;;;; existing software, so until a clear alternative exists, we can't deprecate |
|---|
| 2904 | ;;;; it, and even after it's been deprecated, we will support it for a few |
|---|
| 2905 | ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01 |
|---|
| 2906 | ;;;; |
|---|
| 2907 | ;;;; As a suggested replacement which is portable to all ASDF-supported |
|---|
| 2908 | ;;;; implementations and operating systems except Genera, I recommend |
|---|
| 2909 | ;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its |
|---|
| 2910 | ;;;; derivatives such as xcvb-driver:run-program/for-side-effects. |
|---|
| 2911 | |
|---|
| 2912 | (defun* run-shell-command (control-string &rest args) |
|---|
| 2913 | "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and |
|---|
| 2914 | synchronously execute the result using a Bourne-compatible shell, with |
|---|
| 2915 | output to *VERBOSE-OUT*. Returns the shell's exit code." |
|---|
| 2916 | (let ((command (apply 'format nil control-string args))) |
|---|
| 2917 | (asdf-message "; $ ~A~%" command) |
|---|
| 2918 | |
|---|
| 2919 | #+abcl |
|---|
| 2920 | (ext:run-shell-command command :output *verbose-out*) |
|---|
| 2921 | |
|---|
| 2922 | #+allegro |
|---|
| 2923 | ;; will this fail if command has embedded quotes - it seems to work |
|---|
| 2924 | (multiple-value-bind (stdout stderr exit-code) |
|---|
| 2925 | (excl.osi:command-output |
|---|
| 2926 | #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command) |
|---|
| 2927 | #+mswindows command ; BEWARE! |
|---|
| 2928 | :input nil :whole nil |
|---|
| 2929 | #+mswindows :show-window #+mswindows :hide) |
|---|
| 2930 | (asdf-message "~{~&~a~%~}~%" stderr) |
|---|
| 2931 | (asdf-message "~{~&~a~%~}~%" stdout) |
|---|
| 2932 | exit-code) |
|---|
| 2933 | |
|---|
| 2934 | #+clisp |
|---|
| 2935 | ;; CLISP returns NIL for exit status zero. |
|---|
| 2936 | (if *verbose-out* |
|---|
| 2937 | (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r" |
|---|
| 2938 | command)) |
|---|
| 2939 | (outstream (ext:run-shell-command new-command :output :stream :wait t))) |
|---|
| 2940 | (multiple-value-bind (retval out-lines) |
|---|
| 2941 | (unwind-protect |
|---|
| 2942 | (parse-clisp-shell-output outstream) |
|---|
| 2943 | (ignore-errors (close outstream))) |
|---|
| 2944 | (asdf-message "~{~&~a~%~}~%" out-lines) |
|---|
| 2945 | retval)) |
|---|
| 2946 | ;; there will be no output, just grab up the exit status |
|---|
| 2947 | (or (ext:run-shell-command command :output nil :wait t) 0)) |
|---|
| 2948 | |
|---|
| 2949 | #+clozure |
|---|
| 2950 | (nth-value 1 |
|---|
| 2951 | (ccl:external-process-status |
|---|
| 2952 | (ccl:run-program |
|---|
| 2953 | (cond |
|---|
| 2954 | ((os-unix-p) "/bin/sh") |
|---|
| 2955 | ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! |
|---|
| 2956 | (t (error "Unsupported OS"))) |
|---|
| 2957 | (if (os-unix-p) (list "-c" command) '()) |
|---|
| 2958 | :input nil :output *verbose-out* :wait t))) |
|---|
| 2959 | |
|---|
| 2960 | #+(or cmu scl) |
|---|
| 2961 | (ext:process-exit-code |
|---|
| 2962 | (ext:run-program |
|---|
| 2963 | "/bin/sh" |
|---|
| 2964 | (list "-c" command) |
|---|
| 2965 | :input nil :output *verbose-out*)) |
|---|
| 2966 | |
|---|
| 2967 | #+ecl ;; courtesy of Juan Jose Garcia Ripoll |
|---|
| 2968 | (ext:system command) |
|---|
| 2969 | |
|---|
| 2970 | #+gcl |
|---|
| 2971 | (lisp:system command) |
|---|
| 2972 | |
|---|
| 2973 | #+lispworks |
|---|
| 2974 | (apply 'system:call-system-showing-output command |
|---|
| 2975 | :show-cmd nil :prefix "" :output-stream *verbose-out* |
|---|
| 2976 | (when (os-unix-p) '(:shell-type "/bin/sh"))) |
|---|
| 2977 | |
|---|
| 2978 | #+mcl |
|---|
| 2979 | (ccl::with-cstrs ((%command command)) (_system %command)) |
|---|
| 2980 | |
|---|
| 2981 | #+sbcl |
|---|
| 2982 | (sb-ext:process-exit-code |
|---|
| 2983 | (apply 'sb-ext:run-program |
|---|
| 2984 | #+win32 "sh" #-win32 "/bin/sh" |
|---|
| 2985 | (list "-c" command) |
|---|
| 2986 | :input nil :output *verbose-out* |
|---|
| 2987 | #+win32 '(:search t) #-win32 nil)) |
|---|
| 2988 | |
|---|
| 2989 | #+xcl |
|---|
| 2990 | (ext:run-shell-command command) |
|---|
| 2991 | |
|---|
| 2992 | #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl) |
|---|
| 2993 | (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) |
|---|
| 2994 | |
|---|
| 2995 | #+clisp |
|---|
| 2996 | (defun* parse-clisp-shell-output (stream) |
|---|
| 2997 | "Helper function for running shell commands under clisp. Parses a specially- |
|---|
| 2998 | crafted output string to recover the exit status of the shell command and a |
|---|
| 2999 | list of lines of output." |
|---|
| 3000 | (loop :with status-prefix = "ASDF-EXIT-STATUS " |
|---|
| 3001 | :with prefix-length = (length status-prefix) |
|---|
| 3002 | :with exit-status = -1 :with lines = () |
|---|
| 3003 | :for line = (read-line stream nil nil) |
|---|
| 3004 | :while line :do (push line lines) :finally |
|---|
| 3005 | (let* ((last (car lines)) |
|---|
| 3006 | (status (and last (>= (length last) prefix-length) |
|---|
| 3007 | (string-equal last status-prefix :end1 prefix-length) |
|---|
| 3008 | (parse-integer last :start prefix-length :junk-allowed t)))) |
|---|
| 3009 | (when status |
|---|
| 3010 | (setf exit-status status) |
|---|
| 3011 | (pop lines) (when (equal "" (car lines)) (pop lines))) |
|---|
| 3012 | (return (values exit-status (reverse lines)))))) |
|---|
| 3013 | |
|---|
| 3014 | ;;;; --------------------------------------------------------------------------- |
|---|
| 3015 | ;;;; system-relative-pathname |
|---|
| 3016 | |
|---|
| 3017 | (defun* system-definition-pathname (x) |
|---|
| 3018 | ;; As of 2.014.8, we mean to make this function obsolete, |
|---|
| 3019 | ;; but that won't happen until all clients have been updated. |
|---|
| 3020 | ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" |
|---|
| 3021 | "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. |
|---|
| 3022 | It used to expose ASDF internals with subtle differences with respect to |
|---|
| 3023 | user expectations, that have been refactored away since. |
|---|
| 3024 | We recommend you use ASDF:SYSTEM-SOURCE-FILE instead |
|---|
| 3025 | for a mostly compatible replacement that we're supporting, |
|---|
| 3026 | or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME |
|---|
| 3027 | if that's whay you mean." ;;) |
|---|
| 3028 | (system-source-file x)) |
|---|
| 3029 | |
|---|
| 3030 | (defmethod system-source-file ((system system)) |
|---|
| 3031 | (%system-source-file system)) |
|---|
| 3032 | (defmethod system-source-file ((system-name string)) |
|---|
| 3033 | (%system-source-file (find-system system-name))) |
|---|
| 3034 | (defmethod system-source-file ((system-name symbol)) |
|---|
| 3035 | (%system-source-file (find-system system-name))) |
|---|
| 3036 | |
|---|
| 3037 | (defun* system-source-directory (system-designator) |
|---|
| 3038 | "Return a pathname object corresponding to the |
|---|
| 3039 | directory in which the system specification (.asd file) is |
|---|
| 3040 | located." |
|---|
| 3041 | (pathname-directory-pathname (system-source-file system-designator))) |
|---|
| 3042 | |
|---|
| 3043 | (defun* relativize-directory (directory) |
|---|
| 3044 | (cond |
|---|
| 3045 | ((stringp directory) |
|---|
| 3046 | (list :relative directory)) |
|---|
| 3047 | ((eq (car directory) :absolute) |
|---|
| 3048 | (cons :relative (cdr directory))) |
|---|
| 3049 | (t |
|---|
| 3050 | directory))) |
|---|
| 3051 | |
|---|
| 3052 | (defun* relativize-pathname-directory (pathspec) |
|---|
| 3053 | (let ((p (pathname pathspec))) |
|---|
| 3054 | (make-pathname |
|---|
| 3055 | :directory (relativize-directory (pathname-directory p)) |
|---|
| 3056 | :defaults p))) |
|---|
| 3057 | |
|---|
| 3058 | (defun* system-relative-pathname (system name &key type) |
|---|
| 3059 | (merge-pathnames* |
|---|
| 3060 | (coerce-pathname name :type type) |
|---|
| 3061 | (system-source-directory system))) |
|---|
| 3062 | |
|---|
| 3063 | |
|---|
| 3064 | ;;; --------------------------------------------------------------------------- |
|---|
| 3065 | ;;; implementation-identifier |
|---|
| 3066 | ;;; |
|---|
| 3067 | ;;; produce a string to identify current implementation. |
|---|
| 3068 | ;;; Initially stolen from SLIME's SWANK, rewritten since. |
|---|
| 3069 | ;;; The (car '(...)) idiom avoids unreachable code warnings. |
|---|
| 3070 | |
|---|
| 3071 | (defparameter *implementation-type* |
|---|
| 3072 | (car '(#+abcl :abcl #+allegro :acl |
|---|
| 3073 | #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu |
|---|
| 3074 | #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl |
|---|
| 3075 | #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl))) |
|---|
| 3076 | |
|---|
| 3077 | (defparameter *operating-system* |
|---|
| 3078 | (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win |
|---|
| 3079 | #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd. |
|---|
| 3080 | #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd |
|---|
| 3081 | #+(or solaris sunos) :solaris |
|---|
| 3082 | #+(or freebsd netbsd openbsd bsd) :bsd |
|---|
| 3083 | #+unix :unix |
|---|
| 3084 | #+genera :genera))) |
|---|
| 3085 | |
|---|
| 3086 | (defparameter *architecture* |
|---|
| 3087 | (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64 |
|---|
| 3088 | #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86 |
|---|
| 3089 | #+hppa64 :hppa64 #+hppa :hppa |
|---|
| 3090 | #+(or ppc64 ppc64-target) :ppc64 |
|---|
| 3091 | #+(or ppc32 ppc32-target ppc powerpc) :ppc32 |
|---|
| 3092 | #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32 |
|---|
| 3093 | #+(or arm arm-target) :arm |
|---|
| 3094 | #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java |
|---|
| 3095 | #+mipsel :mispel #+mipseb :mipseb #+mips :mips |
|---|
| 3096 | #+alpha :alpha #+imach :imach))) |
|---|
| 3097 | |
|---|
| 3098 | (defparameter *lisp-version-string* |
|---|
| 3099 | (let ((s (lisp-implementation-version))) |
|---|
| 3100 | (car |
|---|
| 3101 | (list |
|---|
| 3102 | #+allegro |
|---|
| 3103 | (format nil "~A~A~@[~A~]" |
|---|
| 3104 | excl::*common-lisp-version-number* |
|---|
| 3105 | ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox |
|---|
| 3106 | (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") |
|---|
| 3107 | ;; Note if not using International ACL |
|---|
| 3108 | ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm |
|---|
| 3109 | (excl:ics-target-case (:-ics "8"))) |
|---|
| 3110 | #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) |
|---|
| 3111 | #+clisp |
|---|
| 3112 | (subseq s 0 (position #\space s)) ; strip build information (date, etc.) |
|---|
| 3113 | #+clozure |
|---|
| 3114 | (format nil "~d.~d-f~d" ; shorten for windows |
|---|
| 3115 | ccl::*openmcl-major-version* |
|---|
| 3116 | ccl::*openmcl-minor-version* |
|---|
| 3117 | (logand ccl::fasl-version #xFF)) |
|---|
| 3118 | #+cmu (substitute #\- #\/ s) |
|---|
| 3119 | #+ecl (format nil "~A~@[-~A~]" s |
|---|
| 3120 | (let ((vcs-id (ext:lisp-implementation-vcs-id))) |
|---|
| 3121 | (subseq vcs-id 0 (min (length vcs-id) 8)))) |
|---|
| 3122 | #+gcl (subseq s (1+ (position #\space s))) |
|---|
| 3123 | #+genera |
|---|
| 3124 | (multiple-value-bind (major minor) (sct:get-system-version "System") |
|---|
| 3125 | (format nil "~D.~D" major minor)) |
|---|
| 3126 | #+mcl (subseq s 8) ; strip the leading "Version " |
|---|
| 3127 | s)))) |
|---|
| 3128 | |
|---|
| 3129 | (defun* implementation-type () |
|---|
| 3130 | *implementation-type*) |
|---|
| 3131 | |
|---|
| 3132 | (defun* implementation-identifier () |
|---|
| 3133 | (substitute-if |
|---|
| 3134 | #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) |
|---|
| 3135 | (format nil "~(~a~@{~@[-~a~]~}~)" |
|---|
| 3136 | (or *implementation-type* (lisp-implementation-type)) |
|---|
| 3137 | (or *lisp-version-string* (lisp-implementation-version)) |
|---|
| 3138 | (or *operating-system* (software-type)) |
|---|
| 3139 | (or *architecture* (machine-type))))) |
|---|
| 3140 | |
|---|
| 3141 | |
|---|
| 3142 | ;;; --------------------------------------------------------------------------- |
|---|
| 3143 | ;;; Generic support for configuration files |
|---|
| 3144 | |
|---|
| 3145 | (defun inter-directory-separator () |
|---|
| 3146 | (if (os-unix-p) #\: #\;)) |
|---|
| 3147 | |
|---|
| 3148 | (defun* user-homedir () |
|---|
| 3149 | (truenamize |
|---|
| 3150 | (pathname-directory-pathname |
|---|
| 3151 | #+mcl (current-user-homedir-pathname) |
|---|
| 3152 | #-mcl (user-homedir-pathname)))) |
|---|
| 3153 | |
|---|
| 3154 | (defun* try-directory-subpath (x sub &key type) |
|---|
| 3155 | (let* ((p (and x (ensure-directory-pathname x))) |
|---|
| 3156 | (tp (and p (probe-file* p))) |
|---|
| 3157 | (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p))) |
|---|
| 3158 | (ts (and sp (probe-file* sp)))) |
|---|
| 3159 | (and ts (values sp ts)))) |
|---|
| 3160 | (defun* user-configuration-directories () |
|---|
| 3161 | (let ((dirs |
|---|
| 3162 | (flet ((try (x sub) (try-directory-subpath x sub))) |
|---|
| 3163 | `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/") |
|---|
| 3164 | ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") |
|---|
| 3165 | :for dir :in (split-string dirs :separator ":") |
|---|
| 3166 | :collect (try dir "common-lisp/")) |
|---|
| 3167 | ,@(when (os-windows-p) |
|---|
| 3168 | `(,(try (or #+lispworks (sys:get-folder-path :local-appdata) |
|---|
| 3169 | (getenv "LOCALAPPDATA")) |
|---|
| 3170 | "common-lisp/config/") |
|---|
| 3171 | ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData |
|---|
| 3172 | ,(try (or #+lispworks (sys:get-folder-path :appdata) |
|---|
| 3173 | (getenv "APPDATA")) |
|---|
| 3174 | "common-lisp/config/"))) |
|---|
| 3175 | ,(try (user-homedir) ".config/common-lisp/"))))) |
|---|
| 3176 | (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) |
|---|
| 3177 | (defun* system-configuration-directories () |
|---|
| 3178 | (cond |
|---|
| 3179 | ((os-unix-p) '(#p"/etc/common-lisp/")) |
|---|
| 3180 | ((os-windows-p) |
|---|
| 3181 | (aif |
|---|
| 3182 | (flet ((try (x sub) (try-directory-subpath x sub))) |
|---|
| 3183 | ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData |
|---|
| 3184 | (try (or #+lispworks (sys:get-folder-path :common-appdata) |
|---|
| 3185 | (getenv "ALLUSERSAPPDATA") |
|---|
| 3186 | (try (getenv "ALLUSERSPROFILE") "Application Data/")) |
|---|
| 3187 | "common-lisp/config/")) |
|---|
| 3188 | (list it))))) |
|---|
| 3189 | |
|---|
| 3190 | (defun* in-first-directory (dirs x) |
|---|
| 3191 | (loop :for dir :in dirs |
|---|
| 3192 | :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) |
|---|
| 3193 | (defun* in-user-configuration-directory (x) |
|---|
| 3194 | (in-first-directory (user-configuration-directories) x)) |
|---|
| 3195 | (defun* in-system-configuration-directory (x) |
|---|
| 3196 | (in-first-directory (system-configuration-directories) x)) |
|---|
| 3197 | |
|---|
| 3198 | (defun* configuration-inheritance-directive-p (x) |
|---|
| 3199 | (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) |
|---|
| 3200 | (or (member x kw) |
|---|
| 3201 | (and (length=n-p x 1) (member (car x) kw))))) |
|---|
| 3202 | |
|---|
| 3203 | (defun* report-invalid-form (reporter &rest args) |
|---|
| 3204 | (etypecase reporter |
|---|
| 3205 | (null |
|---|
| 3206 | (apply 'error 'invalid-configuration args)) |
|---|
| 3207 | (function |
|---|
| 3208 | (apply reporter args)) |
|---|
| 3209 | ((or symbol string) |
|---|
| 3210 | (apply 'error reporter args)) |
|---|
| 3211 | (cons |
|---|
| 3212 | (apply 'apply (append reporter args))))) |
|---|
| 3213 | |
|---|
| 3214 | (defvar *ignored-configuration-form* nil) |
|---|
| 3215 | |
|---|
| 3216 | (defun* validate-configuration-form (form tag directive-validator |
|---|
| 3217 | &key location invalid-form-reporter) |
|---|
| 3218 | (unless (and (consp form) (eq (car form) tag)) |
|---|
| 3219 | (setf *ignored-configuration-form* t) |
|---|
| 3220 | (report-invalid-form invalid-form-reporter :form form :location location) |
|---|
| 3221 | (return-from validate-configuration-form nil)) |
|---|
| 3222 | (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) |
|---|
| 3223 | :for directive :in (cdr form) |
|---|
| 3224 | :when (cond |
|---|
| 3225 | ((configuration-inheritance-directive-p directive) |
|---|
| 3226 | (incf inherit) t) |
|---|
| 3227 | ((eq directive :ignore-invalid-entries) |
|---|
| 3228 | (setf ignore-invalid-p t) t) |
|---|
| 3229 | ((funcall directive-validator directive) |
|---|
| 3230 | t) |
|---|
| 3231 | (ignore-invalid-p |
|---|
| 3232 | nil) |
|---|
| 3233 | (t |
|---|
| 3234 | (setf *ignored-configuration-form* t) |
|---|
| 3235 | (report-invalid-form invalid-form-reporter :form directive :location location) |
|---|
| 3236 | nil)) |
|---|
| 3237 | :do (push directive x) |
|---|
| 3238 | :finally |
|---|
| 3239 | (unless (= inherit 1) |
|---|
| 3240 | (report-invalid-form invalid-form-reporter |
|---|
| 3241 | :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>") |
|---|
| 3242 | :inherit-configuration :ignore-inherited-configuration))) |
|---|
| 3243 | (return (nreverse x)))) |
|---|
| 3244 | |
|---|
| 3245 | (defun* validate-configuration-file (file validator &key description) |
|---|
| 3246 | (let ((forms (read-file-forms file))) |
|---|
| 3247 | (unless (length=n-p forms 1) |
|---|
| 3248 | (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") |
|---|
| 3249 | description forms)) |
|---|
| 3250 | (funcall validator (car forms) :location file))) |
|---|
| 3251 | |
|---|
| 3252 | (defun* hidden-file-p (pathname) |
|---|
| 3253 | (equal (first-char (pathname-name pathname)) #\.)) |
|---|
| 3254 | |
|---|
| 3255 | (defun* directory* (pathname-spec &rest keys &key &allow-other-keys) |
|---|
| 3256 | (apply 'directory pathname-spec |
|---|
| 3257 | (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) |
|---|
| 3258 | #+clozure '(:follow-links nil) |
|---|
| 3259 | #+clisp '(:circle t :if-does-not-exist :ignore) |
|---|
| 3260 | #+(or cmu scl) '(:follow-links nil :truenamep nil) |
|---|
| 3261 | #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl) |
|---|
| 3262 | '(:resolve-symlinks nil)))))) |
|---|
| 3263 | |
|---|
| 3264 | (defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter) |
|---|
| 3265 | "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will |
|---|
| 3266 | be applied to the results to yield a configuration form. Current |
|---|
| 3267 | values of TAG include :source-registry and :output-translations." |
|---|
| 3268 | (let ((files (sort (ignore-errors |
|---|
| 3269 | (remove-if |
|---|
| 3270 | 'hidden-file-p |
|---|
| 3271 | (directory* (make-pathname :name :wild :type "conf" :defaults directory)))) |
|---|
| 3272 | #'string< :key #'namestring))) |
|---|
| 3273 | `(,tag |
|---|
| 3274 | ,@(loop :for file :in files :append |
|---|
| 3275 | (loop :with ignore-invalid-p = nil |
|---|
| 3276 | :for form :in (read-file-forms file) |
|---|
| 3277 | :when (eq form :ignore-invalid-entries) |
|---|
| 3278 | :do (setf ignore-invalid-p t) |
|---|
| 3279 | :else |
|---|
| 3280 | :when (funcall validator form) |
|---|
| 3281 | :collect form |
|---|
| 3282 | :else |
|---|
| 3283 | :when ignore-invalid-p |
|---|
| 3284 | :do (setf *ignored-configuration-form* t) |
|---|
| 3285 | :else |
|---|
| 3286 | :do (report-invalid-form invalid-form-reporter :form form :location file))) |
|---|
| 3287 | :inherit-configuration))) |
|---|
| 3288 | |
|---|
| 3289 | |
|---|
| 3290 | ;;; --------------------------------------------------------------------------- |
|---|
| 3291 | ;;; asdf-output-translations |
|---|
| 3292 | ;;; |
|---|
| 3293 | ;;; this code is heavily inspired from |
|---|
| 3294 | ;;; asdf-binary-translations, common-lisp-controller and cl-launch. |
|---|
| 3295 | ;;; --------------------------------------------------------------------------- |
|---|
| 3296 | |
|---|
| 3297 | (defvar *output-translations* () |
|---|
| 3298 | "Either NIL (for uninitialized), or a list of one element, |
|---|
| 3299 | said element itself being a sorted list of mappings. |
|---|
| 3300 | Each mapping is a pair of a source pathname and destination pathname, |
|---|
| 3301 | and the order is by decreasing length of namestring of the source pathname.") |
|---|
| 3302 | |
|---|
| 3303 | (defvar *user-cache* |
|---|
| 3304 | (flet ((try (x &rest sub) (and x `(,x ,@sub)))) |
|---|
| 3305 | (or |
|---|
| 3306 | (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation) |
|---|
| 3307 | (when (os-windows-p) |
|---|
| 3308 | (try (or #+lispworks (sys:get-folder-path :local-appdata) |
|---|
| 3309 | (getenv "LOCALAPPDATA") |
|---|
| 3310 | #+lispworks (sys:get-folder-path :appdata) |
|---|
| 3311 | (getenv "APPDATA")) |
|---|
| 3312 | "common-lisp" "cache" :implementation)) |
|---|
| 3313 | '(:home ".cache" "common-lisp" :implementation)))) |
|---|
| 3314 | |
|---|
| 3315 | (defun* output-translations () |
|---|
| 3316 | (car *output-translations*)) |
|---|
| 3317 | |
|---|
| 3318 | (defun* (setf output-translations) (new-value) |
|---|
| 3319 | (setf *output-translations* |
|---|
| 3320 | (list |
|---|
| 3321 | (stable-sort (copy-list new-value) #'> |
|---|
| 3322 | :key #'(lambda (x) |
|---|
| 3323 | (etypecase (car x) |
|---|
| 3324 | ((eql t) -1) |
|---|
| 3325 | (pathname |
|---|
| 3326 | (let ((directory (pathname-directory (car x)))) |
|---|
| 3327 | (if (listp directory) (length directory) 0)))))))) |
|---|
| 3328 | new-value) |
|---|
| 3329 | |
|---|
| 3330 | (defun* output-translations-initialized-p () |
|---|
| 3331 | (and *output-translations* t)) |
|---|
| 3332 | |
|---|
| 3333 | (defun* clear-output-translations () |
|---|
| 3334 | "Undoes any initialization of the output translations. |
|---|
| 3335 | You might want to call that before you dump an image that would be resumed |
|---|
| 3336 | with a different configuration, so the configuration would be re-read then." |
|---|
| 3337 | (setf *output-translations* '()) |
|---|
| 3338 | (values)) |
|---|
| 3339 | |
|---|
| 3340 | (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) |
|---|
| 3341 | (values (or null pathname) &optional)) |
|---|
| 3342 | resolve-location)) |
|---|
| 3343 | |
|---|
| 3344 | (defun* resolve-relative-location-component (x &key directory wilden) |
|---|
| 3345 | (let ((r (etypecase x |
|---|
| 3346 | (pathname x) |
|---|
| 3347 | (string (coerce-pathname x :type (when directory :directory))) |
|---|
| 3348 | (cons |
|---|
| 3349 | (if (null (cdr x)) |
|---|
| 3350 | (resolve-relative-location-component |
|---|
| 3351 | (car x) :directory directory :wilden wilden) |
|---|
| 3352 | (let* ((car (resolve-relative-location-component |
|---|
| 3353 | (car x) :directory t :wilden nil))) |
|---|
| 3354 | (merge-pathnames* |
|---|
| 3355 | (resolve-relative-location-component |
|---|
| 3356 | (cdr x) :directory directory :wilden wilden) |
|---|
| 3357 | car)))) |
|---|
| 3358 | ((eql :default-directory) |
|---|
| 3359 | (relativize-pathname-directory (default-directory))) |
|---|
| 3360 | ((eql :*/) *wild-directory*) |
|---|
| 3361 | ((eql :**/) *wild-inferiors*) |
|---|
| 3362 | ((eql :*.*.*) *wild-file*) |
|---|
| 3363 | ((eql :implementation) |
|---|
| 3364 | (coerce-pathname (implementation-identifier) :type :directory)) |
|---|
| 3365 | ((eql :implementation-type) |
|---|
| 3366 | (coerce-pathname (string-downcase (implementation-type)) :type :directory))))) |
|---|
| 3367 | (when (absolute-pathname-p r) |
|---|
| 3368 | (error (compatfmt "~@<pathname ~S is not relative~@:>") x)) |
|---|
| 3369 | (if (or (pathnamep x) (not wilden)) r (wilden r)))) |
|---|
| 3370 | |
|---|
| 3371 | (defvar *here-directory* nil |
|---|
| 3372 | "This special variable is bound to the currect directory during calls to |
|---|
| 3373 | PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here |
|---|
| 3374 | directive.") |
|---|
| 3375 | |
|---|
| 3376 | (defun* resolve-absolute-location-component (x &key directory wilden) |
|---|
| 3377 | (let* ((r |
|---|
| 3378 | (etypecase x |
|---|
| 3379 | (pathname x) |
|---|
| 3380 | (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) |
|---|
| 3381 | #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) |
|---|
| 3382 | (if directory (ensure-directory-pathname p) p))) |
|---|
| 3383 | (cons |
|---|
| 3384 | (return-from resolve-absolute-location-component |
|---|
| 3385 | (if (null (cdr x)) |
|---|
| 3386 | (resolve-absolute-location-component |
|---|
| 3387 | (car x) :directory directory :wilden wilden) |
|---|
| 3388 | (merge-pathnames* |
|---|
| 3389 | (resolve-relative-location-component |
|---|
| 3390 | (cdr x) :directory directory :wilden wilden) |
|---|
| 3391 | (resolve-absolute-location-component |
|---|
| 3392 | (car x) :directory t :wilden nil))))) |
|---|
| 3393 | ((eql :root) |
|---|
| 3394 | ;; special magic! we encode such paths as relative pathnames, |
|---|
| 3395 | ;; but it means "relative to the root of the source pathname's host and device". |
|---|
| 3396 | (return-from resolve-absolute-location-component |
|---|
| 3397 | (let ((p (make-pathname :directory '(:relative)))) |
|---|
| 3398 | (if wilden (wilden p) p)))) |
|---|
| 3399 | ((eql :home) (user-homedir)) |
|---|
| 3400 | ((eql :here) |
|---|
| 3401 | (resolve-location (or *here-directory* |
|---|
| 3402 | ;; give semantics in the case of use interactively |
|---|
| 3403 | :default-directory) |
|---|
| 3404 | :directory t :wilden nil)) |
|---|
| 3405 | ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) |
|---|
| 3406 | ((eql :system-cache) |
|---|
| 3407 | (error "Using the :system-cache is deprecated. ~%~ |
|---|
| 3408 | Please remove it from your ASDF configuration")) |
|---|
| 3409 | ((eql :default-directory) (default-directory)))) |
|---|
| 3410 | (s (if (and wilden (not (pathnamep x))) |
|---|
| 3411 | (wilden r) |
|---|
| 3412 | r))) |
|---|
| 3413 | (unless (absolute-pathname-p s) |
|---|
| 3414 | (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x)) |
|---|
| 3415 | s)) |
|---|
| 3416 | |
|---|
| 3417 | (defun* resolve-location (x &key directory wilden) |
|---|
| 3418 | (if (atom x) |
|---|
| 3419 | (resolve-absolute-location-component x :directory directory :wilden wilden) |
|---|
| 3420 | (loop :with path = (resolve-absolute-location-component |
|---|
| 3421 | (car x) :directory (and (or directory (cdr x)) t) |
|---|
| 3422 | :wilden (and wilden (null (cdr x)))) |
|---|
| 3423 | :for (component . morep) :on (cdr x) |
|---|
| 3424 | :for dir = (and (or morep directory) t) |
|---|
| 3425 | :for wild = (and wilden (not morep)) |
|---|
| 3426 | :do (setf path (merge-pathnames* |
|---|
| 3427 | (resolve-relative-location-component |
|---|
| 3428 | component :directory dir :wilden wild) |
|---|
| 3429 | path)) |
|---|
| 3430 | :finally (return path)))) |
|---|
| 3431 | |
|---|
| 3432 | (defun* location-designator-p (x) |
|---|
| 3433 | (flet ((absolute-component-p (c) |
|---|
| 3434 | (typep c '(or string pathname |
|---|
| 3435 | (member :root :home :here :user-cache :system-cache :default-directory)))) |
|---|
| 3436 | (relative-component-p (c) |
|---|
| 3437 | (typep c '(or string pathname |
|---|
| 3438 | (member :default-directory :*/ :**/ :*.*.* |
|---|
| 3439 | :implementation :implementation-type))))) |
|---|
| 3440 | (or (typep x 'boolean) |
|---|
| 3441 | (absolute-component-p x) |
|---|
| 3442 | (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) |
|---|
| 3443 | |
|---|
| 3444 | (defun* location-function-p (x) |
|---|
| 3445 | (and |
|---|
| 3446 | (consp x) |
|---|
| 3447 | (length=n-p x 2) |
|---|
| 3448 | (or (and (equal (first x) :function) |
|---|
| 3449 | (typep (second x) 'symbol)) |
|---|
| 3450 | (and (equal (first x) 'lambda) |
|---|
| 3451 | (cddr x) |
|---|
| 3452 | (length=n-p (second x) 2))))) |
|---|
| 3453 | |
|---|
| 3454 | (defun* validate-output-translations-directive (directive) |
|---|
| 3455 | (or (member directive '(:enable-user-cache :disable-cache nil)) |
|---|
| 3456 | (and (consp directive) |
|---|
| 3457 | (or (and (length=n-p directive 2) |
|---|
| 3458 | (or (and (eq (first directive) :include) |
|---|
| 3459 | (typep (second directive) '(or string pathname null))) |
|---|
| 3460 | (and (location-designator-p (first directive)) |
|---|
| 3461 | (or (location-designator-p (second directive)) |
|---|
| 3462 | (location-function-p (second directive)))))) |
|---|
| 3463 | (and (length=n-p directive 1) |
|---|
| 3464 | (location-designator-p (first directive))))))) |
|---|
| 3465 | |
|---|
| 3466 | (defun* validate-output-translations-form (form &key location) |
|---|
| 3467 | (validate-configuration-form |
|---|
| 3468 | form |
|---|
| 3469 | :output-translations |
|---|
| 3470 | 'validate-output-translations-directive |
|---|
| 3471 | :location location :invalid-form-reporter 'invalid-output-translation)) |
|---|
| 3472 | |
|---|
| 3473 | (defun* validate-output-translations-file (file) |
|---|
| 3474 | (validate-configuration-file |
|---|
| 3475 | file 'validate-output-translations-form :description "output translations")) |
|---|
| 3476 | |
|---|
| 3477 | (defun* validate-output-translations-directory (directory) |
|---|
| 3478 | (validate-configuration-directory |
|---|
| 3479 | directory :output-translations 'validate-output-translations-directive |
|---|
| 3480 | :invalid-form-reporter 'invalid-output-translation)) |
|---|
| 3481 | |
|---|
| 3482 | (defun* parse-output-translations-string (string &key location) |
|---|
| 3483 | (cond |
|---|
| 3484 | ((or (null string) (equal string "")) |
|---|
| 3485 | '(:output-translations :inherit-configuration)) |
|---|
| 3486 | ((not (stringp string)) |
|---|
| 3487 | (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) |
|---|
| 3488 | ((eql (char string 0) #\") |
|---|
| 3489 | (parse-output-translations-string (read-from-string string) :location location)) |
|---|
| 3490 | ((eql (char string 0) #\() |
|---|
| 3491 | (validate-output-translations-form (read-from-string string) :location location)) |
|---|
| 3492 | (t |
|---|
| 3493 | (loop |
|---|
| 3494 | :with inherit = nil |
|---|
| 3495 | :with directives = () |
|---|
| 3496 | :with start = 0 |
|---|
| 3497 | :with end = (length string) |
|---|
| 3498 | :with source = nil |
|---|
| 3499 | :with separator = (inter-directory-separator) |
|---|
| 3500 | :for i = (or (position separator string :start start) end) :do |
|---|
| 3501 | (let ((s (subseq string start i))) |
|---|
| 3502 | (cond |
|---|
| 3503 | (source |
|---|
| 3504 | (push (list source (if (equal "" s) nil s)) directives) |
|---|
| 3505 | (setf source nil)) |
|---|
| 3506 | ((equal "" s) |
|---|
| 3507 | (when inherit |
|---|
| 3508 | (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") |
|---|
| 3509 | string)) |
|---|
| 3510 | (setf inherit t) |
|---|
| 3511 | (push :inherit-configuration directives)) |
|---|
| 3512 | (t |
|---|
| 3513 | (setf source s))) |
|---|
| 3514 | (setf start (1+ i)) |
|---|
| 3515 | (when (> start end) |
|---|
| 3516 | (when source |
|---|
| 3517 | (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") |
|---|
| 3518 | string)) |
|---|
| 3519 | (unless inherit |
|---|
| 3520 | (push :ignore-inherited-configuration directives)) |
|---|
| 3521 | (return `(:output-translations ,@(nreverse directives))))))))) |
|---|
| 3522 | |
|---|
| 3523 | (defparameter *default-output-translations* |
|---|
| 3524 | '(environment-output-translations |
|---|
| 3525 | user-output-translations-pathname |
|---|
| 3526 | user-output-translations-directory-pathname |
|---|
| 3527 | system-output-translations-pathname |
|---|
| 3528 | system-output-translations-directory-pathname)) |
|---|
| 3529 | |
|---|
| 3530 | (defun* wrapping-output-translations () |
|---|
| 3531 | `(:output-translations |
|---|
| 3532 | ;; Some implementations have precompiled ASDF systems, |
|---|
| 3533 | ;; so we must disable translations for implementation paths. |
|---|
| 3534 | #+sbcl ,(let ((h (getenv "SBCL_HOME"))) |
|---|
| 3535 | (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ()))) |
|---|
| 3536 | ;; The below two are not needed: no precompiled ASDF system there |
|---|
| 3537 | ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) |
|---|
| 3538 | ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) |
|---|
| 3539 | ;; All-import, here is where we want user stuff to be: |
|---|
| 3540 | :inherit-configuration |
|---|
| 3541 | ;; These are for convenience, and can be overridden by the user: |
|---|
| 3542 | #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) |
|---|
| 3543 | #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) |
|---|
| 3544 | ;; We enable the user cache by default, and here is the place we do: |
|---|
| 3545 | :enable-user-cache)) |
|---|
| 3546 | |
|---|
| 3547 | (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) |
|---|
| 3548 | (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) |
|---|
| 3549 | |
|---|
| 3550 | (defun* user-output-translations-pathname () |
|---|
| 3551 | (in-user-configuration-directory *output-translations-file*)) |
|---|
| 3552 | (defun* system-output-translations-pathname () |
|---|
| 3553 | (in-system-configuration-directory *output-translations-file*)) |
|---|
| 3554 | (defun* user-output-translations-directory-pathname () |
|---|
| 3555 | (in-user-configuration-directory *output-translations-directory*)) |
|---|
| 3556 | (defun* system-output-translations-directory-pathname () |
|---|
| 3557 | (in-system-configuration-directory *output-translations-directory*)) |
|---|
| 3558 | (defun* environment-output-translations () |
|---|
| 3559 | (getenv "ASDF_OUTPUT_TRANSLATIONS")) |
|---|
| 3560 | |
|---|
| 3561 | (defgeneric* process-output-translations (spec &key inherit collect)) |
|---|
| 3562 | (declaim (ftype (function (t &key (:collect (or symbol function))) t) |
|---|
| 3563 | inherit-output-translations)) |
|---|
| 3564 | (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t) |
|---|
| 3565 | process-output-translations-directive)) |
|---|
| 3566 | |
|---|
| 3567 | (defmethod process-output-translations ((x symbol) &key |
|---|
| 3568 | (inherit *default-output-translations*) |
|---|
| 3569 | collect) |
|---|
| 3570 | (process-output-translations (funcall x) :inherit inherit :collect collect)) |
|---|
| 3571 | (defmethod process-output-translations ((pathname pathname) &key inherit collect) |
|---|
| 3572 | (cond |
|---|
| 3573 | ((directory-pathname-p pathname) |
|---|
| 3574 | (process-output-translations (validate-output-translations-directory pathname) |
|---|
| 3575 | :inherit inherit :collect collect)) |
|---|
| 3576 | ((probe-file* pathname) |
|---|
| 3577 | (process-output-translations (validate-output-translations-file pathname) |
|---|
| 3578 | :inherit inherit :collect collect)) |
|---|
| 3579 | (t |
|---|
| 3580 | (inherit-output-translations inherit :collect collect)))) |
|---|
| 3581 | (defmethod process-output-translations ((string string) &key inherit collect) |
|---|
| 3582 | (process-output-translations (parse-output-translations-string string) |
|---|
| 3583 | :inherit inherit :collect collect)) |
|---|
| 3584 | (defmethod process-output-translations ((x null) &key inherit collect) |
|---|
| 3585 | (declare (ignorable x)) |
|---|
| 3586 | (inherit-output-translations inherit :collect collect)) |
|---|
| 3587 | (defmethod process-output-translations ((form cons) &key inherit collect) |
|---|
| 3588 | (dolist (directive (cdr (validate-output-translations-form form))) |
|---|
| 3589 | (process-output-translations-directive directive :inherit inherit :collect collect))) |
|---|
| 3590 | |
|---|
| 3591 | (defun* inherit-output-translations (inherit &key collect) |
|---|
| 3592 | (when inherit |
|---|
| 3593 | (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) |
|---|
| 3594 | |
|---|
| 3595 | (defun* process-output-translations-directive (directive &key inherit collect) |
|---|
| 3596 | (if (atom directive) |
|---|
| 3597 | (ecase directive |
|---|
| 3598 | ((:enable-user-cache) |
|---|
| 3599 | (process-output-translations-directive '(t :user-cache) :collect collect)) |
|---|
| 3600 | ((:disable-cache) |
|---|
| 3601 | (process-output-translations-directive '(t t) :collect collect)) |
|---|
| 3602 | ((:inherit-configuration) |
|---|
| 3603 | (inherit-output-translations inherit :collect collect)) |
|---|
| 3604 | ((:ignore-inherited-configuration :ignore-invalid-entries nil) |
|---|
| 3605 | nil)) |
|---|
| 3606 | (let ((src (first directive)) |
|---|
| 3607 | (dst (second directive))) |
|---|
| 3608 | (if (eq src :include) |
|---|
| 3609 | (when dst |
|---|
| 3610 | (process-output-translations (pathname dst) :inherit nil :collect collect)) |
|---|
| 3611 | (when src |
|---|
| 3612 | (let ((trusrc (or (eql src t) |
|---|
| 3613 | (let ((loc (resolve-location src :directory t :wilden t))) |
|---|
| 3614 | (if (absolute-pathname-p loc) (truenamize loc) loc))))) |
|---|
| 3615 | (cond |
|---|
| 3616 | ((location-function-p dst) |
|---|
| 3617 | (funcall collect |
|---|
| 3618 | (list trusrc |
|---|
| 3619 | (if (symbolp (second dst)) |
|---|
| 3620 | (fdefinition (second dst)) |
|---|
| 3621 | (eval (second dst)))))) |
|---|
| 3622 | ((eq dst t) |
|---|
| 3623 | (funcall collect (list trusrc t))) |
|---|
| 3624 | (t |
|---|
| 3625 | (let* ((trudst (if dst |
|---|
| 3626 | (resolve-location dst :directory t :wilden t) |
|---|
| 3627 | trusrc)) |
|---|
| 3628 | (wilddst (merge-pathnames* *wild-file* trudst))) |
|---|
| 3629 | (funcall collect (list wilddst t)) |
|---|
| 3630 | (funcall collect (list trusrc trudst))))))))))) |
|---|
| 3631 | |
|---|
| 3632 | (defun* compute-output-translations (&optional parameter) |
|---|
| 3633 | "read the configuration, return it" |
|---|
| 3634 | (remove-duplicates |
|---|
| 3635 | (while-collecting (c) |
|---|
| 3636 | (inherit-output-translations |
|---|
| 3637 | `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) |
|---|
| 3638 | :test 'equal :from-end t)) |
|---|
| 3639 | |
|---|
| 3640 | (defvar *output-translations-parameter* nil) |
|---|
| 3641 | |
|---|
| 3642 | (defun* initialize-output-translations (&optional (parameter *output-translations-parameter*)) |
|---|
| 3643 | "read the configuration, initialize the internal configuration variable, |
|---|
| 3644 | return the configuration" |
|---|
| 3645 | (setf *output-translations-parameter* parameter |
|---|
| 3646 | (output-translations) (compute-output-translations parameter))) |
|---|
| 3647 | |
|---|
| 3648 | (defun* disable-output-translations () |
|---|
| 3649 | "Initialize output translations in a way that maps every file to itself, |
|---|
| 3650 | effectively disabling the output translation facility." |
|---|
| 3651 | (initialize-output-translations |
|---|
| 3652 | '(:output-translations :disable-cache :ignore-inherited-configuration))) |
|---|
| 3653 | |
|---|
| 3654 | ;; checks an initial variable to see whether the state is initialized |
|---|
| 3655 | ;; or cleared. In the former case, return current configuration; in |
|---|
| 3656 | ;; the latter, initialize. ASDF will call this function at the start |
|---|
| 3657 | ;; of (asdf:find-system). |
|---|
| 3658 | (defun* ensure-output-translations () |
|---|
| 3659 | (if (output-translations-initialized-p) |
|---|
| 3660 | (output-translations) |
|---|
| 3661 | (initialize-output-translations))) |
|---|
| 3662 | |
|---|
| 3663 | (defun* translate-pathname* (path absolute-source destination &optional root source) |
|---|
| 3664 | (declare (ignore source)) |
|---|
| 3665 | (cond |
|---|
| 3666 | ((functionp destination) |
|---|
| 3667 | (funcall destination path absolute-source)) |
|---|
| 3668 | ((eq destination t) |
|---|
| 3669 | path) |
|---|
| 3670 | ((not (pathnamep destination)) |
|---|
| 3671 | (error "Invalid destination")) |
|---|
| 3672 | ((not (absolute-pathname-p destination)) |
|---|
| 3673 | (translate-pathname path absolute-source (merge-pathnames* destination root))) |
|---|
| 3674 | (root |
|---|
| 3675 | (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) |
|---|
| 3676 | (t |
|---|
| 3677 | (translate-pathname path absolute-source destination)))) |
|---|
| 3678 | |
|---|
| 3679 | (defun* apply-output-translations (path) |
|---|
| 3680 | (etypecase path |
|---|
| 3681 | #+cormanlisp (t (truenamize path)) |
|---|
| 3682 | (logical-pathname |
|---|
| 3683 | path) |
|---|
| 3684 | ((or pathname string) |
|---|
| 3685 | (ensure-output-translations) |
|---|
| 3686 | (loop :with p = (truenamize path) |
|---|
| 3687 | :for (source destination) :in (car *output-translations*) |
|---|
| 3688 | :for root = (when (or (eq source t) |
|---|
| 3689 | (and (pathnamep source) |
|---|
| 3690 | (not (absolute-pathname-p source)))) |
|---|
| 3691 | (pathname-root p)) |
|---|
| 3692 | :for absolute-source = (cond |
|---|
| 3693 | ((eq source t) (wilden root)) |
|---|
| 3694 | (root (merge-pathnames* source root)) |
|---|
| 3695 | (t source)) |
|---|
| 3696 | :when (or (eq source t) (pathname-match-p p absolute-source)) |
|---|
| 3697 | :return (translate-pathname* p absolute-source destination root source) |
|---|
| 3698 | :finally (return p))))) |
|---|
| 3699 | |
|---|
| 3700 | (defmethod output-files :around (operation component) |
|---|
| 3701 | "Translate output files, unless asked not to" |
|---|
| 3702 | (declare (ignorable operation component)) |
|---|
| 3703 | (values |
|---|
| 3704 | (multiple-value-bind (files fixedp) (call-next-method) |
|---|
| 3705 | (if fixedp |
|---|
| 3706 | files |
|---|
| 3707 | (mapcar #'apply-output-translations files))) |
|---|
| 3708 | t)) |
|---|
| 3709 | |
|---|
| 3710 | (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) |
|---|
| 3711 | (if (absolute-pathname-p output-file) |
|---|
| 3712 | ;; what cfp should be doing, w/ mp* instead of mp |
|---|
| 3713 | (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) |
|---|
| 3714 | (defaults (make-pathname |
|---|
| 3715 | :type type :defaults (merge-pathnames* input-file)))) |
|---|
| 3716 | (merge-pathnames* output-file defaults)) |
|---|
| 3717 | (apply-output-translations |
|---|
| 3718 | (apply 'compile-file-pathname input-file keys)))) |
|---|
| 3719 | |
|---|
| 3720 | (defun* tmpize-pathname (x) |
|---|
| 3721 | (make-pathname |
|---|
| 3722 | :name (format nil "ASDF-TMP-~A" (pathname-name x)) |
|---|
| 3723 | :defaults x)) |
|---|
| 3724 | |
|---|
| 3725 | (defun* delete-file-if-exists (x) |
|---|
| 3726 | (when (and x (probe-file* x)) |
|---|
| 3727 | (delete-file x))) |
|---|
| 3728 | |
|---|
| 3729 | (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) |
|---|
| 3730 | (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys)) |
|---|
| 3731 | (tmp-file (tmpize-pathname output-file)) |
|---|
| 3732 | (status :error)) |
|---|
| 3733 | (multiple-value-bind (output-truename warnings-p failure-p) |
|---|
| 3734 | (apply 'compile-file input-file :output-file tmp-file keys) |
|---|
| 3735 | (cond |
|---|
| 3736 | (failure-p |
|---|
| 3737 | (setf status *compile-file-failure-behaviour*)) |
|---|
| 3738 | (warnings-p |
|---|
| 3739 | (setf status *compile-file-warnings-behaviour*)) |
|---|
| 3740 | (t |
|---|
| 3741 | (setf status :success))) |
|---|
| 3742 | (ecase status |
|---|
| 3743 | ((:success :warn :ignore) |
|---|
| 3744 | (delete-file-if-exists output-file) |
|---|
| 3745 | (when output-truename |
|---|
| 3746 | (rename-file output-truename output-file) |
|---|
| 3747 | (setf output-truename output-file))) |
|---|
| 3748 | (:error |
|---|
| 3749 | (delete-file-if-exists output-truename) |
|---|
| 3750 | (setf output-truename nil))) |
|---|
| 3751 | (values output-truename warnings-p failure-p)))) |
|---|
| 3752 | |
|---|
| 3753 | #+abcl |
|---|
| 3754 | (defun* translate-jar-pathname (source wildcard) |
|---|
| 3755 | (declare (ignore wildcard)) |
|---|
| 3756 | (let* ((p (pathname (first (pathname-device source)))) |
|---|
| 3757 | (root (format nil "/___jar___file___root___/~@[~A/~]" |
|---|
| 3758 | (and (find :windows *features*) |
|---|
| 3759 | (pathname-device p))))) |
|---|
| 3760 | (apply-output-translations |
|---|
| 3761 | (merge-pathnames* |
|---|
| 3762 | (relativize-pathname-directory source) |
|---|
| 3763 | (merge-pathnames* |
|---|
| 3764 | (relativize-pathname-directory (ensure-directory-pathname p)) |
|---|
| 3765 | root))))) |
|---|
| 3766 | |
|---|
| 3767 | ;;;; ----------------------------------------------------------------- |
|---|
| 3768 | ;;;; Compatibility mode for ASDF-Binary-Locations |
|---|
| 3769 | |
|---|
| 3770 | (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) |
|---|
| 3771 | (declare (ignorable operation-class system args)) |
|---|
| 3772 | (when (find-symbol* '#:output-files-for-system-and-operation :asdf) |
|---|
| 3773 | (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. |
|---|
| 3774 | ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, |
|---|
| 3775 | which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, |
|---|
| 3776 | and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. |
|---|
| 3777 | In case you insist on preserving your previous A-B-L configuration, but |
|---|
| 3778 | do not know how to achieve the same effect with A-O-T, you may use function |
|---|
| 3779 | ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; |
|---|
| 3780 | call that function where you would otherwise have loaded and configured A-B-L."))) |
|---|
| 3781 | |
|---|
| 3782 | (defun* enable-asdf-binary-locations-compatibility |
|---|
| 3783 | (&key |
|---|
| 3784 | (centralize-lisp-binaries nil) |
|---|
| 3785 | (default-toplevel-directory |
|---|
| 3786 | ;; Use ".cache/common-lisp" instead ??? |
|---|
| 3787 | (merge-pathnames* (make-pathname :directory '(:relative ".fasls")) |
|---|
| 3788 | (user-homedir))) |
|---|
| 3789 | (include-per-user-information nil) |
|---|
| 3790 | (map-all-source-files (or #+(or ecl clisp) t nil)) |
|---|
| 3791 | (source-to-target-mappings nil)) |
|---|
| 3792 | #+(or ecl clisp) |
|---|
| 3793 | (when (null map-all-source-files) |
|---|
| 3794 | (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) |
|---|
| 3795 | (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) |
|---|
| 3796 | (mapped-files (if map-all-source-files *wild-file* |
|---|
| 3797 | (make-pathname :type fasl-type :defaults *wild-file*))) |
|---|
| 3798 | (destination-directory |
|---|
| 3799 | (if centralize-lisp-binaries |
|---|
| 3800 | `(,default-toplevel-directory |
|---|
| 3801 | ,@(when include-per-user-information |
|---|
| 3802 | (cdr (pathname-directory (user-homedir)))) |
|---|
| 3803 | :implementation ,*wild-inferiors*) |
|---|
| 3804 | `(:root ,*wild-inferiors* :implementation)))) |
|---|
| 3805 | (initialize-output-translations |
|---|
| 3806 | `(:output-translations |
|---|
| 3807 | ,@source-to-target-mappings |
|---|
| 3808 | ((:root ,*wild-inferiors* ,mapped-files) |
|---|
| 3809 | (,@destination-directory ,mapped-files)) |
|---|
| 3810 | (t t) |
|---|
| 3811 | :ignore-inherited-configuration)))) |
|---|
| 3812 | |
|---|
| 3813 | ;;;; ----------------------------------------------------------------- |
|---|
| 3814 | ;;;; Source Registry Configuration, by Francois-Rene Rideau |
|---|
| 3815 | ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 |
|---|
| 3816 | |
|---|
| 3817 | ;; Using ack 1.2 exclusions |
|---|
| 3818 | (defvar *default-source-registry-exclusions* |
|---|
| 3819 | '(".bzr" ".cdv" |
|---|
| 3820 | ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards |
|---|
| 3821 | ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" |
|---|
| 3822 | "_sgbak" "autom4te.cache" "cover_db" "_build" |
|---|
| 3823 | "debian")) ;; debian often builds stuff under the debian directory... BAD. |
|---|
| 3824 | |
|---|
| 3825 | (defvar *source-registry-exclusions* *default-source-registry-exclusions*) |
|---|
| 3826 | |
|---|
| 3827 | (defvar *source-registry* nil |
|---|
| 3828 | "Either NIL (for uninitialized), or an equal hash-table, mapping |
|---|
| 3829 | system names to pathnames of .asd files") |
|---|
| 3830 | |
|---|
| 3831 | (defun* source-registry-initialized-p () |
|---|
| 3832 | (typep *source-registry* 'hash-table)) |
|---|
| 3833 | |
|---|
| 3834 | (defun* clear-source-registry () |
|---|
| 3835 | "Undoes any initialization of the source registry. |
|---|
| 3836 | You might want to call that before you dump an image that would be resumed |
|---|
| 3837 | with a different configuration, so the configuration would be re-read then." |
|---|
| 3838 | (setf *source-registry* nil) |
|---|
| 3839 | (values)) |
|---|
| 3840 | |
|---|
| 3841 | (defparameter *wild-asd* |
|---|
| 3842 | (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) |
|---|
| 3843 | |
|---|
| 3844 | (defun* filter-logical-directory-results (directory entries merger) |
|---|
| 3845 | (if (typep directory 'logical-pathname) |
|---|
| 3846 | ;; Try hard to not resolve logical-pathname into physical pathnames; |
|---|
| 3847 | ;; otherwise logical-pathname users/lovers will be disappointed. |
|---|
| 3848 | ;; If directory* could use some implementation-dependent magic, |
|---|
| 3849 | ;; we will have logical pathnames already; otherwise, |
|---|
| 3850 | ;; we only keep pathnames for which specifying the name and |
|---|
| 3851 | ;; translating the LPN commute. |
|---|
| 3852 | (loop :for f :in entries |
|---|
| 3853 | :for p = (or (and (typep f 'logical-pathname) f) |
|---|
| 3854 | (let* ((u (ignore-errors (funcall merger f)))) |
|---|
| 3855 | (and u (equal (ignore-errors (truename u)) f) u))) |
|---|
| 3856 | :when p :collect p) |
|---|
| 3857 | entries)) |
|---|
| 3858 | |
|---|
| 3859 | (defun* directory-files (directory &optional (pattern *wild-file*)) |
|---|
| 3860 | (when (wild-pathname-p directory) |
|---|
| 3861 | (error "Invalid wild in ~S" directory)) |
|---|
| 3862 | (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) |
|---|
| 3863 | (error "Invalid file pattern ~S" pattern)) |
|---|
| 3864 | (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) |
|---|
| 3865 | (filter-logical-directory-results |
|---|
| 3866 | directory entries |
|---|
| 3867 | #'(lambda (f) |
|---|
| 3868 | (make-pathname :defaults directory :version (pathname-version f) |
|---|
| 3869 | :name (pathname-name f) :type (pathname-type f)))))) |
|---|
| 3870 | |
|---|
| 3871 | (defun* directory-asd-files (directory) |
|---|
| 3872 | (directory-files directory *wild-asd*)) |
|---|
| 3873 | |
|---|
| 3874 | (defun* subdirectories (directory) |
|---|
| 3875 | (let* ((directory (ensure-directory-pathname directory)) |
|---|
| 3876 | #-(or abcl cormanlisp genera xcl) |
|---|
| 3877 | (wild (merge-pathnames* |
|---|
| 3878 | #-(or abcl allegro cmu lispworks scl xcl) |
|---|
| 3879 | *wild-directory* |
|---|
| 3880 | #+(or abcl allegro cmu lispworks scl xcl) "*.*" |
|---|
| 3881 | directory)) |
|---|
| 3882 | (dirs |
|---|
| 3883 | #-(or abcl cormanlisp genera xcl) |
|---|
| 3884 | (ignore-errors |
|---|
| 3885 | (directory* wild . #.(or #+clozure '(:directories t :files nil) |
|---|
| 3886 | #+mcl '(:directories t)))) |
|---|
| 3887 | #+(or abcl xcl) (system:list-directory directory) |
|---|
| 3888 | #+cormanlisp (cl::directory-subdirs directory) |
|---|
| 3889 | #+genera (fs:directory-list directory)) |
|---|
| 3890 | #+(or abcl allegro cmu genera lispworks scl xcl) |
|---|
| 3891 | (dirs (loop :for x :in dirs |
|---|
| 3892 | :for d = #+(or abcl xcl) (extensions:probe-directory x) |
|---|
| 3893 | #+allegro (excl:probe-directory x) |
|---|
| 3894 | #+(or cmu scl) (directory-pathname-p x) |
|---|
| 3895 | #+genera (getf (cdr x) :directory) |
|---|
| 3896 | #+lispworks (lw:file-directory-p x) |
|---|
| 3897 | :when d :collect #+(or abcl allegro xcl) d |
|---|
| 3898 | #+genera (ensure-directory-pathname (first x)) |
|---|
| 3899 | #+(or cmu lispworks scl) x))) |
|---|
| 3900 | (filter-logical-directory-results |
|---|
| 3901 | directory dirs |
|---|
| 3902 | (let ((prefix (normalize-pathname-directory-component |
|---|
| 3903 | (pathname-directory directory)))) |
|---|
| 3904 | #'(lambda (d) |
|---|
| 3905 | (let ((dir (normalize-pathname-directory-component |
|---|
| 3906 | (pathname-directory d)))) |
|---|
| 3907 | (and (consp dir) (consp (cdr dir)) |
|---|
| 3908 | (make-pathname |
|---|
| 3909 | :defaults directory :name nil :type nil :version nil |
|---|
| 3910 | :directory (append prefix (last dir)))))))))) |
|---|
| 3911 | |
|---|
| 3912 | (defun* collect-asds-in-directory (directory collect) |
|---|
| 3913 | (map () collect (directory-asd-files directory))) |
|---|
| 3914 | |
|---|
| 3915 | (defun* collect-sub*directories (directory collectp recursep collector) |
|---|
| 3916 | (when (funcall collectp directory) |
|---|
| 3917 | (funcall collector directory)) |
|---|
| 3918 | (dolist (subdir (subdirectories directory)) |
|---|
| 3919 | (when (funcall recursep subdir) |
|---|
| 3920 | (collect-sub*directories subdir collectp recursep collector)))) |
|---|
| 3921 | |
|---|
| 3922 | (defun* collect-sub*directories-asd-files |
|---|
| 3923 | (directory &key |
|---|
| 3924 | (exclude *default-source-registry-exclusions*) |
|---|
| 3925 | collect) |
|---|
| 3926 | (collect-sub*directories |
|---|
| 3927 | directory |
|---|
| 3928 | (constantly t) |
|---|
| 3929 | #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) |
|---|
| 3930 | #'(lambda (dir) (collect-asds-in-directory dir collect)))) |
|---|
| 3931 | |
|---|
| 3932 | (defun* validate-source-registry-directive (directive) |
|---|
| 3933 | (or (member directive '(:default-registry)) |
|---|
| 3934 | (and (consp directive) |
|---|
| 3935 | (let ((rest (rest directive))) |
|---|
| 3936 | (case (first directive) |
|---|
| 3937 | ((:include :directory :tree) |
|---|
| 3938 | (and (length=n-p rest 1) |
|---|
| 3939 | (location-designator-p (first rest)))) |
|---|
| 3940 | ((:exclude :also-exclude) |
|---|
| 3941 | (every #'stringp rest)) |
|---|
| 3942 | ((:default-registry) |
|---|
| 3943 | (null rest))))))) |
|---|
| 3944 | |
|---|
| 3945 | (defun* validate-source-registry-form (form &key location) |
|---|
| 3946 | (validate-configuration-form |
|---|
| 3947 | form :source-registry 'validate-source-registry-directive |
|---|
| 3948 | :location location :invalid-form-reporter 'invalid-source-registry)) |
|---|
| 3949 | |
|---|
| 3950 | (defun* validate-source-registry-file (file) |
|---|
| 3951 | (validate-configuration-file |
|---|
| 3952 | file 'validate-source-registry-form :description "a source registry")) |
|---|
| 3953 | |
|---|
| 3954 | (defun* validate-source-registry-directory (directory) |
|---|
| 3955 | (validate-configuration-directory |
|---|
| 3956 | directory :source-registry 'validate-source-registry-directive |
|---|
| 3957 | :invalid-form-reporter 'invalid-source-registry)) |
|---|
| 3958 | |
|---|
| 3959 | (defun* parse-source-registry-string (string &key location) |
|---|
| 3960 | (cond |
|---|
| 3961 | ((or (null string) (equal string "")) |
|---|
| 3962 | '(:source-registry :inherit-configuration)) |
|---|
| 3963 | ((not (stringp string)) |
|---|
| 3964 | (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) |
|---|
| 3965 | ((find (char string 0) "\"(") |
|---|
| 3966 | (validate-source-registry-form (read-from-string string) :location location)) |
|---|
| 3967 | (t |
|---|
| 3968 | (loop |
|---|
| 3969 | :with inherit = nil |
|---|
| 3970 | :with directives = () |
|---|
| 3971 | :with start = 0 |
|---|
| 3972 | :with end = (length string) |
|---|
| 3973 | :with separator = (inter-directory-separator) |
|---|
| 3974 | :for pos = (position separator string :start start) :do |
|---|
| 3975 | (let ((s (subseq string start (or pos end)))) |
|---|
| 3976 | (flet ((check (dir) |
|---|
| 3977 | (unless (absolute-pathname-p dir) |
|---|
| 3978 | (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) |
|---|
| 3979 | dir)) |
|---|
| 3980 | (cond |
|---|
| 3981 | ((equal "" s) ; empty element: inherit |
|---|
| 3982 | (when inherit |
|---|
| 3983 | (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") |
|---|
| 3984 | string)) |
|---|
| 3985 | (setf inherit t) |
|---|
| 3986 | (push ':inherit-configuration directives)) |
|---|
| 3987 | ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? |
|---|
| 3988 | (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) |
|---|
| 3989 | (t |
|---|
| 3990 | (push `(:directory ,(check s)) directives)))) |
|---|
| 3991 | (cond |
|---|
| 3992 | (pos |
|---|
| 3993 | (setf start (1+ pos))) |
|---|
| 3994 | (t |
|---|
| 3995 | (unless inherit |
|---|
| 3996 | (push '(:ignore-inherited-configuration) directives)) |
|---|
| 3997 | (return `(:source-registry ,@(nreverse directives)))))))))) |
|---|
| 3998 | |
|---|
| 3999 | (defun* register-asd-directory (directory &key recurse exclude collect) |
|---|
| 4000 | (if (not recurse) |
|---|
| 4001 | (collect-asds-in-directory directory collect) |
|---|
| 4002 | (collect-sub*directories-asd-files |
|---|
| 4003 | directory :exclude exclude :collect collect))) |
|---|
| 4004 | |
|---|
| 4005 | (defparameter *default-source-registries* |
|---|
| 4006 | '(environment-source-registry |
|---|
| 4007 | user-source-registry |
|---|
| 4008 | user-source-registry-directory |
|---|
| 4009 | system-source-registry |
|---|
| 4010 | system-source-registry-directory |
|---|
| 4011 | default-source-registry)) |
|---|
| 4012 | |
|---|
| 4013 | (defparameter *source-registry-file* (coerce-pathname "source-registry.conf")) |
|---|
| 4014 | (defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/")) |
|---|
| 4015 | |
|---|
| 4016 | (defun* wrapping-source-registry () |
|---|
| 4017 | `(:source-registry |
|---|
| 4018 | #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME"))) |
|---|
| 4019 | :inherit-configuration |
|---|
| 4020 | #+cmu (:tree #p"modules:"))) |
|---|
| 4021 | (defun* default-source-registry () |
|---|
| 4022 | (flet ((try (x sub) (try-directory-subpath x sub))) |
|---|
| 4023 | `(:source-registry |
|---|
| 4024 | #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/")) |
|---|
| 4025 | (:directory ,(default-directory)) |
|---|
| 4026 | ,@(loop :for dir :in |
|---|
| 4027 | `(,@(when (os-unix-p) |
|---|
| 4028 | `(,(or (getenv "XDG_DATA_HOME") |
|---|
| 4029 | (try (user-homedir) ".local/share/")) |
|---|
| 4030 | ,@(split-string (or (getenv "XDG_DATA_DIRS") |
|---|
| 4031 | "/usr/local/share:/usr/share") |
|---|
| 4032 | :separator ":"))) |
|---|
| 4033 | ,@(when (os-windows-p) |
|---|
| 4034 | `(,(or #+lispworks (sys:get-folder-path :local-appdata) |
|---|
| 4035 | (getenv "LOCALAPPDATA")) |
|---|
| 4036 | ,(or #+lispworks (sys:get-folder-path :appdata) |
|---|
| 4037 | (getenv "APPDATA")) |
|---|
| 4038 | ,(or #+lispworks (sys:get-folder-path :common-appdata) |
|---|
| 4039 | (getenv "ALLUSERSAPPDATA") |
|---|
| 4040 | (try (getenv "ALLUSERSPROFILE") "Application Data/"))))) |
|---|
| 4041 | :collect `(:directory ,(try dir "common-lisp/systems/")) |
|---|
| 4042 | :collect `(:tree ,(try dir "common-lisp/source/"))) |
|---|
| 4043 | :inherit-configuration))) |
|---|
| 4044 | (defun* user-source-registry () |
|---|
| 4045 | (in-user-configuration-directory *source-registry-file*)) |
|---|
| 4046 | (defun* system-source-registry () |
|---|
| 4047 | (in-system-configuration-directory *source-registry-file*)) |
|---|
| 4048 | (defun* user-source-registry-directory () |
|---|
| 4049 | (in-user-configuration-directory *source-registry-directory*)) |
|---|
| 4050 | (defun* system-source-registry-directory () |
|---|
| 4051 | (in-system-configuration-directory *source-registry-directory*)) |
|---|
| 4052 | (defun* environment-source-registry () |
|---|
| 4053 | (getenv "CL_SOURCE_REGISTRY")) |
|---|
| 4054 | |
|---|
| 4055 | (defgeneric* process-source-registry (spec &key inherit register)) |
|---|
| 4056 | (declaim (ftype (function (t &key (:register (or symbol function))) t) |
|---|
| 4057 | inherit-source-registry)) |
|---|
| 4058 | (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t) |
|---|
| 4059 | process-source-registry-directive)) |
|---|
| 4060 | |
|---|
| 4061 | (defmethod process-source-registry ((x symbol) &key inherit register) |
|---|
| 4062 | (process-source-registry (funcall x) :inherit inherit :register register)) |
|---|
| 4063 | (defmethod process-source-registry ((pathname pathname) &key inherit register) |
|---|
| 4064 | (cond |
|---|
| 4065 | ((directory-pathname-p pathname) |
|---|
| 4066 | (let ((*here-directory* (truenamize pathname))) |
|---|
| 4067 | (process-source-registry (validate-source-registry-directory pathname) |
|---|
| 4068 | :inherit inherit :register register))) |
|---|
| 4069 | ((probe-file* pathname) |
|---|
| 4070 | (let ((*here-directory* (pathname-directory-pathname pathname))) |
|---|
| 4071 | (process-source-registry (validate-source-registry-file pathname) |
|---|
| 4072 | :inherit inherit :register register))) |
|---|
| 4073 | (t |
|---|
| 4074 | (inherit-source-registry inherit :register register)))) |
|---|
| 4075 | (defmethod process-source-registry ((string string) &key inherit register) |
|---|
| 4076 | (process-source-registry (parse-source-registry-string string) |
|---|
| 4077 | :inherit inherit :register register)) |
|---|
| 4078 | (defmethod process-source-registry ((x null) &key inherit register) |
|---|
| 4079 | (declare (ignorable x)) |
|---|
| 4080 | (inherit-source-registry inherit :register register)) |
|---|
| 4081 | (defmethod process-source-registry ((form cons) &key inherit register) |
|---|
| 4082 | (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) |
|---|
| 4083 | (dolist (directive (cdr (validate-source-registry-form form))) |
|---|
| 4084 | (process-source-registry-directive directive :inherit inherit :register register)))) |
|---|
| 4085 | |
|---|
| 4086 | (defun* inherit-source-registry (inherit &key register) |
|---|
| 4087 | (when inherit |
|---|
| 4088 | (process-source-registry (first inherit) :register register :inherit (rest inherit)))) |
|---|
| 4089 | |
|---|
| 4090 | (defun* process-source-registry-directive (directive &key inherit register) |
|---|
| 4091 | (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) |
|---|
| 4092 | (ecase kw |
|---|
| 4093 | ((:include) |
|---|
| 4094 | (destructuring-bind (pathname) rest |
|---|
| 4095 | (process-source-registry (resolve-location pathname) :inherit nil :register register))) |
|---|
| 4096 | ((:directory) |
|---|
| 4097 | (destructuring-bind (pathname) rest |
|---|
| 4098 | (when pathname |
|---|
| 4099 | (funcall register (resolve-location pathname :directory t))))) |
|---|
| 4100 | ((:tree) |
|---|
| 4101 | (destructuring-bind (pathname) rest |
|---|
| 4102 | (when pathname |
|---|
| 4103 | (funcall register (resolve-location pathname :directory t) |
|---|
| 4104 | :recurse t :exclude *source-registry-exclusions*)))) |
|---|
| 4105 | ((:exclude) |
|---|
| 4106 | (setf *source-registry-exclusions* rest)) |
|---|
| 4107 | ((:also-exclude) |
|---|
| 4108 | (appendf *source-registry-exclusions* rest)) |
|---|
| 4109 | ((:default-registry) |
|---|
| 4110 | (inherit-source-registry '(default-source-registry) :register register)) |
|---|
| 4111 | ((:inherit-configuration) |
|---|
| 4112 | (inherit-source-registry inherit :register register)) |
|---|
| 4113 | ((:ignore-inherited-configuration) |
|---|
| 4114 | nil))) |
|---|
| 4115 | nil) |
|---|
| 4116 | |
|---|
| 4117 | (defun* flatten-source-registry (&optional parameter) |
|---|
| 4118 | (remove-duplicates |
|---|
| 4119 | (while-collecting (collect) |
|---|
| 4120 | (let ((*default-pathname-defaults* (default-directory))) |
|---|
| 4121 | (inherit-source-registry |
|---|
| 4122 | `(wrapping-source-registry |
|---|
| 4123 | ,parameter |
|---|
| 4124 | ,@*default-source-registries*) |
|---|
| 4125 | :register #'(lambda (directory &key recurse exclude) |
|---|
| 4126 | (collect (list directory :recurse recurse :exclude exclude))))) |
|---|
| 4127 | :test 'equal :from-end t))) |
|---|
| 4128 | |
|---|
| 4129 | ;; Will read the configuration and initialize all internal variables, |
|---|
| 4130 | ;; and return the new configuration. |
|---|
| 4131 | (defun* compute-source-registry (&optional parameter (registry *source-registry*)) |
|---|
| 4132 | (dolist (entry (flatten-source-registry parameter)) |
|---|
| 4133 | (destructuring-bind (directory &key recurse exclude) entry |
|---|
| 4134 | (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates |
|---|
| 4135 | (register-asd-directory |
|---|
| 4136 | directory :recurse recurse :exclude exclude :collect |
|---|
| 4137 | #'(lambda (asd) |
|---|
| 4138 | (let* ((name (pathname-name asd)) |
|---|
| 4139 | (name (if (typep asd 'logical-pathname) |
|---|
| 4140 | ;; logical pathnames are upper-case, |
|---|
| 4141 | ;; at least in the CLHS and on SBCL, |
|---|
| 4142 | ;; yet (coerce-name :foo) is lower-case. |
|---|
| 4143 | ;; won't work well with (load-system "Foo") |
|---|
| 4144 | ;; instead of (load-system 'foo) |
|---|
| 4145 | (string-downcase name) |
|---|
| 4146 | name))) |
|---|
| 4147 | (cond |
|---|
| 4148 | ((gethash name registry) ; already shadowed by something else |
|---|
| 4149 | nil) |
|---|
| 4150 | ((gethash name h) ; conflict at current level |
|---|
| 4151 | (when *asdf-verbose* |
|---|
| 4152 | (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ |
|---|
| 4153 | found several entries for ~A - picking ~S over ~S~:>") |
|---|
| 4154 | directory recurse name (gethash name h) asd))) |
|---|
| 4155 | (t |
|---|
| 4156 | (setf (gethash name registry) asd) |
|---|
| 4157 | (setf (gethash name h) asd)))))) |
|---|
| 4158 | h))) |
|---|
| 4159 | (values)) |
|---|
| 4160 | |
|---|
| 4161 | (defvar *source-registry-parameter* nil) |
|---|
| 4162 | |
|---|
| 4163 | (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*)) |
|---|
| 4164 | (setf *source-registry-parameter* parameter) |
|---|
| 4165 | (setf *source-registry* (make-hash-table :test 'equal)) |
|---|
| 4166 | (compute-source-registry parameter)) |
|---|
| 4167 | |
|---|
| 4168 | ;; Checks an initial variable to see whether the state is initialized |
|---|
| 4169 | ;; or cleared. In the former case, return current configuration; in |
|---|
| 4170 | ;; the latter, initialize. ASDF will call this function at the start |
|---|
| 4171 | ;; of (asdf:find-system) to make sure the source registry is initialized. |
|---|
| 4172 | ;; However, it will do so *without* a parameter, at which point it |
|---|
| 4173 | ;; will be too late to provide a parameter to this function, though |
|---|
| 4174 | ;; you may override the configuration explicitly by calling |
|---|
| 4175 | ;; initialize-source-registry directly with your parameter. |
|---|
| 4176 | (defun* ensure-source-registry (&optional parameter) |
|---|
| 4177 | (unless (source-registry-initialized-p) |
|---|
| 4178 | (initialize-source-registry parameter)) |
|---|
| 4179 | (values)) |
|---|
| 4180 | |
|---|
| 4181 | (defun* sysdef-source-registry-search (system) |
|---|
| 4182 | (ensure-source-registry) |
|---|
| 4183 | (values (gethash (coerce-name system) *source-registry*))) |
|---|
| 4184 | |
|---|
| 4185 | (defun* clear-configuration () |
|---|
| 4186 | (clear-source-registry) |
|---|
| 4187 | (clear-output-translations)) |
|---|
| 4188 | |
|---|
| 4189 | |
|---|
| 4190 | ;;; ECL support for COMPILE-OP / LOAD-OP |
|---|
| 4191 | ;;; |
|---|
| 4192 | ;;; In ECL, these operations produce both FASL files and the |
|---|
| 4193 | ;;; object files that they are built from. Having both of them allows |
|---|
| 4194 | ;;; us to later on reuse the object files for bundles, libraries, |
|---|
| 4195 | ;;; standalone executables, etc. |
|---|
| 4196 | ;;; |
|---|
| 4197 | ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes |
|---|
| 4198 | ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. |
|---|
| 4199 | ;;; |
|---|
| 4200 | #+ecl |
|---|
| 4201 | (progn |
|---|
| 4202 | (setf *compile-op-compile-file-function* 'ecl-compile-file) |
|---|
| 4203 | |
|---|
| 4204 | (defun use-ecl-byte-compiler-p () |
|---|
| 4205 | (member :ecl-bytecmp *features*)) |
|---|
| 4206 | |
|---|
| 4207 | (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) |
|---|
| 4208 | (if (use-ecl-byte-compiler-p) |
|---|
| 4209 | (apply 'compile-file* input-file keys) |
|---|
| 4210 | (multiple-value-bind (object-file flags1 flags2) |
|---|
| 4211 | (apply 'compile-file* input-file :system-p t keys) |
|---|
| 4212 | (values (and object-file |
|---|
| 4213 | (c::build-fasl (compile-file-pathname object-file :type :fasl) |
|---|
| 4214 | :lisp-files (list object-file)) |
|---|
| 4215 | object-file) |
|---|
| 4216 | flags1 |
|---|
| 4217 | flags2)))) |
|---|
| 4218 | |
|---|
| 4219 | (defmethod output-files ((operation compile-op) (c cl-source-file)) |
|---|
| 4220 | (declare (ignorable operation)) |
|---|
| 4221 | (let* ((p (lispize-pathname (component-pathname c))) |
|---|
| 4222 | (f (compile-file-pathname p :type :fasl))) |
|---|
| 4223 | (if (use-ecl-byte-compiler-p) |
|---|
| 4224 | (list f) |
|---|
| 4225 | (list (compile-file-pathname p :type :object) f)))) |
|---|
| 4226 | |
|---|
| 4227 | (defmethod perform ((o load-op) (c cl-source-file)) |
|---|
| 4228 | (map () #'load |
|---|
| 4229 | (loop :for i :in (input-files o c) |
|---|
| 4230 | :unless (string= (pathname-type i) "fas") |
|---|
| 4231 | :collect (compile-file-pathname (lispize-pathname i)))))) |
|---|
| 4232 | |
|---|
| 4233 | ;;;; ----------------------------------------------------------------- |
|---|
| 4234 | ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL |
|---|
| 4235 | ;;;; |
|---|
| 4236 | (defvar *require-asdf-operator* 'load-op) |
|---|
| 4237 | |
|---|
| 4238 | (defun* module-provide-asdf (name) |
|---|
| 4239 | (handler-bind |
|---|
| 4240 | ((style-warning #'muffle-warning) |
|---|
| 4241 | (missing-component (constantly nil)) |
|---|
| 4242 | (error #'(lambda (e) |
|---|
| 4243 | (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%") |
|---|
| 4244 | name e)))) |
|---|
| 4245 | (let ((*verbose-out* (make-broadcast-stream)) |
|---|
| 4246 | (system (find-system (string-downcase name) nil))) |
|---|
| 4247 | (when system |
|---|
| 4248 | (operate *require-asdf-operator* system :verbose nil) |
|---|
| 4249 | t)))) |
|---|
| 4250 | |
|---|
| 4251 | #+(or abcl clisp clozure cmu ecl sbcl) |
|---|
| 4252 | (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) |
|---|
| 4253 | (when x |
|---|
| 4254 | (eval `(pushnew 'module-provide-asdf |
|---|
| 4255 | #+abcl sys::*module-provider-functions* |
|---|
| 4256 | #+clisp ,x |
|---|
| 4257 | #+clozure ccl:*module-provider-functions* |
|---|
| 4258 | #+(or cmu ecl) ext:*module-provider-functions* |
|---|
| 4259 | #+sbcl sb-ext:*module-provider-functions*)))) |
|---|
| 4260 | |
|---|
| 4261 | |
|---|
| 4262 | ;;;; ------------------------------------------------------------------------- |
|---|
| 4263 | ;;;; Cleanups after hot-upgrade. |
|---|
| 4264 | ;;;; Things to do in case we're upgrading from a previous version of ASDF. |
|---|
| 4265 | ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 |
|---|
| 4266 | ;;;; |
|---|
| 4267 | |
|---|
| 4268 | ;;; If a previous version of ASDF failed to read some configuration, try again. |
|---|
| 4269 | (when *ignored-configuration-form* |
|---|
| 4270 | (clear-configuration) |
|---|
| 4271 | (setf *ignored-configuration-form* nil)) |
|---|
| 4272 | |
|---|
| 4273 | ;;;; ----------------------------------------------------------------- |
|---|
| 4274 | ;;;; Done! |
|---|
| 4275 | (when *load-verbose* |
|---|
| 4276 | (asdf-message ";; ASDF, version ~a~%" (asdf-version))) |
|---|
| 4277 | |
|---|
| 4278 | #+allegro |
|---|
| 4279 | (eval-when (:compile-toplevel :execute) |
|---|
| 4280 | (when (boundp 'excl:*warn-on-nested-reader-conditionals*) |
|---|
| 4281 | (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*))) |
|---|
| 4282 | |
|---|
| 4283 | (pushnew :asdf *features*) |
|---|
| 4284 | (pushnew :asdf2 *features*) |
|---|
| 4285 | |
|---|
| 4286 | (provide :asdf) |
|---|
| 4287 | |
|---|
| 4288 | ;;; Local Variables: |
|---|
| 4289 | ;;; mode: lisp |
|---|
| 4290 | ;;; End: |
|---|
