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

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

Update to asdf-2.016.

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