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

Last change on this file since 15414 was 15414, checked in by rme, 8 years ago

Update to ASDF 2.22.

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