source: trunk/abcl/src/org/armedbear/lisp/asdf.lisp @ 13319

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

Actual commit of asdf-2.016.1.

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