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

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

Fix ASDF working with jar archives.

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