Context Navigation

asdf.lisp @ 15753

Visit:

Last change on this file since 15753 was 15753, checked in by rme, 8 years ago
ASDF 2.32.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 433.8 KB

Line
1	;;; -- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp --
2	;;; This is ASDF 2.32: Another System Definition Facility.
3	;;;
4	;;; Feedback, bug reports, and patches are all welcome:
5	;;; please mail to <asdf-devel@common-lisp.net>.
6	;;; Note first that the canonical source for ASDF is presently
7	;;; <URL:http://common-lisp.net/project/asdf/>.
8	;;;
9	;;; If you obtained this copy from anywhere else, and you experience
10	;;; trouble using it, or find bugs, you may want to check at the
11	;;; location above for a more recent version (and for documentation
12	;;; and test files, if your copy came without them) before reporting
13	;;; bugs. There are usually two "supported" revisions - the git master
14	;;; branch is the latest development version, whereas the git release
15	;;; branch may be slightly older but is considered `stable'
16
17	;;; -- LICENSE START
18	;;; (This is the MIT / X Consortium license as taken from
19	;;; http://www.opensource.org/licenses/mit-license.html on or about
20	;;; Monday; July 13, 2009)
21	;;;
22	;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
23	;;;
24	;;; Permission is hereby granted, free of charge, to any person obtaining
25	;;; a copy of this software and associated documentation files (the
26	;;; "Software"), to deal in the Software without restriction, including
27	;;; without limitation the rights to use, copy, modify, merge, publish,
28	;;; distribute, sublicense, and/or sell copies of the Software, and to
29	;;; permit persons to whom the Software is furnished to do so, subject to
30	;;; the following conditions:
31	;;;
32	;;; The above copyright notice and this permission notice shall be
33	;;; included in all copies or substantial portions of the Software.
34	;;;
35	;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
36	;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
37	;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
38	;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
39	;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
40	;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
41	;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
42	;;;
43	;;; -- LICENSE END
44
45	;;; The problem with writing a defsystem replacement is bootstrapping:
46	;;; we can't use defsystem to compile it. Hence, all in one file.
47
48	#+xcvb (module ())
49
50	(in-package :cl-user)
51
52	#+cmu
53	(eval-when (:load-toplevel :compile-toplevel :execute)
54	(declaim (optimize (speed 1) (safety 3) (debug 3)))
55	(setf ext:gc-verbose nil))
56
57	#+(or abcl clisp clozure cmu ecl xcl)
58	(eval-when (:load-toplevel :compile-toplevel :execute)
59	(unless (member :asdf3 features)
60	(let* ((existing-version
61	(when (find-package :asdf)
62	(or (symbol-value (find-symbol (string :asdf-version) :asdf))
63	(let ((ver (symbol-value (find-symbol (string :asdf-revision) :asdf))))
64	(etypecase ver
65	(string ver)
66	(cons (format nil "~{~D~^.~}" ver))
67	(null "1.0"))))))
68	(first-dot (when existing-version (position #\. existing-version)))
69	(second-dot (when first-dot (position #\. existing-version :start (1+ first-dot))))
70	(existing-major-minor (subseq existing-version 0 second-dot))
71	(existing-version-number (and existing-version (read-from-string existing-major-minor)))
72	(away (format nil "~A-~A" :asdf existing-version)))
73	(when (and existing-version (< existing-version-number
74	(or #+abcl 2.25 #+cmu 2.018 2.27)))
75	(rename-package :asdf away)
76	(when load-verbose
77	(format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
78
79	;;;; ---------------------------------------------------------------------------
80	;;;; Handle ASDF package upgrade, including implementation-dependent magic.
81	;;
82	;; See https://bugs.launchpad.net/asdf/+bug/485687
83	;;
84
85	(defpackage :uiop/package
86	;; CAUTION: we must handle the first few packages specially for hot-upgrade.
87	;; This package definition MUST NOT change unless its name too changes;
88	;; if/when it changes, don't forget to add new functions missing from below.
89	;; Until then, asdf/package is frozen to forever
90	;; import and export the same exact symbols as for ASDF 2.27.
91	;; Any other symbol must be import-from'ed and re-export'ed in a different package.
92	(:use :common-lisp)
93	(:export
94	#:find-package* #:find-symbol* #:symbol-call
95	#:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
96	#:symbol-shadowing-p #:home-package-p
97	#:symbol-package-name #:standard-common-lisp-symbol-p
98	#:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
99	#:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
100	#:ensure-package-unused #:delete-package*
101	#:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
102	#:package-definition-form #:parse-define-package-form
103	#:ensure-package #:define-package))
104
105	(in-package :uiop/package)
106
107	;;;; General purpose package utilities
108
109	(eval-when (:load-toplevel :compile-toplevel :execute)
110	(defun find-package* (package-designator &optional (error t))
111	(let ((package (find-package package-designator)))
112	(cond
113	(package package)
114	(error (error "No package named ~S" (string package-designator)))
115	(t nil))))
116	(defun find-symbol* (name package-designator &optional (error t))
117	"Find a symbol in a package of given string'ified NAME;
118	unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
119	by letting you supply a symbol or keyword for the name;
120	also works well when the package is not present.
121	If optional ERROR argument is NIL, return NIL instead of an error
122	when the symbol is not found."
123	(block nil
124	(let ((package (find-package* package-designator error)))
125	(when package ;; package error handled by find-package* already
126	(multiple-value-bind (symbol status) (find-symbol (string name) package)
127	(cond
128	(status (return (values symbol status)))
129	(error (error "There is no symbol ~S in package ~S" name (package-name package))))))
130	(values nil nil))))
131	(defun symbol-call (package name &rest args)
132	"Call a function associated with symbol of given name in given package,
133	with given ARGS. Useful when the call is read before the package is loaded,
134	or when loading the package is optional."
135	(apply (find-symbol* name package) args))
136	(defun intern* (name package-designator &optional (error t))
137	(intern (string name) (find-package* package-designator error)))
138	(defun export* (name package-designator)
139	(let* ((package (find-package* package-designator))
140	(symbol (intern* name package)))
141	(export (or symbol (list symbol)) package)))
142	(defun import* (symbol package-designator)
143	(import (or symbol (list symbol)) (find-package* package-designator)))
144	(defun shadowing-import* (symbol package-designator)
145	(shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
146	(defun shadow* (name package-designator)
147	(shadow (string name) (find-package* package-designator)))
148	(defun make-symbol* (name)
149	(etypecase name
150	(string (make-symbol name))
151	(symbol (copy-symbol name))))
152	(defun unintern* (name package-designator &optional (error t))
153	(block nil
154	(let ((package (find-package* package-designator error)))
155	(when package
156	(multiple-value-bind (symbol status) (find-symbol* name package error)
157	(cond
158	(status (unintern symbol package)
159	(return (values symbol status)))
160	(error (error "symbol ~A not present in package ~A"
161	(string symbol) (package-name package))))))
162	(values nil nil))))
163	(defun symbol-shadowing-p (symbol package)
164	(and (member symbol (package-shadowing-symbols package)) t))
165	(defun home-package-p (symbol package)
166	(and package (let ((sp (symbol-package symbol)))
167	(and sp (let ((pp (find-package* package)))
168	(and pp (eq sp pp))))))))
169
170
171	(eval-when (:load-toplevel :compile-toplevel :execute)
172	(defun symbol-package-name (symbol)
173	(let ((package (symbol-package symbol)))
174	(and package (package-name package))))
175	(defun standard-common-lisp-symbol-p (symbol)
176	(multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
177	(and (eq sym symbol) (eq status :external))))
178	(defun reify-package (package &optional package-context)
179	(if (eq package package-context) t
180	(etypecase package
181	(null nil)
182	((eql (find-package :cl)) :cl)
183	(package (package-name package)))))
184	(defun unreify-package (package &optional package-context)
185	(etypecase package
186	(null nil)
187	((eql t) package-context)
188	((or symbol string) (find-package package))))
189	(defun reify-symbol (symbol &optional package-context)
190	(etypecase symbol
191	((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
192	(symbol (vector (symbol-name symbol)
193	(reify-package (symbol-package symbol) package-context)))))
194	(defun unreify-symbol (symbol &optional package-context)
195	(etypecase symbol
196	(symbol symbol)
197	((simple-vector 2)
198	(let* ((symbol-name (svref symbol 0))
199	(package-foo (svref symbol 1))
200	(package (unreify-package package-foo package-context)))
201	(if package (intern* symbol-name package)
202	(make-symbol* symbol-name)))))))
203
204	(eval-when (:load-toplevel :compile-toplevel :execute)
205	(defvar all-package-happiness '())
206	(defvar all-package-fishiness (list t))
207	(defun record-fishy (info)
208	;;(format t "~&FISHY: ~S~%" info)
209	(push info all-package-fishiness))
210	(defmacro when-package-fishiness (&body body)
211	`(when all-package-fishiness ,@body))
212	(defmacro note-package-fishiness (&rest info)
213	`(when-package-fishiness (record-fishy (list ,@info)))))
214
215	(eval-when (:load-toplevel :compile-toplevel :execute)
216	#+(or clisp clozure)
217	(defun get-setf-function-symbol (symbol)
218	#+clisp (let ((sym (get symbol 'system::setf-function)))
219	(if sym (values sym :setf-function)
220	(let ((sym (get symbol 'system::setf-expander)))
221	(if sym (values sym :setf-expander)
222	(values nil nil)))))
223	#+clozure (gethash symbol ccl::%setf-function-names%))
224	#+(or clisp clozure)
225	(defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
226	#+clisp (assert (member kind '(:setf-function :setf-expander)))
227	#+clozure (assert (eq kind t))
228	#+clisp
229	(cond
230	((null new-setf-symbol)
231	(remprop symbol 'system::setf-function)
232	(remprop symbol 'system::setf-expander))
233	((eq kind :setf-function)
234	(setf (get symbol 'system::setf-function) new-setf-symbol))
235	((eq kind :setf-expander)
236	(setf (get symbol 'system::setf-expander) new-setf-symbol))
237	(t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
238	kind symbol new-setf-symbol)))
239	#+clozure
240	(progn
241	(gethash symbol ccl::%setf-function-names%) new-setf-symbol
242	(gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
243	#+(or clisp clozure)
244	(defun create-setf-function-symbol (symbol)
245	#+clisp (system::setf-symbol symbol)
246	#+clozure (ccl::construct-setf-function-name symbol))
247	(defun set-dummy-symbol (symbol reason other-symbol)
248	(setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
249	(defun make-dummy-symbol (symbol)
250	(let ((dummy (copy-symbol symbol)))
251	(set-dummy-symbol dummy 'replacing symbol)
252	(set-dummy-symbol symbol 'replaced-by dummy)
253	dummy))
254	(defun dummy-symbol (symbol)
255	(get symbol 'dummy-symbol))
256	(defun get-dummy-symbol (symbol)
257	(let ((existing (dummy-symbol symbol)))
258	(if existing (values (cdr existing) (car existing))
259	(make-dummy-symbol symbol))))
260	(defun nuke-symbol-in-package (symbol package-designator)
261	(let ((package (find-package* package-designator))
262	(name (symbol-name symbol)))
263	(multiple-value-bind (sym stat) (find-symbol name package)
264	(when (and (member stat '(:internal :external)) (eq symbol sym))
265	(if (symbol-shadowing-p symbol package)
266	(shadowing-import* (get-dummy-symbol symbol) package)
267	(unintern* symbol package))))))
268	(defun nuke-symbol (symbol &optional (packages (list-all-packages)))
269	#+(or clisp clozure)
270	(multiple-value-bind (setf-symbol kind)
271	(get-setf-function-symbol symbol)
272	(when kind (nuke-symbol setf-symbol)))
273	(loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
274	(defun rehome-symbol (symbol package-designator)
275	"Changes the home package of a symbol, also leaving it present in its old home if any"
276	(let* ((name (symbol-name symbol))
277	(package (find-package* package-designator))
278	(old-package (symbol-package symbol))
279	(old-status (and old-package (nth-value 1 (find-symbol name old-package))))
280	(shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
281	(multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
282	(unless (eq package old-package)
283	(let ((overwritten-symbol-shadowing-p
284	(and overwritten-symbol-status
285	(symbol-shadowing-p overwritten-symbol package))))
286	(note-package-fishiness
287	:rehome-symbol name
288	(when old-package (package-name old-package)) old-status (and shadowing t)
289	(package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
290	(when old-package
291	(if shadowing
292	(shadowing-import* shadowing old-package))
293	(unintern* symbol old-package))
294	(cond
295	(overwritten-symbol-shadowing-p
296	(shadowing-import* symbol package))
297	(t
298	(when overwritten-symbol-status
299	(unintern* overwritten-symbol package))
300	(import* symbol package)))
301	(if shadowing
302	(shadowing-import* symbol old-package)
303	(import* symbol old-package))
304	#+(or clisp clozure)
305	(multiple-value-bind (setf-symbol kind)
306	(get-setf-function-symbol symbol)
307	(when kind
308	(let* ((setf-function (fdefinition setf-symbol))
309	(new-setf-symbol (create-setf-function-symbol symbol)))
310	(note-package-fishiness
311	:setf-function
312	name (package-name package)
313	(symbol-name setf-symbol) (symbol-package-name setf-symbol)
314	(symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
315	(when (symbol-package setf-symbol)
316	(unintern* setf-symbol (symbol-package setf-symbol)))
317	(setf (fdefinition new-setf-symbol) setf-function)
318	(set-setf-function-symbol new-setf-symbol symbol kind))))
319	#+(or clisp clozure)
320	(multiple-value-bind (overwritten-setf foundp)
321	(get-setf-function-symbol overwritten-symbol)
322	(when foundp
323	(unintern overwritten-setf)))
324	(when (eq old-status :external)
325	(export* symbol old-package))
326	(when (eq overwritten-symbol-status :external)
327	(export* symbol package))))
328	(values overwritten-symbol overwritten-symbol-status))))
329	(defun ensure-package-unused (package)
330	(loop :for p :in (package-used-by-list package) :do
331	(unuse-package package p)))
332	(defun delete-package* (package &key nuke)
333	(let ((p (find-package package)))
334	(when p
335	(when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
336	(ensure-package-unused p)
337	(delete-package package))))
338	(defun package-names (package)
339	(cons (package-name package) (package-nicknames package)))
340	(defun packages-from-names (names)
341	(remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
342	(defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
343	separator
344	(index (random most-positive-fixnum)))
345	(loop :for i :from index
346	:for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
347	:thereis (and (not (find-package n)) n)))
348	(defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
349	(let ((new-name
350	(apply 'fresh-package-name
351	:prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
352	(record-fishy (list :rename-away (package-names p) new-name))
353	(rename-package p new-name))))
354
355
356	;;; Communicable representation of symbol and package information
357
358	(eval-when (:load-toplevel :compile-toplevel :execute)
359	(defun package-definition-form (package-designator
360	&key (nicknamesp t) (usep t)
361	(shadowp t) (shadowing-import-p t)
362	(exportp t) (importp t) internp (error t))
363	(let* ((package (or (find-package* package-designator error)
364	(return-from package-definition-form nil)))
365	(name (package-name package))
366	(nicknames (package-nicknames package))
367	(use (mapcar #'package-name (package-use-list package)))
368	(shadow ())
369	(shadowing-import (make-hash-table :test 'equal))
370	(import (make-hash-table :test 'equal))
371	(export ())
372	(intern ()))
373	(when package
374	(loop :for sym :being :the :symbols :in package
375	:for status = (nth-value 1 (find-symbol* sym package)) :do
376	(ecase status
377	((nil :inherited))
378	((:internal :external)
379	(let* ((name (symbol-name sym))
380	(external (eq status :external))
381	(home (symbol-package sym))
382	(home-name (package-name home))
383	(imported (not (eq home package)))
384	(shadowing (symbol-shadowing-p sym package)))
385	(cond
386	((and shadowing imported)
387	(push name (gethash home-name shadowing-import)))
388	(shadowing
389	(push name shadow))
390	(imported
391	(push name (gethash home-name import))))
392	(cond
393	(external
394	(push name export))
395	(imported)
396	(t (push name intern)))))))
397	(labels ((sort-names (names)
398	(sort names #'string<))
399	(table-keys (table)
400	(loop :for k :being :the :hash-keys :of table :collect k))
401	(when-relevant (key value)
402	(when value (list (cons key value))))
403	(import-options (key table)
404	(loop :for i :in (sort-names (table-keys table))
405	:collect `(,key ,i ,@(sort-names (gethash i table))))))
406	`(defpackage ,name
407	,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
408	(:use ,@(and usep (sort-names use)))
409	,@(when-relevant :shadow (and shadowp (sort-names shadow)))
410	,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
411	,@(import-options :import-from (and importp import))
412	,@(when-relevant :export (and exportp (sort-names export)))
413	,@(when-relevant :intern (and internp (sort-names intern)))))))))
414
415
416	;;; ensure-package, define-package
417	(eval-when (:load-toplevel :compile-toplevel :execute)
418	(defun ensure-shadowing-import (name to-package from-package shadowed imported)
419	(check-type name string)
420	(check-type to-package package)
421	(check-type from-package package)
422	(check-type shadowed hash-table)
423	(check-type imported hash-table)
424	(let ((import-me (find-symbol* name from-package)))
425	(multiple-value-bind (existing status) (find-symbol name to-package)
426	(cond
427	((gethash name shadowed)
428	(unless (eq import-me existing)
429	(error "Conflicting shadowings for ~A" name)))
430	(t
431	(setf (gethash name shadowed) t)
432	(setf (gethash name imported) t)
433	(unless (or (null status)
434	(and (member status '(:internal :external))
435	(eq existing import-me)
436	(symbol-shadowing-p existing to-package)))
437	(note-package-fishiness
438	:shadowing-import name
439	(package-name from-package)
440	(or (home-package-p import-me from-package) (symbol-package-name import-me))
441	(package-name to-package) status
442	(and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
443	(shadowing-import* import-me to-package))))))
444	(defun ensure-imported (import-me into-package &optional from-package)
445	(check-type import-me symbol)
446	(check-type into-package package)
447	(check-type from-package (or null package))
448	(let ((name (symbol-name import-me)))
449	(multiple-value-bind (existing status) (find-symbol name into-package)
450	(cond
451	((not status)
452	(import* import-me into-package))
453	((eq import-me existing))
454	(t
455	(let ((shadowing-p (symbol-shadowing-p existing into-package)))
456	(note-package-fishiness
457	:ensure-imported name
458	(and from-package (package-name from-package))
459	(or (home-package-p import-me from-package) (symbol-package-name import-me))
460	(package-name into-package)
461	status
462	(and status (or (home-package-p existing into-package) (symbol-package-name existing)))
463	shadowing-p)
464	(cond
465	((or shadowing-p (eq status :inherited))
466	(shadowing-import* import-me into-package))
467	(t
468	(unintern* existing into-package)
469	(import* import-me into-package))))))))
470	(values))
471	(defun ensure-import (name to-package from-package shadowed imported)
472	(check-type name string)
473	(check-type to-package package)
474	(check-type from-package package)
475	(check-type shadowed hash-table)
476	(check-type imported hash-table)
477	(multiple-value-bind (import-me import-status) (find-symbol name from-package)
478	(when (null import-status)
479	(note-package-fishiness
480	:import-uninterned name (package-name from-package) (package-name to-package))
481	(setf import-me (intern* name from-package)))
482	(multiple-value-bind (existing status) (find-symbol name to-package)
483	(cond
484	((and imported (gethash name imported))
485	(unless (and status (eq import-me existing))
486	(error "Can't import ~S from both ~S and ~S"
487	name (package-name (symbol-package existing)) (package-name from-package))))
488	((gethash name shadowed)
489	(error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
490	(t
491	(setf (gethash name imported) t))))
492	(ensure-imported import-me to-package from-package)))
493	(defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
494	(check-type name string)
495	(check-type symbol symbol)
496	(check-type to-package package)
497	(check-type from-package package)
498	(check-type mixp (member nil t)) ; no cl:boolean on Genera
499	(check-type shadowed hash-table)
500	(check-type imported hash-table)
501	(check-type inherited hash-table)
502	(multiple-value-bind (existing status) (find-symbol name to-package)
503	(let* ((sp (symbol-package symbol))
504	(in (gethash name inherited))
505	(xp (and status (symbol-package existing))))
506	(when (null sp)
507	(note-package-fishiness
508	:import-uninterned name
509	(package-name from-package) (package-name to-package) mixp)
510	(import* symbol from-package)
511	(setf sp (package-name from-package)))
512	(cond
513	((gethash name shadowed))
514	(in
515	(unless (equal sp (first in))
516	(if mixp
517	(ensure-shadowing-import name to-package (second in) shadowed imported)
518	(error "Can't inherit ~S from ~S, it is inherited from ~S"
519	name (package-name sp) (package-name (first in))))))
520	((gethash name imported)
521	(unless (eq symbol existing)
522	(error "Can't inherit ~S from ~S, it is imported from ~S"
523	name (package-name sp) (package-name xp))))
524	(t
525	(setf (gethash name inherited) (list sp from-package))
526	(when (and status (not (eq sp xp)))
527	(let ((shadowing (symbol-shadowing-p existing to-package)))
528	(note-package-fishiness
529	:inherited name
530	(package-name from-package)
531	(or (home-package-p symbol from-package) (symbol-package-name symbol))
532	(package-name to-package)
533	(or (home-package-p existing to-package) (symbol-package-name existing)))
534	(if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
535	(unintern* existing to-package)))))))))
536	(defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
537	(check-type name string)
538	(check-type symbol symbol)
539	(check-type to-package package)
540	(check-type from-package package)
541	(check-type shadowed hash-table)
542	(check-type imported hash-table)
543	(check-type inherited hash-table)
544	(unless (gethash name shadowed)
545	(multiple-value-bind (existing status) (find-symbol name to-package)
546	(let* ((sp (symbol-package symbol))
547	(im (gethash name imported))
548	(in (gethash name inherited)))
549	(cond
550	((or (null status)
551	(and status (eq symbol existing))
552	(and in (eq sp (first in))))
553	(ensure-inherited name symbol to-package from-package t shadowed imported inherited))
554	(in
555	(remhash name inherited)
556	(ensure-shadowing-import name to-package (second in) shadowed imported))
557	(im
558	(error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:~S~]~]"
559	name (package-name from-package)
560	(home-package-p symbol from-package) (symbol-package-name symbol)
561	(package-name to-package)
562	(home-package-p existing to-package) (symbol-package-name existing)))
563	(t
564	(ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
565	(defun recycle-symbol (name recycle exported)
566	(check-type name string)
567	(check-type recycle list)
568	(check-type exported hash-table)
569	(when (gethash name exported) ;; don't bother recycling private symbols
570	(let (recycled foundp)
571	(dolist (r recycle (values recycled foundp))
572	(multiple-value-bind (symbol status) (find-symbol name r)
573	(when (and status (home-package-p symbol r))
574	(cond
575	(foundp
576	;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
577	(note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
578	(t
579	(setf recycled symbol foundp r)))))))))
580	(defun symbol-recycled-p (sym recycle)
581	(check-type sym symbol)
582	(check-type recycle list)
583	(and (member (symbol-package sym) recycle) t))
584	(defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
585	(check-type name string)
586	(check-type package package)
587	(check-type intern (member nil t)) ; no cl:boolean on Genera
588	(check-type shadowed hash-table)
589	(check-type imported hash-table)
590	(check-type inherited hash-table)
591	(unless (or (gethash name shadowed)
592	(gethash name imported)
593	(gethash name inherited))
594	(multiple-value-bind (existing status)
595	(find-symbol name package)
596	(multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
597	(cond
598	((and status (eq existing recycled) (eq previous package)))
599	(previous
600	(rehome-symbol recycled package))
601	((and status (eq package (symbol-package existing))))
602	(t
603	(when status
604	(note-package-fishiness
605	:ensure-symbol name
606	(reify-package (symbol-package existing) package)
607	status intern)
608	(unintern existing))
609	(when intern
610	(intern* name package))))))))
611	(declaim (ftype function ensure-exported))
612	(defun ensure-exported-to-user (name symbol to-package &optional recycle)
613	(check-type name string)
614	(check-type symbol symbol)
615	(check-type to-package package)
616	(check-type recycle list)
617	(assert (equal name (symbol-name symbol)))
618	(multiple-value-bind (existing status) (find-symbol name to-package)
619	(unless (and status (eq symbol existing))
620	(let ((accessible
621	(or (null status)
622	(let ((shadowing (symbol-shadowing-p existing to-package))
623	(recycled (symbol-recycled-p existing recycle)))
624	(unless (and shadowing (not recycled))
625	(note-package-fishiness
626	:ensure-export name (symbol-package-name symbol)
627	(package-name to-package)
628	(or (home-package-p existing to-package) (symbol-package-name existing))
629	status shadowing)
630	(if (or (eq status :inherited) shadowing)
631	(shadowing-import* symbol to-package)
632	(unintern existing to-package))
633	t)))))
634	(when (and accessible (eq status :external))
635	(ensure-exported name symbol to-package recycle))))))
636	(defun ensure-exported (name symbol from-package &optional recycle)
637	(dolist (to-package (package-used-by-list from-package))
638	(ensure-exported-to-user name symbol to-package recycle))
639	(unless (eq from-package (symbol-package symbol))
640	(ensure-imported symbol from-package))
641	(export* name from-package))
642	(defun ensure-export (name from-package &optional recycle)
643	(multiple-value-bind (symbol status) (find-symbol* name from-package)
644	(unless (eq status :external)
645	(ensure-exported name symbol from-package recycle))))
646	(defun ensure-package (name &key
647	nicknames documentation use
648	shadow shadowing-import-from
649	import-from export intern
650	recycle mix reexport
651	unintern)
652	#+(or gcl2.6 genera) (declare (ignore documentation))
653	(let* ((package-name (string name))
654	(nicknames (mapcar #'string nicknames))
655	(names (cons package-name nicknames))
656	(previous (packages-from-names names))
657	(discarded (cdr previous))
658	(to-delete ())
659	(package (or (first previous) (make-package package-name :nicknames nicknames)))
660	(recycle (packages-from-names recycle))
661	(use (mapcar 'find-package* use))
662	(mix (mapcar 'find-package* mix))
663	(reexport (mapcar 'find-package* reexport))
664	(shadow (mapcar 'string shadow))
665	(export (mapcar 'string export))
666	(intern (mapcar 'string intern))
667	(unintern (mapcar 'string unintern))
668	(shadowed (make-hash-table :test 'equal)) ; string to bool
669	(imported (make-hash-table :test 'equal)) ; string to bool
670	(exported (make-hash-table :test 'equal)) ; string to bool
671	;; string to list home package and use package:
672	(inherited (make-hash-table :test 'equal)))
673	(when-package-fishiness (record-fishy package-name))
674	#-(or gcl2.6 genera)
675	(when documentation (setf (documentation package t) documentation))
676	(loop :for p :in (set-difference (package-use-list package) (append mix use))
677	:do (note-package-fishiness :over-use name (package-names p))
678	(unuse-package p package))
679	(loop :for p :in discarded
680	:for n = (remove-if #'(lambda (x) (member x names :test 'equal))
681	(package-names p))
682	:do (note-package-fishiness :nickname name (package-names p))
683	(cond (n (rename-package p (first n) (rest n)))
684	(t (rename-package-away p)
685	(push p to-delete))))
686	(rename-package package package-name nicknames)
687	(dolist (name unintern)
688	(multiple-value-bind (existing status) (find-symbol name package)
689	(when status
690	(unless (eq status :inherited)
691	(note-package-fishiness
692	:unintern (package-name package) name (symbol-package-name existing) status)
693	(unintern* name package nil)))))
694	(dolist (name export)
695	(setf (gethash name exported) t))
696	(dolist (p reexport)
697	(do-external-symbols (sym p)
698	(setf (gethash (string sym) exported) t)))
699	(do-external-symbols (sym package)
700	(let ((name (symbol-name sym)))
701	(unless (gethash name exported)
702	(note-package-fishiness
703	:over-export (package-name package) name
704	(or (home-package-p sym package) (symbol-package-name sym)))
705	(unexport sym package))))
706	(dolist (name shadow)
707	(setf (gethash name shadowed) t)
708	(multiple-value-bind (existing status) (find-symbol name package)
709	(multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
710	(let ((shadowing (and status (symbol-shadowing-p existing package))))
711	(cond
712	((eq previous package))
713	(previous
714	(rehome-symbol recycled package))
715	((or (member status '(nil :inherited))
716	(home-package-p existing package)))
717	(t
718	(let ((dummy (make-symbol name)))
719	(note-package-fishiness
720	:shadow-imported (package-name package) name
721	(symbol-package-name existing) status shadowing)
722	(shadowing-import* dummy package)
723	(import* dummy package)))))))
724	(shadow* name package))
725	(loop :for (p . syms) :in shadowing-import-from
726	:for pp = (find-package* p) :do
727	(dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
728	(loop :for p :in mix
729	:for pp = (find-package* p) :do
730	(do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
731	(loop :for (p . syms) :in import-from
732	:for pp = (find-package p) :do
733	(dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
734	(dolist (p (append use mix))
735	(do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
736	(use-package p package))
737	(loop :for name :being :the :hash-keys :of exported :do
738	(ensure-symbol name package t recycle shadowed imported inherited exported)
739	(ensure-export name package recycle))
740	(dolist (name intern)
741	(ensure-symbol name package t recycle shadowed imported inherited exported))
742	(do-symbols (sym package)
743	(ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
744	(map () 'delete-package* to-delete)
745	package)))
746
747	(eval-when (:load-toplevel :compile-toplevel :execute)
748	(defun parse-define-package-form (package clauses)
749	(loop
750	:with use-p = nil :with recycle-p = nil
751	:with documentation = nil
752	:for (kw . args) :in clauses
753	:when (eq kw :nicknames) :append args :into nicknames :else
754	:when (eq kw :documentation)
755	:do (cond
756	(documentation (error "define-package: can't define documentation twice"))
757	((or (atom args) (cdr args)) (error "define-package: bad documentation"))
758	(t (setf documentation (car args)))) :else
759	:when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
760	:when (eq kw :shadow) :append args :into shadow :else
761	:when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
762	:when (eq kw :import-from) :collect args :into import-from :else
763	:when (eq kw :export) :append args :into export :else
764	:when (eq kw :intern) :append args :into intern :else
765	:when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
766	:when (eq kw :mix) :append args :into mix :else
767	:when (eq kw :reexport) :append args :into reexport :else
768	:when (eq kw :unintern) :append args :into unintern :else
769	:do (error "unrecognized define-package keyword ~S" kw)
770	:finally (return `(,package
771	:nicknames ,nicknames :documentation ,documentation
772	:use ,(if use-p use '(:common-lisp))
773	:shadow ,shadow :shadowing-import-from ,shadowing-import-from
774	:import-from ,import-from :export ,export :intern ,intern
775	:recycle ,(if recycle-p recycle (cons package nicknames))
776	:mix ,mix :reexport ,reexport :unintern ,unintern)))))
777
778	(defmacro define-package (package &rest clauses)
779	(let ((ensure-form
780	`(apply 'ensure-package ',(parse-define-package-form package clauses))))
781	`(progn
782	#+clisp
783	(eval-when (:compile-toplevel :load-toplevel :execute)
784	,ensure-form)
785	#+(or clisp ecl gcl) (defpackage ,package (:use))
786	(eval-when (:compile-toplevel :load-toplevel :execute)
787	,ensure-form))))
788
789	;;;; Final tricks to keep various implementations happy.
790	;; We want most such tricks in common-lisp.lisp,
791	;; but these need to be done before the define-package form there,
792	;; that we nevertheless want to be the very first form.
793	(eval-when (:load-toplevel :compile-toplevel :execute)
794	#+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
795	(setf excl::autoload-package-name-alist
796	(remove "asdf" excl::autoload-package-name-alist
797	:test 'equalp :key 'car))
798	#+gcl
799	;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
800	;; but can run ASDF 2.011. GCL 2.6 has even more issues.
801	(cond
802	((or (< system::gcl-major-version 2)
803	(and (= system::gcl-major-version 2)
804	(< system::gcl-minor-version 6)))
805	(error "GCL 2.6 or later required to use ASDF"))
806	((and (= system::gcl-major-version 2)
807	(= system::gcl-minor-version 6))
808	(pushnew 'ignorable pcl::variable-declarations-without-argument)
809	(pushnew :gcl2.6 features))
810	(t
811	(pushnew :gcl2.7 features))))
812
813	;; Compatibility with whoever calls asdf/package
814	(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
815	;;;; -------------------------------------------------------------------------
816	;;;; Handle compatibility with multiple implementations.
817	;;; This file is for papering over the deficiencies and peculiarities
818	;;; of various Common Lisp implementations.
819	;;; For implementation-specific access to the system, see os.lisp instead.
820	;;; A few functions are defined here, but actually exported from utility;
821	;;; from this package only common-lisp symbols are exported.
822
823	(uiop/package:define-package :uiop/common-lisp
824	(:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
825	(:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
826	(:reexport :common-lisp)
827	(:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
828	#+allegro (:intern #:acl-warn-save)
829	#+cormanlisp (:shadow #:user-homedir-pathname)
830	#+cormanlisp
831	(:export
832	#:logical-pathname #:translate-logical-pathname
833	#:make-broadcast-stream #:file-namestring)
834	#+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
835	#+gcl2.6 (:shadowing-import-from :system #:load-pathname)
836	#+genera (:shadowing-import-from :scl #:boolean)
837	#+genera (:export #:boolean #:ensure-directories-exist)
838	#+mcl (:shadow #:user-homedir-pathname))
839	(in-package :uiop/common-lisp)
840
841	#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
842	(error "ASDF is not supported on your implementation. Please help us port it.")
843
844	;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
845
846
847	;;;; Early meta-level tweaks
848
849	#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
850	clozure lispworks (and sbcl sb-unicode) scl)
851	(eval-when (:load-toplevel :compile-toplevel :execute)
852	(pushnew :asdf-unicode features))
853
854	#+allegro
855	(eval-when (:load-toplevel :compile-toplevel :execute)
856	(defparameter acl-warn-save
857	(when (boundp 'excl:warn-on-nested-reader-conditionals)
858	excl:warn-on-nested-reader-conditionals))
859	(when (boundp 'excl:warn-on-nested-reader-conditionals)
860	(setf excl:warn-on-nested-reader-conditionals nil))
861	(setf print-readably nil))
862
863	#+cormanlisp
864	(eval-when (:load-toplevel :compile-toplevel :execute)
865	(deftype logical-pathname () nil)
866	(defun make-broadcast-stream () error-output)
867	(defun translate-logical-pathname (x) x)
868	(defun user-homedir-pathname (&optional host)
869	(declare (ignore host))
870	(parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
871	(defun file-namestring (p)
872	(setf p (pathname p))
873	(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
874
875	#+ecl
876	(eval-when (:load-toplevel :compile-toplevel :execute)
877	(setf load-verbose nil)
878	(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp features) t))
879	(unless (use-ecl-byte-compiler-p) (require :cmp)))
880
881	#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
882	(eval-when (:load-toplevel :compile-toplevel :execute)
883	(unless (member :ansi-cl features)
884	(error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
885	(setf compiler::compiler-default-type (pathname "")
886	compiler::lsp-ext ""))
887
888	#+gcl2.6
889	(eval-when (:compile-toplevel :load-toplevel :execute)
890	(shadow 'type-of :uiop/common-lisp)
891	(shadowing-import 'system:load-pathname :uiop/common-lisp))
892
893	#+gcl2.6
894	(eval-when (:compile-toplevel :load-toplevel :execute)
895	(export 'type-of :uiop/common-lisp)
896	(export 'system:load-pathname :uiop/common-lisp))
897
898	#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
899	(eval-when (:load-toplevel :compile-toplevel :execute)
900	(defvar gcl2.6 t)
901	(deftype logical-pathname () nil)
902	(defun type-of (x) (class-name (class-of x)))
903	(defun wild-pathname-p (path) (declare (ignore path)) nil)
904	(defun translate-logical-pathname (x) x)
905	(defvar compile-file-pathname nil)
906	(defun pathname-match-p (in-pathname wild-pathname)
907	(declare (ignore in-wildname wild-wildname)) nil)
908	(defun translate-pathname (source from-wildname to-wildname &key)
909	(declare (ignore from-wildname to-wildname)) source)
910	(defun %print-unreadable-object (object stream type identity thunk)
911	(format stream "#<~@[~S ~]" (when type (type-of object)))
912	(funcall thunk)
913	(format stream "~@[ ~X~]>" (when identity (system:address object))))
914	(defmacro with-standard-io-syntax (&body body)
915	`(progn ,@body))
916	(defmacro with-compilation-unit (options &body body)
917	(declare (ignore options)) `(progn ,@body))
918	(defmacro print-unreadable-object ((object stream &key type identity) &body body)
919	`(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
920	(defun ensure-directories-exist (path)
921	(lisp:system (format nil "mkdir -p ~S"
922	(namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
923
924	#+genera
925	(eval-when (:load-toplevel :compile-toplevel :execute)
926	(unless (fboundp 'ensure-directories-exist)
927	(defun ensure-directories-exist (path)
928	(fs:create-directories-recursively (pathname path)))))
929
930	#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
931	(read-from-string
932	"(eval-when (:load-toplevel :compile-toplevel :execute)
933	(ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
934	(ccl:define-entry-point (_system \"system\") ((name :string)) :int)
935	;; Note: ASDF may expect user-homedir-pathname to provide
936	;; the pathname of the current user's home directory, whereas
937	;; MCL by default provides the directory from which MCL was started.
938	;; See http://code.google.com/p/mcl/wiki/Portability
939	(defun user-homedir-pathname ()
940	(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
941	(defun probe-posix (posix-namestring)
942	\"If a file exists for the posix namestring, return the pathname\"
943	(ccl::with-cstrs ((cpath posix-namestring))
944	(ccl::rlet ((is-dir :boolean)
945	(fsref :fsref))
946	(when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
947	(ccl::%path-from-fsref fsref is-dir))))))"))
948
949	#+mkcl
950	(eval-when (:load-toplevel :compile-toplevel :execute)
951	(require :cmp)
952	(setq clos::redefine-class-in-place t)) ;; Make sure we have strict ANSI class redefinition semantics
953
954
955	;;;; Looping
956	(eval-when (:load-toplevel :compile-toplevel :execute)
957	(defmacro loop* (&rest rest)
958	#-genera `(loop ,@rest)
959	#+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
960
961
962	;;;; compatfmt: avoid fancy format directives when unsupported
963	(eval-when (:load-toplevel :compile-toplevel :execute)
964	(defun frob-substrings (string substrings &optional frob)
965	(declare (optimize (speed 0) (safety 3) (debug 3)))
966	(let ((length (length string)) (stream nil))
967	(labels ((emit-string (x &optional (start 0) (end (length x)))
968	(when (< start end)
969	(unless stream (setf stream (make-string-output-stream)))
970	(write-string x stream :start start :end end)))
971	(emit-substring (start end)
972	(when (and (zerop start) (= end length))
973	(return-from frob-substrings string))
974	(emit-string string start end))
975	(recurse (substrings start end)
976	(cond
977	((>= start end))
978	((null substrings) (emit-substring start end))
979	(t (let* ((sub-spec (first substrings))
980	(sub (if (consp sub-spec) (car sub-spec) sub-spec))
981	(fun (if (consp sub-spec) (cdr sub-spec) frob))
982	(found (search sub string :start2 start :end2 end))
983	(more (rest substrings)))
984	(cond
985	(found
986	(recurse more start found)
987	(etypecase fun
988	(null)
989	(string (emit-string fun))
990	(function (funcall fun sub #'emit-string)))
991	(recurse substrings (+ found (length sub)) end))
992	(t
993	(recurse more start end))))))))
994	(recurse substrings 0 length))
995	(if stream (get-output-stream-string stream) "")))
996
997	(defmacro compatfmt (format)
998	#+(or gcl genera)
999	(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
1000	#-(or gcl genera) format))
1001
1002
1003	;;;; -------------------------------------------------------------------------
1004	;;;; General Purpose Utilities for ASDF
1005
1006	(uiop/package:define-package :uiop/utility
1007	(:nicknames :asdf/utility)
1008	(:recycle :uiop/utility :asdf/utility :asdf)
1009	(:use :uiop/common-lisp :uiop/package)
1010	;; import and reexport a few things defined in :asdf/common-lisp
1011	(:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
1012	#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1013	(:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
1014	#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1015	(:export
1016	;; magic helper to define debugging functions:
1017	#:asdf-debug #:load-asdf-debug-utility #:asdf-debug-utility
1018	#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
1019	#:if-let ;; basic flow control
1020	#:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
1021	#:emptyp ;; sequences
1022	#:strcat #:first-char #:last-char #:split-string ;; strings
1023	#:string-prefix-p #:string-enclosed-p #:string-suffix-p
1024	#:find-class* ;; CLOS
1025	#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
1026	#:earlier-stamp #:stamps-earliest #:earliest-stamp
1027	#:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
1028	#:list-to-hash-set ;; hash-table
1029	#:ensure-function #:access-at #:access-at-count ;; functions
1030	#:call-function #:call-functions #:register-hook-function
1031	#:match-condition-p #:match-any-condition-p ;; conditions
1032	#:call-with-muffled-conditions #:with-muffled-conditions
1033	#:lexicographic< #:lexicographic<=
1034	#:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
1035	(in-package :uiop/utility)
1036
1037	;;;; Defining functions in a way compatible with hot-upgrade:
1038	;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
1039	;; thus replacing the function without warning or error
1040	;; even if the signature and/or generic-ness of the function has changed.
1041	;; For a generic function, this invalidates any previous DEFMETHOD.
1042	(eval-when (:load-toplevel :compile-toplevel :execute)
1043	(defun undefine-function (function-spec)
1044	(cond
1045	((symbolp function-spec)
1046	#+clisp
1047	(let ((f (and (fboundp function-spec) (fdefinition function-spec))))
1048	(when (typep f 'clos:standard-generic-function)
1049	(loop :for m :in (clos:generic-function-methods f)
1050	:do (remove-method f m))))
1051	(fmakunbound function-spec))
1052	((and (consp function-spec) (eq (car function-spec) 'setf)
1053	(consp (cdr function-spec)) (null (cddr function-spec)))
1054	#-gcl2.6 (fmakunbound function-spec))
1055	(t (error "bad function spec ~S" function-spec))))
1056	(defun undefine-functions (function-spec-list)
1057	(map () 'undefine-function function-spec-list))
1058	(macrolet
1059	((defdef (def* def)
1060	`(defmacro ,def* (name formals &rest rest)
1061	(destructuring-bind (name &key (supersede t))
1062	(if (or (atom name) (eq (car name) 'setf))
1063	(list name :supersede nil)
1064	name)
1065	(declare (ignorable supersede))
1066	`(progn
1067	;; undefining the previous function is the portable way
1068	;; of overriding any incompatible previous gf, except on CLISP.
1069	;; We usually try to do it only for the functions that need it,
1070	;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
1071	;; (which causes issues in clisp)
1072	,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
1073	`((undefine-function ',name)))
1074	#-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
1075	,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
1076	`((declaim (notinline ,name))))
1077	(,',def ,name ,formals ,@rest))))))
1078	(defdef defgeneric* defgeneric)
1079	(defdef defun* defun))
1080	(defmacro with-upgradability ((&optional) &body body)
1081	`(eval-when (:compile-toplevel :load-toplevel :execute)
1082	,@(loop :for form :in body :collect
1083	(if (consp form)
1084	(destructuring-bind (car . cdr) form
1085	(case car
1086	((defun) `(defun* ,@cdr))
1087	((defgeneric)
1088	(unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
1089	`(defgeneric* ,@cdr)))
1090	(otherwise form)))
1091	form)))))
1092
1093	;;; Magic debugging help. See contrib/debug.lisp
1094	(with-upgradability ()
1095	(defvar asdf-debug-utility
1096	'(or (ignore-errors
1097	(symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp"))
1098	(merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
1099	"form that evaluates to the pathname to your favorite debugging utilities")
1100
1101	(defmacro asdf-debug (&rest keys)
1102	`(eval-when (:compile-toplevel :load-toplevel :execute)
1103	(load-asdf-debug-utility ,@keys)))
1104
1105	(defun load-asdf-debug-utility (&key package utility-file)
1106	(let* ((package (if package (find-package package) package))
1107	(keyword (read-from-string
1108	(format nil ":DBG-~:@(~A~)" (package-name package)))))
1109	(unless (member keyword features)
1110	(let* ((utility-file (or utility-file asdf-debug-utility))
1111	(file (ignore-errors (probe-file (eval utility-file)))))
1112	(if file (load file)
1113	(error "Failed to locate debug utility file: ~S" utility-file)))))))
1114
1115
1116	;;; Flow control
1117	(with-upgradability ()
1118	(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
1119	;; bindings can be (var form) or ((var1 form1) ...)
1120	(let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
1121	(list bindings)
1122	bindings))
1123	(variables (mapcar #'car binding-list)))
1124	`(let ,binding-list
1125	(if (and ,@variables)
1126	,then-form
1127	,else-form)))))
1128
1129	;;; List manipulation
1130	(with-upgradability ()
1131	(defmacro while-collecting ((&rest collectors) &body body)
1132	"COLLECTORS should be a list of names for collections. A collector
1133	defines a function that, when applied to an argument inside BODY, will
1134	add its argument to the corresponding collection. Returns multiple values,
1135	a list for each collection, in order.
1136	E.g.,
1137	$while-collecting \(foo bar$
1138	$dolist \(x '\(\(a 1$ $b 2$ $c 3$\)\)
1139	$foo \(first x$\)
1140	$bar \(second x$\)\)\)
1141	Returns two values: $A B C$ and $1 2 3$."
1142	(let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
1143	(initial-values (mapcar (constantly nil) collectors)))
1144	`(let ,(mapcar #'list vars initial-values)
1145	(flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
1146	,@body
1147	(values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
1148
1149	(define-modify-macro appendf (&rest args)
1150	append "Append onto list") ;; only to be used on short lists.
1151
1152	(defun length=n-p (x n) ;is it that (= (length x) n) ?
1153	(check-type n (integer 0 *))
1154	(loop
1155	:for l = x :then (cdr l)
1156	:for i :downfrom n :do
1157	(cond
1158	((zerop i) (return (null l)))
1159	((not (consp l)) (return nil))))))
1160
1161	;;; remove a key from a plist, i.e. for keyword argument cleanup
1162	(with-upgradability ()
1163	(defun remove-plist-key (key plist)
1164	"Remove a single key from a plist"
1165	(loop* :for (k v) :on plist :by #'cddr
1166	:unless (eq k key)
1167	:append (list k v)))
1168
1169	(defun remove-plist-keys (keys plist)
1170	"Remove a list of keys from a plist"
1171	(loop* :for (k v) :on plist :by #'cddr
1172	:unless (member k keys)
1173	:append (list k v))))
1174
1175
1176	;;; Sequences
1177	(with-upgradability ()
1178	(defun emptyp (x)
1179	"Predicate that is true for an empty sequence"
1180	(or (null x) (and (vectorp x) (zerop (length x))))))
1181
1182
1183	;;; Strings
1184	(with-upgradability ()
1185	(defun strcat (&rest strings)
1186	(apply 'concatenate 'string strings))
1187
1188	(defun first-char (s)
1189	(and (stringp s) (plusp (length s)) (char s 0)))
1190
1191	(defun last-char (s)
1192	(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
1193
1194	(defun split-string (string &key max (separator '(#\Space #\Tab)))
1195	"Split STRING into a list of components separated by
1196	any of the characters in the sequence SEPARATOR.
1197	If MAX is specified, then no more than max(1,MAX) components will be returned,
1198	starting the separation from the end, e.g. when called with arguments
1199	\"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1200	(block ()
1201	(let ((list nil) (words 0) (end (length string)))
1202	(flet ((separatorp (char) (find char separator))
1203	(done () (return (cons (subseq string 0 end) list))))
1204	(loop
1205	:for start = (if (and max (>= words (1- max)))
1206	(done)
1207	(position-if #'separatorp string :end end :from-end t)) :do
1208	(when (null start)
1209	(done))
1210	(push (subseq string (1+ start) end) list)
1211	(incf words)
1212	(setf end start))))))
1213
1214	(defun string-prefix-p (prefix string)
1215	"Does STRING begin with PREFIX?"
1216	(let* ((x (string prefix))
1217	(y (string string))
1218	(lx (length x))
1219	(ly (length y)))
1220	(and (<= lx ly) (string= x y :end2 lx))))
1221
1222	(defun string-suffix-p (string suffix)
1223	"Does STRING end with SUFFIX?"
1224	(let* ((x (string string))
1225	(y (string suffix))
1226	(lx (length x))
1227	(ly (length y)))
1228	(and (<= ly lx) (string= x y :start1 (- lx ly)))))
1229
1230	(defun string-enclosed-p (prefix string suffix)
1231	"Does STRING begin with PREFIX and end with SUFFIX?"
1232	(and (string-prefix-p prefix string)
1233	(string-suffix-p string suffix))))
1234
1235
1236	;;; CLOS
1237	(with-upgradability ()
1238	(defun find-class* (x &optional (errorp t) environment)
1239	(etypecase x
1240	((or standard-class built-in-class) x)
1241	#+gcl2.6 (keyword nil)
1242	(symbol (find-class x errorp environment)))))
1243
1244
1245	;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
1246	(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
1247	(deftype stamp () '(or real boolean)))
1248	(with-upgradability ()
1249	(defun stamp< (x y)
1250	(etypecase x
1251	(null (and y t))
1252	((eql t) nil)
1253	(real (etypecase y
1254	(null nil)
1255	((eql t) t)
1256	(real (< x y))))))
1257	(defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
1258	(defun stamp*< (&rest list) (stamps< list))
1259	(defun stamp<= (x y) (not (stamp< y x)))
1260	(defun earlier-stamp (x y) (if (stamp< x y) x y))
1261	(defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
1262	(defun earliest-stamp (&rest list) (stamps-earliest list))
1263	(defun later-stamp (x y) (if (stamp< x y) y x))
1264	(defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
1265	(defun latest-stamp (&rest list) (stamps-latest list))
1266	(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
1267
1268
1269	;;; Hash-tables
1270	(with-upgradability ()
1271	(defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
1272	(dolist (x list h) (setf (gethash x h) t))))
1273
1274
1275	;;; Function designators
1276	(with-upgradability ()
1277	(defun ensure-function (fun &key (package :cl))
1278	"Coerce the object FUN into a function.
1279
1280	If FUN is a FUNCTION, return it.
1281	If the FUN is a non-sequence literal constant, return constantly that,
1282	i.e. for a boolean keyword character number or pathname.
1283	Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1284	If FUN is a CONS, return the function that applies its CAR
1285	to the appended list of the rest of its CDR and the arguments.
1286	If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1287	and EVAL that in a (FUNCTION ...) context."
1288	(etypecase fun
1289	(function fun)
1290	((or boolean keyword character number pathname) (constantly fun))
1291	((or function symbol) fun)
1292	(cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
1293	(string (eval `(function ,(with-standard-io-syntax
1294	(let ((package (find-package package)))
1295	(read-from-string fun))))))))
1296
1297	(defun access-at (object at)
1298	"Given an OBJECT and an AT specifier, list of successive accessors,
1299	call each accessor on the result of the previous calls.
1300	An accessor may be an integer, meaning a call to ELT,
1301	a keyword, meaning a call to GETF,
1302	NIL, meaning identity,
1303	a function or other symbol, meaning itself,
1304	or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1305	As a degenerate case, the AT specifier may be an atom of a single such accessor
1306	instead of a list."
1307	(flet ((access (object accessor)
1308	(etypecase accessor
1309	(function (funcall accessor object))
1310	(integer (elt object accessor))
1311	(keyword (getf object accessor))
1312	(null object)
1313	(symbol (funcall accessor object))
1314	(cons (funcall (ensure-function accessor) object)))))
1315	(if (listp at)
1316	(dolist (accessor at object)
1317	(setf object (access object accessor)))
1318	(access object at))))
1319
1320	(defun access-at-count (at)
1321	"From an AT specification, extract a COUNT of maximum number
1322	of sub-objects to read as per ACCESS-AT"
1323	(cond
1324	((integerp at)
1325	(1+ at))
1326	((and (consp at) (integerp (first at)))
1327	(1+ (first at)))))
1328
1329	(defun call-function (function-spec &rest arguments)
1330	(apply (ensure-function function-spec) arguments))
1331
1332	(defun call-functions (function-specs)
1333	(map () 'call-function function-specs))
1334
1335	(defun register-hook-function (variable hook &optional call-now-p)
1336	(pushnew hook (symbol-value variable))
1337	(when call-now-p (call-function hook))))
1338
1339
1340	;;; Version handling
1341	(with-upgradability ()
1342	(defun unparse-version (version-list)
1343	(format nil "~{~D~^.~}" version-list))
1344
1345	(defun parse-version (version-string &optional on-error)
1346	"Parse a VERSION-STRING as a series of natural integers separated by dots.
1347	Return a (non-null) list of integers if the string is valid;
1348	otherwise return NIL.
1349
1350	When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1351	with format arguments explaining why the version is invalid.
1352	ON-ERROR is also called if the version is not canonical
1353	in that it doesn't print back to itself, but the list is returned anyway."
1354	(block nil
1355	(unless (stringp version-string)
1356	(call-function on-error "~S: ~S is not a string" 'parse-version version-string)
1357	(return))
1358	(unless (loop :for prev = nil :then c :for c :across version-string
1359	:always (or (digit-char-p c)
1360	(and (eql c #\.) prev (not (eql prev #\.))))
1361	:finally (return (and c (digit-char-p c))))
1362	(call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
1363	'parse-version version-string)
1364	(return))
1365	(let* ((version-list
1366	(mapcar #'parse-integer (split-string version-string :separator ".")))
1367	(normalized-version (unparse-version version-list)))
1368	(unless (equal version-string normalized-version)
1369	(call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
1370	version-list)))
1371
1372	(defun lexicographic< (< x y)
1373	(cond ((null y) nil)
1374	((null x) t)
1375	((funcall < (car x) (car y)) t)
1376	((funcall < (car y) (car x)) nil)
1377	(t (lexicographic< < (cdr x) (cdr y)))))
1378
1379	(defun lexicographic<= (< x y)
1380	(not (lexicographic< < y x)))
1381
1382	(defun version< (version1 version2)
1383	(let ((v1 (parse-version version1 nil))
1384	(v2 (parse-version version2 nil)))
1385	(lexicographic< '< v1 v2)))
1386
1387	(defun version<= (version1 version2)
1388	(not (version< version2 version1)))
1389
1390	(defun version-compatible-p (provided-version required-version)
1391	"Is the provided version a compatible substitution for the required-version?
1392	If major versions differ, it's not compatible.
1393	If they are equal, then any later version is compatible,
1394	with later being determined by a lexicographical comparison of minor numbers."
1395	(let ((x (parse-version provided-version nil))
1396	(y (parse-version required-version nil)))
1397	(and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
1398
1399
1400	;;; Condition control
1401
1402	(with-upgradability ()
1403	(defparameter +simple-condition-format-control-slot+
1404	#+abcl 'system::format-control
1405	#+allegro 'excl::format-control
1406	#+clisp 'system::$format-control
1407	#+clozure 'ccl::format-control
1408	#+(or cmu scl) 'conditions::format-control
1409	#+ecl 'si::format-control
1410	#+(or gcl lispworks) 'conditions::format-string
1411	#+sbcl 'sb-kernel:format-control
1412	#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
1413	"Name of the slot for FORMAT-CONTROL in simple-condition")
1414
1415	(defun match-condition-p (x condition)
1416	"Compare received CONDITION to some pattern X:
1417	a symbol naming a condition class,
1418	a simple vector of length 2, arguments to find-symbol* with result as above,
1419	or a string describing the format-control of a simple-condition."
1420	(etypecase x
1421	(symbol (typep condition x))
1422	((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
1423	(function (funcall x condition))
1424	(string (and (typep condition 'simple-condition)
1425	;; On SBCL, it's always set and the check triggers a warning
1426	#+(or allegro clozure cmu lispworks scl)
1427	(slot-boundp condition +simple-condition-format-control-slot+)
1428	(ignore-errors (equal (simple-condition-format-control condition) x))))))
1429
1430	(defun match-any-condition-p (condition conditions)
1431	"match CONDITION against any of the patterns of CONDITIONS supplied"
1432	(loop :for x :in conditions :thereis (match-condition-p x condition)))
1433
1434	(defun call-with-muffled-conditions (thunk conditions)
1435	(handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
1436	(muffle-warning c)))))
1437	(funcall thunk)))
1438
1439	(defmacro with-muffled-conditions ((conditions) &body body)
1440	`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
1441
1442
1443	;;;; ---------------------------------------------------------------------------
1444	;;;; Access to the Operating System
1445
1446	(uiop/package:define-package :uiop/os
1447	(:nicknames :asdf/os)
1448	(:recycle :uiop/os :asdf/os :asdf)
1449	(:use :uiop/common-lisp :uiop/package :uiop/utility)
1450	(:export
1451	#:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
1452	#:getenv #:getenvp ;; environment variables
1453	#:implementation-identifier ;; implementation identifier
1454	#:implementation-type #:implementation-type
1455	#:operating-system #:architecture #:lisp-version-string
1456	#:hostname #:getcwd #:chdir
1457	;; Windows shortcut support
1458	#:read-null-terminated-string #:read-little-endian
1459	#:parse-file-location-info #:parse-windows-shortcut))
1460	(in-package :uiop/os)
1461
1462	;;; Features
1463	(with-upgradability ()
1464	(defun featurep (x &optional (features features))
1465	(cond
1466	((atom x) (and (member x features) t))
1467	((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
1468	((eq :or (car x)) (some #'featurep (cdr x)))
1469	((eq :and (car x)) (every #'featurep (cdr x)))
1470	(t (error "Malformed feature specification ~S" x))))
1471
1472	(defun os-unix-p ()
1473	(or #+abcl (featurep :unix)
1474	#+(and (not abcl) (or unix cygwin darwin)) t))
1475
1476	(defun os-windows-p ()
1477	(or #+abcl (featurep :windows)
1478	#+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
1479
1480	(defun os-genera-p ()
1481	(or #+genera t))
1482
1483	(defun detect-os ()
1484	(flet ((yes (yes) (pushnew yes features))
1485	(no (no) (setf features (remove no features))))
1486	(cond
1487	((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
1488	((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
1489	((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
1490	(t (error "Congratulations for trying XCVB on an operating system~%~
1491	that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
1492
1493	(detect-os))
1494
1495	;;;; Environment variables: getting them, and parsing them.
1496
1497	(with-upgradability ()
1498	(defun getenv (x)
1499	(declare (ignorable x))
1500	#+(or abcl clisp ecl xcl) (ext:getenv x)
1501	#+allegro (sys:getenv x)
1502	#+clozure (ccl:getenv x)
1503	#+(or cmu scl) (cdr (assoc x ext:environment-list :test #'string=))
1504	#+cormanlisp
1505	(let* ((buffer (ct:malloc 1))
1506	(cname (ct:lisp-string-to-c-string x))
1507	(needed-size (win:getenvironmentvariable cname buffer 0))
1508	(buffer1 (ct:malloc (1+ needed-size))))
1509	(prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
1510	nil
1511	(ct:c-string-to-lisp-string buffer1))
1512	(ct:free buffer)
1513	(ct:free buffer1)))
1514	#+gcl (system:getenv x)
1515	#+genera nil
1516	#+lispworks (lispworks:environment-variable x)
1517	#+mcl (ccl:with-cstrs ((name x))
1518	(let ((value (_getenv name)))
1519	(unless (ccl:%null-ptr-p value)
1520	(ccl:%get-cstring value))))
1521	#+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
1522	#+sbcl (sb-ext:posix-getenv x)
1523	#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
1524	(error "~S is not supported on your implementation" 'getenv))
1525
1526	(defun getenvp (x)
1527	"Predicate that is true if the named variable is present in the libc environment,
1528	then returning the non-empty string value of the variable"
1529	(let ((g (getenv x))) (and (not (emptyp g)) g))))
1530
1531
1532	;;;; implementation-identifier
1533	;;
1534	;; produce a string to identify current implementation.
1535	;; Initially stolen from SLIME's SWANK, completely rewritten since.
1536	;; We're back to runtime checking, for the sake of e.g. ABCL.
1537
1538	(with-upgradability ()
1539	(defun first-feature (feature-sets)
1540	(dolist (x feature-sets)
1541	(multiple-value-bind (short long feature-expr)
1542	(if (consp x)
1543	(values (first x) (second x) (cons :or (rest x)))
1544	(values x x x))
1545	(when (featurep feature-expr)
1546	(return (values short long))))))
1547
1548	(defun implementation-type ()
1549	(first-feature
1550	'(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
1551	(:cmu :cmucl :cmu) :ecl :gcl
1552	(:lwpe :lispworks-personal-edition) (:lw :lispworks)
1553	:mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
1554
1555	(defvar implementation-type (implementation-type))
1556
1557	(defun operating-system ()
1558	(first-feature
1559	'(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
1560	(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
1561	(:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
1562	(:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
1563	:genera)))
1564
1565	(defun architecture ()
1566	(first-feature
1567	'((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
1568	(:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
1569	(:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
1570	:hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
1571	:mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
1572	;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1573	;; we may have to segregate the code still by architecture.
1574	(:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
1575
1576	#+clozure
1577	(defun ccl-fasl-version ()
1578	;; the fasl version is target-dependent from CCL 1.8 on.
1579	(or (let ((s 'ccl::target-fasl-version))
1580	(and (fboundp s) (funcall s)))
1581	(and (boundp 'ccl::fasl-version)
1582	(symbol-value 'ccl::fasl-version))
1583	(error "Can't determine fasl version.")))
1584
1585	(defun lisp-version-string ()
1586	(let ((s (lisp-implementation-version)))
1587	(car ; as opposed to OR, this idiom prevents some unreachable code warning
1588	(list
1589	#+allegro
1590	(format nil "~A~@[~A~]~@[~A~]~@[~A~]"
1591	excl::common-lisp-version-number
1592	;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1593	(and (eq excl:current-case-mode :case-sensitive-lower) "M")
1594	;; Note if not using International ACL
1595	;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
1596	(excl:ics-target-case (:-ics "8"))
1597	(and (member :smp features) "S"))
1598	#+armedbear (format nil "~a-fasl~a" s system::fasl-version)
1599	#+clisp
1600	(subseq s 0 (position #\space s)) ; strip build information (date, etc.)
1601	#+clozure
1602	(format nil "~d.~d-f~d" ; shorten for windows
1603	ccl::openmcl-major-version
1604	ccl::openmcl-minor-version
1605	(logand (ccl-fasl-version) #xFF))
1606	#+cmu (substitute #\- #\/ s)
1607	#+scl (format nil "~A~A" s
1608	;; ANSI upper case vs lower case.
1609	(ecase ext:case-mode (:upper "") (:lower "l")))
1610	#+ecl (format nil "~A~@[-~A~]" s
1611	(let ((vcs-id (ext:lisp-implementation-vcs-id)))
1612	(subseq vcs-id 0 (min (length vcs-id) 8))))
1613	#+gcl (subseq s (1+ (position #\space s)))
1614	#+genera
1615	(multiple-value-bind (major minor) (sct:get-system-version "System")
1616	(format nil "~D.~D" major minor))
1617	#+mcl (subseq s 8) ; strip the leading "Version "
1618	s))))
1619
1620	(defun implementation-identifier ()
1621	(substitute-if
1622	#\_ #'(lambda (x) (find x " /:;&^\\\|?<>(){}[]$#`'\""))
1623	(format nil "~(~a~@{~@[-~a~]~}~)"
1624	(or (implementation-type) (lisp-implementation-type))
1625	(or (lisp-version-string) (lisp-implementation-version))
1626	(or (operating-system) (software-type))
1627	(or (architecture) (machine-type))))))
1628
1629
1630	;;;; Other system information
1631
1632	(with-upgradability ()
1633	(defun hostname ()
1634	;; Note: untested on RMCL
1635	#+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
1636	#+cormanlisp "localhost" ;; is there a better way? Does it matter?
1637	#+allegro (symbol-call :excl.osi :gethostname)
1638	#+clisp (first (split-string (machine-instance) :separator " "))
1639	#+gcl (system:gethostname)))
1640
1641
1642	;;; Current directory
1643	(with-upgradability ()
1644
1645	#+cmu
1646	(defun parse-unix-namestring* (unix-namestring)
1647	(multiple-value-bind (host device directory name type version)
1648	(lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
1649	(make-pathname :host (or host lisp::unix-host) :device device
1650	:directory directory :name name :type type :version version)))
1651
1652	(defun getcwd ()
1653	"Get the current working directory as per POSIX getcwd(3), as a pathname object"
1654	(or #+abcl (parse-namestring
1655	(java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
1656	#+allegro (excl::current-directory)
1657	#+clisp (ext:default-directory)
1658	#+clozure (ccl:current-directory)
1659	#+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
1660	(strcat (nth-value 1 (unix:unix-current-directory)) "/"))
1661	#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
1662	#+ecl (ext:getcwd)
1663	#+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
1664	(first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
1665	#+genera default-pathname-defaults ;; on a Lisp OS, it is canonical!
1666	#+lispworks (system:current-directory)
1667	#+mkcl (mk-ext:getcwd)
1668	#+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
1669	#+xcl (extensions:current-directory)
1670	(error "getcwd not supported on your implementation")))
1671
1672	(defun chdir (x)
1673	"Change current directory, as per POSIX chdir(2), to a given pathname object"
1674	(if-let (x (pathname x))
1675	(or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
1676	#+allegro (excl:chdir x)
1677	#+clisp (ext:cd x)
1678	#+clozure (setf (ccl:current-directory) x)
1679	#+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
1680	#+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
1681	(error "Could not set current directory to ~A" x))
1682	#+ecl (ext:chdir x)
1683	#+genera (setf default-pathname-defaults x)
1684	#+lispworks (hcl:change-directory x)
1685	#+mkcl (mk-ext:chdir x)
1686	#+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
1687	(error "chdir not supported on your implementation")))))
1688
1689
1690	;;;; -----------------------------------------------------------------
1691	;;;; Windows shortcut support. Based on:
1692	;;;;
1693	;;;; Jesse Hager: The Windows Shortcut File Format.
1694	;;;; http://www.wotsit.org/list.asp?fc=13
1695
1696	#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1697	(with-upgradability ()
1698	(defparameter link-initial-dword 76)
1699	(defparameter link-guid #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1700
1701	(defun read-null-terminated-string (s)
1702	(with-output-to-string (out)
1703	(loop :for code = (read-byte s)
1704	:until (zerop code)
1705	:do (write-char (code-char code) out))))
1706
1707	(defun read-little-endian (s &optional (bytes 4))
1708	(loop :for i :from 0 :below bytes
1709	:sum (ash (read-byte s) (* 8 i))))
1710
1711	(defun parse-file-location-info (s)
1712	(let ((start (file-position s))
1713	(total-length (read-little-endian s))
1714	(end-of-header (read-little-endian s))
1715	(fli-flags (read-little-endian s))
1716	(local-volume-offset (read-little-endian s))
1717	(local-offset (read-little-endian s))
1718	(network-volume-offset (read-little-endian s))
1719	(remaining-offset (read-little-endian s)))
1720	(declare (ignore total-length end-of-header local-volume-offset))
1721	(unless (zerop fli-flags)
1722	(cond
1723	((logbitp 0 fli-flags)
1724	(file-position s (+ start local-offset)))
1725	((logbitp 1 fli-flags)
1726	(file-position s (+ start
1727	network-volume-offset
1728	#x14))))
1729	(strcat (read-null-terminated-string s)
1730	(progn
1731	(file-position s (+ start remaining-offset))
1732	(read-null-terminated-string s))))))
1733
1734	(defun parse-windows-shortcut (pathname)
1735	(with-open-file (s pathname :element-type '(unsigned-byte 8))
1736	(handler-case
1737	(when (and (= (read-little-endian s) link-initial-dword)
1738	(let ((header (make-array (length link-guid))))
1739	(read-sequence header s)
1740	(equalp header link-guid)))
1741	(let ((flags (read-little-endian s)))
1742	(file-position s 76) ;skip rest of header
1743	(when (logbitp 0 flags)
1744	;; skip shell item id list
1745	(let ((length (read-little-endian s 2)))
1746	(file-position s (+ length (file-position s)))))
1747	(cond
1748	((logbitp 1 flags)
1749	(parse-file-location-info s))
1750	(t
1751	(when (logbitp 2 flags)
1752	;; skip description string
1753	(let ((length (read-little-endian s 2)))
1754	(file-position s (+ length (file-position s)))))
1755	(when (logbitp 3 flags)
1756	;; finally, our pathname
1757	(let* ((length (read-little-endian s 2))
1758	(buffer (make-array length)))
1759	(read-sequence buffer s)
1760	(map 'string #'code-char buffer)))))))
1761	(end-of-file (c)
1762	(declare (ignore c))
1763	nil)))))
1764
1765
1766	;;;; -------------------------------------------------------------------------
1767	;;;; Portability layer around Common Lisp pathnames
1768	;; This layer allows for portable manipulation of pathname objects themselves,
1769	;; which all is necessary prior to any access the filesystem or environment.
1770
1771	(uiop/package:define-package :uiop/pathname
1772	(:nicknames :asdf/pathname)
1773	(:recycle :uiop/pathname :asdf/pathname :asdf)
1774	(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
1775	(:export
1776	;; Making and merging pathnames, portably
1777	#:normalize-pathname-directory-component #:denormalize-pathname-directory-component
1778	#:merge-pathname-directory-components #:unspecific-pathname-type #:make-pathname*
1779	#:make-pathname-component-logical #:make-pathname-logical
1780	#:merge-pathnames*
1781	#:nil-pathname #:nil-pathname #:with-pathname-defaults
1782	;; Predicates
1783	#:pathname-equal #:logical-pathname-p #:physical-pathname-p
1784	#:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
1785	;; Directories
1786	#:pathname-directory-pathname #:pathname-parent-directory-pathname
1787	#:directory-pathname-p #:ensure-directory-pathname
1788	;; Parsing filenames
1789	#:component-name-to-pathname-components
1790	#:split-name-type #:parse-unix-namestring #:unix-namestring
1791	#:split-unix-namestring-directory-components
1792	;; Absolute and relative pathnames
1793	#:subpathname #:subpathname*
1794	#:ensure-absolute-pathname
1795	#:pathname-root #:pathname-host-pathname
1796	#:subpathp
1797	;; Checking constraints
1798	#:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
1799	;; Wildcard pathnames
1800	#:wild #:wild-file #:wild-directory #:wild-inferiors #:wild-path #:wilden
1801	;; Translate a pathname
1802	#:relativize-directory-component #:relativize-pathname-directory
1803	#:directory-separator-for-host #:directorize-pathname-host-device
1804	#:translate-pathname*
1805	#:output-translation-function))
1806	(in-package :uiop/pathname)
1807
1808	;;; Normalizing pathnames across implementations
1809
1810	(with-upgradability ()
1811	(defun normalize-pathname-directory-component (directory)
1812	"Given a pathname directory component, return an equivalent form that is a list"
1813	#+gcl2.6 (setf directory (substitute :back :parent directory))
1814	(cond
1815	#-(or cmu sbcl scl) ;; these implementations already normalize directory components.
1816	((stringp directory) `(:absolute ,directory))
1817	#+gcl2.6
1818	((and (consp directory) (eq :root (first directory)))
1819	`(:absolute ,@(rest directory)))
1820	((or (null directory)
1821	(and (consp directory) (member (first directory) '(:absolute :relative))))
1822	directory)
1823	#+gcl2.6
1824	((consp directory)
1825	`(:relative ,@directory))
1826	(t
1827	(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
1828
1829	(defun denormalize-pathname-directory-component (directory-component)
1830	#-gcl2.6 directory-component
1831	#+gcl2.6
1832	(let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
1833	directory-component)))
1834	(cond
1835	((and (consp d) (eq :relative (first d))) (rest d))
1836	((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
1837	(t d))))
1838
1839	(defun merge-pathname-directory-components (specified defaults)
1840	;; Helper for merge-pathnames* that handles directory components.
1841	(let ((directory (normalize-pathname-directory-component specified)))
1842	(ecase (first directory)
1843	((nil) defaults)
1844	(:absolute specified)
1845	(:relative
1846	(let ((defdir (normalize-pathname-directory-component defaults))
1847	(reldir (cdr directory)))
1848	(cond
1849	((null defdir)
1850	directory)
1851	((not (eq :back (first reldir)))
1852	(append defdir reldir))
1853	(t
1854	(loop :with defabs = (first defdir)
1855	:with defrev = (reverse (rest defdir))
1856	:while (and (eq :back (car reldir))
1857	(or (and (eq :absolute defabs) (null defrev))
1858	(stringp (car defrev))))
1859	:do (pop reldir) (pop defrev)
1860	:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
1861
1862	;; Giving :unspecific as :type argument to make-pathname is not portable.
1863	;; See CLHS make-pathname and 19.2.2.2.3.
1864	;; This will be :unspecific if supported, or NIL if not.
1865	(defparameter unspecific-pathname-type
1866	#+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
1867	#+(or clisp ecl #\|These haven't been tested:\|# cormanlisp mcl) nil)
1868
1869	(defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
1870	host (device () #+allegro devicep) name type version defaults
1871	#+scl &allow-other-keys)
1872	"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
1873	tries hard to make a pathname that will actually behave as documented,
1874	despite the peculiarities of each implementation"
1875	(declare (ignorable host device directory name type version defaults))
1876	(apply 'make-pathname
1877	(append
1878	#+allegro (when (and devicep (null device)) `(:device :unspecific))
1879	#+gcl2.6
1880	(when directoryp
1881	`(:directory ,(denormalize-pathname-directory-component directory)))
1882	keys)))
1883
1884	(defun make-pathname-component-logical (x)
1885	"Make a pathname component suitable for use in a logical-pathname"
1886	(typecase x
1887	((eql :unspecific) nil)
1888	#+clisp (string (string-upcase x))
1889	#+clisp (cons (mapcar 'make-pathname-component-logical x))
1890	(t x)))
1891
1892	(defun make-pathname-logical (pathname host)
1893	"Take a PATHNAME's directory, name, type and version components,
1894	and make a new pathname with corresponding components and specified logical HOST"
1895	(make-pathname*
1896	:host host
1897	:directory (make-pathname-component-logical (pathname-directory pathname))
1898	:name (make-pathname-component-logical (pathname-name pathname))
1899	:type (make-pathname-component-logical (pathname-type pathname))
1900	:version (make-pathname-component-logical (pathname-version pathname))))
1901
1902	(defun merge-pathnames* (specified &optional (defaults default-pathname-defaults))
1903	"MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
1904	if the SPECIFIED pathname does not have an absolute directory,
1905	then the HOST and DEVICE both come from the DEFAULTS, whereas
1906	if the SPECIFIED pathname does have an absolute directory,
1907	then the HOST and DEVICE both come from the SPECIFIED.
1908	This is what users want on a modern Unix or Windows operating system,
1909	unlike the MERGE-PATHNAME behavior.
1910	Also, if either argument is NIL, then the other argument is returned unmodified;
1911	this is unlike MERGE-PATHNAME which always merges with a pathname,
1912	by default DEFAULT-PATHNAME-DEFAULTS, which cannot be NIL."
1913	(when (null specified) (return-from merge-pathnames* defaults))
1914	(when (null defaults) (return-from merge-pathnames* specified))
1915	#+scl
1916	(ext:resolve-pathname specified defaults)
1917	#-scl
1918	(let* ((specified (pathname specified))
1919	(defaults (pathname defaults))
1920	(directory (normalize-pathname-directory-component (pathname-directory specified)))
1921	(name (or (pathname-name specified) (pathname-name defaults)))
1922	(type (or (pathname-type specified) (pathname-type defaults)))
1923	(version (or (pathname-version specified) (pathname-version defaults))))
1924	(labels ((unspecific-handler (p)
1925	(if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
1926	(multiple-value-bind (host device directory unspecific-handler)
1927	(ecase (first directory)
1928	((:absolute)
1929	(values (pathname-host specified)
1930	(pathname-device specified)
1931	directory
1932	(unspecific-handler specified)))
1933	((nil :relative)
1934	(values (pathname-host defaults)
1935	(pathname-device defaults)
1936	(merge-pathname-directory-components directory (pathname-directory defaults))
1937	(unspecific-handler defaults))))
1938	(make-pathname* :host host :device device :directory directory
1939	:name (funcall unspecific-handler name)
1940	:type (funcall unspecific-handler type)
1941	:version (funcall unspecific-handler version))))))
1942
1943	(defun nil-pathname (&optional (defaults default-pathname-defaults))
1944	"A pathname that is as neutral as possible for use as defaults
1945	when merging, making or parsing pathnames"
1946	;; 19.2.2.2.1 says a NIL host can mean a default host;
1947	;; see also "valid physical pathname host" in the CLHS glossary, that suggests
1948	;; strings and lists of strings or :unspecific
1949	;; But CMUCL decides to die on NIL.
1950	#.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
1951	:host (or #+cmu lisp::unix-host)
1952	#+scl ,@'(:scheme nil :scheme-specific-part nil
1953	:username nil :password nil :parameters nil :query nil :fragment nil)
1954	;; the default shouldn't matter, but we really want something physical
1955	:defaults defaults))
1956
1957	(defvar nil-pathname (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
1958
1959	(defmacro with-pathname-defaults ((&optional defaults) &body body)
1960	`(let ((default-pathname-defaults ,(or defaults 'nil-pathname))) ,@body)))
1961
1962
1963	;;; Some pathname predicates
1964	(with-upgradability ()
1965	(defun pathname-equal (p1 p2)
1966	(when (stringp p1) (setf p1 (pathname p1)))
1967	(when (stringp p2) (setf p2 (pathname p2)))
1968	(flet ((normalize-component (x)
1969	(unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
1970	x)))
1971	(macrolet ((=? (&rest accessors)
1972	(flet ((frob (x)
1973	(reduce 'list (cons 'normalize-component accessors)
1974	:initial-value x :from-end t)))
1975	`(equal ,(frob 'p1) ,(frob 'p2)))))
1976	(or (and (null p1) (null p2))
1977	(and (pathnamep p1) (pathnamep p2)
1978	(and (=? pathname-host)
1979	(=? pathname-device)
1980	(=? normalize-pathname-directory-component pathname-directory)
1981	(=? pathname-name)
1982	(=? pathname-type)
1983	(=? pathname-version)))))))
1984
1985	(defun logical-pathname-p (x)
1986	(typep x 'logical-pathname))
1987
1988	(defun physical-pathname-p (x)
1989	(and (pathnamep x) (not (logical-pathname-p x))))
1990
1991	(defun absolute-pathname-p (pathspec)
1992	"If PATHSPEC is a pathname or namestring object that parses as a pathname
1993	possessing an :ABSOLUTE directory component, return the (parsed) pathname.
1994	Otherwise return NIL"
1995	(and pathspec
1996	(typep pathspec '(or null pathname string))
1997	(let ((pathname (pathname pathspec)))
1998	(and (eq :absolute (car (normalize-pathname-directory-component
1999	(pathname-directory pathname))))
2000	pathname))))
2001
2002	(defun relative-pathname-p (pathspec)
2003	"If PATHSPEC is a pathname or namestring object that parses as a pathname
2004	possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2005	Otherwise return NIL"
2006	(and pathspec
2007	(typep pathspec '(or null pathname string))
2008	(let* ((pathname (pathname pathspec))
2009	(directory (normalize-pathname-directory-component
2010	(pathname-directory pathname))))
2011	(when (or (null directory) (eq :relative (car directory)))
2012	pathname))))
2013
2014	(defun hidden-pathname-p (pathname)
2015	"Return a boolean that is true if the pathname is hidden as per Unix style,
2016	i.e. its name starts with a dot."
2017	(and pathname (equal (first-char (pathname-name pathname)) #\.)))
2018
2019	(defun file-pathname-p (pathname)
2020	"Does PATHNAME represent a file, i.e. has a non-null NAME component?
2021
2022	Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2023
2024	Note that this does _not_ check to see that PATHNAME points to an
2025	actually-existing file.
2026
2027	Returns the (parsed) PATHNAME when true"
2028	(when pathname
2029	(let* ((pathname (pathname pathname))
2030	(name (pathname-name pathname)))
2031	(when (not (member name '(nil :unspecific "") :test 'equal))
2032	pathname)))))
2033
2034
2035	;;; Directory pathnames
2036	(with-upgradability ()
2037	(defun pathname-directory-pathname (pathname)
2038	"Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2039	and NIL NAME, TYPE and VERSION components"
2040	(when pathname
2041	(make-pathname :name nil :type nil :version nil :defaults pathname)))
2042
2043	(defun pathname-parent-directory-pathname (pathname)
2044	"Returns a new pathname that corresponds to the parent of the current pathname's directory,
2045	i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2046	Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2047	(when pathname
2048	(make-pathname* :name nil :type nil :version nil
2049	:directory (merge-pathname-directory-components
2050	'(:relative :back) (pathname-directory pathname))
2051	:defaults pathname)))
2052
2053	(defun directory-pathname-p (pathname)
2054	"Does PATHNAME represent a directory?
2055
2056	A directory-pathname is a pathname _without_ a filename. The three
2057	ways that the filename components can be missing are for it to be NIL,
2058	:UNSPECIFIC or the empty string.
2059
2060	Note that this does _not_ check to see that PATHNAME points to an
2061	actually-existing directory."
2062	(when pathname
2063	(let ((pathname (pathname pathname)))
2064	(flet ((check-one (x)
2065	(member x '(nil :unspecific "") :test 'equal)))
2066	(and (not (wild-pathname-p pathname))
2067	(check-one (pathname-name pathname))
2068	(check-one (pathname-type pathname))
2069	t)))))
2070
2071	(defun ensure-directory-pathname (pathspec &optional (on-error 'error))
2072	"Converts the non-wild pathname designator PATHSPEC to directory form."
2073	(cond
2074	((stringp pathspec)
2075	(ensure-directory-pathname (pathname pathspec)))
2076	((not (pathnamep pathspec))
2077	(call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
2078	((wild-pathname-p pathspec)
2079	(call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
2080	((directory-pathname-p pathspec)
2081	pathspec)
2082	(t
2083	(make-pathname* :directory (append (or (normalize-pathname-directory-component
2084	(pathname-directory pathspec))
2085	(list :relative))
2086	(list (file-namestring pathspec)))
2087	:name nil :type nil :version nil :defaults pathspec)))))
2088
2089
2090	;;; Parsing filenames
2091	(with-upgradability ()
2092	(defun split-unix-namestring-directory-components
2093	(unix-namestring &key ensure-directory dot-dot)
2094	"Splits the path string UNIX-NAMESTRING, returning four values:
2095	A flag that is either :absolute or :relative, indicating
2096	how the rest of the values are to be interpreted.
2097	A directory path --- a list of strings and keywords, suitable for
2098	use with MAKE-PATHNAME when prepended with the flag value.
2099	Directory components with an empty name or the name . are removed.
2100	Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2101	A last-component, either a file-namestring including type extension,
2102	or NIL in the case of a directory pathname.
2103	A flag that is true iff the unix-style-pathname was just
2104	a file-namestring without / path specification.
2105	ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2106	the third return value will be NIL, and final component of the namestring
2107	will be treated as part of the directory path.
2108
2109	An empty string is thus read as meaning a pathname object with all fields nil.
2110
2111	Note that : characters will NOT be interpreted as host specification.
2112	Absolute pathnames are only appropriate on Unix-style systems.
2113
2114	The intention of this function is to support structured component names,
2115	e.g., $:file \"foo/bar\"$, which will be unpacked to relative pathnames."
2116	(check-type unix-namestring string)
2117	(check-type dot-dot (member nil :back :up))
2118	(if (and (not (find #\/ unix-namestring)) (not ensure-directory)
2119	(plusp (length unix-namestring)))
2120	(values :relative () unix-namestring t)
2121	(let* ((components (split-string unix-namestring :separator "/"))
2122	(last-comp (car (last components))))
2123	(multiple-value-bind (relative components)
2124	(if (equal (first components) "")
2125	(if (equal (first-char unix-namestring) #\/)
2126	(values :absolute (cdr components))
2127	(values :relative nil))
2128	(values :relative components))
2129	(setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
2130	components))
2131	(setf components (substitute (or dot-dot :back) ".." components :test #'equal))
2132	(cond
2133	((equal last-comp "")
2134	(values relative components nil nil)) ; "" already removed from components
2135	(ensure-directory
2136	(values relative components nil nil))
2137	(t
2138	(values relative (butlast components) last-comp nil)))))))
2139
2140	(defun split-name-type (filename)
2141	"Split a filename into two values NAME and TYPE that are returned.
2142	We assume filename has no directory component.
2143	The last . if any separates name and type from from type,
2144	except that if there is only one . and it is in first position,
2145	the whole filename is the NAME with an empty type.
2146	NAME is always a string.
2147	For an empty type, UNSPECIFIC-PATHNAME-TYPE is returned."
2148	(check-type filename string)
2149	(assert (plusp (length filename)))
2150	(destructuring-bind (name &optional (type unspecific-pathname-type))
2151	(split-string filename :max 2 :separator ".")
2152	(if (equal name "")
2153	(values filename unspecific-pathname-type)
2154	(values name type))))
2155
2156	(defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
2157	&allow-other-keys)
2158	"Coerce NAME into a PATHNAME using standard Unix syntax.
2159
2160	Unix syntax is used whether or not the underlying system is Unix;
2161	on such non-Unix systems it is only usable but for relative pathnames;
2162	but especially to manipulate relative pathnames portably, it is of crucial
2163	to possess a portable pathname syntax independent of the underlying OS.
2164	This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2165
2166	When given a PATHNAME object, just return it untouched.
2167	When given NIL, just return NIL.
2168	When given a non-null SYMBOL, first downcase its name and treat it as a string.
2169	When given a STRING, portably decompose it into a pathname as below.
2170
2171	#\\/ separates directory components.
2172
2173	The last #\\/-separated substring is interpreted as follows:
2174	1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2175	the string is made the last directory component, and NAME and TYPE are NIL.
2176	if the string is empty, it's the empty pathname with all slots NIL.
2177	2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
2178	are separated by SPLIT-NAME-TYPE.
2179	3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2180
2181	Directory components with an empty name the name . are removed.
2182	Any directory named .. is read as DOT-DOT,
2183	which must be one of :BACK or :UP and defaults to :BACK.
2184
2185	HOST, DEVICE and VERSION components are taken from DEFAULTS,
2186	which itself defaults to NIL-PATHNAME, also used if DEFAULTS in NIL.
2187	No host or device can be specified in the string itself,
2188	which makes it unsuitable for absolute pathnames outside Unix.
2189
2190	For relative pathnames, these components (and hence the defaults) won't matter
2191	if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2192	which is an important reason to always use MERGE-PATHNAMES*.
2193
2194	Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2195	with those keys, removing TYPE DEFAULTS and DOT-DOT.
2196	When you're manipulating pathnames that are supposed to make sense portably
2197	even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2198	to throw an error if the pathname is absolute"
2199	(block nil
2200	(check-type type (or null string (eql :directory)))
2201	(when ensure-directory
2202	(setf type :directory))
2203	(etypecase name
2204	((or null pathname) (return name))
2205	(symbol
2206	(setf name (string-downcase name)))
2207	(string))
2208	(multiple-value-bind (relative path filename file-only)
2209	(split-unix-namestring-directory-components
2210	name :dot-dot dot-dot :ensure-directory (eq type :directory))
2211	(multiple-value-bind (name type)
2212	(cond
2213	((or (eq type :directory) (null filename))
2214	(values nil nil))
2215	(type
2216	(values filename type))
2217	(t
2218	(split-name-type filename)))
2219	(apply 'ensure-pathname
2220	(make-pathname*
2221	:directory (unless file-only (cons relative path))
2222	:name name :type type
2223	:defaults (or defaults nil-pathname))
2224	(remove-plist-keys '(:type :dot-dot :defaults) keys))))))
2225
2226	(defun unix-namestring (pathname)
2227	"Given a non-wild PATHNAME, return a Unix-style namestring for it.
2228	If the PATHNAME is NIL or a STRING, return it unchanged.
2229
2230	This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2231	This is a portable solution for representing relative pathnames,
2232	But unless you are running on a Unix system, it is not a general solution
2233	to representing native pathnames.
2234
2235	An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2236	or if it is a PATHNAME but some of its components are not recognized."
2237	(etypecase pathname
2238	((or null string) pathname)
2239	(pathname
2240	(with-output-to-string (s)
2241	(flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
2242	(let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
2243	(name (pathname-name pathname))
2244	(type (pathname-type pathname))
2245	(type (and (not (eq type :unspecific)) type)))
2246	(cond
2247	((eq dir ()))
2248	((eq dir '(:relative)) (princ "./" s))
2249	((consp dir)
2250	(destructuring-bind (relabs &rest dirs) dir
2251	(or (member relabs '(:relative :absolute)) (err))
2252	(when (eq relabs :absolute) (princ #\/ s))
2253	(loop :for x :in dirs :do
2254	(cond
2255	((member x '(:back :up)) (princ "../" s))
2256	((equal x "") (err))
2257	;;((member x '("." "..") :test 'equal) (err))
2258	((stringp x) (format s "~A/" x))
2259	(t (err))))))
2260	(t (err)))
2261	(cond
2262	(name
2263	(or (and (stringp name) (or (null type) (stringp type))) (err))
2264	(format s "~A~@[.~A~]" name type))
2265	(t
2266	(or (null type) (err)))))))))))
2267
2268	;;; Absolute and relative pathnames
2269	(with-upgradability ()
2270	(defun subpathname (pathname subpath &key type)
2271	"This function takes a PATHNAME and a SUBPATH and a TYPE.
2272	If SUBPATH is already a PATHNAME object (not namestring),
2273	and is an absolute pathname at that, it is returned unchanged;
2274	otherwise, SUBPATH is turned into a relative pathname with given TYPE
2275	as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2276	then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2277	(or (and (pathnamep subpath) (absolute-pathname-p subpath))
2278	(merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
2279	(pathname-directory-pathname pathname))))
2280
2281	(defun subpathname* (pathname subpath &key type)
2282	"returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2283	(and pathname
2284	(subpathname (ensure-directory-pathname pathname) subpath :type type)))
2285
2286	(defun pathname-root (pathname)
2287	(make-pathname* :directory '(:absolute)
2288	:name nil :type nil :version nil
2289	:defaults pathname ;; host device, and on scl, some
2290	;; scheme-specific parts: port username password, not others:
2291	. #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2292
2293	(defun pathname-host-pathname (pathname)
2294	(make-pathname* :directory nil
2295	:name nil :type nil :version nil :device nil
2296	:defaults pathname ;; host device, and on scl, some
2297	;; scheme-specific parts: port username password, not others:
2298	. #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2299
2300	(defun subpathp (maybe-subpath base-pathname)
2301	(and (pathnamep maybe-subpath) (pathnamep base-pathname)
2302	(absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
2303	(directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
2304	(pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
2305	(with-pathname-defaults ()
2306	(let ((enough (enough-namestring maybe-subpath base-pathname)))
2307	(and (relative-pathname-p enough) (pathname enough))))))
2308
2309	(defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
2310	(cond
2311	((absolute-pathname-p path))
2312	((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
2313	((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
2314	((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
2315	(or (if (absolute-pathname-p default-pathname)
2316	(absolute-pathname-p (merge-pathnames* path default-pathname))
2317	(call-function on-error "Default pathname ~S is not an absolute pathname"
2318	default-pathname))
2319	(call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
2320	path default-pathname))))
2321	(t (call-function on-error
2322	"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2323	path defaults)))))
2324
2325
2326	;;; Wildcard pathnames
2327	(with-upgradability ()
2328	(defparameter wild (or #+cormanlisp "*" :wild))
2329	(defparameter wild-directory-component (or #+gcl2.6 "*" :wild))
2330	(defparameter wild-inferiors-component (or #+gcl2.6 "**" :wild-inferiors))
2331	(defparameter wild-file
2332	(make-pathname :directory nil :name wild :type wild
2333	:version (or #-(or allegro abcl xcl) wild)))
2334	(defparameter wild-directory
2335	(make-pathname* :directory `(:relative ,wild-directory-component)
2336	:name nil :type nil :version nil))
2337	(defparameter wild-inferiors
2338	(make-pathname* :directory `(:relative ,wild-inferiors-component)
2339	:name nil :type nil :version nil))
2340	(defparameter wild-path
2341	(merge-pathnames* wild-file wild-inferiors))
2342
2343	(defun wilden (path)
2344	(merge-pathnames* wild-path path)))
2345
2346
2347	;;; Translate a pathname
2348	(with-upgradability ()
2349	(defun relativize-directory-component (directory-component)
2350	(let ((directory (normalize-pathname-directory-component directory-component)))
2351	(cond
2352	((stringp directory)
2353	(list :relative directory))
2354	((eq (car directory) :absolute)
2355	(cons :relative (cdr directory)))
2356	(t
2357	directory))))
2358
2359	(defun relativize-pathname-directory (pathspec)
2360	(let ((p (pathname pathspec)))
2361	(make-pathname*
2362	:directory (relativize-directory-component (pathname-directory p))
2363	:defaults p)))
2364
2365	(defun directory-separator-for-host (&optional (pathname default-pathname-defaults))
2366	(let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
2367	(last-char (namestring foo))))
2368
2369	#-scl
2370	(defun directorize-pathname-host-device (pathname)
2371	#+(or unix abcl)
2372	(when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
2373	(return-from directorize-pathname-host-device pathname))
2374	(let* ((root (pathname-root pathname))
2375	(wild-root (wilden root))
2376	(absolute-pathname (merge-pathnames* pathname root))
2377	(separator (directory-separator-for-host root))
2378	(root-namestring (namestring root))
2379	(root-string
2380	(substitute-if #\/
2381	#'(lambda (x) (or (eql x #\:)
2382	(eql x separator)))
2383	root-namestring)))
2384	(multiple-value-bind (relative path filename)
2385	(split-unix-namestring-directory-components root-string :ensure-directory t)
2386	(declare (ignore relative filename))
2387	(let ((new-base
2388	(make-pathname* :defaults root :directory `(:absolute ,@path))))
2389	(translate-pathname absolute-pathname wild-root (wilden new-base))))))
2390
2391	#+scl
2392	(defun directorize-pathname-host-device (pathname)
2393	(let ((scheme (ext:pathname-scheme pathname))
2394	(host (pathname-host pathname))
2395	(port (ext:pathname-port pathname))
2396	(directory (pathname-directory pathname)))
2397	(flet ((specificp (x) (and x (not (eq x :unspecific)))))
2398	(if (or (specificp port)
2399	(and (specificp host) (plusp (length host)))
2400	(specificp scheme))
2401	(let ((prefix ""))
2402	(when (specificp port)
2403	(setf prefix (format nil ":~D" port)))
2404	(when (and (specificp host) (plusp (length host)))
2405	(setf prefix (strcat host prefix)))
2406	(setf prefix (strcat ":" prefix))
2407	(when (specificp scheme)
2408	(setf prefix (strcat scheme prefix)))
2409	(assert (and directory (eq (first directory) :absolute)))
2410	(make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
2411	:defaults pathname)))
2412	pathname)))
2413
2414	(defun* (translate-pathname*) (path absolute-source destination &optional root source)
2415	(declare (ignore source))
2416	(cond
2417	((functionp destination)
2418	(funcall destination path absolute-source))
2419	((eq destination t)
2420	path)
2421	((not (pathnamep destination))
2422	(error "Invalid destination"))
2423	((not (absolute-pathname-p destination))
2424	(translate-pathname path absolute-source (merge-pathnames* destination root)))
2425	(root
2426	(translate-pathname (directorize-pathname-host-device path) absolute-source destination))
2427	(t
2428	(translate-pathname path absolute-source destination))))
2429
2430	(defvar output-translation-function 'identity)) ; Hook for output translations
2431
2432
2433	;;;; -------------------------------------------------------------------------
2434	;;;; Portability layer around Common Lisp filesystem access
2435
2436	(uiop/package:define-package :uiop/filesystem
2437	(:nicknames :asdf/filesystem)
2438	(:recycle :uiop/filesystem :asdf/pathname :asdf)
2439	(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
2440	(:export
2441	;; Native namestrings
2442	#:native-namestring #:parse-native-namestring
2443	;; Probing the filesystem
2444	#:truename* #:safe-file-write-date #:probe-file*
2445	#:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
2446	#:collect-sub*directories
2447	;; Resolving symlinks somewhat
2448	#:truenamize #:resolve-symlinks #:resolve-symlinks #:resolve-symlinks*
2449	;; merging with cwd
2450	#:get-pathname-defaults #:call-with-current-directory #:with-current-directory
2451	;; Environment pathnames
2452	#:inter-directory-separator #:split-native-pathnames-string
2453	#:getenv-pathname #:getenv-pathnames
2454	#:getenv-absolute-directory #:getenv-absolute-directories
2455	#:lisp-implementation-directory #:lisp-implementation-pathname-p
2456	;; Simple filesystem operations
2457	#:ensure-all-directories-exist
2458	#:rename-file-overwriting-target
2459	#:delete-file-if-exists))
2460	(in-package :uiop/filesystem)
2461
2462	;;; Native namestrings, as seen by the operating system calls rather than Lisp
2463	(with-upgradability ()
2464	(defun native-namestring (x)
2465	"From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2466	(when x
2467	(let ((p (pathname x)))
2468	#+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
2469	#+(or cmu scl) (ext:unix-namestring p nil)
2470	#+sbcl (sb-ext:native-namestring p)
2471	#-(or clozure cmu sbcl scl)
2472	(if (os-unix-p) (unix-namestring p)
2473	(namestring p)))))
2474
2475	(defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
2476	"From a native namestring suitable for use by the operating system, return
2477	a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2478	(check-type string (or string null))
2479	(let* ((pathname
2480	(when string
2481	(with-pathname-defaults ()
2482	#+clozure (ccl:native-to-pathname string)
2483	#+sbcl (sb-ext:parse-native-namestring string)
2484	#-(or clozure sbcl)
2485	(if (os-unix-p)
2486	(parse-unix-namestring string :ensure-directory ensure-directory)
2487	(parse-namestring string)))))
2488	(pathname
2489	(if ensure-directory
2490	(and pathname (ensure-directory-pathname pathname))
2491	pathname)))
2492	(apply 'ensure-pathname pathname constraints))))
2493
2494
2495	;;; Probing the filesystem
2496	(with-upgradability ()
2497	(defun truename* (p)
2498	;; avoids both logical-pathname merging and physical resolution issues
2499	(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
2500
2501	(defun safe-file-write-date (pathname)
2502	;; If FILE-WRITE-DATE returns NIL, it's possible that
2503	;; the user or some other agent has deleted an input file.
2504	;; Also, generated files will not exist at the time planning is done
2505	;; and calls compute-action-stamp which calls safe-file-write-date.
2506	;; So it is very possible that we can't get a valid file-write-date,
2507	;; and we can survive and we will continue the planning
2508	;; as if the file were very old.
2509	;; (or should we treat the case in a different, special way?)
2510	(and pathname
2511	(handler-case (file-write-date (translate-logical-pathname pathname))
2512	(file-error () nil))))
2513
2514	(defun probe-file* (p &key truename)
2515	"when given a pathname P (designated by a string as per PARSE-NAMESTRING),
2516	probes the filesystem for a file or directory with given pathname.
2517	If it exists, return its truename is ENSURE-PATHNAME is true,
2518	or the original (parsed) pathname if it is false (the default)."
2519	(with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
2520	(etypecase p
2521	(null nil)
2522	(string (probe-file* (parse-namestring p) :truename truename))
2523	(pathname
2524	(and (not (wild-pathname-p p))
2525	(handler-case
2526	(or
2527	#+allegro
2528	(probe-file p :follow-symlinks truename)
2529	#-(or allegro clisp gcl2.6)
2530	(if truename
2531	(probe-file p)
2532	(ignore-errors
2533	(let ((pp (translate-logical-pathname p)))
2534	(and
2535	#+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
2536	#+(and lispworks unix) (system:get-file-stat pp)
2537	#+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
2538	#-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
2539	p))))
2540	#+(or clisp gcl2.6)
2541	#.(flet ((probe (probe)
2542	`(let ((foundtrue ,probe))
2543	(cond
2544	(truename foundtrue)
2545	(foundtrue p)))))
2546	#+gcl2.6
2547	(probe '(or (probe-file p)
2548	(and (directory-pathname-p p)
2549	(ignore-errors
2550	(ensure-directory-pathname
2551	(truename* (subpathname
2552	(ensure-directory-pathname p) ".")))))))
2553	#+clisp
2554	(let* ((fs (find-symbol* '#:file-stat :posix nil))
2555	(pp (find-symbol* '#:probe-pathname :ext nil))
2556	(resolve (if pp
2557	`(ignore-errors (,pp p))
2558	'(or (truename* p)
2559	(truename* (ignore-errors (ensure-directory-pathname p)))))))
2560	(if fs
2561	`(if truename
2562	,resolve
2563	(and (ignore-errors (,fs p)) p))
2564	(probe resolve)))))
2565	(file-error () nil)))))))
2566
2567	(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
2568	(apply 'directory pathname-spec
2569	(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
2570	#+clozure '(:follow-links nil)
2571	#+clisp '(:circle t :if-does-not-exist :ignore)
2572	#+(or cmu scl) '(:follow-links nil :truenamep nil)
2573	#+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
2574	'(:resolve-symlinks nil))))))
2575
2576	(defun filter-logical-directory-results (directory entries merger)
2577	(if (logical-pathname-p directory)
2578	;; Try hard to not resolve logical-pathname into physical pathnames;
2579	;; otherwise logical-pathname users/lovers will be disappointed.
2580	;; If directory* could use some implementation-dependent magic,
2581	;; we will have logical pathnames already; otherwise,
2582	;; we only keep pathnames for which specifying the name and
2583	;; translating the LPN commute.
2584	(loop :for f :in entries
2585	:for p = (or (and (logical-pathname-p f) f)
2586	(let* ((u (ignore-errors (funcall merger f))))
2587	;; The first u avoids a cumbersome (truename u) error.
2588	;; At this point f should already be a truename,
2589	;; but isn't quite in CLISP, for it doesn't have :version :newest
2590	(and u (equal (truename* u) (truename* f)) u)))
2591	:when p :collect p)
2592	entries))
2593
2594	(defun directory-files (directory &optional (pattern wild-file))
2595	(let ((dir (pathname directory)))
2596	(when (logical-pathname-p dir)
2597	;; Because of the filtering we do below,
2598	;; logical pathnames have restrictions on wild patterns.
2599	;; Not that the results are very portable when you use these patterns on physical pathnames.
2600	(when (wild-pathname-p dir)
2601	(error "Invalid wild pattern in logical directory ~S" directory))
2602	(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
2603	(error "Invalid file pattern ~S for logical directory ~S" pattern directory))
2604	(setf pattern (make-pathname-logical pattern (pathname-host dir))))
2605	(let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
2606	(filter-logical-directory-results
2607	directory entries
2608	#'(lambda (f)
2609	(make-pathname :defaults dir
2610	:name (make-pathname-component-logical (pathname-name f))
2611	:type (make-pathname-component-logical (pathname-type f))
2612	:version (make-pathname-component-logical (pathname-version f))))))))
2613
2614	(defun subdirectories (directory)
2615	(let* ((directory (ensure-directory-pathname directory))
2616	#-(or abcl cormanlisp genera xcl)
2617	(wild (merge-pathnames*
2618	#-(or abcl allegro cmu lispworks sbcl scl xcl)
2619	wild-directory
2620	#+(or abcl allegro cmu lispworks sbcl scl xcl) "."
2621	directory))
2622	(dirs
2623	#-(or abcl cormanlisp genera xcl)
2624	(ignore-errors
2625	(directory* wild . #.(or #+clozure '(:directories t :files nil)
2626	#+mcl '(:directories t))))
2627	#+(or abcl xcl) (system:list-directory directory)
2628	#+cormanlisp (cl::directory-subdirs directory)
2629	#+genera (fs:directory-list directory))
2630	#+(or abcl allegro cmu genera lispworks sbcl scl xcl)
2631	(dirs (loop :for x :in dirs
2632	:for d = #+(or abcl xcl) (extensions:probe-directory x)
2633	#+allegro (excl:probe-directory x)
2634	#+(or cmu sbcl scl) (directory-pathname-p x)
2635	#+genera (getf (cdr x) :directory)
2636	#+lispworks (lw:file-directory-p x)
2637	:when d :collect #+(or abcl allegro xcl) d
2638	#+genera (ensure-directory-pathname (first x))
2639	#+(or cmu lispworks sbcl scl) x)))
2640	(filter-logical-directory-results
2641	directory dirs
2642	(let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
2643	'(:absolute)))) ; because allegro returns NIL for #p"FOO:"
2644	#'(lambda (d)
2645	(let ((dir (normalize-pathname-directory-component (pathname-directory d))))
2646	(and (consp dir) (consp (cdr dir))
2647	(make-pathname
2648	:defaults directory :name nil :type nil :version nil
2649	:directory (append prefix (make-pathname-component-logical (last dir)))))))))))
2650
2651	(defun collect-sub*directories (directory collectp recursep collector)
2652	(when (funcall collectp directory)
2653	(funcall collector directory))
2654	(dolist (subdir (subdirectories directory))
2655	(when (funcall recursep subdir)
2656	(collect-sub*directories subdir collectp recursep collector)))))
2657
2658	;;; Resolving symlinks somewhat
2659	(with-upgradability ()
2660	(defun truenamize (pathname)
2661	"Resolve as much of a pathname as possible"
2662	(block nil
2663	(when (typep pathname '(or null logical-pathname)) (return pathname))
2664	(let ((p pathname))
2665	(unless (absolute-pathname-p p)
2666	(setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
2667	(return p))))
2668	(when (logical-pathname-p p) (return p))
2669	(let ((found (probe-file* p :truename t)))
2670	(when found (return found)))
2671	(let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
2672	(up-components (reverse (rest directory)))
2673	(down-components ()))
2674	(assert (eq :absolute (first directory)))
2675	(loop :while up-components :do
2676	(if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
2677	:name nil :type nil :version nil :defaults p)))
2678	(return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
2679	:defaults p)
2680	(ensure-directory-pathname parent)))
2681	(push (pop up-components) down-components))
2682	:finally (return p))))))
2683
2684	(defun resolve-symlinks (path)
2685	#-allegro (truenamize path)
2686	#+allegro
2687	(if (physical-pathname-p path)
2688	(or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
2689	path))
2690
2691	(defvar resolve-symlinks t
2692	"Determine whether or not ASDF resolves symlinks when defining systems.
2693	Defaults to T.")
2694
2695	(defun resolve-symlinks* (path)
2696	(if resolve-symlinks
2697	(and path (resolve-symlinks path))
2698	path)))
2699
2700
2701	;;; Check pathname constraints
2702	(with-upgradability ()
2703	(defun ensure-pathname
2704	(pathname &key
2705	on-error
2706	defaults type dot-dot
2707	want-pathname
2708	want-logical want-physical ensure-physical
2709	want-relative want-absolute ensure-absolute ensure-subpath
2710	want-non-wild want-wild wilden
2711	want-file want-directory ensure-directory
2712	want-existing ensure-directories-exist
2713	truename resolve-symlinks truenamize
2714	&aux (p pathname)) ;; mutable working copy, preserve original
2715	"Coerces its argument into a PATHNAME,
2716	optionally doing some transformations and checking specified constraints.
2717
2718	If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
2719
2720	If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
2721	reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
2722	then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
2723	and the all the checks and transformations are run.
2724
2725	Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
2726	The boolean T is an alias for ERROR.
2727	ERROR means that an error will be raised if the constraint is not satisfied.
2728	CERROR means that an continuable error will be raised if the constraint is not satisfied.
2729	IGNORE means just return NIL instead of the pathname.
2730
2731	The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
2732	that will be called with the the following arguments:
2733	a generic format string for ensure pathname, the pathname,
2734	the keyword argument corresponding to the failed check or transformation,
2735	a format string for the reason ENSURE-PATHNAME failed,
2736	and a list with arguments to that format string.
2737	If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
2738	You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
2739
2740	The transformations and constraint checks are done in this order,
2741	which is also the order in the lambda-list:
2742
2743	WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
2744	Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
2745	WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
2746	WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
2747	ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
2748	WANT-RELATIVE checks that pathname has a relative directory component
2749	WANT-ABSOLUTE checks that pathname does have an absolute directory component
2750	ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
2751	that the result absolute is an absolute pathname indeed.
2752	ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
2753	WANT-FILE checks that pathname has a non-nil FILE component
2754	WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
2755	ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
2756	any file and type components as being actually a last directory component.
2757	WANT-NON-WILD checks that pathname is not a wild pathname
2758	WANT-WILD checks that pathname is a wild pathname
2759	WILDEN merges the pathname with */.. if it is not wild
2760	WANT-EXISTING checks that a file (or directory) exists with that pathname.
2761	ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
2762	TRUENAME replaces the pathname by its truename, or errors if not possible.
2763	RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
2764	TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
2765	(block nil
2766	(flet ((report-error (keyword description &rest arguments)
2767	(call-function (or on-error 'error)
2768	"Invalid pathname ~S: ~*~?"
2769	pathname keyword description arguments)))
2770	(macrolet ((err (constraint &rest arguments)
2771	`(report-error ',(intern* constraint :keyword) ,@arguments))
2772	(check (constraint condition &rest arguments)
2773	`(when ,constraint
2774	(unless ,condition (err ,constraint ,@arguments))))
2775	(transform (transform condition expr)
2776	`(when ,transform
2777	(,@(if condition `(when ,condition) '(progn))
2778	(setf p ,expr)))))
2779	(etypecase p
2780	((or null pathname))
2781	(string
2782	(setf p (parse-unix-namestring
2783	p :defaults defaults :type type :dot-dot dot-dot
2784	:ensure-directory ensure-directory :want-relative want-relative))))
2785	(check want-pathname (pathnamep p) "Expected a pathname, not NIL")
2786	(unless (pathnamep p) (return nil))
2787	(check want-logical (logical-pathname-p p) "Expected a logical pathname")
2788	(check want-physical (physical-pathname-p p) "Expected a physical pathname")
2789	(transform ensure-physical () (translate-logical-pathname p))
2790	(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
2791	(check want-relative (relative-pathname-p p) "Expected a relative pathname")
2792	(check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
2793	(transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
2794	(check ensure-absolute (absolute-pathname-p p)
2795	"Could not make into an absolute pathname even after merging with ~S" defaults)
2796	(check ensure-subpath (absolute-pathname-p defaults)
2797	"cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
2798	(check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
2799	(check want-file (file-pathname-p p) "Expected a file pathname")
2800	(check want-directory (directory-pathname-p p) "Expected a directory pathname")
2801	(transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
2802	(check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
2803	(check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
2804	(transform wilden (not (wild-pathname-p p)) (wilden p))
2805	(when want-existing
2806	(let ((existing (probe-file* p :truename truename)))
2807	(if existing
2808	(when truename
2809	(return existing))
2810	(err want-existing "Expected an existing pathname"))))
2811	(when ensure-directories-exist (ensure-directories-exist p))
2812	(when truename
2813	(let ((truename (truename* p)))
2814	(if truename
2815	(return truename)
2816	(err truename "Can't get a truename for pathname"))))
2817	(transform resolve-symlinks () (resolve-symlinks p))
2818	(transform truenamize () (truenamize p))
2819	p)))))
2820
2821
2822	;;; Pathname defaults
2823	(with-upgradability ()
2824	(defun get-pathname-defaults (&optional (defaults default-pathname-defaults))
2825	(or (absolute-pathname-p defaults)
2826	(merge-pathnames* defaults (getcwd))))
2827
2828	(defun call-with-current-directory (dir thunk)
2829	(if dir
2830	(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
2831	(default-pathname-defaults dir)
2832	(cwd (getcwd)))
2833	(chdir dir)
2834	(unwind-protect
2835	(funcall thunk)
2836	(chdir cwd)))
2837	(funcall thunk)))
2838
2839	(defmacro with-current-directory ((&optional dir) &body body)
2840	"Call BODY while the POSIX current working directory is set to DIR"
2841	`(call-with-current-directory ,dir #'(lambda () ,@body))))
2842
2843
2844	;;; Environment pathnames
2845	(with-upgradability ()
2846	(defun inter-directory-separator ()
2847	(if (os-unix-p) #\: #\;))
2848
2849	(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
2850	(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
2851	:collect (apply 'parse-native-namestring namestring constraints)))
2852
2853	(defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
2854	(apply 'parse-native-namestring (getenvp x)
2855	:on-error (or on-error
2856	`(error "In (~S ~S), invalid pathname ~~S: ~~?" getenv-pathname ,x))
2857	constraints))
2858	(defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
2859	(apply 'split-native-pathnames-string (getenvp x)
2860	:on-error (or on-error
2861	`(error "In (~S ~S), invalid pathname ~~S: ~~?" getenv-pathnames ,x))
2862	constraints))
2863	(defun getenv-absolute-directory (x)
2864	(getenv-pathname x :want-absolute t :ensure-directory t))
2865	(defun getenv-absolute-directories (x)
2866	(getenv-pathnames x :want-absolute t :ensure-directory t))
2867
2868	(defun lisp-implementation-directory (&key truename)
2869	(declare (ignorable truename))
2870	#+(or clozure ecl gcl mkcl sbcl)
2871	(let ((dir
2872	(ignore-errors
2873	#+clozure #p"ccl:"
2874	#+(or ecl mkcl) #p"SYS:"
2875	#+gcl system::system-directory
2876	#+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
2877	(funcall it)
2878	(getenv-pathname "SBCL_HOME" :ensure-directory t)))))
2879	(if (and dir truename)
2880	(truename* dir)
2881	dir)))
2882
2883	(defun lisp-implementation-pathname-p (pathname)
2884	;; Other builtin systems are those under the implementation directory
2885	(and (when pathname
2886	(if-let (impdir (lisp-implementation-directory))
2887	(or (subpathp pathname impdir)
2888	(when resolve-symlinks
2889	(if-let (truename (truename* pathname))
2890	(if-let (trueimpdir (truename* impdir))
2891	(subpathp truename trueimpdir)))))))
2892	t)))
2893
2894
2895	;;; Simple filesystem operations
2896	(with-upgradability ()
2897	(defun ensure-all-directories-exist (pathnames)
2898	(dolist (pathname pathnames)
2899	(when pathname
2900	(ensure-directories-exist (translate-logical-pathname pathname)))))
2901
2902	(defun rename-file-overwriting-target (source target)
2903	#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
2904	(posix:copy-file source target :method :rename)
2905	#-clisp
2906	(rename-file source target
2907	#+clozure :if-exists #+clozure :rename-and-delete))
2908
2909	(defun delete-file-if-exists (x)
2910	(when x (handler-case (delete-file x) (file-error () nil)))))
2911
2912
2913	;;;; ---------------------------------------------------------------------------
2914	;;;; Utilities related to streams
2915
2916	(uiop/package:define-package :uiop/stream
2917	(:nicknames :asdf/stream)
2918	(:recycle :uiop/stream :asdf/stream :asdf)
2919	(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
2920	(:export
2921	#:default-stream-element-type #:stderr #:setup-stderr
2922	#:detect-encoding #:encoding-detection-hook #:always-default-encoding
2923	#:encoding-external-format #:encoding-external-format-hook #:default-encoding-external-format
2924	#:default-encoding #:utf-8-external-format
2925	#:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
2926	#:with-output #:output-string #:with-input
2927	#:with-input-file #:call-with-input-file
2928	#:finish-outputs #:format! #:safe-format!
2929	#:copy-stream-to-stream #:concatenate-files
2930	#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
2931	#:slurp-stream-forms #:slurp-stream-form
2932	#:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
2933	#:eval-input #:eval-thunk #:standard-eval-thunk
2934	;; Temporary files
2935	#:temporary-directory #:temporary-directory #:default-temporary-directory
2936	#:setup-temporary-directory
2937	#:call-with-temporary-file #:with-temporary-file
2938	#:add-pathname-suffix #:tmpize-pathname
2939	#:call-with-staging-pathname #:with-staging-pathname))
2940	(in-package :uiop/stream)
2941
2942	(with-upgradability ()
2943	(defvar default-stream-element-type (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
2944	"default element-type for open (depends on the current CL implementation)")
2945
2946	(defvar stderr error-output
2947	"the original error output stream at startup")
2948
2949	(defun setup-stderr ()
2950	(setf stderr
2951	#+allegro excl::stderr
2952	#+clozure ccl::stderr
2953	#-(or allegro clozure) error-output))
2954	(setup-stderr))
2955
2956
2957	;;; Encodings (mostly hooks only; full support requires asdf-encodings)
2958	(with-upgradability ()
2959	(defparameter default-encoding
2960	;; preserve explicit user changes to something other than the legacy default :default
2961	(or (if-let (previous (and (boundp 'default-encoding) (symbol-value 'default-encoding)))
2962	(unless (eq previous :default) previous))
2963	:utf-8)
2964	"Default encoding for source files.
2965	The default value :utf-8 is the portable thing.
2966	The legacy behavior was :default.
2967	If you (asdf:load-system :asdf-encodings) then
2968	you will have autodetection via encoding-detection-hook below,
2969	reading emacs-style -- coding: utf-8 -- specifications,
2970	and falling back to utf-8 or latin1 if nothing is specified.")
2971
2972	(defparameter utf-8-external-format
2973	#+(and asdf-unicode (not clisp)) :utf-8
2974	#+(and asdf-unicode clisp) charset:utf-8
2975	#-asdf-unicode :default
2976	"Default :external-format argument to pass to CL:OPEN and also
2977	CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
2978	On modern implementations, this will decode UTF-8 code points as CL characters.
2979	On legacy implementations, it may fall back on some 8-bit encoding,
2980	with non-ASCII code points being read as several CL characters;
2981	hopefully, if done consistently, that won't affect program behavior too much.")
2982
2983	(defun always-default-encoding (pathname)
2984	(declare (ignore pathname))
2985	default-encoding)
2986
2987	(defvar encoding-detection-hook #'always-default-encoding
2988	"Hook for an extension to define a function to automatically detect a file's encoding")
2989
2990	(defun detect-encoding (pathname)
2991	(if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
2992	(funcall encoding-detection-hook pathname)
2993	default-encoding))
2994
2995	(defun default-encoding-external-format (encoding)
2996	(case encoding
2997	(:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
2998	(:utf-8 utf-8-external-format)
2999	(otherwise
3000	(cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
3001	:default)))
3002
3003	(defvar encoding-external-format-hook
3004	#'default-encoding-external-format
3005	"Hook for an extension to define a mapping between non-default encodings
3006	and implementation-defined external-format's")
3007
3008	(defun encoding-external-format (encoding)
3009	(funcall encoding-external-format-hook encoding)))
3010
3011
3012	;;; Safe syntax
3013	(with-upgradability ()
3014	(defvar standard-readtable (copy-readtable nil))
3015
3016	(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
3017	"Establish safe CL reader options around the evaluation of BODY"
3018	`(call-with-safe-io-syntax #'(lambda () (let ((package (find-package ,package))) ,@body))))
3019
3020	(defun call-with-safe-io-syntax (thunk &key (package :cl))
3021	(with-standard-io-syntax
3022	(let ((package (find-package package))
3023	(read-default-float-format 'double-float)
3024	(print-readably nil)
3025	(read-eval nil))
3026	(funcall thunk))))
3027
3028	(defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
3029	(with-safe-io-syntax (:package package)
3030	(read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
3031
3032
3033	;;; Output to a stream or string, FORMAT-style
3034	(with-upgradability ()
3035	(defun call-with-output (output function)
3036	"Calls FUNCTION with an actual stream argument,
3037	behaving like FORMAT with respect to how stream designators are interpreted:
3038	If OUTPUT is a stream, use it as the stream.
3039	If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
3040	If OUTPUT is T, use STANDARD-OUTPUT as the stream.
3041	If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
3042	Otherwise, signal an error."
3043	(etypecase output
3044	(null
3045	(with-output-to-string (stream) (funcall function stream)))
3046	((eql t)
3047	(funcall function standard-output))
3048	(stream
3049	(funcall function output))
3050	(string
3051	(assert (fill-pointer output))
3052	(with-output-to-string (stream output) (funcall function stream)))))
3053
3054	(defmacro with-output ((output-var &optional (value output-var)) &body body)
3055	"Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3056	as per FORMAT, and evaluate BODY within the scope of this binding."
3057	`(call-with-output ,value #'(lambda (,output-var) ,@body)))
3058
3059	(defun output-string (string &optional output)
3060	"If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3061	(if output
3062	(with-output (output) (princ string output))
3063	string)))
3064
3065
3066	;;; Input helpers
3067	(with-upgradability ()
3068	(defun call-with-input (input function)
3069	"Calls FUNCTION with an actual stream argument, interpreting
3070	stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
3071	If INPUT is a STREAM, use it as the stream.
3072	If INPUT is NIL, use a STANDARD-INPUT as the stream.
3073	If INPUT is T, use TERMINAL-IO as the stream.
3074	As an extension, if INPUT is a string, use it as a string-input-stream.
3075	Otherwise, signal an error."
3076	(etypecase input
3077	(null (funcall function standard-input))
3078	((eql t) (funcall function terminal-io))
3079	(stream (funcall function input))
3080	(string (with-input-from-string (stream input) (funcall function stream)))))
3081
3082	(defmacro with-input ((input-var &optional (value input-var)) &body body)
3083	"Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3084	as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3085	`(call-with-input ,value #'(lambda (,input-var) ,@body)))
3086
3087	(defun call-with-input-file (pathname thunk
3088	&key
3089	(element-type default-stream-element-type)
3090	(external-format utf-8-external-format)
3091	(if-does-not-exist :error))
3092	"Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3093	Other keys are accepted but discarded."
3094	#+gcl2.6 (declare (ignore external-format))
3095	(with-open-file (s pathname :direction :input
3096	:element-type element-type
3097	#-gcl2.6 :external-format #-gcl2.6 external-format
3098	:if-does-not-exist if-does-not-exist)
3099	(funcall thunk s)))
3100
3101	(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
3102	(declare (ignore element-type external-format))
3103	`(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
3104
3105
3106	;;; Ensure output buffers are flushed
3107	(with-upgradability ()
3108	(defun finish-outputs (&rest streams)
3109	"Finish output on the main output streams as well as any specified one.
3110	Useful for portably flushing I/O before user input or program exit."
3111	;; CCL notably buffers its stream output by default.
3112	(dolist (s (append streams
3113	(list stderr error-output standard-output trace-output
3114	debug-io terminal-io debug-io query-io)))
3115	(ignore-errors (finish-output s)))
3116	(values))
3117
3118	(defun format! (stream format &rest args)
3119	"Just like format, but call finish-outputs before and after the output."
3120	(finish-outputs stream)
3121	(apply 'format stream format args)
3122	(finish-output stream))
3123
3124	(defun safe-format! (stream format &rest args)
3125	(with-safe-io-syntax ()
3126	(ignore-errors (apply 'format! stream format args))
3127	(finish-outputs stream)))) ; just in case format failed
3128
3129
3130	;;; Simple Whole-Stream processing
3131	(with-upgradability ()
3132	(defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
3133	"Copy the contents of the INPUT stream into the OUTPUT stream.
3134	If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3135	Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3136	(with-open-stream (input input)
3137	(if linewise
3138	(loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
3139	:while line :do
3140	(when prefix (princ prefix output))
3141	(princ line output)
3142	(unless eof (terpri output))
3143	(finish-output output)
3144	(when eof (return)))
3145	(loop
3146	:with buffer-size = (or buffer-size 8192)
3147	:for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
3148	:for end = (read-sequence buffer input)
3149	:until (zerop end)
3150	:do (write-sequence buffer output :end end)
3151	(when (< end buffer-size) (return))))))
3152
3153	(defun concatenate-files (inputs output)
3154	(with-open-file (o output :element-type '(unsigned-byte 8)
3155	:direction :output :if-exists :rename-and-delete)
3156	(dolist (input inputs)
3157	(with-open-file (i input :element-type '(unsigned-byte 8)
3158	:direction :input :if-does-not-exist :error)
3159	(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
3160
3161	(defun slurp-stream-string (input &key (element-type 'character))
3162	"Read the contents of the INPUT stream as a string"
3163	(with-open-stream (input input)
3164	(with-output-to-string (output)
3165	(copy-stream-to-stream input output :element-type element-type))))
3166
3167	(defun slurp-stream-lines (input &key count)
3168	"Read the contents of the INPUT stream as a list of lines, return those lines.
3169
3170	Read no more than COUNT lines."
3171	(check-type count (or null integer))
3172	(with-open-stream (input input)
3173	(loop :for n :from 0
3174	:for l = (and (or (not count) (< n count))
3175	(read-line input nil nil))
3176	:while l :collect l)))
3177
3178	(defun slurp-stream-line (input &key (at 0))
3179	"Read the contents of the INPUT stream as a list of lines,
3180	then return the ACCESS-AT of that list of lines using the AT specifier.
3181	PATH defaults to 0, i.e. return the first line.
3182	PATH is typically an integer, or a list of an integer and a function.
3183	If PATH is NIL, it will return all the lines in the file.
3184
3185	The stream will not be read beyond the Nth lines,
3186	where N is the index specified by path
3187	if path is either an integer or a list that starts with an integer."
3188	(access-at (slurp-stream-lines input :count (access-at-count at)) at))
3189
3190	(defun slurp-stream-forms (input &key count)
3191	"Read the contents of the INPUT stream as a list of forms,
3192	and return those forms.
3193
3194	If COUNT is null, read to the end of the stream;
3195	if COUNT is an integer, stop after COUNT forms were read.
3196
3197	BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3198	(check-type count (or null integer))
3199	(loop :with eof = '#:eof
3200	:for n :from 0
3201	:for form = (if (and count (>= n count))
3202	eof
3203	(read-preserving-whitespace input nil eof))
3204	:until (eq form eof) :collect form))
3205
3206	(defun slurp-stream-form (input &key (at 0))
3207	"Read the contents of the INPUT stream as a list of forms,
3208	then return the ACCESS-AT of these forms following the AT.
3209	AT defaults to 0, i.e. return the first form.
3210	AT is typically a list of integers.
3211	If AT is NIL, it will return all the forms in the file.
3212
3213	The stream will not be read beyond the Nth form,
3214	where N is the index specified by path,
3215	if path is either an integer or a list that starts with an integer.
3216
3217	BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3218	(access-at (slurp-stream-forms input :count (access-at-count at)) at))
3219
3220	(defun read-file-string (file &rest keys)
3221	"Open FILE with option KEYS, read its contents as a string"
3222	(apply 'call-with-input-file file 'slurp-stream-string keys))
3223
3224	(defun read-file-lines (file &rest keys)
3225	"Open FILE with option KEYS, read its contents as a list of lines
3226	BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3227	(apply 'call-with-input-file file 'slurp-stream-lines keys))
3228
3229	(defun read-file-forms (file &rest keys &key count &allow-other-keys)
3230	"Open input FILE with option KEYS (except COUNT),
3231	and read its contents as per SLURP-STREAM-FORMS with given COUNT.
3232	BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3233	(apply 'call-with-input-file file
3234	#'(lambda (input) (slurp-stream-forms input :count count))
3235	(remove-plist-key :count keys)))
3236
3237	(defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
3238	"Open input FILE with option KEYS (except AT),
3239	and read its contents as per SLURP-STREAM-FORM with given AT specifier.
3240	BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3241	(apply 'call-with-input-file file
3242	#'(lambda (input) (slurp-stream-form input :at at))
3243	(remove-plist-key :at keys)))
3244
3245	(defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
3246	"Reads the specified form from the top of a file using a safe standardized syntax.
3247	Extracts the form using READ-FILE-FORM,
3248	within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3249	(with-safe-io-syntax (:package package)
3250	(apply 'read-file-form pathname (remove-plist-key :package keys))))
3251
3252	(defun eval-input (input)
3253	"Portably read and evaluate forms from INPUT, return the last values."
3254	(with-input (input)
3255	(loop :with results :with eof ='#:eof
3256	:for form = (read input nil eof)
3257	:until (eq form eof)
3258	:do (setf results (multiple-value-list (eval form)))
3259	:finally (return (apply 'values results)))))
3260
3261	(defun eval-thunk (thunk)
3262	"Evaluate a THUNK of code:
3263	If a function, FUNCALL it without arguments.
3264	If a constant literal and not a sequence, return it.
3265	If a cons or a symbol, EVAL it.
3266	If a string, repeatedly read and evaluate from it, returning the last values."
3267	(etypecase thunk
3268	((or boolean keyword number character pathname) thunk)
3269	((or cons symbol) (eval thunk))
3270	(function (funcall thunk))
3271	(string (eval-input thunk))))
3272
3273	(defun standard-eval-thunk (thunk &key (package :cl))
3274	"Like EVAL-THUNK, but in a more standardized evaluation context."
3275	;; Note: it's "standard-" not "safe-", because evaluation is never safe.
3276	(when thunk
3277	(with-safe-io-syntax (:package package)
3278	(let ((read-eval t))
3279	(eval-thunk thunk))))))
3280
3281
3282	;;; Using temporary files
3283	(with-upgradability ()
3284	(defun default-temporary-directory ()
3285	(or
3286	(when (os-unix-p)
3287	(or (getenv-pathname "TMPDIR" :ensure-directory t)
3288	(parse-native-namestring "/tmp/")))
3289	(when (os-windows-p)
3290	(getenv-pathname "TEMP" :ensure-directory t))
3291	(subpathname (user-homedir-pathname) "tmp/")))
3292
3293	(defvar temporary-directory nil)
3294
3295	(defun temporary-directory ()
3296	(or temporary-directory (default-temporary-directory)))
3297
3298	(defun setup-temporary-directory ()
3299	(setf temporary-directory (default-temporary-directory))
3300	;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
3301	#+(and gcl (not gcl2.6)) (setf system::tmp-dir temporary-directory))
3302
3303	(defun call-with-temporary-file
3304	(thunk &key
3305	prefix keep (direction :io)
3306	(element-type default-stream-element-type)
3307	(external-format :default))
3308	#+gcl2.6 (declare (ignorable external-format))
3309	(check-type direction (member :output :io))
3310	(loop
3311	:with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
3312	:for counter :from (random (ash 1 32))
3313	:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
3314	;; TODO: on Unix, do something about umask
3315	;; TODO: on Unix, audit the code so we make sure it uses O_CREAT\|O_EXCL
3316	;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
3317	(with-open-file (stream pathname
3318	:direction direction
3319	:element-type element-type
3320	#-gcl2.6 :external-format #-gcl2.6 external-format
3321	:if-exists nil :if-does-not-exist :create)
3322	(when stream
3323	(return
3324	(if keep
3325	(funcall thunk stream pathname)
3326	(unwind-protect
3327	(funcall thunk stream pathname)
3328	(ignore-errors (delete-file pathname)))))))))
3329
3330	(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
3331	(pathname (gensym "PATHNAME") pathnamep)
3332	prefix keep direction element-type external-format)
3333	&body body)
3334	"Evaluate BODY where the symbols specified by keyword arguments
3335	STREAM and PATHNAME are bound corresponding to a newly created temporary file
3336	ready for I/O. Unless KEEP is specified, delete the file afterwards."
3337	(check-type stream symbol)
3338	(check-type pathname symbol)
3339	`(flet ((think (,stream ,pathname)
3340	,@(unless pathnamep `((declare (ignore ,pathname))))
3341	,@(unless streamp `((when ,stream (close ,stream))))
3342	,@body))
3343	#-gcl (declare (dynamic-extent #'think))
3344	(call-with-temporary-file
3345	#'think
3346	,@(when direction `(:direction ,direction))
3347	,@(when prefix `(:prefix ,prefix))
3348	,@(when keep `(:keep ,keep))
3349	,@(when element-type `(:element-type ,element-type))
3350	,@(when external-format `(:external-format external-format)))))
3351
3352	;; Temporary pathnames in simple cases where no contention is assumed
3353	(defun add-pathname-suffix (pathname suffix)
3354	(make-pathname :name (strcat (pathname-name pathname) suffix)
3355	:defaults pathname))
3356
3357	(defun tmpize-pathname (x)
3358	(add-pathname-suffix x "-ASDF-TMP"))
3359
3360	(defun call-with-staging-pathname (pathname fun)
3361	"Calls fun with a staging pathname, and atomically
3362	renames the staging pathname to the pathname in the end.
3363	Note: this protects only against failure of the program,
3364	not against concurrent attempts.
3365	For the latter case, we ought pick random suffix and atomically open it."
3366	(let* ((pathname (pathname pathname))
3367	(staging (tmpize-pathname pathname)))
3368	(unwind-protect
3369	(multiple-value-prog1
3370	(funcall fun staging)
3371	(rename-file-overwriting-target staging pathname))
3372	(delete-file-if-exists staging))))
3373
3374	(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
3375	`(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
3376
3377	;;;; -------------------------------------------------------------------------
3378	;;;; Starting, Stopping, Dumping a Lisp image
3379
3380	(uiop/package:define-package :uiop/image
3381	(:nicknames :asdf/image)
3382	(:recycle :uiop/image :asdf/image :xcvb-driver)
3383	(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
3384	(:export
3385	#:image-dumped-p #:raw-command-line-arguments #:command-line-arguments
3386	#:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
3387	#:lisp-interaction
3388	#:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
3389	#:call-with-fatal-condition-handler #:with-fatal-condition-handler
3390	#:image-restore-hook #:image-prelude #:image-entry-point
3391	#:image-postlude #:image-dump-hook
3392	#:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
3393	#:shell-boolean-exit
3394	#:register-image-restore-hook #:register-image-dump-hook
3395	#:call-image-restore-hook #:call-image-dump-hook
3396	#:restore-image #:dump-image #:create-image
3397	))
3398	(in-package :uiop/image)
3399
3400	(with-upgradability ()
3401	(defvar lisp-interaction t
3402	"Is this an interactive Lisp environment, or is it batch processing?")
3403
3404	(defvar command-line-arguments nil
3405	"Command-line arguments")
3406
3407	(defvar image-dumped-p nil ; may matter as to how to get to command-line-arguments
3408	"Is this a dumped image? As a standalone executable?")
3409
3410	(defvar image-restore-hook nil
3411	"Functions to call (in reverse order) when the image is restored")
3412
3413	(defvar image-prelude nil
3414	"a form to evaluate, or string containing forms to read and evaluate
3415	when the image is restarted, but before the entry point is called.")
3416
3417	(defvar image-entry-point nil
3418	"a function with which to restart the dumped image when execution is restored from it.")
3419
3420	(defvar image-postlude nil
3421	"a form to evaluate, or string containing forms to read and evaluate
3422	before the image dump hooks are called and before the image is dumped.")
3423
3424	(defvar image-dump-hook nil
3425	"Functions to call (in order) when before an image is dumped")
3426
3427	(defvar fatal-conditions '(error)
3428	"conditions that cause the Lisp image to enter the debugger if interactive,
3429	or to die if not interactive"))
3430
3431
3432	;;; Exiting properly or im-
3433	(with-upgradability ()
3434	(defun quit (&optional (code 0) (finish-output t))
3435	"Quits from the Lisp world, with the given exit status if provided.
3436	This is designed to abstract away the implementation specific quit forms."
3437	(when finish-output ;; essential, for ClozureCL, and for standard compliance.
3438	(finish-outputs))
3439	#+(or abcl xcl) (ext:quit :status code)
3440	#+allegro (excl:exit code :quiet t)
3441	#+clisp (ext:quit code)
3442	#+clozure (ccl:quit code)
3443	#+cormanlisp (win32:exitprocess code)
3444	#+(or cmu scl) (unix:unix-exit code)
3445	#+ecl (si:quit code)
3446	#+gcl (lisp:quit code)
3447	#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
3448	#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
3449	#+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
3450	#+mkcl (mk-ext:quit :exit-code code)
3451	#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
3452	(quit (find-symbol* :quit :sb-ext nil)))
3453	(cond
3454	(exit `(,exit :code code :abort (not finish-output)))
3455	(quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
3456	#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
3457	(error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
3458
3459	(defun die (code format &rest arguments)
3460	"Die in error with some error message"
3461	(with-safe-io-syntax ()
3462	(ignore-errors
3463	(fresh-line stderr)
3464	(apply #'format stderr format arguments)
3465	(format! stderr "~&")))
3466	(quit code))
3467
3468	(defun raw-print-backtrace (&key (stream debug-io) count)
3469	"Print a backtrace, directly accessing the implementation"
3470	(declare (ignorable stream count))
3471	#+abcl
3472	(let ((debug-io stream)) (top-level::backtrace-command count))
3473	#+allegro
3474	(let ((terminal-io stream)
3475	(standard-output stream)
3476	(tpl:zoom-print-circle print-circle)
3477	(tpl:zoom-print-level print-level)
3478	(tpl:zoom-print-length print-length))
3479	(tpl:do-command "zoom"
3480	:from-read-eval-print-loop nil
3481	:count t
3482	:all t))
3483	#+clisp
3484	(system::print-backtrace :out stream :limit count)
3485	#+(or clozure mcl)
3486	(let ((debug-io stream))
3487	(ccl:print-call-history :count count :start-frame-number 1)
3488	(finish-output stream))
3489	#+(or cmu scl)
3490	(let ((debug:debug-print-level print-level)
3491	(debug:debug-print-length print-length))
3492	(debug:backtrace most-positive-fixnum stream))
3493	#+ecl
3494	(si::tpl-backtrace)
3495	#+lispworks
3496	(let ((dbg::debugger-stack
3497	(dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
3498	(debug-io stream)
3499	(dbg:debug-print-level print-level)
3500	(dbg:debug-print-length print-length))
3501	(dbg:bug-backtrace nil))
3502	#+sbcl
3503	(sb-debug:backtrace
3504	#.(if (find-symbol* "VERBOSITY" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
3505	stream))
3506
3507	(defun print-backtrace (&rest keys &key stream count)
3508	(declare (ignore stream count))
3509	(with-safe-io-syntax (:package :cl)
3510	(let ((print-readably nil)
3511	(print-circle t)
3512	(print-miser-width 75)
3513	(print-length nil)
3514	(print-level nil)
3515	(print-pretty t))
3516	(ignore-errors (apply 'raw-print-backtrace keys)))))
3517
3518	(defun print-condition-backtrace (condition &key (stream stderr) count)
3519	;; We print the condition after the backtrace,
3520	;; for the sake of who sees the backtrace at a terminal.
3521	;; It is up to the caller to print the condition before, with some context.
3522	(print-backtrace :stream stream :count count)
3523	(when condition
3524	(safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
3525	condition)))
3526
3527	(defun fatal-condition-p (condition)
3528	(match-any-condition-p condition fatal-conditions))
3529
3530	(defun handle-fatal-condition (condition)
3531	"Depending on whether LISP-INTERACTION is set, enter debugger or die"
3532	(cond
3533	(lisp-interaction
3534	(invoke-debugger condition))
3535	(t
3536	(safe-format! stderr "~&Fatal condition:~%~A~%" condition)
3537	(print-condition-backtrace condition :stream stderr)
3538	(die 99 "~A" condition))))
3539
3540	(defun call-with-fatal-condition-handler (thunk)
3541	(handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
3542	(funcall thunk)))
3543
3544	(defmacro with-fatal-condition-handler ((&optional) &body body)
3545	`(call-with-fatal-condition-handler #'(lambda () ,@body)))
3546
3547	(defun shell-boolean-exit (x)
3548	"Quit with a return code that is 0 iff argument X is true"
3549	(quit (if x 0 1))))
3550
3551
3552	;;; Using image hooks
3553	(with-upgradability ()
3554	(defun register-image-restore-hook (hook &optional (call-now-p t))
3555	(register-hook-function 'image-restore-hook hook call-now-p))
3556
3557	(defun register-image-dump-hook (hook &optional (call-now-p nil))
3558	(register-hook-function 'image-dump-hook hook call-now-p))
3559
3560	(defun call-image-restore-hook ()
3561	(call-functions (reverse image-restore-hook)))
3562
3563	(defun call-image-dump-hook ()
3564	(call-functions image-dump-hook)))
3565
3566
3567	;;; Proper command-line arguments
3568	(with-upgradability ()
3569	(defun raw-command-line-arguments ()
3570	"Find what the actual command line for this process was."
3571	#+abcl ext:command-line-argument-list ; Use 1.0.0 or later!
3572	#+allegro (sys:command-line-arguments) ; default: :application t
3573	#+clisp (coerce (ext:argv) 'list)
3574	#+clozure (ccl::command-line-arguments)
3575	#+(or cmu scl) extensions:command-line-strings
3576	#+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
3577	#+gcl si:command-args
3578	#+genera nil
3579	#+lispworks sys:line-arguments-list
3580	#+sbcl sb-ext:posix-argv
3581	#+xcl system:argv
3582	#-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
3583	(error "raw-command-line-arguments not implemented yet"))
3584
3585	(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
3586	"Extract user arguments from command-line invocation of current process.
3587	Assume the calling conventions of a generated script that uses --
3588	if we are not called from a directly executable image."
3589	#+abcl arguments
3590	#-abcl
3591	(let* (#-(or sbcl allegro)
3592	(arguments
3593	(if (eq image-dumped-p :executable)
3594	arguments
3595	(member "--" arguments :test 'string-equal))))
3596	(rest arguments)))
3597
3598	(defun setup-command-line-arguments ()
3599	(setf command-line-arguments (command-line-arguments)))
3600
3601	(defun restore-image (&key
3602	((:lisp-interaction lisp-interaction) lisp-interaction)
3603	((:restore-hook image-restore-hook) image-restore-hook)
3604	((:prelude image-prelude) image-prelude)
3605	((:entry-point image-entry-point) image-entry-point))
3606	(with-fatal-condition-handler ()
3607	(call-image-restore-hook)
3608	(standard-eval-thunk image-prelude)
3609	(let ((results (multiple-value-list
3610	(if image-entry-point
3611	(call-function image-entry-point)
3612	t))))
3613	(if lisp-interaction
3614	(apply 'values results)
3615	(shell-boolean-exit (first results)))))))
3616
3617
3618	;;; Dumping an image
3619
3620	(with-upgradability ()
3621	#-(or ecl mkcl)
3622	(defun dump-image (filename &key output-name executable
3623	((:postlude image-postlude) image-postlude)
3624	((:dump-hook image-dump-hook) image-dump-hook))
3625	(declare (ignorable filename output-name executable))
3626	(setf image-dumped-p (if executable :executable t))
3627	(standard-eval-thunk image-postlude)
3628	(call-image-dump-hook)
3629	#-(or clisp clozure cmu lispworks sbcl scl)
3630	(when executable
3631	(error "Dumping an executable is not supported on this implementation! Aborting."))
3632	#+allegro
3633	(progn
3634	(sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
3635	(excl:dumplisp :name filename :suppress-allegro-cl-banner t))
3636	#+clisp
3637	(apply #'ext:saveinitmem filename
3638	:quiet t
3639	:start-package package
3640	:keep-global-handlers nil
3641	:executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
3642	(when executable
3643	(list
3644	;; :parse-options nil ;--- requires a non-standard patch to clisp.
3645	:norc t :script nil :init-function #'restore-image)))
3646	#+clozure
3647	(ccl:save-application filename :prepend-kernel t
3648	:toplevel-function (when executable #'restore-image))
3649	#+(or cmu scl)
3650	(progn
3651	(ext:gc :full t)
3652	(setf ext:batch-mode nil)
3653	(setf ext::gc-run-time 0)
3654	(apply 'ext:save-lisp filename #+cmu :executable #+cmu t
3655	(when executable '(:init-function restore-image :process-command-line nil))))
3656	#+gcl
3657	(progn
3658	(si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
3659	(si::save-system filename))
3660	#+lispworks
3661	(if executable
3662	(lispworks:deliver 'restore-image filename 0 :interface nil)
3663	(hcl:save-image filename :environment nil))
3664	#+sbcl
3665	(progn
3666	;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
3667	(setf sb-ext::gc-run-time 0)
3668	(apply 'sb-ext:save-lisp-and-die filename
3669	:executable t ;--- always include the runtime that goes with the core
3670	(when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
3671	#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
3672	(die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
3673	filename (nth-value 1 (implementation-type))))
3674
3675
3676	#+ecl
3677	(defun create-image (destination object-files
3678	&key kind output-name prologue-code epilogue-code
3679	(prelude () preludep) (entry-point () entry-point-p) build-args)
3680	;; Is it meaningful to run these in the current environment?
3681	;; only if we also track the object files that constitute the "current" image,
3682	;; and otherwise simulate dump-image, including quitting at the end.
3683	;; (standard-eval-thunk image-postlude) (call-image-dump-hook)
3684	(check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
3685	(apply 'c::builder
3686	kind (pathname destination)
3687	:lisp-files object-files
3688	:init-name (c::compute-init-name (or output-name destination) :kind kind)
3689	:prologue-code prologue-code
3690	:epilogue-code
3691	`(progn
3692	,epilogue-code
3693	,@(when (eq kind :program)
3694	`((setf image-dumped-p :executable)
3695	(restore-image ;; default behavior would be (si::top-level)
3696	,@(when preludep `(:prelude ',prelude))
3697	,@(when entry-point-p `(:entry-point ',entry-point))))))
3698	build-args)))
3699
3700
3701	;;; Some universal image restore hooks
3702	(with-upgradability ()
3703	(map () 'register-image-restore-hook
3704	'(setup-temporary-directory setup-stderr setup-command-line-arguments
3705	#+abcl detect-os)))
3706	;;;; -------------------------------------------------------------------------
3707	;;;; run-program initially from xcvb-driver.
3708
3709	(uiop/package:define-package :uiop/run-program
3710	(:nicknames :asdf/run-program)
3711	(:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
3712	(:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
3713	(:export
3714	;;; Escaping the command invocation madness
3715	#:easy-sh-character-p #:escape-sh-token #:escape-sh-command
3716	#:escape-windows-token #:escape-windows-command
3717	#:escape-token #:escape-command
3718
3719	;;; run-program
3720	#:slurp-input-stream
3721	#:run-program
3722	#:subprocess-error
3723	#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
3724	))
3725	(in-package :uiop/run-program)
3726
3727	;;;; ----- Escaping strings for the shell -----
3728
3729	(with-upgradability ()
3730	(defun requires-escaping-p (token &key good-chars bad-chars)
3731	"Does this token require escaping, given the specification of
3732	either good chars that don't need escaping or bad chars that do need escaping,
3733	as either a recognizing function or a sequence of characters."
3734	(some
3735	(cond
3736	((and good-chars bad-chars)
3737	(error "only one of good-chars and bad-chars can be provided"))
3738	((functionp good-chars)
3739	(complement good-chars))
3740	((functionp bad-chars)
3741	bad-chars)
3742	((and good-chars (typep good-chars 'sequence))
3743	#'(lambda (c) (not (find c good-chars))))
3744	((and bad-chars (typep bad-chars 'sequence))
3745	#'(lambda (c) (find c bad-chars)))
3746	(t (error "requires-escaping-p: no good-char criterion")))
3747	token))
3748
3749	(defun escape-token (token &key stream quote good-chars bad-chars escaper)
3750	"Call the ESCAPER function on TOKEN string if it needs escaping as per
3751	REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
3752	using STREAM as output (or returning result as a string if NIL)"
3753	(if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
3754	(with-output (stream)
3755	(apply escaper token stream (when quote `(:quote ,quote))))
3756	(output-string token stream)))
3757
3758	(defun escape-windows-token-within-double-quotes (x &optional s)
3759	"Escape a string token X within double-quotes
3760	for use within a MS Windows command-line, outputing to S."
3761	(labels ((issue (c) (princ c s))
3762	(issue-backslash (n) (loop :repeat n :do (issue #\\))))
3763	(loop
3764	:initially (issue #\") :finally (issue #\")
3765	:with l = (length x) :with i = 0
3766	:for i+1 = (1+ i) :while (< i l) :do
3767	(case (char x i)
3768	((#\") (issue-backslash 1) (issue #\") (setf i i+1))
3769	((#\\)
3770	(let* ((j (and (< i+1 l) (position-if-not
3771	#'(lambda (c) (eql c #\\)) x :start i+1)))
3772	(n (- (or j l) i)))
3773	(cond
3774	((null j)
3775	(issue-backslash (* 2 n)) (setf i l))
3776	((and (< j l) (eql (char x j) #\"))
3777	(issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
3778	(t
3779	(issue-backslash n) (setf i j)))))
3780	(otherwise
3781	(issue (char x i)) (setf i i+1))))))
3782
3783	(defun escape-windows-token (token &optional s)
3784	"Escape a string TOKEN within double-quotes if needed
3785	for use within a MS Windows command-line, outputing to S."
3786	(escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
3787	:escaper 'escape-windows-token-within-double-quotes))
3788
3789	(defun escape-sh-token-within-double-quotes (x s &key (quote t))
3790	"Escape a string TOKEN within double-quotes
3791	for use within a POSIX Bourne shell, outputing to S;
3792	omit the outer double-quotes if key argument :QUOTE is NIL"
3793	(when quote (princ #\" s))
3794	(loop :for c :across x :do
3795	(when (find c "$`\\\"") (princ #\\ s))
3796	(princ c s))
3797	(when quote (princ #\" s)))
3798
3799	(defun easy-sh-character-p (x)
3800	(or (alphanumericp x) (find x "+-_.,%@:/")))
3801
3802	(defun escape-sh-token (token &optional s)
3803	"Escape a string TOKEN within double-quotes if needed
3804	for use within a POSIX Bourne shell, outputing to S."
3805	(escape-token token :stream s :quote #\" :good-chars
3806	#'easy-sh-character-p
3807	:escaper 'escape-sh-token-within-double-quotes))
3808
3809	(defun escape-shell-token (token &optional s)
3810	(cond
3811	((os-unix-p) (escape-sh-token token s))
3812	((os-windows-p) (escape-windows-token token s))))
3813
3814	(defun escape-command (command &optional s
3815	(escaper 'escape-shell-token))
3816	"Given a COMMAND as a list of tokens, return a string of the
3817	spaced, escaped tokens, using ESCAPER to escape."
3818	(etypecase command
3819	(string (output-string command s))
3820	(list (with-output (s)
3821	(loop :for first = t :then nil :for token :in command :do
3822	(unless first (princ #\space s))
3823	(funcall escaper token s))))))
3824
3825	(defun escape-windows-command (command &optional s)
3826	"Escape a list of command-line arguments into a string suitable for parsing
3827	by CommandLineToArgv in MS Windows"
3828	;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
3829	;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
3830	(escape-command command s 'escape-windows-token))
3831
3832	(defun escape-sh-command (command &optional s)
3833	"Escape a list of command-line arguments into a string suitable for parsing
3834	by /bin/sh in POSIX"
3835	(escape-command command s 'escape-sh-token))
3836
3837	(defun escape-shell-command (command &optional stream)
3838	"Escape a command for the current operating system's shell"
3839	(escape-command command stream 'escape-shell-token)))
3840
3841
3842	;;;; Slurping a stream, typically the output of another program
3843	(with-upgradability ()
3844	(defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
3845
3846	#-(or gcl2.6 genera)
3847	(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
3848	(funcall function input-stream))
3849
3850	(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
3851	(apply (first list) (cons input-stream (rest list))))
3852
3853	#-(or gcl2.6 genera)
3854	(defmethod slurp-input-stream ((output-stream stream) input-stream
3855	&key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
3856	(copy-stream-to-stream
3857	input-stream output-stream
3858	:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
3859
3860	(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
3861	(declare (ignorable x))
3862	(slurp-stream-string stream))
3863
3864	(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
3865	(declare (ignorable x))
3866	(slurp-stream-string stream))
3867
3868	(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
3869	(declare (ignorable x))
3870	(slurp-stream-lines stream :count count))
3871
3872	(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
3873	(declare (ignorable x))
3874	(slurp-stream-line stream :at at))
3875
3876	(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
3877	(declare (ignorable x))
3878	(slurp-stream-forms stream :count count))
3879
3880	(defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
3881	(declare (ignorable x))
3882	(slurp-stream-form stream :at at))
3883
3884	(defmethod slurp-input-stream (x stream
3885	&key linewise prefix (element-type 'character) buffer-size
3886	&allow-other-keys)
3887	(declare (ignorable stream linewise prefix element-type buffer-size))
3888	(cond
3889	#+(or gcl2.6 genera)
3890	((functionp x) (funcall x stream))
3891	#+(or gcl2.6 genera)
3892	((output-stream-p x)
3893	(copy-stream-to-stream
3894	input-stream output-stream
3895	:linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
3896	(t
3897	(error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
3898
3899
3900	;;;; ----- Running an external program -----
3901	;;; Simple variant of run-program with no input, and capturing output
3902	;;; On some implementations, may output to a temporary file...
3903	(with-upgradability ()
3904	(define-condition subprocess-error (error)
3905	((code :initform nil :initarg :code :reader subprocess-error-code)
3906	(command :initform nil :initarg :command :reader subprocess-error-command)
3907	(process :initform nil :initarg :process :reader subprocess-error-process))
3908	(:report (lambda (condition stream)
3909	(format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
3910	(subprocess-error-process condition)
3911	(subprocess-error-command condition)
3912	(subprocess-error-code condition)))))
3913
3914	(defun run-program (command
3915	&key output ignore-error-status force-shell
3916	(element-type default-stream-element-type)
3917	(external-format :default)
3918	&allow-other-keys)
3919	"Run program specified by COMMAND,
3920	either a list of strings specifying a program and list of arguments,
3921	or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
3922	have its output processed by the OUTPUT processor function
3923	as per SLURP-INPUT-STREAM,
3924	or merely output to the inherited standard output if it's NIL.
3925	Always call a shell (rather than directly execute the command)
3926	if FORCE-SHELL is specified.
3927	Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
3928	is specified.
3929	Return the exit status code of the process that was called.
3930	Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
3931	(declare (ignorable ignore-error-status element-type external-format))
3932	#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
3933	(error "RUN-PROGRAM not implemented for this Lisp")
3934	(labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
3935	(run-program (command &key pipe interactive)
3936	"runs the specified command (a list of program and arguments).
3937	If using a pipe, returns two values: process and stream
3938	If not using a pipe, returns one values: the process result;
3939	also, inherits the output stream."
3940	;; NB: these implementations have unix vs windows set at compile-time.
3941	(assert (not (and pipe interactive)))
3942	(let* ((wait (not pipe))
3943	#-(and clisp os-windows)
3944	(command
3945	(etypecase command
3946	#+os-unix (string `("/bin/sh" "-c" ,command))
3947	#+os-unix (list command)
3948	#+os-windows
3949	(string
3950	;; NB: We do NOT add cmd /c here. You might want to.
3951	#+allegro command
3952	;; On ClozureCL for Windows, we assume you are using
3953	;; r15398 or later in 1.9 or later,
3954	;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
3955	#+clozure (cons "cmd" (strcat "/c " command))
3956	;; NB: On other Windows implementations, this is utterly bogus
3957	;; except in the most trivial cases where no quoting is needed.
3958	;; Use at your own risk.
3959	#-(or allegro clozure) (list "cmd" "/c" command))
3960	#+os-windows
3961	(list
3962	#+(or allegro clozure) (escape-windows-command command)
3963	#-(or allegro clozure) command)))
3964	#+(and clozure os-windows) (command (list command))
3965	(process*
3966	(multiple-value-list
3967	#+allegro
3968	(excl:run-shell-command
3969	#+os-unix (coerce (cons (first command) command) 'vector)
3970	#+os-windows command
3971	:input interactive :output (or (and pipe :stream) interactive) :wait wait
3972	#+os-windows :show-window #+os-windows (and pipe :hide))
3973	#+clisp
3974	(flet ((run (f &rest args)
3975	(apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
3976	,(if pipe :stream :terminal)))))
3977	(etypecase command
3978	#+os-windows (run 'ext:run-shell-command command)
3979	(list (run 'ext:run-program (car command)
3980	:arguments (cdr command)))))
3981	#+lispworks
3982	(system:run-shell-command
3983	(cons "/usr/bin/env" command) ; lispworks wants a full path.
3984	:input interactive :output (or (and pipe :stream) interactive)
3985	:wait wait :save-exit-status (and pipe t))
3986	#+(or clozure cmu ecl sbcl scl)
3987	(#+(or cmu ecl scl) ext:run-program
3988	#+clozure ccl:run-program
3989	#+sbcl sb-ext:run-program
3990	(car command) (cdr command)
3991	:input interactive :wait wait
3992	:output (if pipe :stream t)
3993	. #.(append
3994	#+(or clozure cmu ecl sbcl scl) '(:error t)
3995	;; note: :external-format requires a recent SBCL
3996	#+sbcl '(:search t :external-format external-format)))))
3997	(process
3998	#+(or allegro lispworks) (if pipe (third process) (first process))
3999	#+ecl (third process*)
4000	#-(or allegro lispworks ecl) (first process*))
4001	(stream
4002	(when pipe
4003	#+(or allegro lispworks ecl) (first process*)
4004	#+clisp (first process*)
4005	#+clozure (ccl::external-process-output process)
4006	#+(or cmu scl) (ext:process-output process)
4007	#+sbcl (sb-ext:process-output process))))
4008	(values process stream)))
4009	#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
4010	(process-result (process pipe)
4011	(declare (ignorable pipe))
4012	;; 1- wait
4013	#+(and clozure os-unix) (ccl::external-process-wait process)
4014	#+(or cmu scl) (ext:process-wait process)
4015	#+(and ecl os-unix) (ext:external-process-wait process)
4016	#+sbcl (sb-ext:process-wait process)
4017	;; 2- extract result
4018	#+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
4019	#+clisp process
4020	#+clozure (nth-value 1 (ccl:external-process-status process))
4021	#+(or cmu scl) (ext:process-exit-code process)
4022	#+ecl (nth-value 1 (ext:external-process-status process))
4023	#+lispworks (if pipe (system:pid-exit-status process :wait t) process)
4024	#+sbcl (sb-ext:process-exit-code process))
4025	(check-result (exit-code process)
4026	#+clisp
4027	(setf exit-code
4028	(typecase exit-code (integer exit-code) (null 0) (t -1)))
4029	(unless (or ignore-error-status
4030	(equal exit-code 0))
4031	(error 'subprocess-error :command command :code exit-code :process process))
4032	exit-code)
4033	(use-run-program ()
4034	#-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
4035	(let* ((interactive (eq output :interactive))
4036	(pipe (and output (not interactive))))
4037	(multiple-value-bind (process stream)
4038	(run-program command :pipe pipe :interactive interactive)
4039	(if (and output (not interactive))
4040	(unwind-protect
4041	(slurp-input-stream output stream)
4042	(when stream (close stream))
4043	(check-result (process-result process pipe) process))
4044	(unwind-protect
4045	(check-result
4046	#+(or allegro lispworks) ; when not capturing, returns the exit code!
4047	process
4048	#-(or allegro lispworks) (process-result process pipe)
4049	process))))))
4050	(system-command (command)
4051	(etypecase command
4052	(string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
4053	(list (escape-shell-command
4054	(if (os-unix-p) (cons "exec" command) command)))))
4055	(redirected-system-command (command out)
4056	(format nil (if (os-unix-p) "exec > ~~A ; ~2:~A" "~A > ~A")
4057	(system-command command) (native-namestring out)))
4058	(system (command &key interactive)
4059	(declare (ignorable interactive))
4060	#+(or abcl xcl) (ext:run-shell-command command)
4061	#+allegro
4062	(excl:run-shell-command command :input interactive :output interactive :wait t)
4063	#+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
4064	(process-result (run-program command :pipe nil :interactive interactive) nil)
4065	#+ecl (ext:system command)
4066	#+cormanlisp (win32:system command)
4067	#+gcl (lisp:system command)
4068	#+(and lispworks os-windows)
4069	(system:call-system-showing-output
4070	command :show-cmd interactive :prefix "" :output-stream nil)
4071	#+mcl (ccl::with-cstrs ((%command command)) (_system %command))
4072	#+mkcl (nth-value 2
4073	(mkcl:run-program #+windows command #+windows ()
4074	#-windows "/bin/sh" (list "-c" command)
4075	:input nil :output nil)))
4076	(call-system (command-string &key interactive)
4077	(check-result (system command-string :interactive interactive) nil))
4078	(use-system ()
4079	(let ((interactive (eq output :interactive)))
4080	(if (and output (not interactive))
4081	(with-temporary-file (:pathname tmp :direction :output)
4082	(call-system (redirected-system-command command tmp))
4083	(with-open-file (stream tmp
4084	:direction :input
4085	:if-does-not-exist :error
4086	:element-type element-type
4087	#-gcl2.6 :external-format #-gcl2.6 external-format)
4088	(slurp-input-stream output stream)))
4089	(call-system (system-command command) :interactive interactive)))))
4090	(if (and (not force-shell)
4091	#+(or clisp ecl) ignore-error-status
4092	#+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
4093	(use-run-program)
4094	(use-system)))))
4095
4096	;;;; -------------------------------------------------------------------------
4097	;;;; Support to build (compile and load) Lisp files
4098
4099	(uiop/package:define-package :uiop/lisp-build
4100	(:nicknames :asdf/lisp-build)
4101	(:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
4102	(:use :uiop/common-lisp :uiop/package :uiop/utility
4103	:uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
4104	(:export
4105	;; Variables
4106	#:compile-file-warnings-behaviour #:compile-file-failure-behaviour
4107	#:output-translation-function
4108	#:optimization-settings #:previous-optimization-settings
4109	#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
4110	#:compile-warned-warning #:compile-failed-warning
4111	#:check-lisp-compile-results #:check-lisp-compile-warnings
4112	#:uninteresting-compiler-conditions #:uninteresting-loader-conditions
4113	;; Functions & Macros
4114	#:get-optimization-settings #:proclaim-optimization-settings
4115	#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
4116	#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
4117	#:reify-simple-sexp #:unreify-simple-sexp
4118	#:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
4119	#:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
4120	#:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:warnings-file-type
4121	#:enable-deferred-warnings-check #:disable-deferred-warnings-check
4122	#:current-lisp-file-pathname #:load-pathname
4123	#:lispize-pathname #:compile-file-type #:call-around-hook
4124	#:compile-file* #:compile-file-pathname*
4125	#:load* #:load-from-string #:combine-fasls)
4126	(:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
4127	(in-package :uiop/lisp-build)
4128
4129	(with-upgradability ()
4130	(defvar compile-file-warnings-behaviour
4131	(or #+clisp :ignore :warn)
4132	"How should ASDF react if it encounters a warning when compiling a file?
4133	Valid values are :error, :warn, and :ignore.")
4134
4135	(defvar compile-file-failure-behaviour
4136	(or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
4137	"How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
4138	when compiling a file, which includes any non-style-warning warning.
4139	Valid values are :error, :warn, and :ignore.
4140	Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
4141
4142
4143	;;; Optimization settings
4144	(with-upgradability ()
4145	(defvar optimization-settings nil)
4146	(defvar previous-optimization-settings nil)
4147	(defun get-optimization-settings ()
4148	"Get current compiler optimization settings, ready to PROCLAIM again"
4149	(let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
4150	#-(or clisp clozure cmu ecl sbcl scl)
4151	(warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
4152	#.`(loop :for x :in settings
4153	,@(or #+clozure '(:for v :in '(ccl::nx-speed ccl::nx-space ccl::nx-safety ccl::nx-debug ccl::nx-cspeed))
4154	#+ecl '(:for v :in '(c::speed c::space c::safety c::debug))
4155	#+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
4156	:for y = (or #+clisp (gethash x system::optimize)
4157	#+(or clozure ecl) (symbol-value v)
4158	#+(or cmu scl) (funcall f c::default-cookie)
4159	#+sbcl (cdr (assoc x sb-c::policy)))
4160	:when y :collect (list x y))))
4161	(defun proclaim-optimization-settings ()
4162	"Proclaim the optimization settings in OPTIMIZATION-SETTINGS"
4163	(proclaim `(optimize ,@optimization-settings))
4164	(let ((settings (get-optimization-settings)))
4165	(unless (equal previous-optimization-settings settings)
4166	(setf previous-optimization-settings settings)))))
4167
4168
4169	;;; Condition control
4170	(with-upgradability ()
4171	#+sbcl
4172	(progn
4173	(defun sb-grovel-unknown-constant-condition-p (c)
4174	(and (typep c 'sb-int:simple-style-warning)
4175	(string-enclosed-p
4176	"Couldn't grovel for "
4177	(simple-condition-format-control c)
4178	" (unknown to the C compiler).")))
4179	(deftype sb-grovel-unknown-constant-condition ()
4180	'(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
4181
4182	(defvar uninteresting-compiler-conditions
4183	(append
4184	;;#+clozure '(ccl:compiler-warning)
4185	#+cmu '("Deleting unreachable code.")
4186	#+lispworks '("~S being redefined in ~A (previously in ~A)."
4187	"~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4188	#+sbcl
4189	'(sb-c::simple-compiler-note
4190	"&OPTIONAL and &KEY found in the same lambda list: ~S"
4191	sb-int:package-at-variance
4192	sb-kernel:uninteresting-redefinition
4193	sb-kernel:undefined-alien-style-warning
4194	;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
4195	#+sb-eval sb-kernel:lexical-environment-too-complex
4196	sb-grovel-unknown-constant-condition ; defined above.
4197	;; BEWARE: the below four are controversial to include here.
4198	sb-kernel:redefinition-with-defun
4199	sb-kernel:redefinition-with-defgeneric
4200	sb-kernel:redefinition-with-defmethod
4201	sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
4202	'("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
4203	"Conditions that may be skipped while compiling")
4204
4205	(defvar uninteresting-loader-conditions
4206	(append
4207	'("Overwriting already existing readtable ~S." ;; from named-readtables
4208	#(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
4209	#+clisp '(clos::simple-gf-replacing-method-warning))
4210	"Additional conditions that may be skipped while loading"))
4211
4212	;;;; ----- Filtering conditions while building -----
4213	(with-upgradability ()
4214	(defun call-with-muffled-compiler-conditions (thunk)
4215	(call-with-muffled-conditions
4216	thunk uninteresting-compiler-conditions))
4217	(defmacro with-muffled-compiler-conditions ((&optional) &body body)
4218	"Run BODY where uninteresting compiler conditions are muffled"
4219	`(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
4220	(defun call-with-muffled-loader-conditions (thunk)
4221	(call-with-muffled-conditions
4222	thunk (append uninteresting-compiler-conditions uninteresting-loader-conditions)))
4223	(defmacro with-muffled-loader-conditions ((&optional) &body body)
4224	"Run BODY where uninteresting compiler and additional loader conditions are muffled"
4225	`(call-with-muffled-loader-conditions #'(lambda () ,@body))))
4226
4227
4228	;;;; Handle warnings and failures
4229	(with-upgradability ()
4230	(define-condition compile-condition (condition)
4231	((context-format
4232	:initform nil :reader compile-condition-context-format :initarg :context-format)
4233	(context-arguments
4234	:initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
4235	(description
4236	:initform nil :reader compile-condition-description :initarg :description))
4237	(:report (lambda (c s)
4238	(format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
4239	(or (compile-condition-description c) (type-of c))
4240	(compile-condition-context-format c)
4241	(compile-condition-context-arguments c)))))
4242	(define-condition compile-file-error (compile-condition error) ())
4243	(define-condition compile-warned-warning (compile-condition warning) ())
4244	(define-condition compile-warned-error (compile-condition error) ())
4245	(define-condition compile-failed-warning (compile-condition warning) ())
4246	(define-condition compile-failed-error (compile-condition error) ())
4247
4248	(defun check-lisp-compile-warnings (warnings-p failure-p
4249	&optional context-format context-arguments)
4250	(when failure-p
4251	(case compile-file-failure-behaviour
4252	(:warn (warn 'compile-failed-warning
4253	:description "Lisp compilation failed"
4254	:context-format context-format
4255	:context-arguments context-arguments))
4256	(:error (error 'compile-failed-error
4257	:description "Lisp compilation failed"
4258	:context-format context-format
4259	:context-arguments context-arguments))
4260	(:ignore nil)))
4261	(when warnings-p
4262	(case compile-file-warnings-behaviour
4263	(:warn (warn 'compile-warned-warning
4264	:description "Lisp compilation had style-warnings"
4265	:context-format context-format
4266	:context-arguments context-arguments))
4267	(:error (error 'compile-warned-error
4268	:description "Lisp compilation had style-warnings"
4269	:context-format context-format
4270	:context-arguments context-arguments))
4271	(:ignore nil))))
4272
4273	(defun check-lisp-compile-results (output warnings-p failure-p
4274	&optional context-format context-arguments)
4275	(unless output
4276	(error 'compile-file-error :context-format context-format :context-arguments context-arguments))
4277	(check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
4278
4279
4280	;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
4281	;;;
4282	;;; To support an implementation, three functions must be implemented:
4283	;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
4284	;;; See their respective docstrings.
4285	(with-upgradability ()
4286	(defun reify-simple-sexp (sexp)
4287	(etypecase sexp
4288	(symbol (reify-symbol sexp))
4289	((or number character simple-string pathname) sexp)
4290	(cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
4291	(simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
4292
4293	(defun unreify-simple-sexp (sexp)
4294	(etypecase sexp
4295	((or symbol number character simple-string pathname) sexp)
4296	(cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
4297	((simple-vector 2) (unreify-symbol sexp))
4298	((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
4299
4300	#+clozure
4301	(progn
4302	(defun reify-source-note (source-note)
4303	(when source-note
4304	(with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
4305	(start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
4306	(declare (ignorable source))
4307	(list :filename filename :start-pos start-pos :end-pos end-pos
4308	#\|:source (reify-source-note source)\|#))))
4309	(defun unreify-source-note (source-note)
4310	(when source-note
4311	(destructuring-bind (&key filename start-pos end-pos source) source-note
4312	(ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
4313	:source (unreify-source-note source)))))
4314	(defun unsymbolify-function-name (name)
4315	(if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
4316	`(setf ,setfed)
4317	name))
4318	(defun symbolify-function-name (name)
4319	(if (and (consp name) (eq (first name) 'setf))
4320	(let ((setfed (second name)))
4321	(gethash setfed ccl::%setf-function-names%))
4322	name))
4323	(defun reify-function-name (function-name)
4324	(let ((name (or (first function-name) ;; defun: extract the name
4325	(first (second function-name))))) ;; defmethod: keep gf name, drop method specializers
4326	(list name)))
4327	(defun unreify-function-name (function-name)
4328	function-name)
4329	(defun reify-deferred-warning (deferred-warning)
4330	(with-accessors ((warning-type ccl::compiler-warning-warning-type)
4331	(args ccl::compiler-warning-args)
4332	(source-note ccl:compiler-warning-source-note)
4333	(function-name ccl:compiler-warning-function-name)) deferred-warning
4334	(list :warning-type warning-type :function-name (reify-function-name function-name)
4335	:source-note (reify-source-note source-note)
4336	:args (destructuring-bind (fun formals env) args
4337	(declare (ignorable env))
4338	(list (unsymbolify-function-name fun)
4339	(mapcar (constantly nil) formals)
4340	nil)))))
4341	(defun unreify-deferred-warning (reified-deferred-warning)
4342	(destructuring-bind (&key warning-type function-name source-note args)
4343	reified-deferred-warning
4344	(make-condition (or (cdr (ccl::assq warning-type ccl::compiler-whining-conditions))
4345	'ccl::compiler-warning)
4346	:function-name (unreify-function-name function-name)
4347	:source-note (unreify-source-note source-note)
4348	:warning-type warning-type
4349	:args (destructuring-bind (fun . formals) args
4350	(cons (symbolify-function-name fun) formals))))))
4351	#+(or cmu scl)
4352	(defun reify-undefined-warning (warning)
4353	;; Extracting undefined-warnings from the compilation-unit
4354	;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4355	(list*
4356	(c::undefined-warning-kind warning)
4357	(c::undefined-warning-name warning)
4358	(c::undefined-warning-count warning)
4359	(mapcar
4360	#'(lambda (frob)
4361	;; the lexenv slot can be ignored for reporting purposes
4362	`(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
4363	:source ,(c::compiler-error-context-source frob)
4364	:original-source ,(c::compiler-error-context-original-source frob)
4365	:context ,(c::compiler-error-context-context frob)
4366	:file-name ,(c::compiler-error-context-file-name frob) ; a pathname
4367	:file-position ,(c::compiler-error-context-file-position frob) ; an integer
4368	:original-source-path ,(c::compiler-error-context-original-source-path frob)))
4369	(c::undefined-warning-warnings warning))))
4370
4371	#+sbcl
4372	(defun reify-undefined-warning (warning)
4373	;; Extracting undefined-warnings from the compilation-unit
4374	;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4375	(list*
4376	(sb-c::undefined-warning-kind warning)
4377	(sb-c::undefined-warning-name warning)
4378	(sb-c::undefined-warning-count warning)
4379	(mapcar
4380	#'(lambda (frob)
4381	;; the lexenv slot can be ignored for reporting purposes
4382	`(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
4383	:source ,(sb-c::compiler-error-context-source frob)
4384	:original-source ,(sb-c::compiler-error-context-original-source frob)
4385	:context ,(sb-c::compiler-error-context-context frob)
4386	:file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
4387	:file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
4388	:original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
4389	(sb-c::undefined-warning-warnings warning))))
4390
4391	(defun reify-deferred-warnings ()
4392	"return a portable S-expression, portably readable and writeable in any Common Lisp implementation
4393	using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
4394	WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
4395	#+allegro
4396	(list :functions-defined excl::.functions-defined.
4397	:functions-called excl::.functions-called.)
4398	#+clozure
4399	(mapcar 'reify-deferred-warning
4400	(if-let (dw ccl::outstanding-deferred-warnings)
4401	(let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
4402	(ccl::deferred-warnings.warnings mdw))))
4403	#+(or cmu scl)
4404	(when lisp::in-compilation-unit
4405	;; Try to send nothing through the pipe if nothing needs to be accumulated
4406	`(,@(when c::undefined-warnings
4407	`((c::undefined-warnings
4408	,@(mapcar #'reify-undefined-warning c::undefined-warnings))))
4409	,@(loop :for what :in '(c::compiler-error-count
4410	c::compiler-warning-count
4411	c::compiler-note-count)
4412	:for value = (symbol-value what)
4413	:when (plusp value)
4414	:collect `(,what . ,value))))
4415	#+sbcl
4416	(when sb-c::in-compilation-unit
4417	;; Try to send nothing through the pipe if nothing needs to be accumulated
4418	`(,@(when sb-c::undefined-warnings
4419	`((sb-c::undefined-warnings
4420	,@(mapcar #'reify-undefined-warning sb-c::undefined-warnings))))
4421	,@(loop :for what :in '(sb-c::aborted-compilation-unit-count
4422	sb-c::compiler-error-count
4423	sb-c::compiler-warning-count
4424	sb-c::compiler-style-warning-count
4425	sb-c::compiler-note-count)
4426	:for value = (symbol-value what)
4427	:when (plusp value)
4428	:collect `(,what . ,value)))))
4429
4430	(defun unreify-deferred-warnings (reified-deferred-warnings)
4431	"given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
4432	deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
4433	Handle any warning that has been resolved already,
4434	such as an undefined function that has been defined since