source: branches/1.1.x/src/org/armedbear/lisp/asdf.lisp @ 14278

Last change on this file since 14278 was 14278, checked in by Mark Evenson, 8 years ago

Sync to asdf-2.26.6.

Fixes #271.

Backport r14277.

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