source: branches/1.0.x/abcl/src/org/armedbear/lisp/asdf.lisp @ 13717

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

Backport r13702: update to asdf-2.019 with ABCL patch.

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