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

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

Upgrade to asdf-2.017.

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