asdf.lisp 180 KB
Newer Older
1
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2
;;; This is ASDF 2.017.17: 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
74
  (cond
    ((intersection *features* '(:asdf-unix :unix :cygwin :darwin))
     (pushnew :asdf-unix *features*))
    ((intersection *features* '(:asdf-windows :win32 :windows :mswindows :mingw32))
     (pushnew :asdf-windows *features*)))
75
76
77
78
  ;;; 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))))
79
80

(in-package :asdf)
81

82
;;;; Create packages in a way that is compatible with hot-upgrade.
83
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
84
;;;; See more near the end of the file.
85

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

256
            #:input-files #:output-files #:output-file #:perform ; operation methods
257
258
259
260
            #:operation-done-p #:explain

            #:component #:source-file
            #:c-source-file #:cl-source-file #:java-source-file
261
            #:cl-source-file.cl #:cl-source-file.lsp
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
            #: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

294
            #:operation-description
295
296
            #:operation-on-warnings
            #:operation-on-failure
297
            #:component-visited-p
298
299
300
301
302
303
            ;;#:*component-parent-pathname*
            #:*system-definition-search-functions*
            #:*central-registry*         ; variables
            #:*compile-file-warnings-behaviour*
            #:*compile-file-failure-behaviour*
            #:*resolve-symlinks*
304
            #:*require-asdf-operator*
305
            #:*asdf-verbose*
306
            #:*verbose-out*
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328

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

329
            #:clear-configuration
330
            #:*output-translations-parameter*
331
332
333
334
335
            #:initialize-output-translations
            #:disable-output-translations
            #:clear-output-translations
            #:ensure-output-translations
            #:apply-output-translations
336
            #:compile-file*
337
338
339
            #:compile-file-pathname*
            #:enable-asdf-binary-locations-compatibility
            #:*default-source-registries*
340
            #:*source-registry-parameter*
341
342
343
344
            #:initialize-source-registry
            #:compute-source-registry
            #:clear-source-registry
            #:ensure-source-registry
345
            #:process-source-registry
346
347
            #:system-registered-p
            #:asdf-message
348

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

379
380
381
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
382
383
384
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

385
Defaults to T.")
386

387
388
389
390
(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.")
391

392
393
394
395
396
(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
397

398
(defvar *verbose-out* nil)
399

400
(defparameter +asdf-methods+
401
  '(perform-with-restarts perform explain output-files operation-done-p))
402

403
#+allegro
404
(eval-when (:compile-toplevel :execute)
405
406
407
408
409
410
  (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)))

411
412
413
414
415
416
417
418
419
420
421
422
423
;;;; -------------------------------------------------------------------------
;;;; 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)
424
         #-(or cormanlisp gcl-pre2.7)
425
426
427
         (ftype (function (t t) t) (setf module-components-by-name)))

;;;; -------------------------------------------------------------------------
428
;;;; Compatibility various implementations
429
430
431
#+cormanlisp
(progn
  (deftype logical-pathname () nil)
432
433
  (defun* make-broadcast-stream () *error-output*)
  (defun* file-namestring (p)
434
    (setf p (pathname p))
435
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
436

437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
#.(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))))))"))

456
;;;; -------------------------------------------------------------------------
457
458
;;;; General Purpose Utilities

459
460
461
462
(macrolet
    ((defdef (def* def)
       `(defmacro ,def* (name formals &rest rest)
          `(progn
463
             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
464
465
466
             #-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)))
467
468
469
             (,',def ,name ,formals ,@rest)))))
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))
470

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

489
490
491
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

492
(defun* pathname-directory-pathname (pathname)
493
494
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
495
496
  (when pathname
    (make-pathname :name nil :type nil :version nil :defaults pathname)))
497

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

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

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

572
573
574
575
576
(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
577
578
                   :directory (merge-pathname-directory-components
                               '(:relative :back) (pathname-directory pathname))
579
580
                   :defaults pathname)))

581
(define-modify-macro appendf (&rest args)
582
583
584
585
  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
586

587
(defun* first-char (s)
588
589
  (and (stringp s) (plusp (length s)) (char s 0)))

590
(defun* last-char (s)
591
592
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

593

594
(defun* asdf-message (format-string &rest format-args)
595
  (declare (dynamic-extent format-args))
596
  (apply 'format *verbose-out* format-string format-args))
597

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

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

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

670
(defun* remove-keys (key-names args)
671
672
673
674
675
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

676
(defun* remove-keyword (key args)
677
678
679
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))
680

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

708
(defun* directory-pathname-p (pathname)
709
  "Does PATHNAME represent a directory?
710
711

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

715
Note that this does _not_ check to see that PATHNAME points to an
716
actually-existing directory."
717
718
719
720
721
722
723
724
  (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)))))
725

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

744
745
#+genera
(unless (fboundp 'ensure-directories-exist)
746
  (defun* ensure-directories-exist (path)
747
748
    (fs:create-directories-recursively (pathname path))))

749
(defun* absolute-pathname-p (pathspec)
750
751
  (and (typep pathspec '(or pathname string))
       (eq :absolute (car (pathname-directory (pathname pathspec))))))
752

753
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
754
755
756
757
758
759
760
761
  (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)))))

762
(defun* ends-with (s suffix)
763
764
765
766
767
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
768

769
(defun* read-file-forms (file)
770
771
772
773
774
775
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

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

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

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

833
(defun* resolve-symlinks (path)
834
  #-allegro (truenamize path)
835
836
837
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))
838

839
840
841
842
843
(defun* resolve-symlinks* (path)
  (if *resolve-symlinks*
      (and path (resolve-symlinks path))
      path))

844
(defun* ensure-pathname-absolute (path)
845
846
847
848
849
850
851
852
  (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))))

853
(defun* default-directory ()
854
855
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

856
(defun* lispize-pathname (input-file)
857
858
  (make-pathname :type "lisp" :defaults input-file))

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

870
(defun* wilden (path)
871
872
  (merge-pathnames* *wild-path* path))

873
#-scl
874
(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
875
876
877
  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

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

898
899
900
#+scl
(defun* directorize-pathname-host-device (pathname)
  (let ((scheme (ext:pathname-scheme pathname))
901
902
903
        (host (pathname-host pathname))
        (port (ext:pathname-port pathname))
        (directory (pathname-directory pathname)))
904
    (flet ((not-unspecific (component)
905
             (and (not (eq component :unspecific)) component)))
906
      (cond ((or (not-unspecific port)
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
                 (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)))))
922

923
924
925
926
927
928
;;;; -------------------------------------------------------------------------
;;;; 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))
929
(defgeneric* mark-operation-done (operation component))
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
(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."))

(defgeneric* system-source-file (system)
  (:documentation "Return the source file in which system is defined."))

(defgeneric* component-system (component)
  (:documentation "Find the top-level system containing COMPONENT"))

(defgeneric* component-pathname (component)
  (:documentation "Extracts the pathname applicable for a particular component."))

(defgeneric* component-relative-pathname (component)
  (:documentation "Returns a pathname for the component argument intended to be
interpreted relative to the pathname of that component's parent.
Despite the function's name, the return value may be an absolute
pathname, because an absolute pathname may be interpreted relative to
another pathname in a degenerate way."))

(defgeneric* component-property (component property))

(defgeneric* (setf component-property) (new-value component property))

959
(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
960
961
  (defgeneric* (setf module-components-by-name) (new-value module)))

962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
(defgeneric* version-satisfies (component version))

(defgeneric* find-component (base path)
  (:documentation "Finds the component with PATH starting from BASE module;
if BASE is nil, then the component is assumed to be a system."))

(defgeneric* source-file-type (component system))

(defgeneric* operation-ancestor (operation)
  (:documentation
   "Recursively chase the operation's parent pointer until we get to
the head of the tree"))

(defgeneric* component-visited-p (operation component)
  (:documentation "Returns the value stored by a call to
VISIT-COMPONENT, if that has been called, otherwise NIL.
This value stored will be a cons cell, the first element
of which is a computed key, so not interesting.  The
CDR wil be the DATA value stored by VISIT-COMPONENT; recover
it as (cdr (component-visited-p op c)).
  In the current form of ASDF, the DATA value retrieved is
effectively a boolean, indicating whether some operations are
to be performed in order to do OPERATION X COMPONENT.  If the
data value is NIL, the combination had been explored, but no
operations needed to be performed."))

(defgeneric* visit-component (operation component data)
  (:documentation "Record DATA as being associated with OPERATION
and COMPONENT.  This is a side-effecting function:  the association
will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
OPERATION\).
  No evidence that DATA is ever interesting, beyond just being
non-NIL.  Using the data field is probably very risky; if there is
already a record for OPERATION X COMPONENT, DATA will be quietly
discarded instead of recorded.
  Starting with 2.006, TRAVERSE will store an integer in data,
so that nodes can be sorted in decreasing order of traversal."))


(defgeneric* (setf visiting-component) (new-value operation component))

(defgeneric* component-visiting-p (operation component))

(defgeneric* component-depends-on (operation component)
  (:documentation
   "Returns a list of dependencies needed by the component to perform
    the operation.  A dependency has one of the following forms:

      (<operation> <component>*), where <operation> is a class
        designator and each <component> is a component
        designator, which means that the component depends on
        <operation> having been performed on each <component>; or

      (FEATURE <feature>), which means that the component depends
        on <feature>'s presence in *FEATURES*.

    Methods specialized on subclasses of existing component types
    should usually append the results of CALL-NEXT-METHOD to the
    list."))

(defgeneric* component-self-dependencies (operation component))

(defgeneric* traverse (operation component)
  (:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.

The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))


;;;; -------------------------------------------------------------------------
;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
(when *upgraded-p*
   (when (find-class 'module nil)
     (eval
1038
      '(defmethod update-instance-for-redefined-class :after
1039
1040
           ((m module) added deleted plist &key)
         (declare (ignorable deleted plist))
1041
         (when *asdf-verbose*
1042
           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
1043
                         m (asdf-version)))
1044
1045
         (when (member 'components-by-name added)
           (compute-module-components-by-name m))
1046
1047
1048
1049
1050
1051
         (when (typep m 'system)
           (when (member 'source-file added)
             (%set-system-source-file
              (probe-asd (component-name m) (component-pathname m)) m)
             (when (equal (component-name m) "asdf")
               (setf (component-version m) *asdf-version*))))))))
1052

1053
1054
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
Daniel Barlow's avatar
Daniel Barlow committed
1055

1056
1057
1058
1059
1060
1061
1062
1063
1064
(define-condition system-definition-error (error) ()
  ;; [this use of :report should be redundant, but unfortunately it's not.
  ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
  ;; over print-object; this is always conditions::%print-condition for
  ;; condition objects, which in turn does inheritance of :report options at
  ;; run-time.  fortunately, inheritance means we only need this kludge here in
  ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
  #+cmu (:report print-object))

Daniel Barlow's avatar
Daniel Barlow committed
1065
(define-condition formatted-system-definition-error (system-definition-error)
1066
1067
1068
  ((format-control :initarg :format-control :reader format-control)
   (format-arguments :initarg :format-arguments :reader format-arguments))
  (:report (lambda (c s)
1069
               (apply 'format s (format-control c) (format-arguments c)))))
1070

1071
(define-con