asdf.lisp 170 KB
Newer Older
1
;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2
;;; This is ASDF 2.015: 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
53
54
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
(error "ASDF is not supported on your implementation. Please help us with it.")

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
  #+(and ecl (not ecl-bytecmp)) (require :cmp)
65
  #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
66
67
68
69
70
  #+(or unix cygwin) (pushnew :asdf-unix *features*)
  ;;; 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))))
71
72

(in-package :asdf)
73

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

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

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

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

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

            #:component-depends-on

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

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

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

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

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

367
368
369
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
370
(defun asdf-version ()
371
  "Exported interface to the version of ASDF currently installed. A string.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
372
You can compare this string with e.g.:
373
(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
374
  *asdf-version*)
375

376
377
378
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

379
Defaults to T.")
380

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

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

392
(defvar *verbose-out* nil)
393

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

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

405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
;;;; -------------------------------------------------------------------------
;;;; 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)
         #-cormanlisp
         (ftype (function (t t) t) (setf module-components-by-name)))

;;;; -------------------------------------------------------------------------
;;;; Compatibility with Corman Lisp
#+cormanlisp
(progn
  (deftype logical-pathname () nil)
  (defun make-broadcast-stream () *error-output*)
  (defun file-namestring (p)
    (setf p (pathname p))
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
  (defparameter *count* 3)
  (defun dbg (&rest x)
    (format *error-output* "~S~%" x)))
#+cormanlisp
(defun maybe-break ()
  (decf *count*)
  (unless (plusp *count*)
    (setf *count* 3)
    (break)))

440
;;;; -------------------------------------------------------------------------
441
442
;;;; General Purpose Utilities

443
444
445
446
447
(macrolet
    ((defdef (def* def)
       `(defmacro ,def* (name formals &rest rest)
          `(progn
             #+(or ecl gcl) (fmakunbound ',name)
448
449
450
             #-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)))
451
452
453
             (,',def ,name ,formals ,@rest)))))
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))
454

455
(defmacro while-collecting ((&rest collectors) &body body)
456
457
458
459
460
461
462
463
464
465
  "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\)."
466
467
468
  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
        (initial-values (mapcar (constantly nil) collectors)))
    `(let ,(mapcar #'list vars initial-values)
469
       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
470
         ,@body
471
         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
472

473
474
475
(defmacro aif (test then &optional else)
  `(let ((it ,test)) (if it ,then ,else)))

476
(defun* pathname-directory-pathname (pathname)
477
478
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
479
480
  (when pathname
    (make-pathname :name nil :type nil :version nil :defaults pathname)))
481

482
483
(defun* normalize-pathname-directory-component (directory)
  (cond
484
    #-(or cmu sbcl scl)
485
486
487
488
489
490
491
492
    ((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
493
     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516

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

517
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
518
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
519
520
521
522
does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
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))
523
524
525
  #+scl
  (ext:resolve-pathname specified defaults)
  #-scl
526
527
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
528
         (directory (normalize-pathname-directory-component (pathname-directory specified)))
529
530
531
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
532
533
534
535
536
    (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)
537
          (ecase (first directory)
538
539
540
541
542
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                     directory
                     (unspecific-handler specified)))
543
            ((nil :relative)
544
545
             (values (pathname-host defaults)
                     (pathname-device defaults)
546
                     (merge-pathname-directory-components directory (pathname-directory defaults))
547
548
549
550
551
                     (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))))))
552

553
554
555
556
557
558
559
560
561
(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
                   :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
                   :defaults pathname)))


562
(define-modify-macro appendf (&rest args)
563
564
565
566
  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
567

568
(defun* first-char (s)
569
570
  (and (stringp s) (plusp (length s)) (char s 0)))

571
(defun* last-char (s)
572
573
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

574

575
(defun* asdf-message (format-string &rest format-args)
576
  (declare (dynamic-extent format-args))
577
  (apply 'format *verbose-out* format-string format-args))
578

579
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
580
581
  "Split STRING into a list of components separated by
any of the characters in the sequence SEPARATOR.
582
583
584
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\")."
585
  (catch nil
586
587
    (let ((list nil) (words 0) (end (length string)))
      (flet ((separatorp (char) (find char separator))
588
             (done () (throw nil (cons (subseq string 0 end) list))))
589
590
591
592
593
594
595
596
597
        (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))))))
598

599
(defun* split-name-type (filename)
600
601
602
603
  (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.
604
         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
605
606
607
608
609
    (destructuring-bind (name &optional (type unspecific))
        (split-string filename :max 2 :separator ".")
      (if (equal name "")
          (values filename unspecific)
          (values name type)))))
610

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

651
(defun* remove-keys (key-names args)
652
653
654
655
656
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

657
(defun* remove-keyword (key args)
658
659
660
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))
661

662
663
664
665
#+mcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))

666
(defun* getenv (x)
667
  (declare (ignorable x))
668
  #+(or abcl clisp xcl) (ext:getenv x)
669
670
671
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
672
673
674
675
676
677
678
679
680
681
  #+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)))
682
683
684
685
686
687
688
689
690
  #+ecl (si:getenv x)
  #+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)
691
692
  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
  (error "~S is not supported on your implementation" 'getenv))
693

694
(defun* directory-pathname-p (pathname)
695
  "Does PATHNAME represent a directory?
696
697

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

701
Note that this does _not_ check to see that PATHNAME points to an
702
actually-existing directory."
703
704
705
706
707
708
709
710
  (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)))))
711

712
(defun* ensure-directory-pathname (pathspec)
713
  "Converts the non-wild pathname designator PATHSPEC to directory form."
714
715
  (cond
   ((stringp pathspec)
716
    (ensure-directory-pathname (pathname pathspec)))
717
   ((not (pathnamep pathspec))
718
    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
719
   ((wild-pathname-p pathspec)
720
    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
721
722
723
724
725
726
727
728
   ((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))))
729

730
731
732
733
734
#+genera
(unless (fboundp 'ensure-directories-exist)
  (defun ensure-directories-exist (path)
    (fs:create-directories-recursively (pathname path))))

735
(defun* absolute-pathname-p (pathspec)
736
737
  (and (typep pathspec '(or pathname string))
       (eq :absolute (car (pathname-directory (pathname pathspec))))))
738

739
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
740
741
742
743
744
745
746
747
  (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)))))

748
(defun* ends-with (s suffix)
749
750
751
752
753
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))
754

755
(defun* read-file-forms (file)
756
757
758
759
760
761
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

762
#+asdf-unix
763
(progn
764
765
  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
766
  (defun* get-uid ()
767
    #+allegro (excl.osi:getuid)
768
    #+ccl (ccl::getuid)
769
    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
770
                  :for f = (ignore-errors (read-from-string s))
771
                  :when f :return (funcall f))
772
773
774
775
776
    #+(or cmu scl) (unix:unix-getuid)
    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
                   '(ext::getuid))
    #+sbcl (sb-unix:unix-getuid)
777
    #-(or allegro ccl clisp cmu ecl sbcl scl)
778
779
780
781
782
783
784
    (let ((uid-string
           (with-output-to-string (*verbose-out*)
             (run-shell-command "id -ur"))))
      (with-input-from-string (stream uid-string)
        (read-line stream)
        (handler-case (parse-integer (read-line stream))
          (error () (error "Unable to find out user ID")))))))
785

786
(defun* pathname-root (pathname)
787
  (make-pathname :directory '(:absolute)
788
                 :name nil :type nil :version nil
789
790
                 :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
791

792
793
794
(defun* find-symbol* (s p)
  (find-symbol (string s) p))

795
(defun* probe-file* (p)
796
797
  "when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
798
  (etypecase p
799
800
801
802
803
804
    (null nil)
    (string (probe-file* (parse-namestring p)))
    (pathname (unless (wild-pathname-p p)
                #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
                      #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
                      '(ignore-errors (truename p)))))))
805

806
(defun* truenamize (p)
807
  "Resolve as much of a pathname as possible"
808
  (block nil
809
    (when (typep p '(or null logical-pathname)) (return p))
810
    (let* ((p (merge-pathnames* p))
811
812
           (directory (pathname-directory p)))
      (when (typep p 'logical-pathname) (return p))
813
814
      (let ((found (probe-file* p)))
        (when found (return found)))
815
      #-(or cmu sbcl scl) (when (stringp directory) (return p))
816
      (when (not (eq :absolute (car directory))) (return p))
817
      (let ((sofar (probe-file* (pathname-root p))))
818
        (unless sofar (return p))
819
        (flet ((solution (directories)
820
821
                 (merge-pathnames*
                  (make-pathname :host nil :device nil
822
                                 :directory `(:relative ,@directories)
823
824
                                 :name (pathname-name p)
                                 :type (pathname-type p)
825
                                 :version (pathname-version p))
826
827
828
                  sofar)))
          (loop :for component :in (cdr directory)
            :for rest :on (cdr directory)
829
830
831
832
            :for more = (probe-file*
                         (merge-pathnames*
                          (make-pathname :directory `(:relative ,component))
                          sofar)) :do
833
834
            (if more
                (setf sofar more)
835
                (return (solution rest)))
836
837
            :finally
            (return (solution nil))))))))
838

839
(defun* resolve-symlinks (path)
840
  #-allegro (truenamize path)
841
842
843
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))
844

845
846
847
848
849
(defun* resolve-symlinks* (path)
  (if *resolve-symlinks*
      (and path (resolve-symlinks path))
      path))

850
851
852
853
854
855
856
857
858
(defun ensure-pathname-absolute (path)
  (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))))

859
(defun* default-directory ()
860
861
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

862
(defun* lispize-pathname (input-file)
863
864
  (make-pathname :type "lisp" :defaults input-file))

865
(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
866
(defparameter *wild-file*
867
  (make-pathname :name *wild* :type *wild* :version *wild* :directory nil))
868
(defparameter *wild-directory*
869
  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
870
871
(defparameter *wild-inferiors*
  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
872
(defparameter *wild-path*
873
  (merge-pathnames *wild-file* *wild-inferiors*))
874

875
(defun* wilden (path)
876
877
  (merge-pathnames* *wild-path* path))

878
#-scl
879
880
881
882
(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

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

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

928
929
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
959
960
961
962
;;;; -------------------------------------------------------------------------
;;;; 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))
(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))

963
964
965
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric* (setf module-components-by-name) (new-value module)))

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