source: trunk/source/tools/asdf.lisp @ 14688

Last change on this file since 14688 was 14688, checked in by rme, 9 years ago

Revert r14687. The ASDF dust seems not to have settled yet.

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