contrib/asdf/asdf.lisp

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