source: trunk/source/tools/asdf.lisp @ 15496

Last change on this file since 15496 was 15496, checked in by rme, 7 years ago

Update ASDF to version 2.26. Update and rename README file.

See ticket:1028.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 194.1 KB
Line 
1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
2;;; This is ASDF 2.26: 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")
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 (append unintern #+cmu redefined-functions))
219               (ensure-shadow p shadow)
220               (ensure-export p export)
221               #-cmu (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 #+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 "~@<Error while invoking ~A on ~A~@:>")
1216                       (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 :reader %system-source-file :initarg :source-file ; for CLISP upgrade
1465                :writer %set-system-source-file)
1466   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1467
1468;;;; -------------------------------------------------------------------------
1469;;;; version-satisfies
1470
1471(defmethod version-satisfies ((c component) version)
1472  (unless (and version (slot-boundp c 'version))
1473    (when version
1474      (warn "Requested version ~S but component ~S has no version" version c))
1475    (return-from version-satisfies t))
1476  (version-satisfies (component-version c) version))
1477
1478(defun* asdf-version ()
1479  "Exported interface to the version of ASDF currently installed. A string.
1480You can compare this string with e.g.:
1481(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
1482  *asdf-version*)
1483
1484(defun* parse-version (string &optional on-error)
1485  "Parse a version string as a series of natural integers separated by dots.
1486Return a (non-null) list of integers if the string is valid, NIL otherwise.
1487If on-error is error, warn, or designates a function of compatible signature,
1488the function is called with an explanation of what is wrong with the argument.
1489NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
1490  (and
1491   (or (stringp string)
1492       (when on-error
1493         (funcall on-error "~S: ~S is not a string"
1494                  'parse-version string)) nil)
1495   (or (loop :for prev = nil :then c :for c :across string
1496         :always (or (digit-char-p c)
1497                     (and (eql c #\.) prev (not (eql prev #\.))))
1498         :finally (return (and c (digit-char-p c))))
1499       (when on-error
1500         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
1501                  'parse-version string)) nil)
1502   (mapcar #'parse-integer (split-string string :separator "."))))
1503
1504(defmethod version-satisfies ((cver string) version)
1505  (let ((x (parse-version cver 'warn))
1506        (y (parse-version version 'warn)))
1507    (labels ((bigger (x y)
1508               (cond ((not y) t)
1509                     ((not x) nil)
1510                     ((> (car x) (car y)) t)
1511                     ((= (car x) (car y))
1512                      (bigger (cdr x) (cdr y))))))
1513      (and x y (= (car x) (car y))
1514           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1515
1516;;;; -----------------------------------------------------------------
1517;;;; Windows shortcut support.  Based on:
1518;;;;
1519;;;; Jesse Hager: The Windows Shortcut File Format.
1520;;;; http://www.wotsit.org/list.asp?fc=13
1521
1522#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1523(progn
1524(defparameter *link-initial-dword* 76)
1525(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1526
1527(defun* read-null-terminated-string (s)
1528  (with-output-to-string (out)
1529    (loop :for code = (read-byte s)
1530      :until (zerop code)
1531      :do (write-char (code-char code) out))))
1532
1533(defun* read-little-endian (s &optional (bytes 4))
1534  (loop :for i :from 0 :below bytes
1535    :sum (ash (read-byte s) (* 8 i))))
1536
1537(defun* parse-file-location-info (s)
1538  (let ((start (file-position s))
1539        (total-length (read-little-endian s))
1540        (end-of-header (read-little-endian s))
1541        (fli-flags (read-little-endian s))
1542        (local-volume-offset (read-little-endian s))
1543        (local-offset (read-little-endian s))
1544        (network-volume-offset (read-little-endian s))
1545        (remaining-offset (read-little-endian s)))
1546    (declare (ignore total-length end-of-header local-volume-offset))
1547    (unless (zerop fli-flags)
1548      (cond
1549        ((logbitp 0 fli-flags)
1550          (file-position s (+ start local-offset)))
1551        ((logbitp 1 fli-flags)
1552          (file-position s (+ start
1553                              network-volume-offset
1554                              #x14))))
1555      (strcat (read-null-terminated-string s)
1556              (progn
1557                (file-position s (+ start remaining-offset))
1558                (read-null-terminated-string s))))))
1559
1560(defun* parse-windows-shortcut (pathname)
1561  (with-open-file (s pathname :element-type '(unsigned-byte 8))
1562    (handler-case
1563        (when (and (= (read-little-endian s) *link-initial-dword*)
1564                   (let ((header (make-array (length *link-guid*))))
1565                     (read-sequence header s)
1566                     (equalp header *link-guid*)))
1567          (let ((flags (read-little-endian s)))
1568            (file-position s 76)        ;skip rest of header
1569            (when (logbitp 0 flags)
1570              ;; skip shell item id list
1571              (let ((length (read-little-endian s 2)))
1572                (file-position s (+ length (file-position s)))))
1573            (cond
1574              ((logbitp 1 flags)
1575                (parse-file-location-info s))
1576              (t
1577                (when (logbitp 2 flags)
1578                  ;; skip description string
1579                  (let ((length (read-little-endian s 2)))
1580                    (file-position s (+ length (file-position s)))))
1581                (when (logbitp 3 flags)
1582                  ;; finally, our pathname
1583                  (let* ((length (read-little-endian s 2))
1584                         (buffer (make-array length)))
1585                    (read-sequence buffer s)
1586                    (map 'string #'code-char buffer)))))))
1587      (end-of-file ()
1588        nil)))))
1589
1590;;;; -------------------------------------------------------------------------
1591;;;; Finding systems
1592
1593(defun* make-defined-systems-table ()
1594  (make-hash-table :test 'equal))
1595
1596(defvar *defined-systems* (make-defined-systems-table)
1597  "This is a hash table whose keys are strings, being the
1598names of the systems, and whose values are pairs, the first
1599element of which is a universal-time indicating when the
1600system definition was last updated, and the second element
1601of which is a system object.")
1602
1603(defun* coerce-name (name)
1604  (typecase name
1605    (component (component-name name))
1606    (symbol (string-downcase (symbol-name name)))
1607    (string name)
1608    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
1609
1610(defun* system-registered-p (name)
1611  (gethash (coerce-name name) *defined-systems*))
1612
1613(defun* registered-systems ()
1614  (loop :for (() . system) :being :the :hash-values :of *defined-systems*
1615    :collect (coerce-name system)))
1616
1617(defun* register-system (system)
1618  (check-type system system)
1619  (let ((name (component-name system)))
1620    (check-type name string)
1621    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
1622    (unless (eq system (cdr (gethash name *defined-systems*)))
1623      (setf (gethash name *defined-systems*)
1624            (cons (get-universal-time) system)))))
1625
1626(defun* clear-system (name)
1627  "Clear the entry for a system in the database of systems previously loaded.
1628Note that this does NOT in any way cause the code of the system to be unloaded."
1629  ;; There is no "unload" operation in Common Lisp, and
1630  ;; a general such operation cannot be portably written,
1631  ;; considering how much CL relies on side-effects to global data structures.
1632  (remhash (coerce-name name) *defined-systems*))
1633
1634(defun* map-systems (fn)
1635  "Apply FN to each defined system.
1636
1637FN should be a function of one argument. It will be
1638called with an object of type asdf:system."
1639  (maphash #'(lambda (_ datum)
1640               (declare (ignore _))
1641               (destructuring-bind (_ . def) datum
1642                 (declare (ignore _))
1643                 (funcall fn def)))
1644           *defined-systems*))
1645
1646;;; for the sake of keeping things reasonably neat, we adopt a
1647;;; convention that functions in this list are prefixed SYSDEF-
1648
1649(defvar *system-definition-search-functions* '())
1650
1651(setf *system-definition-search-functions*
1652      (append
1653       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
1654       (remove 'contrib-sysdef-search *system-definition-search-functions*)
1655       ;; Tuck our defaults at the end of the list if they were absent.
1656       ;; This is imperfect, in case they were removed on purpose,
1657       ;; but then it will be the responsibility of whoever does that
1658       ;; to upgrade asdf before he does such a thing rather than after.
1659       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
1660                  '(sysdef-central-registry-search
1661                    sysdef-source-registry-search
1662                    sysdef-find-asdf))))
1663
1664(defun* search-for-system-definition (system)
1665  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
1666        (cons 'find-system-if-being-defined
1667              *system-definition-search-functions*)))
1668
1669(defvar *central-registry* nil
1670"A list of 'system directory designators' ASDF uses to find systems.
1671
1672A 'system directory designator' is a pathname or an expression
1673which evaluates to a pathname. For example:
1674
1675    (setf asdf:*central-registry*
1676          (list '*default-pathname-defaults*
1677                #p\"/home/me/cl/systems/\"
1678                #p\"/usr/share/common-lisp/systems/\"))
1679
1680This is for backward compatibilily.
1681Going forward, we recommend new users should be using the source-registry.
1682")
1683
1684(defun* featurep (x &optional (features *features*))
1685  (cond
1686    ((atom x)
1687     (and (member x features) t))
1688    ((eq :not (car x))
1689     (assert (null (cddr x)))
1690     (not (featurep (cadr x) features)))
1691    ((eq :or (car x))
1692     (some #'(lambda (x) (featurep x features)) (cdr x)))
1693    ((eq :and (car x))
1694     (every #'(lambda (x) (featurep x features)) (cdr x)))
1695    (t
1696     (error "Malformed feature specification ~S" x))))
1697
1698(defun* os-unix-p ()
1699  (featurep '(:or :unix :cygwin :darwin)))
1700
1701(defun* os-windows-p ()
1702  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
1703
1704(defun* probe-asd (name defaults)
1705  (block nil
1706    (when (directory-pathname-p defaults)
1707      (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
1708        (when file
1709          (return file)))
1710      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
1711      (when (os-windows-p)
1712        (let ((shortcut
1713               (make-pathname
1714                :defaults defaults :version :newest :case :local
1715                :name (strcat name ".asd")
1716                :type "lnk")))
1717          (when (probe-file* shortcut)
1718            (let ((target (parse-windows-shortcut shortcut)))
1719              (when target
1720                (return (pathname target))))))))))
1721
1722(defun* sysdef-central-registry-search (system)
1723  (let ((name (coerce-name system))
1724        (to-remove nil)
1725        (to-replace nil))
1726    (block nil
1727      (unwind-protect
1728           (dolist (dir *central-registry*)
1729             (let ((defaults (eval dir)))
1730               (when defaults
1731                 (cond ((directory-pathname-p defaults)
1732                        (let ((file (probe-asd name defaults)))
1733                          (when file
1734                            (return file))))
1735                       (t
1736                        (restart-case
1737                            (let* ((*print-circle* nil)
1738                                   (message
1739                                    (format nil
1740                                            (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
1741                                            system dir defaults)))
1742                              (error message))
1743                          (remove-entry-from-registry ()
1744                            :report "Remove entry from *central-registry* and continue"
1745                            (push dir to-remove))
1746                          (coerce-entry-to-directory ()
1747                            :report (lambda (s)
1748                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
1749                                              (ensure-directory-pathname defaults) dir))
1750                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1751        ;; cleanup
1752        (dolist (dir to-remove)
1753          (setf *central-registry* (remove dir *central-registry*)))
1754        (dolist (pair to-replace)
1755          (let* ((current (car pair))
1756                 (new (cdr pair))
1757                 (position (position current *central-registry*)))
1758            (setf *central-registry*
1759                  (append (subseq *central-registry* 0 position)
1760                          (list new)
1761                          (subseq *central-registry* (1+ position))))))))))
1762
1763(defun* make-temporary-package ()
1764  (flet ((try (counter)
1765           (ignore-errors
1766             (make-package (format nil "~A~D" :asdf counter)
1767                           :use '(:cl :asdf)))))
1768    (do* ((counter 0 (+ counter 1))
1769          (package (try counter) (try counter)))
1770         (package package))))
1771
1772(defun* safe-file-write-date (pathname)
1773  ;; If FILE-WRITE-DATE returns NIL, it's possible that
1774  ;; the user or some other agent has deleted an input file.
1775  ;; Also, generated files will not exist at the time planning is done
1776  ;; and calls operation-done-p which calls safe-file-write-date.
1777  ;; So it is very possible that we can't get a valid file-write-date,
1778  ;; and we can survive and we will continue the planning
1779  ;; as if the file were very old.
1780  ;; (or should we treat the case in a different, special way?)
1781  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
1782      (progn
1783        (when (and pathname *asdf-verbose*)
1784          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
1785                pathname))
1786        0)))
1787
1788(defmethod find-system ((name null) &optional (error-p t))
1789  (declare (ignorable name))
1790  (when error-p
1791    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
1792
1793(defmethod find-system (name &optional (error-p t))
1794  (find-system (coerce-name name) error-p))
1795
1796(defvar *systems-being-defined* nil
1797  "A hash-table of systems currently being defined keyed by name, or NIL")
1798
1799(defun* find-system-if-being-defined (name)
1800  (when *systems-being-defined*
1801    (gethash (coerce-name name) *systems-being-defined*)))
1802
1803(defun* call-with-system-definitions (thunk)
1804  (if *systems-being-defined*
1805      (funcall thunk)
1806      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
1807        (funcall thunk))))
1808
1809(defmacro with-system-definitions ((&optional) &body body)
1810  `(call-with-system-definitions #'(lambda () ,@body)))
1811
1812(defun* load-sysdef (name pathname)
1813  ;; Tries to load system definition with canonical NAME from PATHNAME.
1814  (with-system-definitions ()
1815    (let ((package (make-temporary-package)))
1816      (unwind-protect
1817           (handler-bind
1818               ((error #'(lambda (condition)
1819                           (error 'load-system-definition-error
1820                                  :name name :pathname pathname
1821                                  :condition condition))))
1822             (let ((*package* package)
1823                   (*default-pathname-defaults*
1824                    ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
1825                    (pathname-directory-pathname (translate-logical-pathname pathname)))
1826                   (external-format (encoding-external-format (detect-encoding pathname))))
1827               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
1828                             pathname package)
1829               (load pathname :external-format external-format)))
1830        (delete-package package)))))
1831
1832(defun* locate-system (name)
1833  "Given a system NAME designator, try to locate where to load the system from.
1834Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
1835FOUNDP is true when a system was found,
1836either a new unregistered one or a previously registered one.
1837FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
1838PATHNAME when not null is a path from where to load the system,
1839either associated with FOUND-SYSTEM, or with the PREVIOUS system.
1840PREVIOUS when not null is a previously loaded SYSTEM object of same name.
1841PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
1842  (let* ((name (coerce-name name))
1843         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
1844         (previous (cdr in-memory))
1845         (previous (and (typep previous 'system) previous))
1846         (previous-time (car in-memory))
1847         (found (search-for-system-definition name))
1848         (found-system (and (typep found 'system) found))
1849         (pathname (or (and (typep found '(or pathname string)) (pathname found))
1850                       (and found-system (system-source-file found-system))
1851                       (and previous (system-source-file previous))))
1852         (foundp (and (or found-system pathname previous) t)))
1853    (check-type found (or null pathname system))
1854    (when foundp
1855      (setf pathname (resolve-symlinks* pathname))
1856      (when (and pathname (not (absolute-pathname-p pathname)))
1857        (setf pathname (ensure-pathname-absolute pathname))
1858        (when found-system
1859          (%set-system-source-file pathname found-system)))
1860      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
1861                                             (system-source-file previous) pathname)))
1862        (%set-system-source-file pathname previous)
1863        (setf previous-time nil))
1864      (values foundp found-system pathname previous previous-time))))
1865
1866(defmethod find-system ((name string) &optional (error-p t))
1867  (with-system-definitions ()
1868    (loop
1869      (restart-case
1870          (multiple-value-bind (foundp found-system pathname previous previous-time)
1871              (locate-system name)
1872            (declare (ignore foundp))
1873            (when (and found-system (not previous))
1874              (register-system found-system))
1875            (when (and pathname
1876                       (or (not previous-time)
1877                           ;; don't reload if it's already been loaded,
1878                           ;; or its filestamp is in the future which means some clock is skewed
1879                           ;; and trying to load might cause an infinite loop.
1880                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
1881              (load-sysdef name pathname))
1882            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
1883              (return
1884                (cond
1885                  (in-memory
1886                   (when pathname
1887                     (setf (car in-memory) (safe-file-write-date pathname)))
1888                   (cdr in-memory))
1889                  (error-p
1890                   (error 'missing-component :requires name))))))
1891        (reinitialize-source-registry-and-retry ()
1892          :report (lambda (s)
1893                    (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
1894          (initialize-source-registry))))))
1895
1896(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1897  (setf fallback (coerce-name fallback)
1898        requested (coerce-name requested))
1899  (when (equal requested fallback)
1900    (let ((registered (cdr (gethash fallback *defined-systems*))))
1901      (or registered
1902          (apply 'make-instance 'system
1903                 :name fallback :source-file source-file keys)))))
1904
1905(defun* sysdef-find-asdf (name)
1906  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
1907  (find-system-fallback name "asdf" :version *asdf-version*))
1908
1909
1910;;;; -------------------------------------------------------------------------
1911;;;; Finding components
1912
1913(defmethod find-component ((base string) path)
1914  (let ((s (find-system base nil)))
1915    (and s (find-component s path))))
1916
1917(defmethod find-component ((base symbol) path)
1918  (cond
1919    (base (find-component (coerce-name base) path))
1920    (path (find-component path nil))
1921    (t    nil)))
1922
1923(defmethod find-component ((base cons) path)
1924  (find-component (car base) (cons (cdr base) path)))
1925
1926(defmethod find-component ((module module) (name string))
1927  (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1928    (compute-module-components-by-name module))
1929  (values (gethash name (module-components-by-name module))))
1930
1931(defmethod find-component ((component component) (name symbol))
1932  (if name
1933      (find-component component (coerce-name name))
1934      component))
1935
1936(defmethod find-component ((module module) (name cons))
1937  (find-component (find-component module (car name)) (cdr name)))
1938
1939
1940;;; component subclasses
1941
1942(defclass source-file (component)
1943  ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1944
1945(defclass cl-source-file (source-file)
1946  ((type :initform "lisp")))
1947(defclass cl-source-file.cl (cl-source-file)
1948  ((type :initform "cl")))
1949(defclass cl-source-file.lsp (cl-source-file)
1950  ((type :initform "lsp")))
1951(defclass c-source-file (source-file)
1952  ((type :initform "c")))
1953(defclass java-source-file (source-file)
1954  ((type :initform "java")))
1955(defclass static-file (source-file) ())
1956(defclass doc-file (static-file) ())
1957(defclass html-file (doc-file)
1958  ((type :initform "html")))
1959
1960(defmethod source-file-type ((component module) (s module))
1961  (declare (ignorable component s))
1962  :directory)
1963(defmethod source-file-type ((component source-file) (s module))
1964  (declare (ignorable s))
1965  (source-file-explicit-type component))
1966
1967(defmethod component-relative-pathname ((component component))
1968  (coerce-pathname
1969   (or (slot-value component 'relative-pathname)
1970       (component-name component))
1971   :type (source-file-type component (component-system component))
1972   :defaults (component-parent-pathname component)))
1973
1974;;;; -------------------------------------------------------------------------
1975;;;; Operations
1976
1977;;; one of these is instantiated whenever #'operate is called
1978
1979(defclass operation ()
1980  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1981   ;; T to force the inside of the specified system,
1982   ;;   but not recurse to other systems we depend on.
1983   ;; :ALL (or any other atom) to force all systems
1984   ;;   including other systems we depend on.
1985   ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1986   ;;   to force systems named in a given list
1987   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
1988   (forced :initform nil :initarg :force :accessor operation-forced)
1989   (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
1990   (original-initargs :initform nil :initarg :original-initargs
1991                      :accessor operation-original-initargs)
1992   (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1993   (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1994   (parent :initform nil :initarg :parent :accessor operation-parent)))
1995
1996(defmethod print-object ((o operation) stream)
1997  (print-unreadable-object (o stream :type t :identity t)
1998    (ignore-errors
1999      (prin1 (operation-original-initargs o) stream))))
2000
2001(defmethod shared-initialize :after ((operation operation) slot-names
2002                                     &key force force-not
2003                                     &allow-other-keys)
2004  ;; the &allow-other-keys disables initarg validity checking
2005  (declare (ignorable operation slot-names force force-not))
2006  (macrolet ((frob (x) ;; normalize forced and forced-not slots
2007               `(when (consp (,x operation))
2008                  (setf (,x operation)
2009                        (mapcar #'coerce-name (,x operation))))))
2010    (frob operation-forced) (frob operation-forced-not))
2011  (values))
2012
2013(defun* node-for (o c)
2014  (cons (class-name (class-of o)) c))
2015
2016(defmethod operation-ancestor ((operation operation))
2017  (aif (operation-parent operation)
2018       (operation-ancestor it)
2019       operation))
2020
2021
2022(defun* make-sub-operation (c o dep-c dep-o)
2023  "C is a component, O is an operation, DEP-C is another
2024component, and DEP-O, confusingly enough, is an operation
2025class specifier, not an operation."
2026  (let* ((args (copy-list (operation-original-initargs o)))
2027         (force-p (getf args :force)))
2028    ;; note explicit comparison with T: any other non-NIL force value
2029    ;; (e.g. :recursive) will pass through
2030    (cond ((and (null (component-parent c))
2031                (null (component-parent dep-c))
2032                (not (eql c dep-c)))
2033           (when (eql force-p t)
2034             (setf (getf args :force) nil))
2035           (apply 'make-instance dep-o
2036                  :parent o
2037                  :original-initargs args args))
2038          ((subtypep (type-of o) dep-o)
2039           o)
2040          (t
2041           (apply 'make-instance dep-o
2042                  :parent o :original-initargs args args)))))
2043
2044
2045(defmethod visit-component ((o operation) (c component) data)
2046  (unless (component-visited-p o c)
2047    (setf (gethash (node-for o c)
2048                   (operation-visited-nodes (operation-ancestor o)))
2049          (cons t data))))
2050
2051(defmethod component-visited-p ((o operation) (c component))
2052  (gethash (node-for o c)
2053           (operation-visited-nodes (operation-ancestor o))))
2054
2055(defmethod (setf visiting-component) (new-value operation component)
2056  ;; MCL complains about unused lexical variables
2057  (declare (ignorable operation component))
2058  new-value)
2059
2060(defmethod (setf visiting-component) (new-value (o operation) (c component))
2061  (let ((node (node-for o c))
2062        (a (operation-ancestor o)))
2063    (if new-value
2064        (setf (gethash node (operation-visiting-nodes a)) t)
2065        (remhash node (operation-visiting-nodes a)))
2066    new-value))
2067
2068(defmethod component-visiting-p ((o operation) (c component))
2069  (let ((node (node-for o c)))
2070    (gethash node (operation-visiting-nodes (operation-ancestor o)))))
2071
2072(defmethod component-depends-on ((op-spec symbol) (c component))
2073  ;; Note: we go from op-spec to operation via make-instance
2074  ;; to allow for specialization through defmethod's, even though
2075  ;; it's a detour in the default case below.
2076  (component-depends-on (make-instance op-spec) c))
2077
2078(defmethod component-depends-on ((o operation) (c component))
2079  (cdr (assoc (type-of o) (component-in-order-to c))))
2080
2081(defmethod component-self-dependencies ((o operation) (c component))
2082  (remove-if-not
2083   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
2084   (component-depends-on o c)))
2085
2086(defmethod input-files ((operation operation) (c component))
2087  (let ((parent (component-parent c))
2088        (self-deps (component-self-dependencies operation c)))
2089    (if self-deps
2090        (mapcan #'(lambda (dep)
2091                    (destructuring-bind (op name) dep
2092                      (output-files (make-instance op)
2093                                    (find-component parent name))))
2094                self-deps)
2095        ;; no previous operations needed?  I guess we work with the
2096        ;; original source file, then
2097        (list (component-pathname c)))))
2098
2099(defmethod input-files ((operation operation) (c module))
2100  (declare (ignorable operation c))
2101  nil)
2102
2103(defmethod component-operation-time (o c)
2104  (gethash (type-of o) (component-operation-times c)))
2105
2106(defmethod operation-done-p ((o operation) (c component))
2107  (let ((out-files (output-files o c))
2108        (in-files (input-files o c))
2109        (op-time (component-operation-time o c)))
2110    (flet ((earliest-out ()
2111             (reduce #'min (mapcar #'safe-file-write-date out-files)))
2112           (latest-in ()
2113             (reduce #'max (mapcar #'safe-file-write-date in-files))))
2114      (cond
2115        ((and (not in-files) (not out-files))
2116         ;; arbitrary decision: an operation that uses nothing to
2117         ;; produce nothing probably isn't doing much.
2118         ;; e.g. operations on systems, modules that have no immediate action,
2119         ;; but are only meaningful through traversed dependencies
2120         t)
2121        ((not out-files)
2122         ;; an operation without output-files is probably meant
2123         ;; for its side-effects in the current image,
2124         ;; assumed to be idem-potent,
2125         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
2126         (and op-time (>= op-time (latest-in))))
2127        ((not in-files)
2128         ;; an operation with output-files and no input-files
2129         ;; is probably meant for its side-effects on the file-system,
2130         ;; assumed to have to be done everytime.
2131         ;; (I don't think there is any such case in ASDF unless extended)
2132         nil)
2133        (t
2134         ;; an operation with both input and output files is assumed
2135         ;; as computing the latter from the former,
2136         ;; assumed to have been done if the latter are all older
2137         ;; than the former.
2138         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
2139         ;; We use >= instead of > to play nice with generated files.
2140         ;; This opens a race condition if an input file is changed
2141         ;; after the output is created but within the same second
2142         ;; of filesystem time; but the same race condition exists
2143         ;; whenever the computation from input to output takes more
2144         ;; than one second of filesystem time (or just crosses the
2145         ;; second). So that's cool.
2146         (and
2147          (every #'probe-file* in-files)
2148          (every #'probe-file* out-files)
2149          (>= (earliest-out) (latest-in))))))))
2150
2151
2152
2153;;; For 1.700 I've done my best to refactor TRAVERSE
2154;;; by splitting it up in a bunch of functions,
2155;;; so as to improve the collection and use-detection algorithm. --fare
2156;;; The protocol is as follows: we pass around operation, dependency,
2157;;; bunch of other stuff, and a force argument. Return a force flag.
2158;;; The returned flag is T if anything has changed that requires a rebuild.
2159;;; The force argument is a list of components that will require a rebuild
2160;;; if the flag is T, at which point whoever returns the flag has to
2161;;; mark them all as forced, and whoever recurses again can use a NIL list
2162;;; as a further argument.
2163
2164(defvar *forcing* nil
2165  "This dynamically-bound variable is used to force operations in
2166recursive calls to traverse.")
2167
2168(defgeneric* do-traverse (operation component collect))
2169
2170(defun* resolve-dependency-name (component name &optional version)
2171  (loop
2172    (restart-case
2173        (return
2174          (let ((comp (find-component (component-parent component) name)))
2175            (unless comp
2176              (error 'missing-dependency
2177                     :required-by component
2178                     :requires name))
2179            (when version
2180              (unless (version-satisfies comp version)
2181                (error 'missing-dependency-of-version
2182                       :required-by component
2183                       :version version
2184                       :requires name)))
2185            comp))
2186      (retry ()
2187        :report (lambda (s)
2188                  (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
2189        :test
2190        (lambda (c)
2191          (or (null c)
2192              (and (typep c 'missing-dependency)
2193                   (eq (missing-required-by c) component)
2194                   (equal (missing-requires c) name))))))))
2195
2196(defun* resolve-dependency-spec (component dep-spec)
2197  (cond
2198    ((atom dep-spec)
2199     (resolve-dependency-name component dep-spec))
2200    ;; Structured dependencies --- this parses keywords.
2201    ;; The keywords could conceivably be broken out and cleanly (extensibly)
2202    ;; processed by EQL methods. But for now, here's what we've got.
2203    ((eq :version (first dep-spec))
2204     ;; https://bugs.launchpad.net/asdf/+bug/527788
2205     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
2206    ((eq :feature (first dep-spec))
2207     ;; This particular subform is not documented and
2208     ;; has always been broken in the past.
2209     ;; Therefore no one uses it, and I'm cerroring it out,
2210     ;; after fixing it
2211     ;; See https://bugs.launchpad.net/asdf/+bug/518467
2212     (cerror "Continue nonetheless."
2213             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
2214     (when (find (second dep-spec) *features* :test 'string-equal)
2215       (resolve-dependency-name component (third dep-spec))))
2216    (t
2217     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
2218
2219(defun* do-one-dep (op c collect dep-op dep-c)
2220  ;; Collects a partial plan for performing dep-op on dep-c
2221  ;; as dependencies of a larger plan involving op and c.
2222  ;; Returns t if this should force recompilation of those who depend on us.
2223  ;; dep-op is an operation class name (not an operation object),
2224  ;; whereas dep-c is a component object.n
2225  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
2226
2227(defun* do-dep (op c collect dep-op-spec dep-c-specs)
2228  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
2229  ;; as dependencies of a larger plan involving op and c.
2230  ;; Returns t if this should force recompilation of those who depend on us.
2231  ;; dep-op-spec is either an operation class name (not an operation object),
2232  ;; or the magic symbol asdf:feature.
2233  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
2234  ;; and the plan will succeed if that keyword is present in *feature*,
2235  ;; or fail if it isn't
2236  ;; (at which point c's :if-component-dep-fails will kick in).
2237  ;; If dep-op-spec is an operation class name,
2238  ;; then dep-c-specs specifies a list of sibling component of c,
2239  ;; as per resolve-dependency-spec, such that operating op on c
2240  ;; depends on operating dep-op-spec on each of them.
2241  (cond ((eq dep-op-spec 'feature)
2242         (if (member (car dep-c-specs) *features*)
2243             nil
2244             (error 'missing-dependency
2245                    :required-by c
2246                    :requires (list :feature (car dep-c-specs)))))
2247        (t
2248         (let ((flag nil))
2249           (dolist (d dep-c-specs)
2250             (when (do-one-dep op c collect dep-op-spec
2251                               (resolve-dependency-spec c d))
2252               (setf flag t)))
2253           flag))))
2254
2255(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
2256
2257(defun* do-collect (collect x)
2258  (funcall collect x))
2259
2260(defmethod do-traverse ((operation operation) (c component) collect)
2261  (let ((*forcing* *forcing*)
2262        (flag nil)) ;; return value: must we rebuild this and its dependencies?
2263    (labels
2264        ((update-flag (x)
2265           (orf flag x))
2266         (dep (op comp)
2267           (update-flag (do-dep operation c collect op comp))))
2268      ;; Have we been visited yet? If so, just process the result.
2269      (aif (component-visited-p operation c)
2270           (progn
2271             (update-flag (cdr it))
2272             (return-from do-traverse flag)))
2273      ;; dependencies
2274      (when (component-visiting-p operation c)
2275        (error 'circular-dependency :components (list c)))
2276      (setf (visiting-component operation c) t)
2277      (unwind-protect
2278           (block nil
2279             (when (typep c 'system) ;; systems can be forced or forced-not
2280               (let ((ancestor (operation-ancestor operation)))
2281                 (flet ((match? (f)
2282                          (and f (or (not (consp f)) ;; T or :ALL
2283                                     (member (component-name c) f :test #'equal)))))
2284                   (cond
2285                     ((match? (operation-forced ancestor))
2286                      (setf *forcing* t))
2287                     ((match? (operation-forced-not ancestor))
2288                      (return))))))
2289             ;; first we check and do all the dependencies for the module.
2290             ;; Operations planned in this loop will show up
2291             ;; in the results, and are consumed below.
2292             (let ((*forcing* nil))
2293               ;; upstream dependencies are never forced to happen just because
2294               ;; the things that depend on them are....
2295               (loop
2296                 :for (required-op . deps) :in (component-depends-on operation c)
2297                 :do (dep required-op deps)))
2298             ;; constituent bits
2299             (let ((module-ops
2300                    (when (typep c 'module)
2301                      (let ((at-least-one nil)
2302                            ;; This is set based on the results of the
2303                            ;; dependencies and whether we are in the
2304                            ;; context of a *forcing* call...
2305                            ;; inter-system dependencies do NOT trigger
2306                            ;; building components
2307                            (*forcing*
2308                             (or *forcing*
2309                                 (and flag (not (typep c 'system)))))
2310                            (error nil))
2311                        (while-collecting (internal-collect)
2312                          (dolist (kid (module-components c))
2313                            (handler-case
2314                                (update-flag
2315                                 (do-traverse operation kid #'internal-collect))
2316                              #-genera
2317                              (missing-dependency (condition)
2318                                (when (eq (module-if-component-dep-fails c)
2319                                          :fail)
2320                                  (error condition))
2321                                (setf error condition))
2322                              (:no-error (c)
2323                                (declare (ignore c))
2324                                (setf at-least-one t))))
2325                          (when (and (eq (module-if-component-dep-fails c)
2326                                         :try-next)
2327                                     (not at-least-one))
2328                            (error error)))))))
2329               (update-flag (or *forcing* (not (operation-done-p operation c))))
2330                 ;; For sub-operations, check whether
2331                 ;; the original ancestor operation was forced,
2332                 ;; or names us amongst an explicit list of things to force...
2333                 ;; except that this check doesn't distinguish
2334                 ;; between all the things with a given name. Sigh.
2335                 ;; BROKEN!
2336               (when flag
2337                 (let ((do-first (cdr (assoc (class-name (class-of operation))
2338                                             (component-do-first c)))))
2339                   (loop :for (required-op . deps) :in do-first
2340                     :do (do-dep operation c collect required-op deps)))
2341                 (do-collect collect (vector module-ops))
2342                 (do-collect collect (cons operation c)))))
2343        (setf (visiting-component operation c) nil)))
2344    (visit-component operation c (when flag (incf *visit-count*)))
2345    flag))
2346
2347(defun* flatten-tree (l)
2348  ;; You collected things into a list.
2349  ;; Most elements are just things to collect again.
2350  ;; A (simple-vector 1) indicate that you should recurse into its contents.
2351  ;; This way, in two passes (rather than N being the depth of the tree),
2352  ;; you can collect things with marginally constant-time append,
2353  ;; achieving linear time collection instead of quadratic time.
2354  (while-collecting (c)
2355    (labels ((r (x)
2356               (if (typep x '(simple-vector 1))
2357                   (r* (svref x 0))
2358                   (c x)))
2359             (r* (l)
2360               (dolist (x l) (r x))))
2361      (r* l))))
2362
2363(defmethod traverse ((operation operation) (c component))
2364  (flatten-tree
2365   (while-collecting (collect)
2366     (let ((*visit-count* 0))
2367       (do-traverse operation c #'collect)))))
2368
2369(defmethod perform ((operation operation) (c source-file))
2370  (sysdef-error
2371   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
2372   (class-of operation) (class-of c)))
2373
2374(defmethod perform ((operation operation) (c module))
2375  (declare (ignorable operation c))
2376  nil)
2377
2378(defmethod mark-operation-done ((operation operation) (c component))
2379  (setf (gethash (type-of operation) (component-operation-times c))
2380    (reduce #'max
2381            (cons (get-universal-time)
2382                  (mapcar #'safe-file-write-date (input-files operation c))))))
2383
2384(defmethod perform-with-restarts (operation component)
2385  ;; TOO verbose, especially as the default. Add your own :before method
2386  ;; to perform-with-restart or perform if you want that:
2387  #|(when *asdf-verbose* (explain operation component))|#
2388  (perform operation component))
2389
2390(defmethod perform-with-restarts :around (operation component)
2391  (loop
2392    (restart-case
2393        (return (call-next-method))
2394      (retry ()
2395        :report
2396        (lambda (s)
2397          (format s (compatfmt "~@<Retry ~A.~@:>")
2398                  (operation-description operation component))))
2399      (accept ()
2400        :report
2401        (lambda (s)
2402          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
2403                  (operation-description operation component)))
2404        (mark-operation-done operation component)
2405        (return)))))
2406
2407(defmethod explain ((operation operation) (component component))
2408  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
2409                (operation-description operation component)))
2410
2411(defmethod operation-description (operation component)
2412  (format nil (compatfmt "~@<~A on ~A~@:>")
2413          (class-of operation) component))
2414
2415;;;; -------------------------------------------------------------------------
2416;;;; compile-op
2417
2418(defclass compile-op (operation)
2419  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
2420   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
2421                :initform *compile-file-warnings-behaviour*)
2422   (on-failure :initarg :on-failure :accessor operation-on-failure
2423               :initform *compile-file-failure-behaviour*)
2424   (flags :initarg :flags :accessor compile-op-flags
2425          :initform nil)))
2426
2427(defun* output-file (operation component)
2428  "The unique output file of performing OPERATION on COMPONENT"
2429  (let ((files (output-files operation component)))
2430    (assert (length=n-p files 1))
2431    (first files)))
2432
2433(defun* ensure-all-directories-exist (pathnames)
2434   (dolist (pathname pathnames)
2435     (ensure-directories-exist (translate-logical-pathname pathname))))
2436
2437(defmethod perform :before ((operation compile-op) (c source-file))
2438  (ensure-all-directories-exist (output-files operation c)))
2439
2440(defmethod perform :after ((operation operation) (c component))
2441  (mark-operation-done operation c))
2442
2443(defgeneric* around-compile-hook (component))
2444(defgeneric* call-with-around-compile-hook (component thunk))
2445
2446(defmethod around-compile-hook ((c component))
2447  (cond
2448    ((slot-boundp c 'around-compile)
2449     (slot-value c 'around-compile))
2450    ((component-parent c)
2451     (around-compile-hook (component-parent c)))))
2452
2453(defun ensure-function (fun &key (package :asdf))
2454  (etypecase fun
2455    ((or symbol function) fun)
2456    (cons (eval `(function ,fun)))
2457    (string (eval `(function ,(with-standard-io-syntax
2458                               (let ((*package* (find-package package)))
2459                                 (read-from-string fun))))))))
2460
2461(defmethod call-with-around-compile-hook ((c component) thunk)
2462  (let ((hook (around-compile-hook c)))
2463    (if hook
2464        (funcall (ensure-function hook) thunk)
2465        (funcall thunk))))
2466
2467;;; perform is required to check output-files to find out where to put
2468;;; its answers, in case it has been overridden for site policy
2469(defmethod perform ((operation compile-op) (c cl-source-file))
2470  (let ((source-file (component-pathname c))
2471        ;; on some implementations, there are more than one output-file,
2472        ;; but the first one should always be the primary fasl that gets loaded.
2473        (output-file (first (output-files operation c)))
2474        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
2475        (*compile-file-failure-behaviour* (operation-on-failure operation)))
2476    (multiple-value-bind (output warnings-p failure-p)
2477        (call-with-around-compile-hook
2478         c #'(lambda (&rest flags)
2479               (apply *compile-op-compile-file-function* source-file
2480                      :output-file output-file
2481                      :external-format (component-external-format c)
2482                      (append flags (compile-op-flags operation)))))
2483      (unless output
2484        (error 'compile-error :component c :operation operation))
2485      (when failure-p
2486        (case (operation-on-failure operation)
2487          (:warn (warn
2488                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
2489                  operation c))
2490          (:error (error 'compile-failed :component c :operation operation))
2491          (:ignore nil)))
2492      (when warnings-p
2493        (case (operation-on-warnings operation)
2494          (:warn (warn
2495                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
2496                  operation c))
2497          (:error (error 'compile-warned :component c :operation operation))
2498          (:ignore nil))))))
2499
2500(defmethod output-files ((operation compile-op) (c cl-source-file))
2501  (declare (ignorable operation))
2502  (let* ((p (lispize-pathname (component-pathname c)))
2503         (f (compile-file-pathname ;; fasl
2504             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
2505         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
2506    #+ecl (if (use-ecl-byte-compiler-p)
2507              (list f)
2508              (list (compile-file-pathname p :type :object) f))
2509    #+mkcl (list o f)
2510    #-(or ecl mkcl) (list f)))
2511
2512(defmethod perform ((operation compile-op) (c static-file))
2513  (declare (ignorable operation c))
2514  nil)
2515
2516(defmethod output-files ((operation compile-op) (c static-file))
2517  (declare (ignorable operation c))
2518  nil)
2519
2520(defmethod input-files ((operation compile-op) (c static-file))
2521  (declare (ignorable operation c))
2522  nil)
2523
2524(defmethod operation-description ((operation compile-op) component)
2525  (declare (ignorable operation))
2526  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
2527
2528(defmethod operation-description ((operation compile-op) (component module))
2529  (declare (ignorable operation))
2530  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
2531
2532
2533;;;; -------------------------------------------------------------------------
2534;;;; load-op
2535
2536(defclass basic-load-op (operation) ())
2537
2538(defclass load-op (basic-load-op) ())
2539
2540(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
2541  (loop
2542    (restart-case
2543        (return (call-next-method))
2544      (try-recompiling ()
2545        :report (lambda (s)
2546                  (format s "Recompile ~a and try loading it again"
2547                          (component-name c)))
2548        (perform (make-sub-operation c o c 'compile-op) c)))))
2549
2550(defmethod perform ((o load-op) (c cl-source-file))
2551  (map () #'load
2552       #-(or ecl mkcl)
2553       (input-files o c)
2554       #+(or ecl mkcl)
2555       (loop :for i :in (input-files o c)
2556             :unless (string= (pathname-type i) "fas")
2557             :collect (compile-file-pathname (lispize-pathname i)))))
2558
2559(defmethod perform ((operation load-op) (c static-file))
2560  (declare (ignorable operation c))
2561  nil)
2562
2563(defmethod operation-done-p ((operation load-op) (c static-file))
2564  (declare (ignorable operation c))
2565  t)
2566
2567(defmethod output-files ((operation operation) (c component))
2568  (declare (ignorable operation c))
2569  nil)
2570
2571(defmethod component-depends-on ((operation load-op) (c component))
2572  (declare (ignorable operation))
2573  (cons (list 'compile-op (component-name c))
2574        (call-next-method)))
2575
2576(defmethod operation-description ((operation load-op) component)
2577  (declare (ignorable operation))
2578  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
2579          component))
2580
2581(defmethod operation-description ((operation load-op) (component cl-source-file))
2582  (declare (ignorable operation))
2583  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
2584          component))
2585
2586(defmethod operation-description ((operation load-op) (component module))
2587  (declare (ignorable operation))
2588  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
2589          component))
2590
2591;;;; -------------------------------------------------------------------------
2592;;;; load-source-op
2593
2594(defclass load-source-op (basic-load-op) ())
2595
2596(defmethod perform ((o load-source-op) (c cl-source-file))
2597  (declare (ignorable o))
2598  (let ((source (component-pathname c)))
2599    (setf (component-property c 'last-loaded-as-source)
2600          (and (call-with-around-compile-hook
2601                c #'(lambda () (load source :external-format (component-external-format c))))
2602               (get-universal-time)))))
2603
2604(defmethod perform ((operation load-source-op) (c static-file))
2605  (declare (ignorable operation c))
2606  nil)
2607
2608(defmethod output-files ((operation load-source-op) (c component))
2609  (declare (ignorable operation c))
2610  nil)
2611
2612;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
2613(defmethod component-depends-on ((o load-source-op) (c component))
2614  (declare (ignorable o))
2615  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
2616    :for (op . co) :in what-would-load-op-do
2617    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
2618
2619(defmethod operation-done-p ((o load-source-op) (c source-file))
2620  (declare (ignorable o))
2621  (if (or (not (component-property c 'last-loaded-as-source))
2622          (> (safe-file-write-date (component-pathname c))
2623             (component-property c 'last-loaded-as-source)))
2624      nil t))
2625
2626(defmethod operation-description ((operation load-source-op) component)
2627  (declare (ignorable operation))
2628  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
2629          component))
2630
2631(defmethod operation-description ((operation load-source-op) (component module))
2632  (declare (ignorable operation))
2633  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
2634
2635
2636;;;; -------------------------------------------------------------------------
2637;;;; test-op
2638
2639(defclass test-op (operation) ())
2640
2641(defmethod perform ((operation test-op) (c component))
2642  (declare (ignorable operation c))
2643  nil)
2644
2645(defmethod operation-done-p ((operation test-op) (c system))
2646  "Testing a system is _never_ done."
2647  (declare (ignorable operation c))
2648  nil)
2649
2650(defmethod component-depends-on :around ((o test-op) (c system))
2651  (declare (ignorable o))
2652  (cons `(load-op ,(component-name c)) (call-next-method)))
2653
2654
2655;;;; -------------------------------------------------------------------------
2656;;;; Invoking Operations
2657
2658(defgeneric* operate (operation-class system &key &allow-other-keys))
2659(defgeneric* perform-plan (plan &key))
2660
2661;;;; Separating this into a different function makes it more forward-compatible
2662(defun* cleanup-upgraded-asdf (old-version)
2663  (let ((new-version (asdf-version)))
2664    (unless (equal old-version new-version)
2665      (cond
2666        ((version-satisfies new-version old-version)
2667         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
2668                       old-version new-version))
2669        ((version-satisfies old-version new-version)
2670         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
2671               old-version new-version))
2672        (t
2673         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
2674                       old-version new-version)))
2675      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
2676        ;; Invalidate all systems but ASDF itself.
2677        (setf *defined-systems* (make-defined-systems-table))
2678        (register-system asdf)
2679        ;; If we're in the middle of something, restart it.
2680        (when *systems-being-defined*
2681          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
2682            (clrhash *systems-being-defined*)
2683            (dolist (s l) (find-system s nil))))
2684        t))))
2685
2686;;;; Try to upgrade of ASDF. If a different version was used, return T.
2687;;;; We need do that before we operate on anything that depends on ASDF.
2688(defun* upgrade-asdf ()
2689  (let ((version (asdf-version)))
2690    (handler-bind (((or style-warning warning) #'muffle-warning))
2691      (operate 'load-op :asdf :verbose nil))
2692    (cleanup-upgraded-asdf version)))
2693
2694(defmethod perform-plan ((steps list) &key)
2695  (let ((*package* *package*)
2696        (*readtable* *readtable*))
2697    (with-compilation-unit ()
2698      (loop :for (op . component) :in steps :do
2699        (perform-with-restarts op component)))))
2700
2701(defmethod operate (operation-class system &rest args
2702                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2703                    &allow-other-keys)
2704  (declare (ignore force))
2705  (with-system-definitions ()
2706    (let* ((op (apply 'make-instance operation-class
2707                      :original-initargs args
2708                      args))
2709           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2710           (system (etypecase system
2711                     (system system)
2712                     ((or string symbol) (find-system system)))))
2713      (unless (version-satisfies system version)
2714        (error 'missing-component-of-version :requires system :version version))
2715      (let ((steps (traverse op system)))
2716        (when (and (not (equal '("asdf") (component-find-path system)))
2717                   (find '("asdf") (mapcar 'cdr steps)
2718                         :test 'equal :key 'component-find-path)
2719                   (upgrade-asdf))
2720          ;; If we needed to upgrade ASDF to achieve our goal,
2721          ;; then do it specially as the first thing, then
2722          ;; invalidate all existing system
2723          ;; retry the whole thing with the new OPERATE function,
2724          ;; which on some implementations
2725          ;; has a new symbol shadowing the current one.
2726          (return-from operate
2727            (apply (find-symbol* 'operate :asdf) operation-class system args)))
2728        (perform-plan steps)
2729        (values op steps)))))
2730
2731(defun* oos (operation-class system &rest args &key force verbose version
2732            &allow-other-keys)
2733  (declare (ignore force verbose version))
2734  (apply 'operate operation-class system args))
2735
2736(let ((operate-docstring
2737  "Operate does three things:
2738
27391. It creates an instance of OPERATION-CLASS using any keyword parameters
2740as initargs.
27412. It finds the  asdf-system specified by SYSTEM (possibly loading
2742it from disk).
27433. It then calls TRAVERSE with the operation and system as arguments
2744
2745The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2746handling code. If a VERSION argument is supplied, then operate also
2747ensures that the system found satisfies it using the VERSION-SATISFIES
2748method.
2749
2750Note that dependencies may cause the operation to invoke other
2751operations on the system or its components: the new operations will be
2752created with the same initargs as the original one.
2753"))
2754  (setf (documentation 'oos 'function)
2755        (format nil
2756                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
2757                operate-docstring))
2758  (setf (documentation 'operate 'function)
2759        operate-docstring))
2760
2761(defun* load-system (system &rest keys &key force verbose version &allow-other-keys)
2762  "Shorthand for `(operate 'asdf:load-op system)`.
2763See OPERATE for details."
2764  (declare (ignore force verbose version))
2765  (apply 'operate *load-system-operation* system keys)
2766  t)
2767
2768(defun* load-systems (&rest systems)
2769  (map () 'load-system systems))
2770
2771(defun component-loaded-p (c)
2772  (and (gethash 'load-op (component-operation-times (find-component c nil))) t))
2773
2774(defun loaded-systems ()
2775  (remove-if-not 'component-loaded-p (registered-systems)))
2776
2777(defun require-system (s &rest keys &key &allow-other-keys)
2778  (apply 'load-system s :force-not (loaded-systems) keys))
2779
2780(defun* compile-system (system &rest args &key force verbose version
2781                       &allow-other-keys)
2782  "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
2783for details."
2784  (declare (ignore force verbose version))
2785  (apply 'operate 'compile-op system args)
2786  t)
2787
2788(defun* test-system (system &rest args &key force verbose version
2789                    &allow-other-keys)
2790  "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
2791details."
2792  (declare (ignore force verbose version))
2793  (apply 'operate 'test-op system args)
2794  t)
2795
2796;;;; -------------------------------------------------------------------------
2797;;;; Defsystem
2798
2799(defun* load-pathname ()
2800  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
2801
2802(defun* determine-system-pathname (pathname)
2803  ;; The defsystem macro calls us to determine
2804  ;; the pathname of a system as follows:
2805  ;; 1. the one supplied,
2806  ;; 2. derived from *load-pathname* via load-pathname
2807  ;; 3. taken from the *default-pathname-defaults* via default-directory
2808  (let* ((file-pathname (load-pathname))
2809         (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2810    (or (and pathname (subpathname directory-pathname pathname :type :directory))
2811        directory-pathname
2812        (default-directory))))
2813
2814(defun* find-class* (x &optional (errorp t) environment)
2815  (etypecase x
2816    ((or standard-class built-in-class) x)
2817    (symbol (find-class x errorp environment))))
2818
2819(defun* class-for-type (parent type)
2820  (or (loop :for symbol :in (list
2821                             type
2822                             (find-symbol* type *package*)
2823                             (find-symbol* type :asdf))
2824        :for class = (and symbol (find-class symbol nil))
2825        :when (and class
2826                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
2827                                 class (find-class 'component)))
2828        :return class)
2829      (and (eq type :file)
2830           (find-class*
2831            (or (loop :for module = parent :then (component-parent module) :while module
2832                  :thereis (module-default-component-class module))
2833                *default-component-class*) nil))
2834      (sysdef-error "don't recognize component type ~A" type)))
2835
2836(defun* maybe-add-tree (tree op1 op2 c)
2837  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2838Returns the new tree (which probably shares structure with the old one)"
2839  (let ((first-op-tree (assoc op1 tree)))
2840    (if first-op-tree
2841        (progn
2842          (aif (assoc op2 (cdr first-op-tree))
2843               (if (find c (cdr it) :test #'equal)
2844                   nil
2845                   (setf (cdr it) (cons c (cdr it))))
2846               (setf (cdr first-op-tree)
2847                     (acons op2 (list c) (cdr first-op-tree))))
2848          tree)
2849        (acons op1 (list (list op2 c)) tree))))
2850
2851(defun* union-of-dependencies (&rest deps)
2852  (let ((new-tree nil))
2853    (dolist (dep deps)
2854      (dolist (op-tree dep)
2855        (dolist (op  (cdr op-tree))
2856          (dolist (c (cdr op))
2857            (setf new-tree
2858                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2859    new-tree))
2860
2861
2862(defvar *serial-depends-on* nil)
2863
2864(defun* sysdef-error-component (msg type name value)
2865  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
2866                type name value))
2867
2868(defun* check-component-input (type name weakly-depends-on
2869                              depends-on components in-order-to)
2870  "A partial test of the values of a component."
2871  (unless (listp depends-on)
2872    (sysdef-error-component ":depends-on must be a list."
2873                            type name depends-on))
2874  (unless (listp weakly-depends-on)
2875    (sysdef-error-component ":weakly-depends-on must be a list."
2876                            type name weakly-depends-on))
2877  (unless (listp components)
2878    (sysdef-error-component ":components must be NIL or a list of components."
2879                            type name components))
2880  (unless (and (listp in-order-to) (listp (car in-order-to)))
2881    (sysdef-error-component ":in-order-to must be NIL or a list of components."
2882                            type name in-order-to)))
2883
2884(defun* %remove-component-inline-methods (component)
2885  (dolist (name +asdf-methods+)
2886    (map ()
2887         ;; this is inefficient as most of the stored
2888         ;; methods will not be for this particular gf
2889         ;; But this is hardly performance-critical
2890         #'(lambda (m)
2891             (remove-method (symbol-function name) m))
2892         (component-inline-methods component)))
2893  ;; clear methods, then add the new ones
2894  (setf (component-inline-methods component) nil))
2895
2896(defun* %define-component-inline-methods (ret rest)
2897  (dolist (name +asdf-methods+)
2898    (let ((keyword (intern (symbol-name name) :keyword)))
2899      (loop :for data = rest :then (cddr data)
2900        :for key = (first data)
2901        :for value = (second data)
2902        :while data
2903        :when (eq key keyword) :do
2904        (destructuring-bind (op qual (o c) &body body) value
2905          (pushnew
2906           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2907                             ,@body))
2908           (component-inline-methods ret)))))))
2909
2910(defun* %refresh-component-inline-methods (component rest)
2911  (%remove-component-inline-methods component)
2912  (%define-component-inline-methods component rest))
2913
2914(defun* parse-component-form (parent options)
2915  (destructuring-bind
2916        (type name &rest rest &key
2917              ;; the following list of keywords is reproduced below in the
2918              ;; remove-keys form.  important to keep them in sync
2919              components pathname
2920              perform explain output-files operation-done-p
2921              weakly-depends-on depends-on serial in-order-to
2922              do-first
2923              (version nil versionp)
2924              ;; list ends
2925              &allow-other-keys) options
2926    (declare (ignorable perform explain output-files operation-done-p))
2927    (check-component-input type name weakly-depends-on depends-on components in-order-to)
2928
2929    (when (and parent
2930               (find-component parent name)
2931               ;; ignore the same object when rereading the defsystem
2932               (not
2933                (typep (find-component parent name)
2934                       (class-for-type parent type))))
2935      (error 'duplicate-names :name name))
2936
2937    (when versionp
2938      (unless (parse-version version nil)
2939        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
2940              version name parent)))
2941
2942    (let* ((args (list* :name (coerce-name name)
2943                        :pathname pathname
2944                        :parent parent
2945                        (remove-keys
2946                         '(components pathname
2947                           perform explain output-files operation-done-p
2948                           weakly-depends-on depends-on serial in-order-to)
2949                         rest)))
2950           (ret (find-component parent name)))
2951      (when weakly-depends-on
2952        (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
2953      (when *serial-depends-on*
2954        (push *serial-depends-on* depends-on))
2955      (if ret ; preserve identity
2956          (apply 'reinitialize-instance ret args)
2957          (setf ret (apply 'make-instance (class-for-type parent type) args)))
2958      (component-pathname ret) ; eagerly compute the absolute pathname
2959      (when (typep ret 'module)
2960        (let ((*serial-depends-on* nil))
2961          (setf (module-components ret)
2962                (loop
2963                  :for c-form :in components
2964                  :for c = (parse-component-form ret c-form)
2965                  :for name = (component-name c)
2966                  :collect c
2967                  :when serial :do (setf *serial-depends-on* name))))
2968        (compute-module-components-by-name ret))
2969
2970      (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2971
2972      (setf (component-in-order-to ret)
2973            (union-of-dependencies
2974             in-order-to
2975             `((compile-op (compile-op ,@depends-on))
2976               (load-op (load-op ,@depends-on)))))
2977      (setf (component-do-first ret)
2978            (union-of-dependencies
2979             do-first
2980             `((compile-op (load-op ,@depends-on)))))
2981
2982      (%refresh-component-inline-methods ret rest)
2983      ret)))
2984
2985(defun* reset-system (system &rest keys &key &allow-other-keys)
2986  (change-class (change-class system 'proto-system) 'system)
2987  (apply 'reinitialize-instance system keys))
2988
2989(defun* do-defsystem (name &rest options
2990                           &key pathname (class 'system)
2991                           defsystem-depends-on &allow-other-keys)
2992  ;; The system must be registered before we parse the body,
2993  ;; otherwise we recur when trying to find an existing system
2994  ;; of the same name to reuse options (e.g. pathname) from.
2995  ;; To avoid infinite recursion in cases where you defsystem a system
2996  ;; that is registered to a different location to find-system,
2997  ;; we also need to remember it in a special variable *systems-being-defined*.
2998  (with-system-definitions ()
2999    (let* ((name (coerce-name name))
3000           (registered (system-registered-p name))
3001           (registered! (if registered
3002                            (rplaca registered (get-universal-time))
3003                            (register-system (make-instance 'system :name name))))
3004           (system (reset-system (cdr registered!)
3005                                :name name :source-file (load-pathname)))
3006           (component-options (remove-keys '(:class) options)))
3007      (setf (gethash name *systems-being-defined*) system)
3008      (apply 'load-systems defsystem-depends-on)
3009      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
3010      ;; since the class might not be defined as part of those.
3011      (let ((class (class-for-type nil class)))
3012        (unless (eq (type-of system) class)
3013          (change-class system class)))
3014      (parse-component-form
3015       nil (list*
3016            :module name
3017            :pathname (determine-system-pathname pathname)
3018            component-options)))))
3019
3020(defmacro defsystem (name &body options)
3021  `(apply 'do-defsystem ',name ',options))
3022
3023;;;; ---------------------------------------------------------------------------
3024;;;; run-shell-command
3025;;;;
3026;;;; run-shell-command functions for other lisp implementations will be
3027;;;; gratefully accepted, if they do the same thing.
3028;;;; If the docstring is ambiguous, send a bug report.
3029;;;;
3030;;;; WARNING! The function below is mostly dysfunctional.
3031;;;; For instance, it will probably run fine on most implementations on Unix,
3032;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
3033;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
3034;;;; But behavior on Windows may vary wildly between implementations,
3035;;;; either relying on your having installed a POSIX sh, or going through
3036;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
3037;;;; what is easily expressible in said implementation.
3038;;;;
3039;;;; We probably should move this functionality to its own system and deprecate
3040;;;; use of it from the asdf package. However, this would break unspecified
3041;;;; existing software, so until a clear alternative exists, we can't deprecate
3042;;;; it, and even after it's been deprecated, we will support it for a few
3043;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
3044;;;;
3045;;;; As a suggested replacement which is portable to all ASDF-supported
3046;;;; implementations and operating systems except Genera, I recommend
3047;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
3048
3049(defun* run-shell-command (control-string &rest args)
3050  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
3051synchronously execute the result using a Bourne-compatible shell, with
3052output to *VERBOSE-OUT*.  Returns the shell's exit code."
3053  (let ((command (apply 'format nil control-string args)))
3054    (asdf-message "; $ ~A~%" command)
3055
3056    #+abcl
3057    (ext:run-shell-command command :output *verbose-out*)
3058
3059    #+allegro
3060    ;; will this fail if command has embedded quotes - it seems to work
3061    (multiple-value-bind (stdout stderr exit-code)
3062        (excl.osi:command-output
3063         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
3064         #+mswindows command ; BEWARE!
3065         :input nil :whole nil
3066         #+mswindows :show-window #+mswindows :hide)
3067      (asdf-message "~{~&~a~%~}~%" stderr)
3068      (asdf-message "~{~&~a~%~}~%" stdout)
3069      exit-code)
3070
3071    #+clisp
3072    ;; CLISP returns NIL for exit status zero.
3073    (if *verbose-out*
3074        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
3075                                    command))
3076               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
3077            (multiple-value-bind (retval out-lines)
3078                (unwind-protect
3079                     (parse-clisp-shell-output outstream)
3080                  (ignore-errors (close outstream)))
3081              (asdf-message "~{~&~a~%~}~%" out-lines)
3082              retval))
3083        ;; there will be no output, just grab up the exit status
3084        (or (ext:run-shell-command command :output nil :wait t) 0))
3085
3086    #+clozure
3087    (nth-value 1
3088               (ccl:external-process-status
3089                (ccl:run-program
3090                 (cond
3091                   ((os-unix-p) "/bin/sh")
3092                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
3093                   (t (error "Unsupported OS")))
3094                 (if (os-unix-p) (list "-c" command) '())
3095                 :input nil :output *verbose-out* :wait t)))
3096
3097    #+(or cmu scl)
3098    (ext:process-exit-code
3099     (ext:run-program
3100      "/bin/sh"
3101      (list "-c" command)
3102      :input nil :output *verbose-out*))
3103
3104    #+cormanlisp
3105    (win32:system command)
3106
3107    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
3108    (ext:system command)
3109
3110    #+gcl
3111    (lisp:system command)
3112
3113    #+lispworks
3114    (apply 'system:call-system-showing-output command
3115           :show-cmd nil :prefix "" :output-stream *verbose-out*
3116           (when (os-unix-p) '(:shell-type "/bin/sh")))
3117
3118    #+mcl
3119    (ccl::with-cstrs ((%command command)) (_system %command))
3120
3121    #+mkcl
3122    ;; This has next to no chance of working on basic Windows!
3123    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
3124    (multiple-value-bind (io process exit-code)
3125        (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
3126                                  (list "-c" command)
3127                                  :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
3128                                  #-windows '(:search nil))
3129      (declare (ignore io process))
3130      exit-code)
3131
3132    #+sbcl
3133    (sb-ext:process-exit-code
3134     (apply 'sb-ext:run-program
3135            #+win32 "sh" #-win32 "/bin/sh"
3136            (list  "-c" command)
3137            :input nil :output *verbose-out*
3138            #+win32 '(:search t) #-win32 nil))
3139
3140    #+xcl
3141    (ext:run-shell-command command)
3142
3143    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
3144    (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
3145
3146#+clisp
3147(defun* parse-clisp-shell-output (stream)
3148  "Helper function for running shell commands under clisp.  Parses a specially-
3149crafted output string to recover the exit status of the shell command and a
3150list of lines of output."
3151  (loop :with status-prefix = "ASDF-EXIT-STATUS "
3152    :with prefix-length = (length status-prefix)
3153    :with exit-status = -1 :with lines = ()
3154    :for line = (read-line stream nil nil)
3155    :while line :do (push line lines) :finally
3156    (let* ((last (car lines))
3157           (status (and last (>= (length last) prefix-length)
3158                        (string-equal last status-prefix :end1 prefix-length)
3159                        (parse-integer last :start prefix-length :junk-allowed t))))
3160      (when status
3161        (setf exit-status status)
3162        (pop lines) (when (equal "" (car lines)) (pop lines)))
3163      (return (values exit-status (reverse lines))))))
3164
3165;;;; ---------------------------------------------------------------------------
3166;;;; system-relative-pathname
3167
3168(defun* system-definition-pathname (x)
3169  ;; As of 2.014.8, we mean to make this function obsolete,
3170  ;; but that won't happen until all clients have been updated.
3171  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
3172  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
3173It used to expose ASDF internals with subtle differences with respect to
3174user expectations, that have been refactored away since.
3175We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
3176for a mostly compatible replacement that we're supporting,
3177or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
3178if that's whay you mean." ;;)
3179  (system-source-file x))
3180
3181(defmethod system-source-file ((system system))
3182  ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
3183  (unless (slot-boundp system 'source-file)
3184    (%set-system-source-file
3185     (probe-asd (component-name system) (component-pathname system)) system))
3186  (%system-source-file system))
3187(defmethod system-source-file ((system-name string))
3188  (%system-source-file (find-system system-name)))
3189(defmethod system-source-file ((system-name symbol))
3190  (%system-source-file (find-system system-name)))
3191
3192(defun* system-source-directory (system-designator)
3193  "Return a pathname object corresponding to the
3194directory in which the system specification (.asd file) is
3195located."
3196  (pathname-directory-pathname (system-source-file system-designator)))
3197
3198(defun* relativize-directory (directory)
3199  (cond
3200    ((stringp directory)
3201     (list :relative directory))
3202    ((eq (car directory) :absolute)
3203     (cons :relative (cdr directory)))
3204    (t
3205     directory)))
3206
3207(defun* relativize-pathname-directory (pathspec)
3208  (let ((p (pathname pathspec)))
3209    (make-pathname
3210     :directory (relativize-directory (pathname-directory p))
3211     :defaults p)))
3212
3213(defun* system-relative-pathname (system name &key type)
3214  (subpathname (system-source-directory system) name :type type))
3215
3216
3217;;; ---------------------------------------------------------------------------
3218;;; implementation-identifier
3219;;;
3220;;; produce a string to identify current implementation.
3221;;; Initially stolen from SLIME's SWANK, rewritten since.
3222;;; We're back to runtime checking, for the sake of e.g. ABCL.
3223
3224(defun* first-feature (features)
3225  (dolist (x features)
3226    (multiple-value-bind (val feature)
3227        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
3228      (when (featurep feature) (return val)))))
3229
3230(defun implementation-type ()
3231  (first-feature
3232   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
3233     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
3234
3235(defun operating-system ()
3236  (first-feature
3237   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
3238     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
3239     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
3240     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
3241     :genera)))
3242
3243(defun architecture ()
3244  (first-feature
3245   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
3246     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
3247     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
3248     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
3249     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
3250     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
3251     ;; we may have to segregate the code still by architecture.
3252     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
3253
3254#+clozure
3255(defun* ccl-fasl-version ()
3256  ;; the fasl version is target-dependent from CCL 1.8 on.
3257  (or (let ((s 'ccl::target-fasl-version))
3258        (and (fboundp s) (funcall s)))
3259      (and (boundp 'ccl::fasl-version)
3260           (symbol-value 'ccl::fasl-version))
3261      (error "Can't determine fasl version.")))
3262
3263(defun lisp-version-string ()
3264  (let ((s (lisp-implementation-version)))
3265    (car ; as opposed to OR, this idiom prevents some unreachable code warning
3266     (list
3267      #+allegro
3268      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
3269              excl::*common-lisp-version-number*
3270              ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
3271              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
3272              ;; Note if not using International ACL
3273              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
3274              (excl:ics-target-case (:-ics "8"))
3275              (and (member :smp *features*) "S"))
3276      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
3277      #+clisp
3278      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
3279      #+clozure
3280      (format nil "~d.~d-f~d" ; shorten for windows
3281              ccl::*openmcl-major-version*
3282              ccl::*openmcl-minor-version*
3283              (logand (ccl-fasl-version) #xFF))
3284      #+cmu (substitute #\- #\/ s)
3285      #+scl (format nil "~A~A" s
3286                    ;; ANSI upper case vs lower case.
3287                    (ecase ext:*case-mode* (:upper "") (:lower "l")))
3288      #+ecl (format nil "~A~@[-~A~]" s
3289                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
3290                      (subseq vcs-id 0 (min (length vcs-id) 8))))
3291      #+gcl (subseq s (1+ (position #\space s)))
3292      #+genera
3293      (multiple-value-bind (major minor) (sct:get-system-version "System")
3294        (format nil "~D.~D" major minor))
3295      #+mcl (subseq s 8) ; strip the leading "Version "
3296      s))))
3297
3298(defun* implementation-identifier ()
3299  (substitute-if
3300   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
3301   (format nil "~(~a~@{~@[-~a~]~}~)"
3302           (or (implementation-type) (lisp-implementation-type))
3303           (or (lisp-version-string) (lisp-implementation-version))
3304           (or (operating-system) (software-type))
3305           (or (architecture) (machine-type)))))
3306
3307(defun* hostname ()
3308  ;; Note: untested on RMCL
3309  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
3310  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
3311  #+allegro (excl.osi:gethostname)
3312  #+clisp (first (split-string (machine-instance) :separator " "))
3313  #+gcl (system:gethostname))
3314
3315
3316;;; ---------------------------------------------------------------------------
3317;;; Generic support for configuration files
3318
3319(defun inter-directory-separator ()
3320  (if (os-unix-p) #\: #\;))
3321
3322(defun* user-homedir ()
3323  (truenamize
3324   (pathname-directory-pathname
3325    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
3326    #+mcl (current-user-homedir-pathname)
3327    #-(or cormanlisp mcl) (user-homedir-pathname))))
3328
3329(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
3330  (when (plusp (length x))
3331    (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
3332      (when want-absolute
3333        (unless (absolute-pathname-p p)
3334          (cerror "ignore relative pathname"
3335                  "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
3336          (return-from ensure-pathname* nil)))
3337      p)))
3338(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
3339  (loop :for dir :in (split-string
3340                      x :separator (string (inter-directory-separator)))
3341        :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
3342(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
3343  (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
3344(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
3345  (and (plusp (length s))
3346       (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
3347(defun* getenv-absolute-directory (x)
3348  (getenv-pathname x :want-absolute t :want-directory t))
3349(defun* getenv-absolute-directories (x)
3350  (getenv-pathnames x :want-absolute t :want-directory t))
3351
3352(defun* get-folder-path (folder)
3353  (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
3354   #+(and lispworks mswindows) (sys:get-folder-path folder)
3355   ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
3356   (ecase folder
3357    (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
3358    (:appdata (getenv-absolute-directory "APPDATA"))
3359    (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
3360                         (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
3361
3362(defun* user-configuration-directories ()
3363  (let ((dirs
3364         `(,@(when (os-unix-p)
3365               (cons
3366                (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
3367                (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
3368                  :collect (subpathname* dir "common-lisp/"))))
3369           ,@(when (os-windows-p)
3370               `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
3371                 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
3372           ,(subpathname (user-homedir) ".config/common-lisp/"))))
3373    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
3374                       :from-end t :test 'equal)))
3375
3376(defun* system-configuration-directories ()
3377  (cond
3378    ((os-unix-p) '(#p"/etc/common-lisp/"))
3379    ((os-windows-p)
3380     (aif
3381      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
3382      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
3383      (list it)))))
3384
3385(defun* in-first-directory (dirs x &key (direction :input))
3386  (loop :with fun = (ecase direction
3387                      ((nil :input :probe) 'probe-file*)
3388                      ((:output :io) 'identity))
3389    :for dir :in dirs
3390    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
3391
3392(defun* in-user-configuration-directory (x &key (direction :input))
3393  (in-first-directory (user-configuration-directories) x :direction direction))
3394(defun* in-system-configuration-directory (x &key (direction :input))
3395  (in-first-directory (system-configuration-directories) x :direction direction))
3396
3397(defun* configuration-inheritance-directive-p (x)
3398  (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
3399    (or (member x kw)
3400        (and (length=n-p x 1) (member (car x) kw)))))
3401
3402(defun* report-invalid-form (reporter &rest args)
3403  (etypecase reporter
3404    (null
3405     (apply 'error 'invalid-configuration args))
3406    (function
3407     (apply reporter args))
3408    ((or symbol string)
3409     (apply 'error reporter args))
3410    (cons
3411     (apply 'apply (append reporter args)))))
3412
3413(defvar *ignored-configuration-form* nil)
3414
3415(defun* validate-configuration-form (form tag directive-validator
3416                                    &key location invalid-form-reporter)
3417  (unless (and (consp form) (eq (car form) tag))
3418    (setf *ignored-configuration-form* t)
3419    (report-invalid-form invalid-form-reporter :form form :location location)
3420    (return-from validate-configuration-form nil))
3421  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
3422    :for directive :in (cdr form)
3423    :when (cond
3424            ((configuration-inheritance-directive-p directive)
3425             (incf inherit) t)
3426            ((eq directive :ignore-invalid-entries)
3427             (setf ignore-invalid-p t) t)
3428            ((funcall directive-validator directive)
3429             t)
3430            (ignore-invalid-p
3431             nil)
3432            (t
3433             (setf *ignored-configuration-form* t)
3434             (report-invalid-form invalid-form-reporter :form directive :location location)
3435             nil))
3436    :do (push directive x)
3437    :finally
3438    (unless (= inherit 1)
3439      (report-invalid-form invalid-form-reporter
3440             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
3441                              :inherit-configuration :ignore-inherited-configuration)))
3442    (return (nreverse x))))
3443
3444(defun* validate-configuration-file (file validator &key description)
3445  (let ((forms (read-file-forms file)))
3446    (unless (length=n-p forms 1)
3447      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
3448             description forms))
3449    (funcall validator (car forms) :location file)))
3450
3451(defun* hidden-file-p (pathname)
3452  (equal (first-char (pathname-name pathname)) #\.))
3453
3454(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
3455  (apply 'directory pathname-spec
3456         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3457                             #+clozure '(:follow-links nil)
3458                             #+clisp '(:circle t :if-does-not-exist :ignore)
3459                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
3460                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
3461                                      '(:resolve-symlinks nil))))))
3462
3463(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
3464  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
3465be applied to the results to yield a configuration form.  Current
3466values of TAG include :source-registry and :output-translations."
3467  (let ((files (sort (ignore-errors
3468                       (remove-if
3469                        'hidden-file-p
3470                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
3471                     #'string< :key #'namestring)))
3472    `(,tag
3473      ,@(loop :for file :in files :append
3474          (loop :with ignore-invalid-p = nil
3475            :for form :in (read-file-forms file)
3476            :when (eq form :ignore-invalid-entries)
3477              :do (setf ignore-invalid-p t)
3478            :else
3479              :when (funcall validator form)
3480                :collect form
3481              :else
3482                :when ignore-invalid-p
3483                  :do (setf *ignored-configuration-form* t)
3484                :else
3485                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
3486      :inherit-configuration)))
3487
3488
3489;;; ---------------------------------------------------------------------------
3490;;; asdf-output-translations
3491;;;
3492;;; this code is heavily inspired from
3493;;; asdf-binary-translations, common-lisp-controller and cl-launch.
3494;;; ---------------------------------------------------------------------------
3495
3496(defvar *output-translations* ()
3497  "Either NIL (for uninitialized), or a list of one element,
3498said element itself being a sorted list of mappings.
3499Each mapping is a pair of a source pathname and destination pathname,
3500and the order is by decreasing length of namestring of the source pathname.")
3501
3502(defvar *user-cache*
3503  (flet ((try (x &rest sub) (and x `(,x ,@sub))))
3504    (or
3505     (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
3506     (when (os-windows-p)
3507       (try (or (get-folder-path :local-appdata)
3508                (get-folder-path :appdata))
3509            "common-lisp" "cache" :implementation))
3510     '(:home ".cache" "common-lisp" :implementation))))
3511
3512(defun* output-translations ()
3513  (car *output-translations*))
3514
3515(defun* (setf output-translations) (new-value)
3516  (setf *output-translations*
3517        (list
3518         (stable-sort (copy-list new-value) #'>
3519                      :key #'(lambda (x)
3520                               (etypecase (car x)
3521                                 ((eql t) -1)
3522                                 (pathname
3523                                  (let ((directory (pathname-directory (car x))))
3524                                    (if (listp directory) (length directory) 0))))))))
3525  new-value)
3526
3527(defun* output-translations-initialized-p ()
3528  (and *output-translations* t))
3529
3530(defun* clear-output-translations ()
3531  "Undoes any initialization of the output translations.
3532You might want to call that before you dump an image that would be resumed
3533with a different configuration, so the configuration would be re-read then."
3534  (setf *output-translations* '())
3535  (values))
3536
3537(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
3538                          (values (or null pathname) &optional))
3539                resolve-location))
3540
3541(defun* resolve-relative-location-component (x &key directory wilden)
3542  (let ((r (etypecase x
3543             (pathname x)
3544             (string (coerce-pathname x :type (when directory :directory)))
3545             (cons
3546              (if (null (cdr x))
3547                  (resolve-relative-location-component
3548                   (car x) :directory directory :wilden wilden)
3549                  (let* ((car (resolve-relative-location-component
3550                               (car x) :directory t :wilden nil)))
3551                    (merge-pathnames*
3552                     (resolve-relative-location-component
3553                      (cdr x) :directory directory :wilden wilden)
3554                     car))))
3555             ((eql :default-directory)
3556              (relativize-pathname-directory (default-directory)))
3557             ((eql :*/) *wild-directory*)
3558             ((eql :**/) *wild-inferiors*)
3559             ((eql :*.*.*) *wild-file*)
3560             ((eql :implementation)
3561              (coerce-pathname (implementation-identifier) :type :directory))
3562             ((eql :implementation-type)
3563              (coerce-pathname (string-downcase (implementation-type)) :type :directory))
3564             ((eql :hostname)
3565              (coerce-pathname (hostname) :type :directory)))))
3566    (when (absolute-pathname-p r)
3567      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
3568    (if (or (pathnamep x) (not wilden)) r (wilden r))))
3569
3570(defvar *here-directory* nil
3571  "This special variable is bound to the currect directory during calls to
3572PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
3573directive.")
3574
3575(defun* resolve-absolute-location-component (x &key directory wilden)
3576  (let* ((r
3577          (etypecase x
3578            (pathname x)
3579            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
3580                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
3581                      (if directory (ensure-directory-pathname p) p)))
3582            (cons
3583             (return-from resolve-absolute-location-component
3584               (if (null (cdr x))
3585                   (resolve-absolute-location-component
3586                    (car x) :directory directory :wilden wilden)
3587                   (merge-pathnames*
3588                    (resolve-relative-location-component
3589                     (cdr x) :directory directory :wilden wilden)
3590                    (resolve-absolute-location-component
3591                     (car x) :directory t :wilden nil)))))
3592            ((eql :root)
3593             ;; special magic! we encode such paths as relative pathnames,
3594             ;; but it means "relative to the root of the source pathname's host and device".
3595             (return-from resolve-absolute-location-component
3596               (let ((p (make-pathname :directory '(:relative))))
3597                 (if wilden (wilden p) p))))
3598            ((eql :home) (user-homedir))
3599            ((eql :here)
3600             (resolve-location (or *here-directory*
3601                                   ;; give semantics in the case of use interactively
3602                                   :default-directory)
3603                          :directory t :wilden nil))
3604            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
3605            ((eql :system-cache)
3606             (error "Using the :system-cache is deprecated. ~%~
3607Please remove it from your ASDF configuration"))
3608            ((eql :default-directory) (default-directory))))
3609         (s (if (and wilden (not (pathnamep x)))
3610                (wilden r)
3611                r)))
3612    (unless (absolute-pathname-p s)
3613      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
3614    s))
3615
3616(defun* resolve-location (x &key directory wilden)
3617  (if (atom x)
3618      (resolve-absolute-location-component x :directory directory :wilden wilden)
3619      (loop :with path = (resolve-absolute-location-component
3620                          (car x) :directory (and (or directory (cdr x)) t)
3621                          :wilden (and wilden (null (cdr x))))
3622        :for (component . morep) :on (cdr x)
3623        :for dir = (and (or morep directory) t)
3624        :for wild = (and wilden (not morep))
3625        :do (setf path (merge-pathnames*
3626                        (resolve-relative-location-component
3627                         component :directory dir :wilden wild)
3628                        path))
3629        :finally (return path))))
3630
3631(defun* location-designator-p (x)
3632  (flet ((absolute-component-p (c)
3633           (typep c '(or string pathname
3634                      (member :root :home :here :user-cache :system-cache :default-directory))))
3635         (relative-component-p (c)
3636           (typep c '(or string pathname
3637                      (member :default-directory :*/ :**/ :*.*.*
3638                        :implementation :implementation-type)))))
3639    (or (typep x 'boolean)
3640        (absolute-component-p x)
3641        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
3642
3643(defun* location-function-p (x)
3644  (and
3645   (length=n-p x 2)
3646   (eq (car x) :function)
3647   (or (symbolp (cadr x))
3648       (and (consp (cadr x))
3649            (eq (caadr x) 'lambda)
3650            (length=n-p (cadadr x) 2)))))
3651
3652(defun* validate-output-translations-directive (directive)
3653  (or (member directive '(:enable-user-cache :disable-cache nil))
3654      (and (consp directive)
3655           (or (and (length=n-p directive 2)
3656                    (or (and (eq (first directive) :include)
3657                             (typep (second directive) '(or string pathname null)))
3658                        (and (location-designator-p (first directive))
3659                             (or (location-designator-p (second directive))
3660                                 (location-function-p (second directive))))))
3661               (and (length=n-p directive 1)
3662                    (location-designator-p (first directive)))))))
3663
3664(defun* validate-output-translations-form (form &key location)
3665  (validate-configuration-form
3666   form
3667   :output-translations
3668   'validate-output-translations-directive
3669   :location location :invalid-form-reporter 'invalid-output-translation))
3670
3671(defun* validate-output-translations-file (file)
3672  (validate-configuration-file
3673   file 'validate-output-translations-form :description "output translations"))
3674
3675(defun* validate-output-translations-directory (directory)
3676  (validate-configuration-directory
3677   directory :output-translations 'validate-output-translations-directive
3678   :invalid-form-reporter 'invalid-output-translation))
3679
3680(defun* parse-output-translations-string (string &key location)
3681  (cond
3682    ((or (null string) (equal string ""))
3683     '(:output-translations :inherit-configuration))
3684    ((not (stringp string))
3685     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3686    ((eql (char string 0) #\")
3687     (parse-output-translations-string (read-from-string string) :location location))
3688    ((eql (char string 0) #\()
3689     (validate-output-translations-form (read-from-string string) :location location))
3690    (t
3691     (loop
3692      :with inherit = nil
3693      :with directives = ()
3694      :with start = 0
3695      :with end = (length string)
3696      :with source = nil
3697      :with separator = (inter-directory-separator)
3698      :for i = (or (position separator string :start start) end) :do
3699      (let ((s (subseq string start i)))
3700        (cond
3701          (source
3702           (push (list source (if (equal "" s) nil s)) directives)
3703           (setf source nil))
3704          ((equal "" s)
3705           (when inherit
3706             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3707                    string))
3708           (setf inherit t)
3709           (push :inherit-configuration directives))
3710          (t
3711           (setf source s)))
3712        (setf start (1+ i))
3713        (when (> start end)
3714          (when source
3715            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
3716                   string))
3717          (unless inherit
3718            (push :ignore-inherited-configuration directives))
3719          (return `(:output-translations ,@(nreverse directives)))))))))
3720
3721(defparameter *default-output-translations*
3722  '(environment-output-translations
3723    user-output-translations-pathname
3724    user-output-translations-directory-pathname
3725    system-output-translations-pathname
3726    system-output-translations-directory-pathname))
3727
3728(defun* wrapping-output-translations ()
3729  `(:output-translations
3730    ;; Some implementations have precompiled ASDF systems,
3731    ;; so we must disable translations for implementation paths.
3732    #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
3733              (when h `((,(truenamize h) ,*wild-inferiors*) ())))
3734    ;; The below two are not needed: no precompiled ASDF system there
3735    #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
3736    #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
3737    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
3738    ;; All-import, here is where we want user stuff to be:
3739    :inherit-configuration
3740    ;; These are for convenience, and can be overridden by the user:
3741    #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
3742    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
3743    ;; We enable the user cache by default, and here is the place we do:
3744    :enable-user-cache))
3745
3746(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
3747(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
3748
3749(defun* user-output-translations-pathname (&key (direction :input))
3750  (in-user-configuration-directory *output-translations-file* :direction direction))
3751(defun* system-output-translations-pathname (&key (direction :input))
3752  (in-system-configuration-directory *output-translations-file* :direction direction))
3753(defun* user-output-translations-directory-pathname (&key (direction :input))
3754  (in-user-configuration-directory *output-translations-directory* :direction direction))
3755(defun* system-output-translations-directory-pathname (&key (direction :input))
3756  (in-system-configuration-directory *output-translations-directory* :direction direction))
3757(defun* environment-output-translations ()
3758  (getenv "ASDF_OUTPUT_TRANSLATIONS"))
3759
3760(defgeneric* process-output-translations (spec &key inherit collect))
3761(declaim (ftype (function (t &key (:collect (or symbol function))) t)
3762                inherit-output-translations))
3763(declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
3764                process-output-translations-directive))
3765
3766(defmethod process-output-translations ((x symbol) &key
3767                                        (inherit *default-output-translations*)
3768                                        collect)
3769  (process-output-translations (funcall x) :inherit inherit :collect collect))
3770(defmethod process-output-translations ((pathname pathname) &key inherit collect)
3771  (cond
3772    ((directory-pathname-p pathname)
3773     (process-output-translations (validate-output-translations-directory pathname)
3774                                  :inherit inherit :collect collect))
3775    ((probe-file* pathname)
3776     (process-output-translations (validate-output-translations-file pathname)
3777                                  :inherit inherit :collect collect))
3778    (t
3779     (inherit-output-translations inherit :collect collect))))
3780(defmethod process-output-translations ((string string) &key inherit collect)
3781  (process-output-translations (parse-output-translations-string string)
3782                               :inherit inherit :collect collect))
3783(defmethod process-output-translations ((x null) &key inherit collect)
3784  (declare (ignorable x))
3785  (inherit-output-translations inherit :collect collect))
3786(defmethod process-output-translations ((form cons) &key inherit collect)
3787  (dolist (directive (cdr (validate-output-translations-form form)))
3788    (process-output-translations-directive directive :inherit inherit :collect collect)))
3789
3790(defun* inherit-output-translations (inherit &key collect)
3791  (when inherit
3792    (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
3793
3794(defun* process-output-translations-directive (directive &key inherit collect)
3795  (if (atom directive)
3796      (ecase directive
3797        ((:enable-user-cache)
3798         (process-output-translations-directive '(t :user-cache) :collect collect))
3799        ((:disable-cache)
3800         (process-output-translations-directive '(t t) :collect collect))
3801        ((:inherit-configuration)
3802         (inherit-output-translations inherit :collect collect))
3803        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
3804         nil))
3805      (let ((src (first directive))
3806            (dst (second directive)))
3807        (if (eq src :include)
3808            (when dst
3809              (process-output-translations (pathname dst) :inherit nil :collect collect))
3810            (when src
3811              (let ((trusrc (or (eql src t)
3812                                (let ((loc (resolve-location src :directory t :wilden t)))
3813                                  (if (absolute-pathname-p loc) (truenamize loc) loc)))))
3814                (cond
3815                  ((location-function-p dst)
3816                   (funcall collect
3817                            (list trusrc
3818                                  (if (symbolp (second dst))
3819                                      (fdefinition (second dst))
3820                                      (eval (second dst))))))
3821                  ((eq dst t)
3822                   (funcall collect (list trusrc t)))
3823                  (t
3824                   (let* ((trudst (if dst
3825                                      (resolve-location dst :directory t :wilden t)
3826                                      trusrc))
3827                          (wilddst (merge-pathnames* *wild-file* trudst)))
3828                     (funcall collect (list wilddst t))
3829                     (funcall collect (list trusrc trudst)))))))))))
3830
3831(defun* compute-output-translations (&optional parameter)
3832  "read the configuration, return it"
3833  (remove-duplicates
3834   (while-collecting (c)
3835     (inherit-output-translations
3836      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
3837   :test 'equal :from-end t))
3838
3839(defvar *output-translations-parameter* nil)
3840
3841(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
3842  "read the configuration, initialize the internal configuration variable,
3843return the configuration"
3844  (setf *output-translations-parameter* parameter
3845        (output-translations) (compute-output-translations parameter)))
3846
3847(defun* disable-output-translations ()
3848  "Initialize output translations in a way that maps every file to itself,
3849effectively disabling the output translation facility."
3850  (initialize-output-translations
3851   '(:output-translations :disable-cache :ignore-inherited-configuration)))
3852
3853;; checks an initial variable to see whether the state is initialized
3854;; or cleared. In the former case, return current configuration; in
3855;; the latter, initialize.  ASDF will call this function at the start
3856;; of (asdf:find-system).
3857(defun* ensure-output-translations ()
3858  (if (output-translations-initialized-p)
3859      (output-translations)
3860      (initialize-output-translations)))
3861
3862(defun* translate-pathname* (path absolute-source destination &optional root source)
3863  (declare (ignore source))
3864  (cond
3865    ((functionp destination)
3866     (funcall destination path absolute-source))
3867    ((eq destination t)
3868     path)
3869    ((not (pathnamep destination))
3870     (error "Invalid destination"))
3871    ((not (absolute-pathname-p destination))
3872     (translate-pathname path absolute-source (merge-pathnames* destination root)))
3873    (root
3874     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3875    (t
3876     (translate-pathname path absolute-source destination))))
3877
3878(defun* apply-output-translations (path)
3879  #+cormanlisp (truenamize path) #-cormanlisp
3880  (etypecase path
3881    (logical-pathname
3882     path)
3883    ((or pathname string)
3884     (ensure-output-translations)
3885     (loop :with p = (truenamize path)
3886       :for (source destination) :in (car *output-translations*)
3887       :for root = (when (or (eq source t)
3888                             (and (pathnamep source)
3889                                  (not (absolute-pathname-p source))))
3890                     (pathname-root p))
3891       :for absolute-source = (cond
3892                                ((eq source t) (wilden root))
3893                                (root (merge-pathnames* source root))
3894                                (t source))
3895       :when (or (eq source t) (pathname-match-p p absolute-source))
3896       :return (translate-pathname* p absolute-source destination root source)
3897       :finally (return p)))))
3898
3899(defmethod output-files :around (operation component)
3900  "Translate output files, unless asked not to"
3901  operation component ;; hush genera, not convinced by declare ignorable(!)
3902  (values
3903   (multiple-value-bind (files fixedp) (call-next-method)
3904     (if fixedp
3905         files
3906         (mapcar #'apply-output-translations files)))
3907   t))
3908
3909(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3910  (if (absolute-pathname-p output-file)
3911      ;; what cfp should be doing, w/ mp* instead of mp
3912      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
3913             (defaults (make-pathname
3914                        :type type :defaults (merge-pathnames* input-file))))
3915        (merge-pathnames* output-file defaults))
3916      (apply-output-translations
3917       (apply 'compile-file-pathname input-file
3918              (if output-file keys (remove-keyword :output-file keys))))))
3919
3920(defun* tmpize-pathname (x)
3921  (make-pathname
3922   :name (strcat "ASDF-TMP-" (pathname-name x))
3923   :defaults x))
3924
3925(defun* delete-file-if-exists (x)
3926  (when (and x (probe-file* x))
3927    (delete-file x)))
3928
3929(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
3930  (let* ((keywords (remove-keyword :compile-check keys))
3931         (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
3932         (tmp-file (tmpize-pathname output-file))
3933         (status :error))
3934    (multiple-value-bind (output-truename warnings-p failure-p)
3935        (apply 'compile-file input-file :output-file tmp-file keywords)
3936      (cond
3937        (failure-p
3938         (setf status *compile-file-failure-behaviour*))
3939        (warnings-p
3940         (setf status *compile-file-warnings-behaviour*))
3941        (t
3942         (setf status :success)))
3943      (cond
3944        ((and (ecase status
3945                ((:success :warn :ignore) t)
3946                ((:error nil)))
3947              (or (not compile-check)
3948                  (apply compile-check input-file :output-file tmp-file keywords)))
3949         (delete-file-if-exists output-file)
3950         (when output-truename
3951           (rename-file output-truename output-file)
3952           (setf output-truename output-file)))
3953        (t ;; error or failed check
3954         (delete-file-if-exists output-truename)
3955         (setf output-truename nil failure-p t)))
3956      (values output-truename warnings-p failure-p))))
3957
3958#+abcl
3959(defun* translate-jar-pathname (source wildcard)
3960  (declare (ignore wildcard))
3961  (let* ((p (pathname (first (pathname-device source))))
3962         (root (format nil "/___jar___file___root___/~@[~A/~]"
3963                       (and (find :windows *features*)
3964                            (pathname-device p)))))
3965    (apply-output-translations
3966     (merge-pathnames*
3967      (relativize-pathname-directory source)
3968      (merge-pathnames*
3969       (relativize-pathname-directory (ensure-directory-pathname p))
3970       root)))))
3971
3972;;;; -----------------------------------------------------------------
3973;;;; Compatibility mode for ASDF-Binary-Locations
3974
3975(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
3976  (declare (ignorable operation-class system args))
3977  (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
3978    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
3979ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
3980which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
3981and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
3982In case you insist on preserving your previous A-B-L configuration, but
3983do not know how to achieve the same effect with A-O-T, you may use function
3984ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
3985call that function where you would otherwise have loaded and configured A-B-L.")))
3986
3987(defun* enable-asdf-binary-locations-compatibility
3988    (&key
3989     (centralize-lisp-binaries nil)
3990     (default-toplevel-directory
3991         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
3992     (include-per-user-information nil)
3993     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
3994     (source-to-target-mappings nil))
3995  #+(or clisp ecl mkcl)
3996  (when (null map-all-source-files)
3997    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
3998  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3999         (mapped-files (if map-all-source-files *wild-file*
4000                           (make-pathname :type fasl-type :defaults *wild-file*)))
4001         (destination-directory
4002          (if centralize-lisp-binaries
4003              `(,default-toplevel-directory
4004                ,@(when include-per-user-information
4005                        (cdr (pathname-directory (user-homedir))))
4006                :implementation ,*wild-inferiors*)
4007              `(:root ,*wild-inferiors* :implementation))))
4008    (initialize-output-translations
4009     `(:output-translations
4010       ,@source-to-target-mappings
4011       ((:root ,*wild-inferiors* ,mapped-files)
4012        (,@destination-directory ,mapped-files))
4013       (t t)
4014       :ignore-inherited-configuration))))
4015
4016;;;; -----------------------------------------------------------------
4017;;;; Source Registry Configuration, by Francois-Rene Rideau
4018;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
4019
4020;; Using ack 1.2 exclusions
4021(defvar *default-source-registry-exclusions*
4022  '(".bzr" ".cdv"
4023    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
4024    ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
4025    "_sgbak" "autom4te.cache" "cover_db" "_build"
4026    "debian")) ;; debian often builds stuff under the debian directory... BAD.
4027
4028(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
4029
4030(defvar *source-registry* nil
4031  "Either NIL (for uninitialized), or an equal hash-table, mapping
4032system names to pathnames of .asd files")
4033
4034(defun* source-registry-initialized-p ()
4035  (typep *source-registry* 'hash-table))
4036
4037(defun* clear-source-registry ()
4038  "Undoes any initialization of the source registry.
4039You might want to call that before you dump an image that would be resumed
4040with a different configuration, so the configuration would be re-read then."
4041  (setf *source-registry* nil)
4042  (values))
4043
4044(defparameter *wild-asd*
4045  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
4046
4047(defun* filter-logical-directory-results (directory entries merger)
4048  (if (typep directory 'logical-pathname)
4049      ;; Try hard to not resolve logical-pathname into physical pathnames;
4050      ;; otherwise logical-pathname users/lovers will be disappointed.
4051      ;; If directory* could use some implementation-dependent magic,
4052      ;; we will have logical pathnames already; otherwise,
4053      ;; we only keep pathnames for which specifying the name and
4054      ;; translating the LPN commute.
4055      (loop :for f :in entries
4056        :for p = (or (and (typep f 'logical-pathname) f)
4057                     (let* ((u (ignore-errors (funcall merger f))))
4058                       ;; The first u avoids a cumbersome (truename u) error.
4059                       ;; At this point f should already be a truename,
4060                       ;; but isn't quite in CLISP, for doesn't have :version :newest
4061                       (and u (equal (ignore-errors (truename u)) (truename f)) u)))
4062        :when p :collect p)
4063      entries))
4064
4065(defun* directory-files (directory &optional (pattern *wild-file*))
4066  (let ((dir (pathname directory)))
4067    (when (typep dir 'logical-pathname)
4068      ;; Because of the filtering we do below,
4069      ;; logical pathnames have restrictions on wild patterns.
4070      ;; Not that the results are very portable when you use these patterns on physical pathnames.
4071      (when (wild-pathname-p dir)
4072        (error "Invalid wild pattern in logical directory ~S" directory))
4073      (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
4074        (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
4075      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
4076    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
4077      (filter-logical-directory-results
4078       directory entries
4079       #'(lambda (f)
4080           (make-pathname :defaults dir
4081                          :name (make-pathname-component-logical (pathname-name f))
4082                          :type (make-pathname-component-logical (pathname-type f))
4083                          :version (make-pathname-component-logical (pathname-version f))))))))
4084
4085(defun* directory-asd-files (directory)
4086  (directory-files directory *wild-asd*))
4087
4088(defun* subdirectories (directory)
4089  (let* ((directory (ensure-directory-pathname directory))
4090         #-(or abcl cormanlisp genera xcl)
4091         (wild (merge-pathnames*
4092                #-(or abcl allegro cmu lispworks sbcl scl xcl)
4093                *wild-directory*
4094                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
4095                directory))
4096         (dirs
4097          #-(or abcl cormanlisp genera xcl)
4098          (ignore-errors
4099            (directory* wild . #.(or #+clozure '(:directories t :files nil)
4100                                     #+mcl '(:directories t))))
4101          #+(or abcl xcl) (system:list-directory directory)
4102          #+cormanlisp (cl::directory-subdirs directory)
4103          #+genera (fs:directory-list directory))
4104         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
4105         (dirs (loop :for x :in dirs
4106                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
4107                          #+allegro (excl:probe-directory x)
4108                          #+(or cmu sbcl scl) (directory-pathname-p x)
4109                          #+genera (getf (cdr x) :directory)
4110                          #+lispworks (lw:file-directory-p x)
4111                 :when d :collect #+(or abcl allegro xcl) d
4112                                  #+genera (ensure-directory-pathname (first x))
4113                                  #+(or cmu lispworks sbcl scl) x)))
4114    (filter-logical-directory-results
4115     directory dirs
4116     (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
4117                       '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
4118       #'(lambda (d)
4119           (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
4120             (and (consp dir) (consp (cdr dir))
4121                  (make-pathname
4122                   :defaults directory :name nil :type nil :version nil
4123                   :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
4124
4125(defun* collect-asds-in-directory (directory collect)
4126  (map () collect (directory-asd-files directory)))
4127
4128(defun* collect-sub*directories (directory collectp recursep collector)
4129  (when (funcall collectp directory)
4130    (funcall collector directory))
4131  (dolist (subdir (subdirectories directory))
4132    (when (funcall recursep subdir)
4133      (collect-sub*directories subdir collectp recursep collector))))
4134
4135(defun* collect-sub*directories-asd-files
4136    (directory &key
4137     (exclude *default-source-registry-exclusions*)
4138     collect)
4139  (collect-sub*directories
4140   directory
4141   (constantly t)
4142   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
4143   #'(lambda (dir) (collect-asds-in-directory dir collect))))
4144
4145(defun* validate-source-registry-directive (directive)
4146  (or (member directive '(:default-registry))
4147      (and (consp directive)
4148           (let ((rest (rest directive)))
4149             (case (first directive)
4150               ((:include :directory :tree)
4151                (and (length=n-p rest 1)
4152                     (location-designator-p (first rest))))
4153               ((:exclude :also-exclude)
4154                (every #'stringp rest))
4155               ((:default-registry)
4156                (null rest)))))))
4157
4158(defun* validate-source-registry-form (form &key location)
4159  (validate-configuration-form
4160   form :source-registry 'validate-source-registry-directive
4161   :location location :invalid-form-reporter 'invalid-source-registry))
4162
4163(defun* validate-source-registry-file (file)
4164  (validate-configuration-file
4165   file 'validate-source-registry-form :description "a source registry"))
4166
4167(defun* validate-source-registry-directory (directory)
4168  (validate-configuration-directory
4169   directory :source-registry 'validate-source-registry-directive
4170   :invalid-form-reporter 'invalid-source-registry))
4171
4172(defun* parse-source-registry-string (string &key location)
4173  (cond
4174    ((or (null string) (equal string ""))
4175     '(:source-registry :inherit-configuration))
4176    ((not (stringp string))
4177     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
4178    ((find (char string 0) "\"(")
4179     (validate-source-registry-form (read-from-string string) :location location))
4180    (t
4181     (loop
4182      :with inherit = nil
4183      :with directives = ()
4184      :with start = 0
4185      :with end = (length string)
4186      :with separator = (inter-directory-separator)
4187      :for pos = (position separator string :start start) :do
4188      (let ((s (subseq string start (or pos end))))
4189        (flet ((check (dir)
4190                 (unless (absolute-pathname-p dir)
4191                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
4192                 dir))
4193          (cond
4194            ((equal "" s) ; empty element: inherit
4195             (when inherit
4196               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
4197                      string))
4198             (setf inherit t)
4199             (push ':inherit-configuration directives))
4200            ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
4201             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
4202            (t
4203             (push `(:directory ,(check s)) directives))))
4204        (cond
4205          (pos
4206           (setf start (1+ pos)))
4207          (t
4208           (unless inherit
4209             (push '(:ignore-inherited-configuration) directives))
4210           (return `(:source-registry ,@(nreverse directives))))))))))
4211
4212(defun* register-asd-directory (directory &key recurse exclude collect)
4213  (if (not recurse)
4214      (collect-asds-in-directory directory collect)
4215      (collect-sub*directories-asd-files
4216       directory :exclude exclude :collect collect)))
4217
4218(defparameter *default-source-registries*
4219  '(environment-source-registry
4220    user-source-registry
4221    user-source-registry-directory
4222    system-source-registry
4223    system-source-registry-directory
4224    default-source-registry))
4225
4226(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
4227(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
4228
4229(defun* wrapping-source-registry ()
4230  `(:source-registry
4231    #+ecl (:tree ,(translate-logical-pathname "SYS:"))
4232    #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
4233    #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
4234    :inherit-configuration
4235    #+cmu (:tree #p"modules:")
4236    #+scl (:tree #p"file://modules/")))
4237(defun* default-source-registry ()
4238  `(:source-registry
4239    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
4240    (:directory ,(default-directory))
4241    ,@(loop :for dir :in
4242        `(,@(when (os-unix-p)
4243              `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
4244                     (subpathname (user-homedir) ".local/share/"))
4245                ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
4246                      '("/usr/local/share" "/usr/share"))))
4247          ,@(when (os-windows-p)
4248              (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
4249        :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
4250        :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
4251    :inherit-configuration))
4252(defun* user-source-registry (&key (direction :input))
4253  (in-user-configuration-directory *source-registry-file* :direction direction))
4254(defun* system-source-registry (&key (direction :input))
4255  (in-system-configuration-directory *source-registry-file* :direction direction))
4256(defun* user-source-registry-directory (&key (direction :input))
4257  (in-user-configuration-directory *source-registry-directory* :direction direction))
4258(defun* system-source-registry-directory (&key (direction :input))
4259  (in-system-configuration-directory *source-registry-directory* :direction direction))
4260(defun* environment-source-registry ()
4261  (getenv "CL_SOURCE_REGISTRY"))
4262
4263(defgeneric* process-source-registry (spec &key inherit register))
4264(declaim (ftype (function (t &key (:register (or symbol function))) t)
4265                inherit-source-registry))
4266(declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
4267                process-source-registry-directive))
4268
4269(defmethod process-source-registry ((x symbol) &key inherit register)
4270  (process-source-registry (funcall x) :inherit inherit :register register))
4271(defmethod process-source-registry ((pathname pathname) &key inherit register)
4272  (cond
4273    ((directory-pathname-p pathname)
4274     (let ((*here-directory* (truenamize pathname)))
4275       (process-source-registry (validate-source-registry-directory pathname)
4276                                :inherit inherit :register register)))
4277    ((probe-file* pathname)
4278     (let ((*here-directory* (pathname-directory-pathname pathname)))
4279       (process-source-registry (validate-source-registry-file pathname)
4280                                :inherit inherit :register register)))
4281    (t
4282     (inherit-source-registry inherit :register register))))
4283(defmethod process-source-registry ((string string) &key inherit register)
4284  (process-source-registry (parse-source-registry-string string)
4285                           :inherit inherit :register register))
4286(defmethod process-source-registry ((x null) &key inherit register)
4287  (declare (ignorable x))
4288  (inherit-source-registry inherit :register register))
4289(defmethod process-source-registry ((form cons) &key inherit register)
4290  (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
4291    (dolist (directive (cdr (validate-source-registry-form form)))
4292      (process-source-registry-directive directive :inherit inherit :register register))))
4293
4294(defun* inherit-source-registry (inherit &key register)
4295  (when inherit
4296    (process-source-registry (first inherit) :register register :inherit (rest inherit))))
4297
4298(defun* process-source-registry-directive (directive &key inherit register)
4299  (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
4300    (ecase kw
4301      ((:include)
4302       (destructuring-bind (pathname) rest
4303         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
4304      ((:directory)
4305       (destructuring-bind (pathname) rest
4306         (when pathname
4307           (funcall register (resolve-location pathname :directory t)))))
4308      ((:tree)
4309       (destructuring-bind (pathname) rest
4310         (when pathname
4311           (funcall register (resolve-location pathname :directory t)
4312                    :recurse t :exclude *source-registry-exclusions*))))
4313      ((:exclude)
4314       (setf *source-registry-exclusions* rest))
4315      ((:also-exclude)
4316       (appendf *source-registry-exclusions* rest))
4317      ((:default-registry)
4318       (inherit-source-registry '(default-source-registry) :register register))
4319      ((:inherit-configuration)
4320       (inherit-source-registry inherit :register register))
4321      ((:ignore-inherited-configuration)
4322       nil)))
4323  nil)
4324
4325(defun* flatten-source-registry (&optional parameter)
4326  (remove-duplicates
4327   (while-collecting (collect)
4328     (let ((*default-pathname-defaults* (default-directory)))
4329       (inherit-source-registry
4330        `(wrapping-source-registry
4331          ,parameter
4332          ,@*default-source-registries*)
4333        :register #'(lambda (directory &key recurse exclude)
4334                      (collect (list directory :recurse recurse :exclude exclude))))))
4335   :test 'equal :from-end t))
4336
4337;; Will read the configuration and initialize all internal variables.
4338(defun* compute-source-registry (&optional parameter (registry *source-registry*))
4339  (dolist (entry (flatten-source-registry parameter))
4340    (destructuring-bind (directory &key recurse exclude) entry
4341      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
4342        (register-asd-directory
4343         directory :recurse recurse :exclude exclude :collect
4344         #'(lambda (asd)
4345             (let* ((name (pathname-name asd))
4346                    (name (if (typep asd 'logical-pathname)
4347                              ;; logical pathnames are upper-case,
4348                              ;; at least in the CLHS and on SBCL,
4349                              ;; yet (coerce-name :foo) is lower-case.
4350                              ;; won't work well with (load-system "Foo")
4351                              ;; instead of (load-system 'foo)
4352                              (string-downcase name)
4353                              name)))
4354               (cond
4355                 ((gethash name registry) ; already shadowed by something else
4356                  nil)
4357                 ((gethash name h) ; conflict at current level
4358                  (when *asdf-verbose*
4359                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
4360                                found several entries for ~A - picking ~S over ~S~:>")
4361                          directory recurse name (gethash name h) asd)))
4362                 (t
4363                  (setf (gethash name registry) asd)
4364                  (setf (gethash name h) asd))))))
4365        h)))
4366  (values))
4367
4368(defvar *source-registry-parameter* nil)
4369
4370(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
4371  (setf *source-registry-parameter* parameter)
4372  (setf *source-registry* (make-hash-table :test 'equal))
4373  (compute-source-registry parameter))
4374
4375;; Checks an initial variable to see whether the state is initialized
4376;; or cleared. In the former case, return current configuration; in
4377;; the latter, initialize.  ASDF will call this function at the start
4378;; of (asdf:find-system) to make sure the source registry is initialized.
4379;; However, it will do so *without* a parameter, at which point it
4380;; will be too late to provide a parameter to this function, though
4381;; you may override the configuration explicitly by calling
4382;; initialize-source-registry directly with your parameter.
4383(defun* ensure-source-registry (&optional parameter)
4384  (unless (source-registry-initialized-p)
4385    (initialize-source-registry parameter))
4386  (values))
4387
4388(defun* sysdef-source-registry-search (system)
4389  (ensure-source-registry)
4390  (values (gethash (coerce-name system) *source-registry*)))
4391
4392(defun* clear-configuration ()
4393  (clear-source-registry)
4394  (clear-output-translations))
4395
4396
4397;;; ECL and MKCL support for COMPILE-OP / LOAD-OP
4398;;;
4399;;; In ECL and MKCL, these operations produce both
4400;;; FASL files and the object files that they are built from.
4401;;; Having both of them allows us to later on reuse the object files
4402;;; for bundles, libraries, standalone executables, etc.
4403;;;
4404;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
4405;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
4406;;;
4407;;; Also, register-pre-built-system.
4408
4409#+(or ecl mkcl)
4410(progn
4411  (defun register-pre-built-system (name)
4412    (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))
4413
4414  #+(or (and ecl win32) (and mkcl windows))
4415  (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
4416    (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
4417
4418  (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
4419        (loop :for f :in #+ecl ext:*module-provider-functions*
4420          #+mkcl mk-ext::*module-provider-functions*
4421          :unless (eq f 'module-provide-asdf)
4422          :collect #'(lambda (name)
4423                       (let ((l (multiple-value-list (funcall f name))))
4424                         (and (first l) (register-pre-built-system (coerce-name name)))
4425                         (values-list l)))))
4426
4427  (setf *compile-op-compile-file-function* 'compile-file-keeping-object)
4428
4429  (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys)
4430    (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys)
4431     #+mkcl progn
4432     (multiple-value-bind (object-file flags1 flags2)
4433         (apply 'compile-file* input-file
4434                #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys)
4435       (values (and object-file
4436                    (compiler::build-fasl
4437                     (compile-file-pathname object-file
4438                                            #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t)
4439                     #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file))
4440                    object-file)
4441               flags1
4442               flags2)))))
4443
4444;;;; -----------------------------------------------------------------------
4445;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
4446;;;;
4447(defun* module-provide-asdf (name)
4448  (handler-bind
4449      ((style-warning #'muffle-warning)
4450       #-genera
4451       (missing-component (constantly nil))
4452       (error #'(lambda (e)
4453                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
4454                          name e))))
4455    (let ((*verbose-out* (make-broadcast-stream))
4456          (system (find-system (string-downcase name) nil)))
4457      (when system
4458        (require-system system :verbose nil)
4459        t))))
4460
4461#+(or abcl clisp clozure cmu ecl mkcl sbcl)
4462(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
4463  (when x
4464    (eval `(pushnew 'module-provide-asdf
4465            #+abcl sys::*module-provider-functions*
4466            #+clisp ,x
4467            #+clozure ccl:*module-provider-functions*
4468            #+(or cmu ecl) ext:*module-provider-functions*
4469            #+mkcl mk-ext:*module-provider-functions*
4470            #+sbcl sb-ext:*module-provider-functions*))))
4471
4472
4473;;;; -------------------------------------------------------------------------
4474;;;; Cleanups after hot-upgrade.
4475;;;; Things to do in case we're upgrading from a previous version of ASDF.
4476;;;; See https://bugs.launchpad.net/asdf/+bug/485687
4477;;;;
4478
4479;;; If a previous version of ASDF failed to read some configuration, try again.
4480(when *ignored-configuration-form*
4481  (clear-configuration)
4482  (setf *ignored-configuration-form* nil))
4483
4484;;;; -----------------------------------------------------------------
4485;;;; Done!
4486(when *load-verbose*
4487  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
4488
4489#+mkcl
4490(progn
4491  (defvar *loading-asdf-bundle* nil)
4492  (unless *loading-asdf-bundle*
4493    (let ((*central-registry*
4494           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*))
4495          (*loading-asdf-bundle* t))
4496      (clear-system :asdf-bundle) ;; we hope to force a reload.
4497      (multiple-value-bind (result bundling-error)
4498          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
4499        (unless result
4500          (format *error-output*
4501                  "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%"
4502                  bundling-error))))))
4503
4504#+allegro
4505(eval-when (:compile-toplevel :execute)
4506  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
4507    (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
4508
4509(pushnew :asdf *features*)
4510(pushnew :asdf2 *features*)
4511
4512(provide :asdf)
4513
4514;;; Local Variables:
4515;;; mode: lisp
4516;;; End:
Note: See TracBrowser for help on using the repository browser.