source: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp @ 13656

Last change on this file since 13656 was 13656, checked in by Mark Evenson, 10 years ago

Upgrade to ASDF 2.0.17.022

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