source: trunk/abcl/src/org/armedbear/lisp/asdf.lisp @ 13258

Last change on this file since 13258 was 13258, checked in by Mark Evenson, 11 years ago

Update to ASDF-2.014.

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