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

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

ASDF 2.23 from upstream.

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