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

Last change on this file since 14166 was 14166, checked in by Mark Evenson, 8 years ago

Update to asdf-2.25.

Note that ASDF no longer exports symbols that are now exported by
ASDF-UTILS, which is available via Quicklisp. ASDF-ABCL has been
adjusted for this, but there may be other problems lurking.

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