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

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

Upgradte to asdf-2.20.

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