asdf.lisp 182 KB
Newer Older
1
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2
;;; This is ASDF 2.018: Another System Definition Facility.
3
;;;
4 5
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
Francois-Rene Rideau's avatar
1.647:  
Francois-Rene Rideau committed
6
;;; Note first that the canonical source for ASDF is presently
7
;;; <URL:http://common-lisp.net/project/asdf/>.
8 9 10 11 12
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
13 14 15
;;; bugs.  There are usually two "supported" revisions - the git master
;;; branch is the latest development version, whereas the git release
;;; branch may be slightly older but is considered `stable'
16

17
;;; -- LICENSE START
18
;;; (This is the MIT / X Consortium license as taken from
19 20 21
;;;  http://www.opensource.org/licenses/mit-license.html on or about
;;;  Monday; July 13, 2009)
;;;
22
;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
42 43
;;;
;;; -- LICENSE END
44

45 46
;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it.  Hence, all in one file.
Daniel Barlow's avatar
Daniel Barlow committed
47

48 49
#+xcvb (module ())

50
(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
51

52
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
53
(error "ASDF is not supported on your implementation. Please help us port it.")
54

55 56
#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this

57
(eval-when (:compile-toplevel :load-toplevel :execute)
58
  ;;; Implementation-dependent tweaks
59
  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
60 61 62
  #+allegro
  (setf excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
63
                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
64
  #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp))
65 66
  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
67 68 69
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
    (pushnew :gcl-pre2.7 *features*))
70 71 72 73
  ;;; make package if it doesn't exist yet.
  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
  (unless (find-package :asdf)
    (make-package :asdf :use '(:common-lisp))))
74 75

(in-package :asdf)
76

77
;;;; Create packages in a way that is compatible with hot-upgrade.
78
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
79
;;;; See more near the end of the file.
80

81
(eval-when (:load-toplevel :compile-toplevel :execute)
82 83
  (defvar *asdf-version* nil)
  (defvar *upgraded-p* nil)
84
  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
85 86
  (defun find-symbol* (s p)
    (find-symbol (string s) p))
87 88 89
  ;; Strip out formatting that is not supported on Genera.
  ;; Has to be inside the eval-when to make Lispworks happy (!)
  (defmacro compatfmt (format)
90 91
    #-(or gcl genera) format
    #+(or gcl genera)
92
    (loop :for (unsupported . replacement) :in
93 94 95
      (append
       '(("~3i~_" . ""))
       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
96 97 98 99 100 101
      (loop :for found = (search unsupported format) :while found :do
        (setf format
              (concatenate 'simple-string
                           (subseq format 0 found) replacement
                           (subseq format (+ found (length unsupported)))))))
    format)
102
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
103 104
         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
         ;; can help you do these changes in synch (look at the source for documentation).
105
         ;; Relying on its automation, the version is now redundantly present on top of this file.
106 107
         ;; "2.345" would be an official release
         ;; "2.345.6" would be a development version in the official upstream
108 109
         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
110
         (asdf-version "2.018")
111
         (existing-asdf (find-class 'component nil))
112
         (existing-version *asdf-version*)
113 114
         (already-there (equal asdf-version existing-version)))
    (unless (and existing-asdf already-there)
115
      (when (and existing-asdf *asdf-verbose*)
116
        (format *trace-output*
117 118
                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
                existing-version asdf-version))
119
      (labels
120
          ((present-symbol-p (symbol package)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
121
             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
122 123 124 125 126 127 128
           (present-symbols (package)
             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
             (let (l)
               (do-symbols (s package)
                 (when (present-symbol-p s package) (push s l)))
               (reverse l)))
           (unlink-package (package)
129 130
             (let ((u (find-package package)))
               (when u
131
                 (ensure-unintern u (present-symbols u))
132 133 134
                 (loop :for p :in (package-used-by-list u) :do
                   (unuse-package u p))
                 (delete-package u))))
135
           (ensure-exists (name nicknames use)
136 137 138 139 140 141 142 143 144 145
             (let ((previous
                    (remove-duplicates
                     (mapcar #'find-package (cons name nicknames))
                     :from-end t)))
               ;; do away with packages with conflicting (nick)names
               (map () #'unlink-package (cdr previous))
               ;; reuse previous package with same name
               (let ((p (car previous)))
                 (cond
                   (p
146 147
                    (rename-package p name nicknames)
                    (ensure-use p use)
148 149 150
                    p)
                   (t
                    (make-package name :nicknames nicknames :use use))))))
151 152 153
           (intern* (symbol package)
             (intern (string symbol) package))
           (remove-symbol (symbol package)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
154
             (let ((sym (find-symbol* symbol package)))
155
               (when sym
156
                 #-cormanlisp (unexport sym package)
157 158
                 (unintern sym package)
                 sym)))
159
           (ensure-unintern (package symbols)
160 161 162 163 164
             (loop :with packages = (list-all-packages)
               :for sym :in symbols
               :for removed = (remove-symbol sym package)
               :when removed :do
               (loop :for p :in packages :do
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
165
                 (when (eq removed (find-symbol* sym p))
166
                   (unintern removed p)))))
167 168 169 170 171
           (ensure-shadow (package symbols)
             (shadow symbols package))
           (ensure-use (package use)
             (dolist (used (reverse use))
               (do-external-symbols (sym used)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
172
                 (unless (eq sym (find-symbol* sym package))
173 174 175 176
                   (remove-symbol sym package)))
               (use-package used package)))
           (ensure-fmakunbound (package symbols)
             (loop :for name :in symbols
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
177
               :for sym = (find-symbol* name package)
178 179
               :when sym :do (fmakunbound sym)))
           (ensure-export (package export)
180 181 182
             (let ((formerly-exported-symbols nil)
                   (bothly-exported-symbols nil)
                   (newly-exported-symbols nil))
183
               (do-external-symbols (sym package)
184 185 186 187 188 189 190 191 192
                 (if (member sym export :test 'string-equal)
                     (push sym bothly-exported-symbols)
                     (push sym formerly-exported-symbols)))
               (loop :for sym :in export :do
                 (unless (member sym bothly-exported-symbols :test 'string-equal)
                   (push sym newly-exported-symbols)))
               (loop :for user :in (package-used-by-list package)
                 :for shadowing = (package-shadowing-symbols user) :do
                 (loop :for new :in newly-exported-symbols
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
193
                   :for old = (find-symbol* new user)
194 195 196 197
                   :when (and old (not (member old shadowing)))
                   :do (unintern old user)))
               (loop :for x :in newly-exported-symbols :do
                 (export (intern* x package)))))
198
           (ensure-package (name &key nicknames use unintern
199
                                 shadow export redefined-functions)
200
             (let* ((p (ensure-exists name nicknames use)))
201 202 203
               (ensure-unintern p unintern)
               (ensure-shadow p shadow)
               (ensure-export p export)
204
               (ensure-fmakunbound p redefined-functions)
205 206 207
               p)))
        (macrolet
            ((pkgdcl (name &key nicknames use export
208
                           redefined-functions unintern shadow)
209 210 211
                 `(ensure-package
                   ',name :nicknames ',nicknames :use ',use :export ',export
                   :shadow ',shadow
212
                   :unintern ',unintern
213
                   :redefined-functions ',redefined-functions)))
214 215
          (pkgdcl
           :asdf
216
           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
217
           :use (:common-lisp)
218 219 220
           :redefined-functions
           (#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
221
            #:system-source-file #:operate #:find-component #:find-system
222
            #:apply-output-translations #:translate-pathname* #:resolve-location
223 224 225
            #:system-relative-pathname
            #:inherit-source-registry #:process-source-registry
            #:process-source-registry-directive
226
            #:compile-file* #:source-file-type)
227 228
           :unintern
           (#:*asdf-revision* #:around #:asdf-method-combination
229
            #:split #:make-collector
230
            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
231 232
           :export
           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
233
            #:system-definition-pathname #:with-system-definitions
234
            #:search-for-system-definition #:find-component ; miscellaneous
235
            #:compile-system #:load-system #:test-system #:clear-system
236 237 238 239 240 241
            #:compile-op #:load-op #:load-source-op
            #:test-op
            #:operation               ; operations
            #:feature                 ; sort-of operation
            #:version                 ; metaphorically sort-of an operation
            #:version-satisfies
242
            #:upgrade-asdf
243
            #:implementation-identifier #:implementation-type
244

245
            #:input-files #:output-files #:output-file #:perform ; operation methods
246 247 248 249
            #:operation-done-p #:explain

            #:component #:source-file
            #:c-source-file #:cl-source-file #:java-source-file
250
            #:cl-source-file.cl #:cl-source-file.lsp
251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
            #:static-file
            #:doc-file
            #:html-file
            #:text-file
            #:source-file-type
            #:module                     ; components
            #:system
            #:unix-dso

            #:module-components          ; component accessors
            #:module-components-by-name  ; component accessors
            #:component-pathname
            #:component-relative-pathname
            #:component-name
            #:component-version
            #:component-parent
            #:component-property
            #:component-system

            #:component-depends-on

            #:system-description
            #:system-long-description
            #:system-author
            #:system-maintainer
            #:system-license
            #:system-licence
            #:system-source-file
            #:system-source-directory
            #:system-relative-pathname
            #:map-systems

283
            #:operation-description
284 285
            #:operation-on-warnings
            #:operation-on-failure
286
            #:component-visited-p
287 288 289 290 291 292
            ;;#:*component-parent-pathname*
            #:*system-definition-search-functions*
            #:*central-registry*         ; variables
            #:*compile-file-warnings-behaviour*
            #:*compile-file-failure-behaviour*
            #:*resolve-symlinks*
293
            #:*require-asdf-operator*
294
            #:*asdf-verbose*
295
            #:*verbose-out*
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317

            #:asdf-version

            #:operation-error #:compile-failed #:compile-warned #:compile-error
            #:error-name
            #:error-pathname
            #:load-system-definition-error
            #:error-component #:error-operation
            #:system-definition-error
            #:missing-component
            #:missing-component-of-version
            #:missing-dependency
            #:missing-dependency-of-version
            #:circular-dependency        ; errors
            #:duplicate-names

            #:try-recompiling
            #:retry
            #:accept                     ; restarts
            #:coerce-entry-to-directory
            #:remove-entry-from-registry

318
            #:clear-configuration
319
            #:*output-translations-parameter*
320 321 322 323 324
            #:initialize-output-translations
            #:disable-output-translations
            #:clear-output-translations
            #:ensure-output-translations
            #:apply-output-translations
325
            #:compile-file*
326 327 328
            #:compile-file-pathname*
            #:enable-asdf-binary-locations-compatibility
            #:*default-source-registries*
329
            #:*source-registry-parameter*
330 331 332 333
            #:initialize-source-registry
            #:compute-source-registry
            #:clear-source-registry
            #:ensure-source-registry
334
            #:process-source-registry
335 336
            #:system-registered-p
            #:asdf-message
337

338 339
            ;; Utilities
            #:absolute-pathname-p
340
            ;; #:aif #:it
341
            ;; #:appendf
342 343
            #:coerce-name
            #:directory-pathname-p
344
            ;; #:ends-with
345 346
            #:ensure-directory-pathname
            #:getenv
347
            ;; #:length=n-p
348
            ;; #:find-symbol*
349
            #:merge-pathnames*
350
            #:coerce-pathname
351
            #:subpathname
352 353
            #:pathname-directory-pathname
            #:read-file-forms
354 355
            ;; #:remove-keys
            ;; #:remove-keyword
356 357 358 359
            #:resolve-symlinks
            #:split-string
            #:component-name-to-pathname-components
            #:split-name-type
360
            #:subdirectories
361 362
            #:truenamize
            #:while-collecting)))
363
        #+genera (import 'scl:boolean :asdf)
364 365 366 367
        (setf *asdf-version* asdf-version
              *upgraded-p* (if existing-version
                               (cons existing-version *upgraded-p*)
                               *upgraded-p*))))))
Daniel Barlow's avatar
Daniel Barlow committed
368

369 370 371
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
372 373 374
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

375
Defaults to T.")
376

377 378 379 380
(defvar *compile-file-warnings-behaviour*
  (or #+clisp :ignore :warn)
  "How should ASDF react if it encounters a warning when compiling a file?
Valid values are :error, :warn, and :ignore.")
381

382 383 384 385 386
(defvar *compile-file-failure-behaviour*
  (or #+sbcl :error #+clisp :ignore :warn)
  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
when compiling a file?  Valid values are :error, :warn, and :ignore.
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
Daniel Barlow's avatar
 
Daniel Barlow committed
387

388
(defvar *verbose-out* nil)
389

390
(defparameter +asdf-methods+
391
  '(perform-with-restarts perform explain output-files operation-done-p))
392

393
#+allegro
394
(eval-when (:compile-toplevel :execute)
395 396 397 398 399 400
  (defparameter *acl-warn-save*
                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
                  excl:*warn-on-nested-reader-conditionals*))
  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    (setf excl:*warn-on-nested-reader-conditionals* nil)))

401 402 403 404 405 406 407 408 409 410 411 412 413
;;;; -------------------------------------------------------------------------
;;;; Resolve forward references

(declaim (ftype (function (t) t)
                format-arguments format-control
                error-name error-pathname error-condition
                duplicate-names-name
                error-component error-operation
                module-components module-components-by-name
                circular-dependency-components
                condition-arguments condition-form
                condition-format condition-location
                coerce-name)
414
         #-(or cormanlisp gcl-pre2.7)
415 416 417
         (ftype (function (t t) t) (setf module-components-by-name)))

;;;; -------------------------------------------------------------------------
418
;;;; Compatibility various implementations
419 420 421
#+cormanlisp
(progn
  (deftype logical-pathname () nil)
422 423
  (defun* make-broadcast-stream () *error-output*)
  (defun* file-namestring (p)
424
    (setf p (pathname p))
425
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
426

427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
      (read-from-string
       "(eval-when (:compile-toplevel :load-toplevel :execute)
          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
          ;; Note: ASDF may expect user-homedir-pathname to provide
          ;; the pathname of the current user's home directory, whereas
          ;; MCL by default provides the directory from which MCL was started.
          ;; See http://code.google.com/p/mcl/wiki/Portability
          (defun current-user-homedir-pathname ()
            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
          (defun probe-posix (posix-namestring)
            \"If a file exists for the posix namestring, return the pathname\"
            (ccl::with-cstrs ((cpath posix-namestring))
              (ccl::rlet ((is-dir :boolean)
                          (fsref :fsref))
                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
                  (ccl::%path-from-fsref fsref is-dir))))))"))

446
;;;; -------------------------------------------------------------------------
447 448
;;;; General Purpose Utilities

449 450 451 452
(macrolet
    ((defdef (def* def)
       `(defmacro ,def* (name formals &rest rest)
          `(progn
453
             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
454 455 456
             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
                `(declaim (notinline ,name)))
457 458 459
             (,',def ,name ,formals ,@rest)))))
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))
460

461
(defmacro while-collecting ((&rest collectors) &body body)
462 463 464 465 466 467 468 469 470 471
  "COLLECTORS should be a list of names for collections.  A collector
defines a function that, when applied to an argument inside BODY, will
add its argument to the corresponding collection.  Returns multiple values,
a list for each collection, in order.
   E.g.,
\(while-collecting \(foo bar\)
           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
             \(foo \(first x\)\)
             \(bar \(second x\)\)\)\)
Returns two values: \(A B C\) and \(1 2 3\)."
472 473 474
  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
        (initial-values (mapcar (constantly nil) collectors)))
    `(let ,(mapcar #'list vars initial-values)
475
       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
476
         ,@body
477
         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
478

Daniel Barlow's avatar
Daniel Barlow committed
479 480 481
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

482
(defun* pathname-directory-pathname (pathname)
483 484
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
485 486
  (when pathname
    (make-pathname :name nil :type nil :version nil :defaults pathname)))
487

488 489
(defun* normalize-pathname-directory-component (directory)
  (cond
490
    #-(or cmu sbcl scl)
491 492 493 494 495 496 497 498
    ((stringp directory) `(:absolute ,directory) directory)
    #+gcl
    ((and (consp directory) (stringp (first directory)))
     `(:absolute ,@directory))
    ((or (null directory)
         (and (consp directory) (member (first directory) '(:absolute :relative))))
     directory)
    (t
499
     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522

(defun* merge-pathname-directory-components (specified defaults)
  (let ((directory (normalize-pathname-directory-component specified)))
    (ecase (first directory)
      ((nil) defaults)
      (:absolute specified)
      (:relative
       (let ((defdir (normalize-pathname-directory-component defaults))
             (reldir (cdr directory)))
         (cond
           ((null defdir)
            directory)
           ((not (eq :back (first reldir)))
            (append defdir reldir))
           (t
            (loop :with defabs = (first defdir)
              :with defrev = (reverse (rest defdir))
              :while (and (eq :back (car reldir))
                          (or (and (eq :absolute defabs) (null defrev))
                              (stringp (car defrev))))
              :do (pop reldir) (pop defrev)
              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))

523
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
524 525 526 527 528
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
529 530 531
Also, if either argument is NIL, then the other argument is returned unmodified."
  (when (null specified) (return-from merge-pathnames* defaults))
  (when (null defaults) (return-from merge-pathnames* specified))
532 533 534
  #+scl
  (ext:resolve-pathname specified defaults)
  #-scl
535 536
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
537
         (directory (normalize-pathname-directory-component (pathname-directory specified)))
538 539 540
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
541 542 543 544 545
    (labels ((ununspecific (x)
               (if (eq x :unspecific) nil x))
             (unspecific-handler (p)
               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
546
          (ecase (first directory)
547 548 549 550 551
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                     directory
                     (unspecific-handler specified)))
552
            ((nil :relative)
553 554
             (values (pathname-host defaults)
                     (pathname-device defaults)
555
                     (merge-pathname-directory-components directory (pathname-directory defaults))
556 557 558 559 560
                     (unspecific-handler defaults))))
        (make-pathname :host host :device device :directory directory
                       :name (funcall unspecific-handler name)
                       :type (funcall unspecific-handler type)
                       :version (funcall unspecific-handler version))))))
561

562 563 564 565 566
(defun* pathname-parent-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
  (when pathname
    (make-pathname :name nil :type nil :version nil
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
567 568
                   :directory (merge-pathname-directory-components
                               '(:relative :back) (pathname-directory pathname))
569 570
                   :defaults pathname)))

571
(define-modify-macro appendf (&rest args)
572 573 574 575
  append "Append onto list") ;; only to be used on short lists.

(define-modify-macro orf (&rest args)
  or "or a flag")
Daniel Barlow's avatar
 
Daniel Barlow committed
576

577
(defun* first-char (s)
578 579
  (and (stringp s) (plusp (length s)) (char s 0)))

580
(defun* last-char (s)
581 582
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

583

584
(defun* asdf-message (format-string &rest format-args)
585
  (declare (dynamic-extent format-args))
586
  (apply 'format *verbose-out* format-string format-args))
587

588
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
589 590
  "Split STRING into a list of components separated by
any of the characters in the sequence SEPARATOR.
591 592 593
If MAX is specified, then no more than max(1,MAX) components will be returned,
starting the separation from the end, e.g. when called with arguments
 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
594
  (catch nil
595 596
    (let ((list nil) (words 0) (end (length string)))
      (flet ((separatorp (char) (find char separator))
597
             (done () (throw nil (cons (subseq string 0 end) list))))
598 599 600 601 602 603 604 605 606
        (loop
          :for start = (if (and max (>= words (1- max)))
                           (done)
                           (position-if #'separatorp string :end end :from-end t)) :do
          (when (null start)
            (done))
          (push (subseq string (1+ start) end) list)
          (incf words)
          (setf end start))))))
607

608
(defun* split-name-type (filename)
609 610 611 612
  (let ((unspecific
         ;; Giving :unspecific as argument to make-pathname is not portable.
         ;; See CLHS make-pathname and 19.2.2.2.3.
         ;; We only use it on implementations that support it.
613
         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
614 615 616 617 618
    (destructuring-bind (name &optional (type unspecific))
        (split-string filename :max 2 :separator ".")
      (if (equal name "")
          (values filename unspecific)
          (values name type)))))
619

620
(defun* component-name-to-pathname-components (s &key force-directory force-relative)
621 622 623 624 625 626 627 628 629 630
  "Splits the path string S, returning three values:
A flag that is either :absolute or :relative, indicating
   how the rest of the values are to be interpreted.
A directory path --- a list of strings, suitable for
   use with MAKE-PATHNAME when prepended with the flag
   value.
A filename with type extension, possibly NIL in the
   case of a directory pathname.
FORCE-DIRECTORY forces S to be interpreted as a directory
pathname \(third return value will be NIL, final component
631 632 633 634 635
of S will be treated as part of the directory path.

The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
pathnames."
636
  (check-type s string)
637
  (when (find #\: s)
638
    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
639
  (let* ((components (split-string s :separator "/"))
640 641 642
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
643
            (if (equal (first-char s) #\/)
644 645
                (progn
                  (when force-relative
646
                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
647
                  (values :absolute (cdr components)))
648
                (values :relative nil))
649
          (values :relative components))
650 651
      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
      (setf components (substitute :back ".." components :test #'equal))
652 653
      (cond
        ((equal last-comp "")
654
         (values relative components nil)) ; "" already removed
655 656 657 658
        (force-directory
         (values relative components nil))
        (t
         (values relative (butlast components) last-comp))))))
659

660
(defun* remove-keys (key-names args)
661 662 663 664 665
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

666
(defun* remove-keyword (key args)
667 668 669
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))
670

671
(defun* getenv (x)
672
  (declare (ignorable x))
673
  #+(or abcl clisp ecl xcl) (ext:getenv x)
674 675 676
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
677 678 679 680 681 682 683 684 685 686
  #+cormanlisp
  (let* ((buffer (ct:malloc 1))
         (cname (ct:lisp-string-to-c-string x))
         (needed-size (win:getenvironmentvariable cname buffer 0))
         (buffer1 (ct:malloc (1+ needed-size))))
    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
               nil
               (ct:c-string-to-lisp-string buffer1))
      (ct:free buffer)
      (ct:free buffer1)))
687 688 689 690 691 692 693 694
  #+gcl (system:getenv x)
  #+genera nil
  #+lispworks (lispworks:environment-variable x)
  #+mcl (ccl:with-cstrs ((name x))
          (let ((value (_getenv name)))
            (unless (ccl:%null-ptr-p value)
              (ccl:%get-cstring value))))
  #+sbcl (sb-ext:posix-getenv x)
695 696
  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
  (error "~S is not supported on your implementation" 'getenv))
697

698
(defun* directory-pathname-p (pathname)
699
  "Does PATHNAME represent a directory?
700 701

A directory-pathname is a pathname _without_ a filename. The three
702 703
ways that the filename components can be missing are for it to be NIL,
:UNSPECIFIC or the empty string.
704

705
Note that this does _not_ check to see that PATHNAME points to an
706
actually-existing directory."
707 708 709 710 711 712 713 714
  (when pathname
    (let ((pathname (pathname pathname)))
      (flet ((check-one (x)
               (member x '(nil :unspecific "") :test 'equal)))
        (and (not (wild-pathname-p pathname))
             (check-one (pathname-name pathname))
             (check-one (pathname-type pathname))
             t)))))
715

716
(defun* ensure-directory-pathname (pathspec)
717
  "Converts the non-wild pathname designator PATHSPEC to directory form."
718 719
  (cond
   ((stringp pathspec)
720
    (ensure-directory-pathname (pathname pathspec)))
721
   ((not (pathnamep pathspec))
722
    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
723
   ((wild-pathname-p pathspec)
724
    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
725 726 727 728 729 730 731 732
   ((directory-pathname-p pathspec)
    pathspec)
   (t
    (make-pathname :directory (append (or (pathname-directory pathspec)
                                          (list :relative))
                                      (list (file-namestring pathspec)))
                   :name nil :type nil :version nil
                   :defaults pathspec))))
733

734 735
#+genera
(unless (fboundp 'ensure-directories-exist)
736
  (defun* ensure-directories-exist (path)
737 738
    (fs:create-directories-recursively (pathname path))))

739
(defun* absolute-pathname-p (pathspec)
740 741
  (and (typep pathspec '(or pathname string))
       (eq :absolute (car (pathname-directory (pathname pathspec))))))
742

743
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
744 745 746 747 748 749 750 751
  (check-type n (integer 0 *))
  (loop
    :for l = x :then (cdr l)
    :for i :downfrom n :do
    (cond
      ((zerop i) (return (null l)))
      ((not (consp l)) (return nil)))))

752
(defun* ends-with (s suffix)
753 754 755 756 757
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
758

759
(defun* read-file-forms (file)
760 761 762 763 764 765
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

766
(defun* pathname-root (pathname)
767
  (make-pathname :directory '(:absolute)
768
                 :name nil :type nil :version nil
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
769 770
                 :defaults pathname ;; host device, and on scl, *some*
                 ;; scheme-specific parts: port username password, not others:
771
                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
772

773
(defun* probe-file* (p)
774 775
  "when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
776
  (etypecase p
777 778 779
    (null nil)
    (string (probe-file* (parse-namestring p)))
    (pathname (unless (wild-pathname-p p)
780 781
                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
                      '(probe-file p)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
782 783
                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
                                   `(ignore-errors (,it p)))
784
                      '(ignore-errors (truename p)))))))
785

786
(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
787
  "Resolve as much of a pathname as possible"
788
  (block nil
789 790
    (when (typep pathname '(or null logical-pathname)) (return pathname))
    (let ((p (merge-pathnames* pathname defaults)))
791
      (when (typep p 'logical-pathname) (return p))
792 793
      (let ((found (probe-file* p)))
        (when found (return found)))
794 795 796 797 798
      (unless (absolute-pathname-p p)
        (let ((true-defaults (ignore-errors (truename defaults))))
          (when true-defaults
            (setf p (merge-pathnames pathname true-defaults)))))
      (unless (absolute-pathname-p p) (return p))
799
      (let ((sofar (probe-file* (pathname-root p))))
800
        (unless sofar (return p))
801
        (flet ((solution (directories)
802 803
                 (merge-pathnames*
                  (make-pathname :host nil :device nil
804
                                 :directory `(:relative ,@directories)
805 806
                                 :name (pathname-name p)
                                 :type (pathname-type p)
807
                                 :version (pathname-version p))
808
                  sofar)))
809 810 811
          (loop :with directory = (normalize-pathname-directory-component
                                   (pathname-directory p))
            :for component :in (cdr directory)
812
            :for rest :on (cdr directory)
813 814 815 816
            :for more = (probe-file*
                         (merge-pathnames*
                          (make-pathname :directory `(:relative ,component))
                          sofar)) :do
817 818
            (if more
                (setf sofar more)
819
                (return (solution rest)))
820 821
            :finally
            (return (solution nil))))))))
822

823
(defun* resolve-symlinks (path)
824
  #-allegro (truenamize path)
825 826 827
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))
828

829 830 831 832 833
(defun* resolve-symlinks* (path)
  (if *resolve-symlinks*
      (and path (resolve-symlinks path))
      path))

834
(defun* ensure-pathname-absolute (path)
835 836 837 838 839 840 841 842
  (cond
    ((absolute-pathname-p path) path)
    ((stringp path) (ensure-pathname-absolute (pathname path)))
    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
    (t (let ((resolved (resolve-symlinks path)))
         (assert (absolute-pathname-p resolved))
         resolved))))

843
(defun* default-directory ()
844 845
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

846
(defun* lispize-pathname (input-file)
847 848
  (make-pathname :type "lisp" :defaults input-file))

849
(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
850
(defparameter *wild-file*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
851 852
  (make-pathname :name *wild* :type *wild*
                 :version (or #-(or abcl xcl) *wild*) :directory nil))
853
(defparameter *wild-directory*
854
  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
855 856
(defparameter *wild-inferiors*
  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
857
(defparameter *wild-path*
858
  (merge-pathnames *wild-file* *wild-inferiors*))
859

860
(defun* wilden (path)
861 862
  (merge-pathnames* *wild-path* path))

863
#-scl
864
(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
865 866 867
  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

868
#-scl
869
(defun* directorize-pathname-host-device (pathname)
870 871 872
  (let* ((root (pathname-root pathname))
         (wild-root (wilden root))
         (absolute-pathname (merge-pathnames* pathname root))
873
         (separator (directory-separator-for-host root))
874 875 876
         (root-namestring (namestring root))
         (root-string
          (substitute-if #\/
877 878
                         #'(lambda (x) (or (eql x #\:)
                                           (eql x separator)))
879 880
                         root-namestring)))
    (multiple-value-bind (relative path filename)
881
        (component-name-to-pathname-components root-string :force-directory t)
882 883 884 885 886 887
      (declare (ignore relative filename))
      (let ((new-base
             (make-pathname :defaults root
                            :directory `(:absolute ,@path))))
        (translate-pathname absolute-pathname wild-root (wilden new-base))))))

888 889 890
#+scl
(defun* directorize-pathname-host-device (pathname)
  (let ((scheme (ext:pathname-scheme pathname))
891 892 893
        (host (pathname-host pathname))
        (port (ext:pathname-port pathname))
        (directory (pathname-directory pathname)))
894
    (flet ((not-unspecific (component)
895
             (and (not (eq component :unspecific)) component)))
896
      (cond ((or (not-unspecific port)
897 898 899 900 901 902 903 904 905 906 907 908 909 910 911
                 (and (not-unspecific host) (plusp (length host)))
                 (not-unspecific scheme))
             (let ((prefix ""))
               (when (not-unspecific port)
                 (setf prefix (format nil ":~D" port)))
               (when (and (not-unspecific host) (plusp (length host)))
                 (setf prefix (concatenate 'string host prefix)))
               (setf prefix (concatenate 'string ":" prefix))
               (when (not-unspecific scheme)
               (setf prefix (concatenate 'string scheme prefix)))
               (assert (and directory (eq (first directory) :absolute)))
               (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
                              :defaults pathname)))
            (t
             pathname)))))
912

913 914 915 916 917 918
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
(defgeneric* find-system (system &optional error-p))
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
(defgeneric* operation-done-p (operation component))
919
(defgeneric* mark-operation-done (operation component))
920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948
(defgeneric* explain (operation component))
(defgeneric* output-files (operation component))
(defgeneric* input-files (operation component))
(defgeneric* component-operation-time (operation component))
(defgeneric* operation-description (operation component)
  (:documentation "returns a phrase that describes performing this operation
on this component, e.g. \"loading /a/b/c\".
You can put together sentences using this phrase."