asdf.lisp 183 KB
Newer Older
1
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2
;;; This is ASDF 2.20: 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 1) (debug 3) (safety 3))) ; NO: trust 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 65
  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
66 67
  #+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
68 69 70
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
    (pushnew :gcl-pre2.7 *features*))
71 72 73 74
  ;;; 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))))
75 76

(in-package :asdf)
77

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

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

            #:component #:source-file
            #:c-source-file #:cl-source-file #:java-source-file
247
            #:cl-source-file.cl #:cl-source-file.lsp
248 249 250 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
            #: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

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

            #: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

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

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

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

378
Defaults to T.")
379

380 381 382 383
(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.")
384

385 386 387 388 389
(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
390

391
(defvar *verbose-out* nil)
392

393
(defparameter +asdf-methods+
394
  '(perform-with-restarts perform explain output-files operation-done-p))
395

396
#+allegro
397
(eval-when (:compile-toplevel :execute)
398 399 400 401 402 403
  (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)))

404 405 406 407 408 409 410 411 412 413 414 415 416
;;;; -------------------------------------------------------------------------
;;;; 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)
417
         (ftype (function (&optional t) (values)) initialize-source-registry)
418
         #-(or cormanlisp gcl-pre2.7)
419 420 421
         (ftype (function (t t) t) (setf module-components-by-name)))

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

431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
#.(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))))))"))

450
;;;; -------------------------------------------------------------------------
451 452
;;;; General Purpose Utilities

453 454 455 456
(macrolet
    ((defdef (def* def)
       `(defmacro ,def* (name formals &rest rest)
          `(progn
457
             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
458 459 460
             #-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)))
461 462 463
             (,',def ,name ,formals ,@rest)))))
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))
464

465
(defmacro while-collecting ((&rest collectors) &body body)
466 467 468 469 470 471 472 473 474 475
  "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\)."
476 477 478
  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
        (initial-values (mapcar (constantly nil) collectors)))
    `(let ,(mapcar #'list vars initial-values)
479
       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
480
         ,@body
481
         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
482

Daniel Barlow's avatar
Daniel Barlow committed
483 484 485
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

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

492 493
(defun* normalize-pathname-directory-component (directory)
  (cond
494
    #-(or cmu sbcl scl)
495 496 497 498 499 500 501 502
    ((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
503
     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526

(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)))))))))))

527 528 529
(defun* ununspecific (x)
  (if (eq x :unspecific) nil x))

530
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
531 532 533 534 535
  "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.
536 537 538
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))
539 540 541
  #+scl
  (ext:resolve-pathname specified defaults)
  #-scl
542 543
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
544
         (directory (normalize-pathname-directory-component (pathname-directory specified)))
545 546 547
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
548
    (labels ((unspecific-handler (p)
549 550
               (if (typep p 'logical-pathname) #'ununspecific #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
551
          (ecase (first directory)
552 553 554 555 556
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                     directory
                     (unspecific-handler specified)))
557
            ((nil :relative)
558 559
             (values (pathname-host defaults)
                     (pathname-device defaults)
560
                     (merge-pathname-directory-components directory (pathname-directory defaults))
561 562 563 564 565
                     (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))))))
566

567 568 569 570 571
(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
572 573
                   :directory (merge-pathname-directory-components
                               '(:relative :back) (pathname-directory pathname))
574 575
                   :defaults pathname)))

576
(define-modify-macro appendf (&rest args)
577 578 579 580
  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
581

582
(defun* first-char (s)
583 584
  (and (stringp s) (plusp (length s)) (char s 0)))

585
(defun* last-char (s)
586 587
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

588

589
(defun* asdf-message (format-string &rest format-args)
590
  (declare (dynamic-extent format-args))
591
  (apply 'format *verbose-out* format-string format-args))
592

593
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
594 595
  "Split STRING into a list of components separated by
any of the characters in the sequence SEPARATOR.
596 597 598
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\")."
599
  (catch nil
600 601
    (let ((list nil) (words 0) (end (length string)))
      (flet ((separatorp (char) (find char separator))
602
             (done () (throw nil (cons (subseq string 0 end) list))))
603 604 605 606 607 608 609 610 611
        (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))))))
612

613
(defun* split-name-type (filename)
614 615 616 617
  (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.
618
         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
619 620 621 622 623
    (destructuring-bind (name &optional (type unspecific))
        (split-string filename :max 2 :separator ".")
      (if (equal name "")
          (values filename unspecific)
          (values name type)))))
624

625
(defun* component-name-to-pathname-components (s &key force-directory force-relative)
626 627 628 629 630 631 632 633 634 635
  "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
636 637 638 639 640
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."
641
  (check-type s string)
642
  (when (find #\: s)
643
    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
644
  (let* ((components (split-string s :separator "/"))
645 646 647
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
648
            (if (equal (first-char s) #\/)
649 650
                (progn
                  (when force-relative
651
                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
652
                  (values :absolute (cdr components)))
653
                (values :relative nil))
654
          (values :relative components))
655 656
      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
      (setf components (substitute :back ".." components :test #'equal))
657 658
      (cond
        ((equal last-comp "")
659
         (values relative components nil)) ; "" already removed
660 661 662 663
        (force-directory
         (values relative components nil))
        (t
         (values relative (butlast components) last-comp))))))
664

665
(defun* remove-keys (key-names args)
666 667 668 669 670
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

671
(defun* remove-keyword (key args)
672 673 674
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))
675

676
(defun* getenv (x)
677
  (declare (ignorable x))
678
  #+(or abcl clisp ecl xcl) (ext:getenv x)
679 680 681
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
682 683 684 685 686 687 688 689 690 691
  #+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)))
692 693 694 695 696 697 698 699
  #+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)
700 701
  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
  (error "~S is not supported on your implementation" 'getenv))
702

703
(defun* directory-pathname-p (pathname)
704
  "Does PATHNAME represent a directory?
705 706

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

710
Note that this does _not_ check to see that PATHNAME points to an
711
actually-existing directory."
712 713 714 715 716 717 718 719
  (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)))))
720

721
(defun* ensure-directory-pathname (pathspec)
722
  "Converts the non-wild pathname designator PATHSPEC to directory form."
723 724
  (cond
   ((stringp pathspec)
725
    (ensure-directory-pathname (pathname pathspec)))
726
   ((not (pathnamep pathspec))
727
    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
728
   ((wild-pathname-p pathspec)
729
    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
730 731 732 733 734 735 736 737
   ((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))))
738

739 740
#+genera
(unless (fboundp 'ensure-directories-exist)
741
  (defun* ensure-directories-exist (path)
742 743
    (fs:create-directories-recursively (pathname path))))

744
(defun* absolute-pathname-p (pathspec)
745 746
  (and (typep pathspec '(or pathname string))
       (eq :absolute (car (pathname-directory (pathname pathspec))))))
747

748
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
749 750 751 752 753 754 755 756
  (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)))))

757
(defun* ends-with (s suffix)
758 759 760 761 762
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
763

764
(defun* read-file-forms (file)
765 766 767 768 769 770
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

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

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

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

828
(defun* resolve-symlinks (path)
829
  #-allegro (truenamize path)
830 831 832
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))
833

834 835 836 837 838
(defun* resolve-symlinks* (path)
  (if *resolve-symlinks*
      (and path (resolve-symlinks path))
      path))

839
(defun* ensure-pathname-absolute (path)
840 841 842 843 844 845 846 847
  (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))))

848
(defun* default-directory ()
849 850
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

851
(defun* lispize-pathname (input-file)
852 853
  (make-pathname :type "lisp" :defaults input-file))

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

865
(defun* wilden (path)
866 867
  (merge-pathnames* *wild-path* path))

868
#-scl
869
(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
870 871 872
  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

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

893 894 895
#+scl
(defun* directorize-pathname-host-device (pathname)
  (let ((scheme (ext:pathname-scheme pathname))
896 897 898
        (host (pathname-host pathname))
        (port (ext:pathname-port pathname))
        (directory (pathname-directory pathname)))
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
    (if (or (ununspecific port)
            (and (ununspecific host) (plusp (length host)))
            (ununspecific scheme))
        (let ((prefix ""))
          (when (ununspecific port)
            (setf prefix (format nil ":~D" port)))
          (when (and (ununspecific host) (plusp (length host)))
            (setf prefix (strcat host prefix)))
          (setf prefix (strcat ":" prefix))
          (when (ununspecific scheme)
            (setf prefix (strcat scheme prefix)))
          (assert (and directory (eq (first directory) :absolute)))
          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
                         :defaults pathname)))
    pathname))
914

915 916 917 918 919 920
;;;; -------------------------------------------------------------------------
;;;; 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))