contrib/asdf/asdf.lisp

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