Context Navigation

asdf.lisp @ 13692

Visit:

Last change on this file since 13692 was 13692, checked in by Mark Evenson, 12 years ago

Enable ASDF to load from jar files again for #181.

Unsure if we need to somehow change the semantics of how
MERGE-PATHNAMES works in the presence of JAR-PATHNAMES. Currently, we
have the following behavior:

CL-USER> (merge-pathnames "/home/evenson/work/abcl/dist/abcl-contrib.jar" #p"jar:file:/foo/bar.jar!/fee/")
#P"jar:file:/foo/bar.jar!/home/evenson/work/abcl/dist/abcl-contrib.jar"

Should we "break" ANSI here, so that if we have a defaulted DEVICE, we
also keep the defaulted DIRECTORY? Unfortunately, I think this will
break some common cases of dealing with relative directories inside a
JAR-PATHNAME. Need to consider this with email to both
@armedbear-develop and @asdf-develop.

Property svn:eol-style set to native
Property svn:keywords set to Id

File size: 182.2 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: