2 ;;;; ---------------------------------------------------------------------------
3 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
5 ;; See https://bugs.launchpad.net/asdf/+bug/485687
8 (defpackage :uiop
/package
9 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
10 ;; This package definition MUST NOT change unless its name too changes;
11 ;; if/when it changes, don't forget to add new functions missing from below.
12 ;; Until then, uiop/package is frozen to forever
13 ;; import and export the same exact symbols as for ASDF 2.27.
14 ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
17 #:find-package
* #:find-symbol
* #:symbol-call
18 #:intern
* #:export
* #:import
* #:shadowing-import
* #:shadow
* #:make-symbol
* #:unintern
*
19 #:symbol-shadowing-p
#:home-package-p
20 #:symbol-package-name
#:standard-common-lisp-symbol-p
21 #:reify-package
#:unreify-package
#:reify-symbol
#:unreify-symbol
22 #:nuke-symbol-in-package
#:nuke-symbol
#:rehome-symbol
23 #:ensure-package-unused
#:delete-package
*
24 #:package-names
#:packages-from-names
#:fresh-package-name
#:rename-package-away
25 #:package-definition-form
#:parse-define-package-form
26 #:ensure-package
#:define-package
))
28 (in-package :uiop
/package
)
30 ;;;; General purpose package utilities
32 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
33 (defun find-package* (package-designator &optional
(error t
))
34 (let ((package (find-package package-designator
)))
37 (error (error "No package named ~S" (string package-designator
)))
39 (defun find-symbol* (name package-designator
&optional
(error t
))
40 "Find a symbol in a package of given string'ified NAME;
41 unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
42 by letting you supply a symbol or keyword for the name;
43 also works well when the package is not present.
44 If optional ERROR argument is NIL, return NIL instead of an error
45 when the symbol is not found."
47 (let ((package (find-package* package-designator error
)))
48 (when package
;; package error handled by find-package* already
49 (multiple-value-bind (symbol status
) (find-symbol (string name
) package
)
51 (status (return (values symbol status
)))
52 (error (error "There is no symbol ~S in package ~S" name
(package-name package
))))))
54 (defun symbol-call (package name
&rest args
)
55 "Call a function associated with symbol of given name in given package,
56 with given ARGS. Useful when the call is read before the package is loaded,
57 or when loading the package is optional."
58 (apply (find-symbol* name package
) args
))
59 (defun intern* (name package-designator
&optional
(error t
))
60 (intern (string name
) (find-package* package-designator error
)))
61 (defun export* (name package-designator
)
62 (let* ((package (find-package* package-designator
))
63 (symbol (intern* name package
)))
64 (export (or symbol
(list symbol
)) package
)))
65 (defun import* (symbol package-designator
)
66 (import (or symbol
(list symbol
)) (find-package* package-designator
)))
67 (defun shadowing-import* (symbol package-designator
)
68 (shadowing-import (or symbol
(list symbol
)) (find-package* package-designator
)))
69 (defun shadow* (name package-designator
)
70 (shadow (list (string name
)) (find-package* package-designator
)))
71 (defun make-symbol* (name)
73 (string (make-symbol name
))
74 (symbol (copy-symbol name
))))
75 (defun unintern* (name package-designator
&optional
(error t
))
77 (let ((package (find-package* package-designator error
)))
79 (multiple-value-bind (symbol status
) (find-symbol* name package error
)
81 (status (unintern symbol package
)
82 (return (values symbol status
)))
83 (error (error "symbol ~A not present in package ~A"
84 (string symbol
) (package-name package
))))))
86 (defun symbol-shadowing-p (symbol package
)
87 (and (member symbol
(package-shadowing-symbols package
)) t
))
88 (defun home-package-p (symbol package
)
89 (and package
(let ((sp (symbol-package symbol
)))
90 (and sp
(let ((pp (find-package* package
)))
91 (and pp
(eq sp pp
))))))))
94 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
95 (defun symbol-package-name (symbol)
96 (let ((package (symbol-package symbol
)))
97 (and package
(package-name package
))))
98 (defun standard-common-lisp-symbol-p (symbol)
99 (multiple-value-bind (sym status
) (find-symbol* symbol
:common-lisp nil
)
100 (and (eq sym symbol
) (eq status
:external
))))
101 (defun reify-package (package &optional package-context
)
102 (if (eq package package-context
) t
105 ((eql (find-package :cl
)) :cl
)
106 (package (package-name package
)))))
107 (defun unreify-package (package &optional package-context
)
110 ((eql t
) package-context
)
111 ((or symbol string
) (find-package package
))))
112 (defun reify-symbol (symbol &optional package-context
)
114 ((or keyword
(satisfies standard-common-lisp-symbol-p
)) symbol
)
115 (symbol (vector (symbol-name symbol
)
116 (reify-package (symbol-package symbol
) package-context
)))))
117 (defun unreify-symbol (symbol &optional package-context
)
121 (let* ((symbol-name (svref symbol
0))
122 (package-foo (svref symbol
1))
123 (package (unreify-package package-foo package-context
)))
124 (if package
(intern* symbol-name package
)
125 (make-symbol* symbol-name
)))))))
127 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
128 (defvar *all-package-happiness
* '())
129 (defvar *all-package-fishiness
* (list t
))
130 (defun record-fishy (info)
131 ;;(format t "~&FISHY: ~S~%" info)
132 (push info
*all-package-fishiness
*))
133 (defmacro when-package-fishiness
(&body body
)
134 `(when *all-package-fishiness
* ,@body
))
135 (defmacro note-package-fishiness
(&rest info
)
136 `(when-package-fishiness (record-fishy (list ,@info
)))))
138 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
140 (defun get-setf-function-symbol (symbol)
141 #+clisp
(let ((sym (get symbol
'system
::setf-function
)))
142 (if sym
(values sym
:setf-function
)
143 (let ((sym (get symbol
'system
::setf-expander
)))
144 (if sym
(values sym
:setf-expander
)
146 #+clozure
(gethash symbol ccl
::%setf-function-names%
))
148 (defun set-setf-function-symbol (new-setf-symbol symbol
&optional kind
)
149 #+clisp
(assert (member kind
'(:setf-function
:setf-expander
)))
150 #+clozure
(assert (eq kind t
))
153 ((null new-setf-symbol
)
154 (remprop symbol
'system
::setf-function
)
155 (remprop symbol
'system
::setf-expander
))
156 ((eq kind
:setf-function
)
157 (setf (get symbol
'system
::setf-function
) new-setf-symbol
))
158 ((eq kind
:setf-expander
)
159 (setf (get symbol
'system
::setf-expander
) new-setf-symbol
))
160 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
161 kind symbol new-setf-symbol
)))
164 (gethash symbol ccl
::%setf-function-names%
) new-setf-symbol
165 (gethash new-setf-symbol ccl
::%setf-function-name-inverses%
) symbol
))
167 (defun create-setf-function-symbol (symbol)
168 #+clisp
(system::setf-symbol symbol
)
169 #+clozure
(ccl::construct-setf-function-name symbol
))
170 (defun set-dummy-symbol (symbol reason other-symbol
)
171 (setf (get symbol
'dummy-symbol
) (cons reason other-symbol
)))
172 (defun make-dummy-symbol (symbol)
173 (let ((dummy (copy-symbol symbol
)))
174 (set-dummy-symbol dummy
'replacing symbol
)
175 (set-dummy-symbol symbol
'replaced-by dummy
)
177 (defun dummy-symbol (symbol)
178 (get symbol
'dummy-symbol
))
179 (defun get-dummy-symbol (symbol)
180 (let ((existing (dummy-symbol symbol
)))
181 (if existing
(values (cdr existing
) (car existing
))
182 (make-dummy-symbol symbol
))))
183 (defun nuke-symbol-in-package (symbol package-designator
)
184 (let ((package (find-package* package-designator
))
185 (name (symbol-name symbol
)))
186 (multiple-value-bind (sym stat
) (find-symbol name package
)
187 (when (and (member stat
'(:internal
:external
)) (eq symbol sym
))
188 (if (symbol-shadowing-p symbol package
)
189 (shadowing-import* (get-dummy-symbol symbol
) package
)
190 (unintern* symbol package
))))))
191 (defun nuke-symbol (symbol &optional
(packages (list-all-packages)))
193 (multiple-value-bind (setf-symbol kind
)
194 (get-setf-function-symbol symbol
)
195 (when kind
(nuke-symbol setf-symbol
)))
196 (loop :for p
:in packages
:do
(nuke-symbol-in-package symbol p
)))
197 (defun rehome-symbol (symbol package-designator
)
198 "Changes the home package of a symbol, also leaving it present in its old home if any"
199 (let* ((name (symbol-name symbol
))
200 (package (find-package* package-designator
))
201 (old-package (symbol-package symbol
))
202 (old-status (and old-package
(nth-value 1 (find-symbol name old-package
))))
203 (shadowing (and old-package
(symbol-shadowing-p symbol old-package
) (make-symbol name
))))
204 (multiple-value-bind (overwritten-symbol overwritten-symbol-status
) (find-symbol name package
)
205 (unless (eq package old-package
)
206 (let ((overwritten-symbol-shadowing-p
207 (and overwritten-symbol-status
208 (symbol-shadowing-p overwritten-symbol package
))))
209 (note-package-fishiness
211 (when old-package
(package-name old-package
)) old-status
(and shadowing t
)
212 (package-name package
) overwritten-symbol-status overwritten-symbol-shadowing-p
)
215 (shadowing-import* shadowing old-package
))
216 (unintern* symbol old-package
))
218 (overwritten-symbol-shadowing-p
219 (shadowing-import* symbol package
))
221 (when overwritten-symbol-status
222 (unintern* overwritten-symbol package
))
223 (import* symbol package
)))
225 (shadowing-import* symbol old-package
)
226 (import* symbol old-package
))
228 (multiple-value-bind (setf-symbol kind
)
229 (get-setf-function-symbol symbol
)
231 (let* ((setf-function (fdefinition setf-symbol
))
232 (new-setf-symbol (create-setf-function-symbol symbol
)))
233 (note-package-fishiness
235 name
(package-name package
)
236 (symbol-name setf-symbol
) (symbol-package-name setf-symbol
)
237 (symbol-name new-setf-symbol
) (symbol-package-name new-setf-symbol
))
238 (when (symbol-package setf-symbol
)
239 (unintern* setf-symbol
(symbol-package setf-symbol
)))
240 (setf (fdefinition new-setf-symbol
) setf-function
)
241 (set-setf-function-symbol new-setf-symbol symbol kind
))))
243 (multiple-value-bind (overwritten-setf foundp
)
244 (get-setf-function-symbol overwritten-symbol
)
246 (unintern overwritten-setf
)))
247 (when (eq old-status
:external
)
248 (export* symbol old-package
))
249 (when (eq overwritten-symbol-status
:external
)
250 (export* symbol package
))))
251 (values overwritten-symbol overwritten-symbol-status
))))
252 (defun ensure-package-unused (package)
253 (loop :for p
:in
(package-used-by-list package
) :do
254 (unuse-package package p
)))
255 (defun delete-package* (package &key nuke
)
256 (let ((p (find-package package
)))
258 (when nuke
(do-symbols (s p
) (when (home-package-p s p
) (nuke-symbol s
))))
259 (ensure-package-unused p
)
260 (delete-package package
))))
261 (defun package-names (package)
262 (cons (package-name package
) (package-nicknames package
)))
263 (defun packages-from-names (names)
264 (remove-duplicates (remove nil
(mapcar #'find-package names
)) :from-end t
))
265 (defun fresh-package-name (&key
(prefix :%TO-BE-DELETED
)
267 (index (random most-positive-fixnum
)))
268 (loop :for i
:from index
269 :for n
= (format nil
"~A~@[~A~D~]" prefix
(and (plusp i
) (or separator
"")) i
)
270 :thereis
(and (not (find-package n
)) n
)))
271 (defun rename-package-away (p &rest keys
&key prefix
&allow-other-keys
)
273 (apply 'fresh-package-name
274 :prefix
(or prefix
(format nil
"__~A__" (package-name p
))) keys
)))
275 (record-fishy (list :rename-away
(package-names p
) new-name
))
276 (rename-package p new-name
))))
279 ;;; Communicable representation of symbol and package information
281 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
282 (defun package-definition-form (package-designator
283 &key
(nicknamesp t
) (usep t
)
284 (shadowp t
) (shadowing-import-p t
)
285 (exportp t
) (importp t
) internp
(error t
))
286 (let* ((package (or (find-package* package-designator error
)
287 (return-from package-definition-form nil
)))
288 (name (package-name package
))
289 (nicknames (package-nicknames package
))
290 (use (mapcar #'package-name
(package-use-list package
)))
292 (shadowing-import (make-hash-table :test
'equal
))
293 (import (make-hash-table :test
'equal
))
297 (loop :for sym
:being
:the
:symbols
:in package
298 :for status
= (nth-value 1 (find-symbol* sym package
)) :do
301 ((:internal
:external
)
302 (let* ((name (symbol-name sym
))
303 (external (eq status
:external
))
304 (home (symbol-package sym
))
305 (home-name (package-name home
))
306 (imported (not (eq home package
)))
307 (shadowing (symbol-shadowing-p sym package
)))
309 ((and shadowing imported
)
310 (push name
(gethash home-name shadowing-import
)))
314 (push name
(gethash home-name import
))))
319 (t (push name intern
)))))))
320 (labels ((sort-names (names)
321 (sort (copy-list names
) #'string
<))
323 (loop :for k
:being
:the
:hash-keys
:of table
:collect k
))
324 (when-relevant (key value
)
325 (when value
(list (cons key value
))))
326 (import-options (key table
)
327 (loop :for i
:in
(sort-names (table-keys table
))
328 :collect
`(,key
,i
,@(sort-names (gethash i table
))))))
330 ,@(when-relevant :nicknames
(and nicknamesp
(sort-names nicknames
)))
331 (:use
,@(and usep
(sort-names use
)))
332 ,@(when-relevant :shadow
(and shadowp
(sort-names shadow
)))
333 ,@(import-options :shadowing-import-from
(and shadowing-import-p shadowing-import
))
334 ,@(import-options :import-from
(and importp import
))
335 ,@(when-relevant :export
(and exportp
(sort-names export
)))
336 ,@(when-relevant :intern
(and internp
(sort-names intern
)))))))))
339 ;;; ensure-package, define-package
340 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
341 (defun ensure-shadowing-import (name to-package from-package shadowed imported
)
342 (check-type name string
)
343 (check-type to-package package
)
344 (check-type from-package package
)
345 (check-type shadowed hash-table
)
346 (check-type imported hash-table
)
347 (let ((import-me (find-symbol* name from-package
)))
348 (multiple-value-bind (existing status
) (find-symbol name to-package
)
350 ((gethash name shadowed
)
351 (unless (eq import-me existing
)
352 (error "Conflicting shadowings for ~A" name
)))
354 (setf (gethash name shadowed
) t
)
355 (setf (gethash name imported
) t
)
356 (unless (or (null status
)
357 (and (member status
'(:internal
:external
))
358 (eq existing import-me
)
359 (symbol-shadowing-p existing to-package
)))
360 (note-package-fishiness
361 :shadowing-import name
362 (package-name from-package
)
363 (or (home-package-p import-me from-package
) (symbol-package-name import-me
))
364 (package-name to-package
) status
365 (and status
(or (home-package-p existing to-package
) (symbol-package-name existing
)))))
366 (shadowing-import* import-me to-package
))))))
367 (defun ensure-imported (import-me into-package
&optional from-package
)
368 (check-type import-me symbol
)
369 (check-type into-package package
)
370 (check-type from-package
(or null package
))
371 (let ((name (symbol-name import-me
)))
372 (multiple-value-bind (existing status
) (find-symbol name into-package
)
375 (import* import-me into-package
))
376 ((eq import-me existing
))
378 (let ((shadowing-p (symbol-shadowing-p existing into-package
)))
379 (note-package-fishiness
380 :ensure-imported name
381 (and from-package
(package-name from-package
))
382 (or (home-package-p import-me from-package
) (symbol-package-name import-me
))
383 (package-name into-package
)
385 (and status
(or (home-package-p existing into-package
) (symbol-package-name existing
)))
388 ((or shadowing-p
(eq status
:inherited
))
389 (shadowing-import* import-me into-package
))
391 (unintern* existing into-package
)
392 (import* import-me into-package
))))))))
394 (defun ensure-import (name to-package from-package shadowed imported
)
395 (check-type name string
)
396 (check-type to-package package
)
397 (check-type from-package package
)
398 (check-type shadowed hash-table
)
399 (check-type imported hash-table
)
400 (multiple-value-bind (import-me import-status
) (find-symbol name from-package
)
401 (when (null import-status
)
402 (note-package-fishiness
403 :import-uninterned name
(package-name from-package
) (package-name to-package
))
404 (setf import-me
(intern* name from-package
)))
405 (multiple-value-bind (existing status
) (find-symbol name to-package
)
407 ((and imported
(gethash name imported
))
408 (unless (and status
(eq import-me existing
))
409 (error "Can't import ~S from both ~S and ~S"
410 name
(package-name (symbol-package existing
)) (package-name from-package
))))
411 ((gethash name shadowed
)
412 (error "Can't both shadow ~S and import it from ~S" name
(package-name from-package
)))
414 (setf (gethash name imported
) t
))))
415 (ensure-imported import-me to-package from-package
)))
416 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited
)
417 (check-type name string
)
418 (check-type symbol symbol
)
419 (check-type to-package package
)
420 (check-type from-package package
)
421 (check-type mixp
(member nil t
)) ; no cl:boolean on Genera
422 (check-type shadowed hash-table
)
423 (check-type imported hash-table
)
424 (check-type inherited hash-table
)
425 (multiple-value-bind (existing status
) (find-symbol name to-package
)
426 (let* ((sp (symbol-package symbol
))
427 (in (gethash name inherited
))
428 (xp (and status
(symbol-package existing
))))
430 (note-package-fishiness
431 :import-uninterned name
432 (package-name from-package
) (package-name to-package
) mixp
)
433 (import* symbol from-package
)
434 (setf sp
(package-name from-package
)))
436 ((gethash name shadowed
))
438 (unless (equal sp
(first in
))
440 (ensure-shadowing-import name to-package
(second in
) shadowed imported
)
441 (error "Can't inherit ~S from ~S, it is inherited from ~S"
442 name
(package-name sp
) (package-name (first in
))))))
443 ((gethash name imported
)
444 (unless (eq symbol existing
)
445 (error "Can't inherit ~S from ~S, it is imported from ~S"
446 name
(package-name sp
) (package-name xp
))))
448 (setf (gethash name inherited
) (list sp from-package
))
449 (when (and status
(not (eq sp xp
)))
450 (let ((shadowing (symbol-shadowing-p existing to-package
)))
451 (note-package-fishiness
453 (package-name from-package
)
454 (or (home-package-p symbol from-package
) (symbol-package-name symbol
))
455 (package-name to-package
)
456 (or (home-package-p existing to-package
) (symbol-package-name existing
)))
457 (if shadowing
(ensure-shadowing-import name to-package from-package shadowed imported
)
458 (unintern* existing to-package
)))))))))
459 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited
)
460 (check-type name string
)
461 (check-type symbol symbol
)
462 (check-type to-package package
)
463 (check-type from-package package
)
464 (check-type shadowed hash-table
)
465 (check-type imported hash-table
)
466 (check-type inherited hash-table
)
467 (unless (gethash name shadowed
)
468 (multiple-value-bind (existing status
) (find-symbol name to-package
)
469 (let* ((sp (symbol-package symbol
))
470 (im (gethash name imported
))
471 (in (gethash name inherited
)))
474 (and status
(eq symbol existing
))
475 (and in
(eq sp
(first in
))))
476 (ensure-inherited name symbol to-package from-package t shadowed imported inherited
))
478 (remhash name inherited
)
479 (ensure-shadowing-import name to-package
(second in
) shadowed imported
))
481 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
482 name
(package-name from-package
)
483 (home-package-p symbol from-package
) (symbol-package-name symbol
)
484 (package-name to-package
)
485 (home-package-p existing to-package
) (symbol-package-name existing
)))
487 (ensure-inherited name symbol to-package from-package t shadowed imported inherited
)))))))
489 (defun recycle-symbol (name recycle exported
)
490 ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
491 ;; packages, and a hash-table of names (strings) of symbols scheduled to be
492 ;; EXPORTED from the package being defined. It returns two values, the
493 ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
494 ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
495 ;; re-homing of the symbol, etc.
496 (check-type name string
)
497 (check-type recycle list
)
498 (check-type exported hash-table
)
499 (when (gethash name exported
) ;; don't bother recycling private symbols
500 (let (recycled foundp
)
501 (dolist (r recycle
(values recycled foundp
))
502 (multiple-value-bind (symbol status
) (find-symbol name r
)
503 (when (and status
(home-package-p symbol r
))
506 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
507 (note-package-fishiness :recycled-duplicate name
(package-name foundp
) (package-name r
)))
509 (setf recycled symbol foundp r
)))))))))
510 (defun symbol-recycled-p (sym recycle
)
511 (check-type sym symbol
)
512 (check-type recycle list
)
513 (and (member (symbol-package sym
) recycle
) t
))
514 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported
)
515 (check-type name string
)
516 (check-type package package
)
517 (check-type intern
(member nil t
)) ; no cl:boolean on Genera
518 (check-type shadowed hash-table
)
519 (check-type imported hash-table
)
520 (check-type inherited hash-table
)
521 (unless (or (gethash name shadowed
)
522 (gethash name imported
)
523 (gethash name inherited
))
524 (multiple-value-bind (existing status
)
525 (find-symbol name package
)
526 (multiple-value-bind (recycled previous
) (recycle-symbol name recycle exported
)
528 ((and status
(eq existing recycled
) (eq previous package
)))
530 (rehome-symbol recycled package
))
531 ((and status
(eq package
(symbol-package existing
))))
534 (note-package-fishiness
536 (reify-package (symbol-package existing
) package
)
540 (intern* name package
))))))))
541 (declaim (ftype (function (t t t
&optional t
) t
) ensure-exported
))
542 (defun ensure-exported-to-user (name symbol to-package
&optional recycle
)
543 (check-type name string
)
544 (check-type symbol symbol
)
545 (check-type to-package package
)
546 (check-type recycle list
)
547 (assert (equal name
(symbol-name symbol
)))
548 (multiple-value-bind (existing status
) (find-symbol name to-package
)
549 (unless (and status
(eq symbol existing
))
552 (let ((shadowing (symbol-shadowing-p existing to-package
))
553 (recycled (symbol-recycled-p existing recycle
)))
554 (unless (and shadowing
(not recycled
))
555 (note-package-fishiness
556 :ensure-export name
(symbol-package-name symbol
)
557 (package-name to-package
)
558 (or (home-package-p existing to-package
) (symbol-package-name existing
))
560 (if (or (eq status
:inherited
) shadowing
)
561 (shadowing-import* symbol to-package
)
562 (unintern existing to-package
))
564 (when (and accessible
(eq status
:external
))
565 (ensure-exported name symbol to-package recycle
))))))
566 (defun ensure-exported (name symbol from-package
&optional recycle
)
567 (dolist (to-package (package-used-by-list from-package
))
568 (ensure-exported-to-user name symbol to-package recycle
))
569 (unless (eq from-package
(symbol-package symbol
))
570 (ensure-imported symbol from-package
))
571 (export* name from-package
))
572 (defun ensure-export (name from-package
&optional recycle
)
573 (multiple-value-bind (symbol status
) (find-symbol* name from-package
)
574 (unless (eq status
:external
)
575 (ensure-exported name symbol from-package recycle
))))
576 (defun ensure-package (name &key
577 nicknames documentation use
578 shadow shadowing-import-from
579 import-from export intern
582 #+genera
(declare (ignore documentation
))
583 (let* ((package-name (string name
))
584 (nicknames (mapcar #'string nicknames
))
585 (names (cons package-name nicknames
))
586 (previous (packages-from-names names
))
587 (discarded (cdr previous
))
589 (package (or (first previous
) (make-package package-name
:nicknames nicknames
)))
590 (recycle (packages-from-names recycle
))
591 (use (mapcar 'find-package
* use
))
592 (mix (mapcar 'find-package
* mix
))
593 (reexport (mapcar 'find-package
* reexport
))
594 (shadow (mapcar 'string shadow
))
595 (export (mapcar 'string export
))
596 (intern (mapcar 'string intern
))
597 (unintern (mapcar 'string unintern
))
598 (shadowed (make-hash-table :test
'equal
)) ; string to bool
599 (imported (make-hash-table :test
'equal
)) ; string to bool
600 (exported (make-hash-table :test
'equal
)) ; string to bool
601 ;; string to list home package and use package:
602 (inherited (make-hash-table :test
'equal
)))
603 (when-package-fishiness (record-fishy package-name
))
605 (when documentation
(setf (documentation package t
) documentation
))
606 (loop :for p
:in
(set-difference (package-use-list package
) (append mix use
))
607 :do
(note-package-fishiness :over-use name
(package-names p
))
608 (unuse-package p package
))
609 (loop :for p
:in discarded
610 :for n
= (remove-if #'(lambda (x) (member x names
:test
'equal
))
612 :do
(note-package-fishiness :nickname name
(package-names p
))
613 (cond (n (rename-package p
(first n
) (rest n
)))
614 (t (rename-package-away p
)
615 (push p to-delete
))))
616 (rename-package package package-name nicknames
)
617 (dolist (name unintern
)
618 (multiple-value-bind (existing status
) (find-symbol name package
)
620 (unless (eq status
:inherited
)
621 (note-package-fishiness
622 :unintern
(package-name package
) name
(symbol-package-name existing
) status
)
623 (unintern* name package nil
)))))
624 (dolist (name export
)
625 (setf (gethash name exported
) t
))
627 (do-external-symbols (sym p
)
628 (setf (gethash (string sym
) exported
) t
)))
629 (do-external-symbols (sym package
)
630 (let ((name (symbol-name sym
)))
631 (unless (gethash name exported
)
632 (note-package-fishiness
633 :over-export
(package-name package
) name
634 (or (home-package-p sym package
) (symbol-package-name sym
)))
635 (unexport sym package
))))
636 (dolist (name shadow
)
637 (setf (gethash name shadowed
) t
)
638 (multiple-value-bind (existing status
) (find-symbol name package
)
639 (multiple-value-bind (recycled previous
) (recycle-symbol name recycle exported
)
640 (let ((shadowing (and status
(symbol-shadowing-p existing package
))))
642 ((eq previous package
))
644 (rehome-symbol recycled package
))
645 ((or (member status
'(nil :inherited
))
646 (home-package-p existing package
)))
648 (let ((dummy (make-symbol name
)))
649 (note-package-fishiness
650 :shadow-imported
(package-name package
) name
651 (symbol-package-name existing
) status shadowing
)
652 (shadowing-import* dummy package
)
653 (import* dummy package
)))))))
654 (shadow* name package
))
655 (loop :for
(p . syms
) :in shadowing-import-from
656 :for pp
= (find-package* p
) :do
657 (dolist (sym syms
) (ensure-shadowing-import (string sym
) package pp shadowed imported
)))
659 :for pp
= (find-package* p
) :do
660 (do-external-symbols (sym pp
) (ensure-mix (symbol-name sym
) sym package pp shadowed imported inherited
)))
661 (loop :for
(p . syms
) :in import-from
662 :for pp
= (find-package p
) :do
663 (dolist (sym syms
) (ensure-import (symbol-name sym
) package pp shadowed imported
)))
664 (dolist (p (append use mix
))
665 (do-external-symbols (sym p
) (ensure-inherited (string sym
) sym package p nil shadowed imported inherited
))
666 (use-package p package
))
667 (loop :for name
:being
:the
:hash-keys
:of exported
:do
668 (ensure-symbol name package t recycle shadowed imported inherited exported
)
669 (ensure-export name package recycle
))
670 (dolist (name intern
)
671 (ensure-symbol name package t recycle shadowed imported inherited exported
))
672 (do-symbols (sym package
)
673 (ensure-symbol (symbol-name sym
) package nil recycle shadowed imported inherited exported
))
674 (map () 'delete-package
* to-delete
)
677 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
678 (defun parse-define-package-form (package clauses
)
680 :with use-p
= nil
:with recycle-p
= nil
681 :with documentation
= nil
682 :for
(kw . args
) :in clauses
683 :when
(eq kw
:nicknames
) :append args
:into nicknames
:else
684 :when
(eq kw
:documentation
)
686 (documentation (error "define-package: can't define documentation twice"))
687 ((or (atom args
) (cdr args
)) (error "define-package: bad documentation"))
688 (t (setf documentation
(car args
)))) :else
689 :when
(eq kw
:use
) :append args
:into use
:and
:do
(setf use-p t
) :else
690 :when
(eq kw
:shadow
) :append args
:into shadow
:else
691 :when
(eq kw
:shadowing-import-from
) :collect args
:into shadowing-import-from
:else
692 :when
(eq kw
:import-from
) :collect args
:into import-from
:else
693 :when
(eq kw
:export
) :append args
:into export
:else
694 :when
(eq kw
:intern
) :append args
:into intern
:else
695 :when
(eq kw
:recycle
) :append args
:into recycle
:and
:do
(setf recycle-p t
) :else
696 :when
(eq kw
:mix
) :append args
:into mix
:else
697 :when
(eq kw
:reexport
) :append args
:into reexport
:else
698 :when
(eq kw
:use-reexport
) :append args
:into use
:and
:append args
:into reexport
699 :and
:do
(setf use-p t
) :else
700 :when
(eq kw
:mix-reexport
) :append args
:into mix
:and
:append args
:into reexport
701 :and
:do
(setf use-p t
) :else
702 :when
(eq kw
:unintern
) :append args
:into unintern
:else
703 :do
(error "unrecognized define-package keyword ~S" kw
)
704 :finally
(return `(,package
705 :nicknames
,nicknames
:documentation
,documentation
706 :use
,(if use-p use
'(:common-lisp
))
707 :shadow
,shadow
:shadowing-import-from
,shadowing-import-from
708 :import-from
,import-from
:export
,export
:intern
,intern
709 :recycle
,(if recycle-p recycle
(cons package nicknames
))
710 :mix
,mix
:reexport
,reexport
:unintern
,unintern
)))))
712 (defmacro define-package
(package &rest clauses
)
713 "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
715 DEFINE-PACKAGE supports the following keywords:
716 USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE.
717 RECYCLE -- Recycle the package's exported symbols from the specified packages,
718 in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
719 either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
720 one of the :RECYCLE packages, the first such symbol is re-homed to the package
722 For the sake of idempotence, it is important that the package being defined
723 should appear in first position if it already exists, and even if it doesn't,
724 ahead of any package that is not going to be deleted afterwards and never
725 created again. In short, except for special cases, always make it the first
726 package on the list if the list is not empty.
727 MIX -- Takes a list of package designators. MIX behaves like
728 \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
729 resolve conflicts in favor of the first found symbol. It may still yield
730 an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
731 REEXPORT -- Takes a list of package designators. For each package, p, in the list,
732 export symbols with the same name as those exported from p. Note that in the case
733 of shadowing, etc. the symbols with the same name may not be the same symbols.
734 UNINTERN -- Remove symbols here from PACKAGE."
736 `(apply 'ensure-package
',(parse-define-package-form package clauses
))))
738 #+(or clasp ecl gcl mkcl
) (defpackage ,package
(:use
))
739 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
742 ;;;; Final tricks to keep various implementations happy.
743 ;; We want most such tricks in common-lisp.lisp,
744 ;; but these need to be done before the define-package form there,
745 ;; that we nevertheless want to be the very first form.
746 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
747 #+allegro
;; We need to disable autoloading BEFORE any mention of package ASDF.
748 (setf excl
::*autoload-package-name-alist
*
749 (remove "asdf" excl
::*autoload-package-name-alist
*
750 :test
'equalp
:key
'car
)))
752 ;; Compatibility with whoever calls asdf/package
753 (define-package :asdf
/package
(:use
:cl
:uiop
/package
) (:reexport
:uiop
/package
))
754 ;;;; -------------------------------------------------------------------------
755 ;;;; Handle compatibility with multiple implementations.
756 ;;; This file is for papering over the deficiencies and peculiarities
757 ;;; of various Common Lisp implementations.
758 ;;; For implementation-specific access to the system, see os.lisp instead.
759 ;;; A few functions are defined here, but actually exported from utility;
760 ;;; from this package only common-lisp symbols are exported.
762 (uiop/package
:define-package
:uiop
/common-lisp
763 (:nicknames
:uoip
/cl
:asdf
/common-lisp
:asdf
/cl
)
765 (:use-reexport
#-genera
:common-lisp
#+genera
:future-common-lisp
)
766 (:recycle
:uiop
/common-lisp
:uoip
/cl
:asdf
/common-lisp
:asdf
/cl
:asdf
)
767 #+allegro
(:intern
#:*acl-warn-save
*)
768 #+cormanlisp
(:shadow
#:user-homedir-pathname
)
771 #:logical-pathname
#:translate-logical-pathname
772 #:make-broadcast-stream
#:file-namestring
)
773 #+genera
(:shadowing-import-from
:scl
#:boolean
)
774 #+genera
(:export
#:boolean
#:ensure-directories-exist
#:read-sequence
#:write-sequence
)
775 #+mcl
(:shadow
#:user-homedir-pathname
))
776 (in-package :uiop
/common-lisp
)
778 #-
(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
779 (error "ASDF is not supported on your implementation. Please help us port it.")
781 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
784 ;;;; Early meta-level tweaks
786 #+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl
)
787 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
788 ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
789 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
790 (when (and #+allegro
(member :ics
*features
*)
791 #+(or clasp clisp cmu ecl mkcl
) (member :unicode
*features
*)
792 #+sbcl
(member :sb-unicode
*features
*))
793 (pushnew :asdf-unicode
*features
*)))
796 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
797 (defparameter *acl-warn-save
*
798 (when (boundp 'excl
:*warn-on-nested-reader-conditionals
*)
799 excl
:*warn-on-nested-reader-conditionals
*))
800 (when (boundp 'excl
:*warn-on-nested-reader-conditionals
*)
801 (setf excl
:*warn-on-nested-reader-conditionals
* nil
))
802 (setf *print-readably
* nil
))
805 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
806 (setf *load-verbose
* nil
)
807 (defun use-ecl-byte-compiler-p () nil
))
809 #+clozure
(in-package :ccl
)
810 #+(and clozure windows-target
) ;; See http://trac.clozure.com/ccl/ticket/1117
811 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
812 (unless (fboundp 'external-process-wait
)
814 (defun external-process-wait (proc)
815 (when (and (external-process-pid proc
) (eq (external-process-%status proc
) :running
))
816 (with-interrupts-enabled
817 (wait-on-semaphore (external-process-completed proc
))))
818 (values (external-process-%exit-code proc
)
819 (external-process-%status proc
))))))
820 #+clozure
(in-package :uiop
/common-lisp
)
823 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
824 (deftype logical-pathname
() nil
)
825 (defun make-broadcast-stream () *error-output
*)
826 (defun translate-logical-pathname (x) x
)
827 (defun user-homedir-pathname (&optional host
)
828 (declare (ignore host
))
829 (parse-namestring (format nil
"~A\\" (cl:user-homedir-pathname
))))
830 (defun file-namestring (p)
831 (setf p
(pathname p
))
832 (format nil
"~@[~A~]~@[.~A~]" (pathname-name p
) (pathname-type p
))))
834 #+(and ecl
(not clasp
))
835 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
836 (setf *load-verbose
* nil
)
837 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp
*features
*) t
))
838 (unless (use-ecl-byte-compiler-p) (require :cmp
)))
841 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
842 (unless (member :ansi-cl
*features
*)
843 (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
844 (setf compiler
::*compiler-default-type
* (pathname "")
845 compiler
::*lsp-ext
* "")
846 #.
(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
849 ((or (< system
::*gcl-major-version
* 2)
850 (and (= system
::*gcl-major-version
* 2)
851 (< system
::*gcl-minor-version
* 7)))
852 '(error "GCL 2.7 or later required to use ASDF")))))
857 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
858 (unless (fboundp 'lambda
)
859 (defmacro lambda
(&whole form
&rest bvl-decls-and-body
)
860 (declare (ignore bvl-decls-and-body
)(zwei::indentation
1 1))
861 `#',(cons 'lisp
::lambda
(cdr form
))))
862 (unless (fboundp 'ensure-directories-exist
)
863 (defun ensure-directories-exist (path)
864 (fs:create-directories-recursively
(pathname path
))))
865 (unless (fboundp 'read-sequence
)
866 (defun read-sequence (sequence stream
&key
(start 0) end
)
867 (scl:send stream
:string-in nil sequence start end
)))
868 (unless (fboundp 'write-sequence
)
869 (defun write-sequence (sequence stream
&key
(start 0) end
)
870 (scl:send stream
:string-out sequence start end
)
873 #.
(or #+mcl
;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
875 "(eval-when (:load-toplevel :compile-toplevel :execute)
876 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
877 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
878 ;; Note: ASDF may expect user-homedir-pathname to provide
879 ;; the pathname of the current user's home directory, whereas
880 ;; MCL by default provides the directory from which MCL was started.
881 ;; See http://code.google.com/p/mcl/wiki/Portability
882 (defun user-homedir-pathname ()
883 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
884 (defun probe-posix (posix-namestring)
885 \"If a file exists for the posix namestring, return the pathname\"
886 (ccl::with-cstrs ((cpath posix-namestring))
887 (ccl::rlet ((is-dir :boolean)
889 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
890 (ccl::%path-from-fsref fsref is-dir))))))"))
893 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
895 (setq clos
::*redefine-class-in-place
* t
)) ;; Make sure we have strict ANSI class redefinition semantics
899 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
900 (defmacro loop
* (&rest rest
)
901 #-genera
`(loop ,@rest
)
902 #+genera
`(lisp:loop
,@rest
))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
905 ;;;; compatfmt: avoid fancy format directives when unsupported
906 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
907 (defun frob-substrings (string substrings
&optional frob
)
908 "for each substring in SUBSTRINGS, find occurrences of it within STRING
909 that don't use parts of matched occurrences of previous strings, and
910 FROB them, that is to say, remove them if FROB is NIL,
911 replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
912 call FROB with the match and a function that emits a string in the output.
913 Return a string made of the parts not omitted or emitted by FROB."
914 (declare (optimize (speed 0) (safety #-gcl
3 #+gcl
0) (debug 3)))
915 (let ((length (length string
)) (stream nil
))
916 (labels ((emit-string (x &optional
(start 0) (end (length x
)))
918 (unless stream
(setf stream
(make-string-output-stream)))
919 (write-string x stream
:start start
:end end
)))
920 (emit-substring (start end
)
921 (when (and (zerop start
) (= end length
))
922 (return-from frob-substrings string
))
923 (emit-string string start end
))
924 (recurse (substrings start end
)
927 ((null substrings
) (emit-substring start end
))
928 (t (let* ((sub-spec (first substrings
))
929 (sub (if (consp sub-spec
) (car sub-spec
) sub-spec
))
930 (fun (if (consp sub-spec
) (cdr sub-spec
) frob
))
931 (found (search sub string
:start2 start
:end2 end
))
932 (more (rest substrings
)))
935 (recurse more start found
)
938 (string (emit-string fun
))
939 (function (funcall fun sub
#'emit-string
)))
940 (recurse substrings
(+ found
(length sub
)) end
))
942 (recurse more start end
))))))))
943 (recurse substrings
0 length
))
944 (if stream
(get-output-stream-string stream
) "")))
946 (defmacro compatfmt
(format)
948 (frob-substrings format
`("~3i~_" #+genera
,@'("~@<" "~@;" "~@:>" "~:>")))
949 #-
(or gcl genera
) format
))
950 ;;;; -------------------------------------------------------------------------
951 ;;;; General Purpose Utilities for ASDF
953 (uiop/package
:define-package
:uiop
/utility
954 (:nicknames
:asdf
/utility
)
955 (:recycle
:uiop
/utility
:asdf
/utility
:asdf
)
956 (:use
:uiop
/common-lisp
:uiop
/package
)
957 ;; import and reexport a few things defined in :uiop/common-lisp
958 (:import-from
:uiop
/common-lisp
#:compatfmt
#:loop
* #:frob-substrings
959 #+(or clasp ecl
) #:use-ecl-byte-compiler-p
#+mcl
#:probe-posix
)
960 (:export
#:compatfmt
#:loop
* #:frob-substrings
#:compatfmt
961 #+(or clasp ecl
) #:use-ecl-byte-compiler-p
#+mcl
#:probe-posix
)
963 ;; magic helper to define debugging functions:
964 #:uiop-debug
#:load-uiop-debug-utility
#:*uiop-debug-utility
*
965 #:with-upgradability
;; (un)defining functions in an upgrade-friendly way
966 #:undefine-function
#:undefine-functions
#:defun
* #:defgeneric
*
967 #:nest
#:if-let
;; basic flow control
968 #:while-collecting
#:appendf
#:length
=n-p
#:ensure-list
;; lists
969 #:remove-plist-keys
#:remove-plist-key
;; plists
970 #:emptyp
;; sequences
971 #:+non-base-chars-exist-p
+ ;; characters
972 #:+max-character-type-index
+ #:character-type-index
#:+character-types
+
973 #:base-string-p
#:strings-common-element-type
#:reduce
/strcat
#:strcat
;; strings
974 #:first-char
#:last-char
#:split-string
#:stripln
#:+cr
+ #:+lf
+ #:+crlf
+
975 #:string-prefix-p
#:string-enclosed-p
#:string-suffix-p
976 #:standard-case-symbol-name
#:find-standard-case-symbol
977 #:coerce-class
;; CLOS
978 #:stamp
< #:stamps
< #:stamp
*< #:stamp
<= ;; stamps
979 #:earlier-stamp
#:stamps-earliest
#:earliest-stamp
980 #:later-stamp
#:stamps-latest
#:latest-stamp
#:latest-stamp-f
981 #:list-to-hash-set
#:ensure-gethash
;; hash-table
982 #:ensure-function
#:access-at
#:access-at-count
;; functions
983 #:call-function
#:call-functions
#:register-hook-function
984 #:match-condition-p
#:match-any-condition-p
;; conditions
985 #:call-with-muffled-conditions
#:with-muffled-conditions
986 #:lexicographic
< #:lexicographic
<=
987 #:parse-version
#:unparse-version
#:version
< #:version
<= #:version-compatible-p
)) ;; version
988 (in-package :uiop
/utility
)
990 ;;;; Defining functions in a way compatible with hot-upgrade:
991 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
992 ;; thus replacing the function without warning or error
993 ;; even if the signature and/or generic-ness of the function has changed.
994 ;; For a generic function, this invalidates any previous DEFMETHOD.
995 (eval-when (:load-toplevel
:compile-toplevel
:execute
)
996 (defun undefine-function (function-spec)
998 ((symbolp function-spec
)
999 ;; undefining the previous function is the portable way
1000 ;; of overriding any incompatible previous gf,
1001 ;; but CLISP needs extra help with getting rid of previous methods.
1003 (let ((f (and (fboundp function-spec
) (fdefinition function-spec
))))
1004 (when (typep f
'clos
:standard-generic-function
)
1005 (loop :for m
:in
(clos:generic-function-methods f
)
1006 :do
(remove-method f m
))))
1007 (fmakunbound function-spec
))
1008 ((and (consp function-spec
) (eq (car function-spec
) 'setf
)
1009 (consp (cdr function-spec
)) (null (cddr function-spec
)))
1010 (fmakunbound function-spec
))
1011 (t (error "bad function spec ~S" function-spec
))))
1012 (defun undefine-functions (function-spec-list)
1013 (map () 'undefine-function function-spec-list
))
1016 `(defmacro ,def
* (name formals
&rest rest
)
1017 (destructuring-bind (name &key
(supersede t
))
1018 (if (or (atom name
) (eq (car name
) 'setf
))
1019 (list name
:supersede nil
)
1021 (declare (ignorable supersede
))
1023 ;; We usually try to do it only for the functions that need it,
1024 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer.
1025 ,@(when (or supersede
#+(or clasp ecl
) t
)
1026 `((undefine-function ',name
)))
1027 ,@(when (and #+(or clasp ecl
) (symbolp name
)) ; fails for setf functions on ecl
1028 `((declaim (notinline ,name
))))
1029 (,',def
,name
,formals
,@rest
))))))
1030 (defdef defgeneric
* defgeneric
)
1031 (defdef defun
* defun
))
1032 (defmacro with-upgradability
((&optional
) &body body
)
1033 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
1034 to also declare the functions NOTINLINE and to accept a wrapping the function name
1035 specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
1036 is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
1037 to supersede any previous definition."
1038 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1039 ,@(loop :for form
:in body
:collect
1041 (destructuring-bind (car . cdr
) form
1043 ((defun) `(defun* ,@cdr
))
1044 ((defgeneric) `(defgeneric* ,@cdr
))
1048 ;;; Magic debugging help. See contrib/debug.lisp
1049 (with-upgradability ()
1050 (defvar *uiop-debug-utility
*
1052 (symbol-call :asdf
:system-relative-pathname
:uiop
"contrib/debug.lisp"))
1053 (symbol-call :uiop
/pathname
:subpathname
(user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
1054 "form that evaluates to the pathname to your favorite debugging utilities")
1056 (defmacro uiop-debug
(&rest keys
)
1057 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1058 (load-uiop-debug-utility ,@keys
)))
1060 (defun load-uiop-debug-utility (&key package utility-file
)
1061 (let* ((*package
* (if package
(find-package package
) *package
*))
1062 (keyword (read-from-string
1063 (format nil
":DBG-~:@(~A~)" (package-name *package
*)))))
1064 (unless (member keyword
*features
*)
1065 (let* ((utility-file (or utility-file
*uiop-debug-utility
*))
1066 (file (ignore-errors (probe-file (eval utility-file
)))))
1067 (if file
(load file
)
1068 (error "Failed to locate debug utility file: ~S" utility-file
)))))))
1071 (with-upgradability ()
1072 (defmacro nest
(&rest things
)
1073 "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer
1074 (reduce #'(lambda (outer inner
) `(,@outer
,inner
))
1075 things
:from-end t
))
1077 (defmacro if-let
(bindings &body
(then-form &optional else-form
)) ;; from alexandria
1078 ;; bindings can be (var form) or ((var1 form1) ...)
1079 (let* ((binding-list (if (and (consp bindings
) (symbolp (car bindings
)))
1082 (variables (mapcar #'car binding-list
)))
1084 (if (and ,@variables
)
1088 ;;; List manipulation
1089 (with-upgradability ()
1090 (defmacro while-collecting
((&rest collectors
) &body body
)
1091 "COLLECTORS should be a list of names for collections. A collector
1092 defines a function that, when applied to an argument inside BODY, will
1093 add its argument to the corresponding collection. Returns multiple values,
1094 a list for each collection, in order.
1096 \(while-collecting \(foo bar\)
1097 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
1099 \(bar \(second x\)\)\)\)
1100 Returns two values: \(A B C\) and \(1 2 3\)."
1101 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x
))) collectors
))
1102 (initial-values (mapcar (constantly nil
) collectors
)))
1103 `(let ,(mapcar #'list vars initial-values
)
1104 (flet ,(mapcar #'(lambda (c v
) `(,c
(x) (push x
,v
) (values))) collectors vars
)
1106 (values ,@(mapcar #'(lambda (v) `(reverse ,v
)) vars
))))))
1108 (define-modify-macro appendf
(&rest args
)
1109 append
"Append onto list") ;; only to be used on short lists.
1111 (defun length=n-p
(x n
) ;is it that (= (length x) n) ?
1112 (check-type n
(integer 0 *))
1114 :for l
= x
:then
(cdr l
)
1115 :for i
:downfrom n
:do
1117 ((zerop i
) (return (null l
)))
1118 ((not (consp l
)) (return nil
)))))
1120 (defun ensure-list (x)
1121 (if (listp x
) x
(list x
))))
1124 ;;; remove a key from a plist, i.e. for keyword argument cleanup
1125 (with-upgradability ()
1126 (defun remove-plist-key (key plist
)
1127 "Remove a single key from a plist"
1128 (loop* :for
(k v
) :on plist
:by
#'cddr
1130 :append
(list k v
)))
1132 (defun remove-plist-keys (keys plist
)
1133 "Remove a list of keys from a plist"
1134 (loop* :for
(k v
) :on plist
:by
#'cddr
1135 :unless
(member k keys
)
1136 :append
(list k v
))))
1140 (with-upgradability ()
1142 "Predicate that is true for an empty sequence"
1143 (or (null x
) (and (vectorp x
) (zerop (length x
))))))
1147 (with-upgradability ()
1148 ;; base-char != character on ECL, LW, SBCL, Genera.
1149 ;; NB: We assume a total order on character types.
1150 ;; If that's not true... this code will need to be updated.
1151 (defparameter +character-types
+ ;; assuming a simple hierarchy
1152 #.
(coerce (loop* :for
(type next
) :on
1153 '(;; In SCL, all characters seem to be 16-bit base-char
1154 ;; Yet somehow character fails to be a subtype of base-char
1156 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
1157 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
1158 #+(and lispworks
(not (or lispworks4 lispworks5 lispworks6
)))
1160 #+lispworks lw
:simple-char
1162 :unless
(and next
(subtypep next type
))
1163 :collect type
) 'vector
))
1164 (defparameter +max-character-type-index
+ (1- (length +character-types
+)))
1165 (defconstant +non-base-chars-exist-p
+ (plusp +max-character-type-index
+))
1166 (when +non-base-chars-exist-p
+ (pushnew :non-base-chars-exist-p
*features
*)))
1168 (with-upgradability ()
1169 (defun character-type-index (x)
1170 (declare (ignorable x
))
1171 #.
(case +max-character-type-index
+
1174 (character (if (typep x
'base-char
) 0 1))
1175 (symbol (if (subtypep x
'base-char
) 0 1))))
1177 '(or (position-if (etypecase x
1178 (character #'(lambda (type) (typep x type
)))
1179 (symbol #'(lambda (type) (subtypep x type
))))
1181 (error "Not a character or character type: ~S" x
))))))
1185 (with-upgradability ()
1186 (defun base-string-p (string)
1187 "Does the STRING only contain BASE-CHARs?"
1188 (declare (ignorable string
))
1189 (and #+non-base-chars-exist-p
(eq 'base-char
(array-element-type string
))))
1191 (defun strings-common-element-type (strings)
1192 "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
1193 (declare (ignorable strings
))
1194 #.
(if +non-base-chars-exist-p
+
1195 `(aref +character-types
+
1196 (loop :with index
= 0 :for s
:in strings
:do
1197 (flet ((consider (i)
1198 (cond ((= i
,+max-character-type-index
+) (return i
))
1199 ,@(when (> +max-character-type-index
+ 1) `(((> i index
) (setf index i
)))))))
1201 ((emptyp s
)) ;; NIL or empty string
1202 ((characterp s
) (consider (character-type-index s
)))
1203 ((stringp s
) (let ((string-type-index
1204 (character-type-index (array-element-type s
))))
1205 (unless (>= index string-type-index
)
1206 (loop :for c
:across s
:for i
= (character-type-index c
)
1208 ,@(when (> +max-character-type-index
+ 1)
1209 `((when (= i string-type-index
) (return))))))))
1210 (t (error "Invalid string designator ~S for ~S" s
'strings-common-element-type
))))
1211 :finally
(return index
)))
1214 (defun reduce/strcat
(strings &key key start end
)
1215 "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
1216 NIL is interpreted as an empty string. A character is interpreted as a string of length one."
1217 (when (or start end
) (setf strings
(subseq strings start end
)))
1218 (when key
(setf strings
(mapcar key strings
)))
1219 (loop :with output
= (make-string (loop :for s
:in strings
1220 :sum
(if (characterp s
) 1 (length s
)))
1221 :element-type
(strings-common-element-type strings
))
1223 :for input
:in strings
1224 :do
(etypecase input
1226 (character (setf (char output pos
) input
) (incf pos
))
1227 (string (replace output input
:start1 pos
) (incf pos
(length input
))))
1228 :finally
(return output
)))
1230 (defun strcat (&rest strings
)
1231 "Concatenate strings.
1232 NIL is interpreted as an empty string, a character as a string of length one."
1233 (reduce/strcat strings
))
1235 (defun first-char (s)
1236 "Return the first character of a non-empty string S, or NIL"
1237 (and (stringp s
) (plusp (length s
)) (char s
0)))
1239 (defun last-char (s)
1240 "Return the last character of a non-empty string S, or NIL"
1241 (and (stringp s
) (plusp (length s
)) (char s
(1- (length s
)))))
1243 (defun split-string (string &key max
(separator '(#\Space
#\Tab
)))
1244 "Split STRING into a list of components separated by
1245 any of the characters in the sequence SEPARATOR.
1246 If MAX is specified, then no more than max(1,MAX) components will be returned,
1247 starting the separation from the end, e.g. when called with arguments
1248 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1250 (let ((list nil
) (words 0) (end (length string
)))
1251 (when (zerop end
) (return nil
))
1252 (flet ((separatorp (char) (find char separator
))
1253 (done () (return (cons (subseq string
0 end
) list
))))
1255 :for start
= (if (and max
(>= words
(1- max
)))
1257 (position-if #'separatorp string
:end end
:from-end t
))
1258 :do
(when (null start
) (done))
1259 (push (subseq string
(1+ start
) end
) list
)
1261 (setf end start
))))))
1263 (defun string-prefix-p (prefix string
)
1264 "Does STRING begin with PREFIX?"
1265 (let* ((x (string prefix
))
1269 (and (<= lx ly
) (string= x y
:end2 lx
))))
1271 (defun string-suffix-p (string suffix
)
1272 "Does STRING end with SUFFIX?"
1273 (let* ((x (string string
))
1277 (and (<= ly lx
) (string= x y
:start1
(- lx ly
)))))
1279 (defun string-enclosed-p (prefix string suffix
)
1280 "Does STRING begin with PREFIX and end with SUFFIX?"
1281 (and (string-prefix-p prefix string
)
1282 (string-suffix-p string suffix
)))
1284 (defvar +cr
+ (coerce #(#\Return
) 'string
))
1285 (defvar +lf
+ (coerce #(#\Linefeed
) 'string
))
1286 (defvar +crlf
+ (coerce #(#\Return
#\Linefeed
) 'string
))
1289 "Strip a string X from any ending CR, LF or CRLF.
1290 Return two values, the stripped string and the ending that was stripped,
1291 or the original value and NIL if no stripping took place.
1292 Since our STRCAT accepts NIL as empty string designator,
1293 the two results passed to STRCAT always reconstitute the original string"
1294 (check-type x string
)
1296 (flet ((c (end) (when (string-suffix-p x end
)
1297 (return (values (subseq x
0 (- (length x
) (length end
))) end
)))))
1298 (when x
(c +crlf
+) (c +lf
+) (c +cr
+) (values x nil
)))))
1300 (defun standard-case-symbol-name (name-designator)
1301 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
1302 if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
1303 platform such as Allegro with modern syntax."
1304 (check-type name-designator
(or string symbol
))
1306 ((or (symbolp name-designator
) #+allegro
(eq excl
:*current-case-mode
* :case-sensitive-lower
))
1307 (string name-designator
))
1308 ;; Should we be doing something on CLISP?
1309 (t (string-upcase name-designator
))))
1311 (defun find-standard-case-symbol (name-designator package-designator
&optional
(error t
))
1312 "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
1313 where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
1314 If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
1315 (find-symbol* (standard-case-symbol-name name-designator
)
1316 (etypecase package-designator
1317 ((or package symbol
) package-designator
)
1318 (string (standard-case-symbol-name package-designator
)))
1321 ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
1322 (eval-when (#-lispworks
:compile-toplevel
:load-toplevel
:execute
)
1323 (deftype stamp
() '(or real boolean
)))
1324 (with-upgradability ()
1333 (defun stamps< (list) (loop :for y
:in list
:for x
= nil
:then y
:always
(stamp< x y
)))
1334 (defun stamp*< (&rest list
) (stamps< list
))
1335 (defun stamp<= (x y
) (not (stamp< y x
)))
1336 (defun earlier-stamp (x y
) (if (stamp< x y
) x y
))
1337 (defun stamps-earliest (list) (reduce 'earlier-stamp list
:initial-value t
))
1338 (defun earliest-stamp (&rest list
) (stamps-earliest list
))
1339 (defun later-stamp (x y
) (if (stamp< x y
) y x
))
1340 (defun stamps-latest (list) (reduce 'later-stamp list
:initial-value nil
))
1341 (defun latest-stamp (&rest list
) (stamps-latest list
))
1342 (define-modify-macro latest-stamp-f
(&rest stamps
) latest-stamp
))
1345 ;;; Function designators
1346 (with-upgradability ()
1347 (defun ensure-function (fun &key
(package :cl
))
1348 "Coerce the object FUN into a function.
1350 If FUN is a FUNCTION, return it.
1351 If the FUN is a non-sequence literal constant, return constantly that,
1352 i.e. for a boolean keyword character number or pathname.
1353 Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1354 If FUN is a CONS, return the function that applies its CAR
1355 to the appended list of the rest of its CDR and the arguments,
1356 unless the CAR is LAMBDA, in which case the expression is evaluated.
1357 If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1358 and EVAL that in a (FUNCTION ...) context."
1361 ((or boolean keyword character number pathname
) (constantly fun
))
1362 (hash-table #'(lambda (x) (gethash x fun
)))
1363 (symbol (fdefinition fun
))
1364 (cons (if (eq 'lambda
(car fun
))
1366 #'(lambda (&rest args
) (apply (car fun
) (append (cdr fun
) args
)))))
1367 (string (eval `(function ,(with-standard-io-syntax
1368 (let ((*package
* (find-package package
)))
1369 (read-from-string fun
))))))))
1371 (defun access-at (object at
)
1372 "Given an OBJECT and an AT specifier, list of successive accessors,
1373 call each accessor on the result of the previous calls.
1374 An accessor may be an integer, meaning a call to ELT,
1375 a keyword, meaning a call to GETF,
1376 NIL, meaning identity,
1377 a function or other symbol, meaning itself,
1378 or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1379 As a degenerate case, the AT specifier may be an atom of a single such accessor
1381 (flet ((access (object accessor
)
1383 (function (funcall accessor object
))
1384 (integer (elt object accessor
))
1385 (keyword (getf object accessor
))
1387 (symbol (funcall accessor object
))
1388 (cons (funcall (ensure-function accessor
) object
)))))
1390 (dolist (accessor at object
)
1391 (setf object
(access object accessor
)))
1392 (access object at
))))
1394 (defun access-at-count (at)
1395 "From an AT specification, extract a COUNT of maximum number
1396 of sub-objects to read as per ACCESS-AT"
1400 ((and (consp at
) (integerp (first at
)))
1403 (defun call-function (function-spec &rest arguments
)
1404 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
1405 with the given ARGUMENTS"
1406 (apply (ensure-function function-spec
) arguments
))
1408 (defun call-functions (function-specs)
1409 "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
1410 (map () 'call-function function-specs
))
1412 (defun register-hook-function (variable hook
&optional call-now-p
)
1413 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
1414 When CALL-NOW-P is true, also call the function immediately."
1415 (pushnew hook
(symbol-value variable
) :test
'equal
)
1416 (when call-now-p
(call-function hook
))))
1420 (with-upgradability ()
1421 (defun coerce-class (class &key
(package :cl
) (super t
) (error 'error
))
1422 "Coerce CLASS to a class that is subclass of SUPER if specified,
1423 or invoke ERROR handler as per CALL-FUNCTION.
1425 A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
1426 -- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
1427 A string is read as a symbol while in PACKAGE, the symbol designates a class.
1429 A class object designates itself.
1430 NIL designates itself (no class).
1431 A symbol otherwise designates a class by name."
1434 (keyword (or (find-symbol* class package nil
)
1435 (find-symbol* class
*package
* nil
)))
1436 (string (symbol-call :uiop
:safe-read-from-string class
:package package
))
1439 (etypecase normalized
1440 ((or standard-class built-in-class
) normalized
)
1441 ((or null keyword
) nil
)
1442 (symbol (find-class normalized nil nil
)))))
1444 (or (eq super t
) (#-cormanlisp subtypep
#+cormanlisp cl
::subclassp found super
))
1446 (call-function error
"Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super
)))))
1450 (with-upgradability ()
1451 (defun ensure-gethash (key table default
)
1452 "Lookup the TABLE for a KEY as by GETHASH, but if not present,
1453 call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
1454 set the corresponding entry to the result in the table.
1455 Return two values: the entry after its optional computation, and whether it was found"
1456 (multiple-value-bind (value foundp
) (gethash key table
)
1460 (setf (gethash key table
) (call-function default
)))
1463 (defun list-to-hash-set (list &aux
(h (make-hash-table :test
'equal
)))
1464 "Convert a LIST into hash-table that has the same elements when viewed as a set,
1465 up to the given equality TEST"
1466 (dolist (x list h
) (setf (gethash x h
) t
))))
1469 ;;; Version handling
1470 (with-upgradability ()
1471 (defun unparse-version (version-list)
1472 (format nil
"~{~D~^.~}" version-list
))
1474 (defun parse-version (version-string &optional on-error
)
1475 "Parse a VERSION-STRING as a series of natural integers separated by dots.
1476 Return a (non-null) list of integers if the string is valid;
1477 otherwise return NIL.
1479 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1480 with format arguments explaining why the version is invalid.
1481 ON-ERROR is also called if the version is not canonical
1482 in that it doesn't print back to itself, but the list is returned anyway."
1484 (unless (stringp version-string
)
1485 (call-function on-error
"~S: ~S is not a string" 'parse-version version-string
)
1487 (unless (loop :for prev
= nil
:then c
:for c
:across version-string
1488 :always
(or (digit-char-p c
)
1489 (and (eql c
#\.
) prev
(not (eql prev
#\.
))))
1490 :finally
(return (and c
(digit-char-p c
))))
1491 (call-function on-error
"~S: ~S doesn't follow asdf version numbering convention"
1492 'parse-version version-string
)
1494 (let* ((version-list
1495 (mapcar #'parse-integer
(split-string version-string
:separator
".")))
1496 (normalized-version (unparse-version version-list
)))
1497 (unless (equal version-string normalized-version
)
1498 (call-function on-error
"~S: ~S contains leading zeros" 'parse-version version-string
))
1501 (defun lexicographic< (< x y
)
1502 (cond ((null y
) nil
)
1504 ((funcall < (car x
) (car y
)) t
)
1505 ((funcall < (car y
) (car x
)) nil
)
1506 (t (lexicographic< < (cdr x
) (cdr y
)))))
1508 (defun lexicographic<= (< x y
)
1509 (not (lexicographic< < y x
)))
1511 (defun version< (version1 version2
)
1512 (let ((v1 (parse-version version1 nil
))
1513 (v2 (parse-version version2 nil
)))
1514 (lexicographic< '< v1 v2
)))
1516 (defun version<= (version1 version2
)
1517 (not (version< version2 version1
)))
1519 (defun version-compatible-p (provided-version required-version
)
1520 "Is the provided version a compatible substitution for the required-version?
1521 If major versions differ, it's not compatible.
1522 If they are equal, then any later version is compatible,
1523 with later being determined by a lexicographical comparison of minor numbers."
1524 (let ((x (parse-version provided-version nil
))
1525 (y (parse-version required-version nil
)))
1526 (and x y
(= (car x
) (car y
)) (lexicographic<= '< (cdr y
) (cdr x
))))))
1529 ;;; Condition control
1531 (with-upgradability ()
1532 (defparameter +simple-condition-format-control-slot
+
1533 #+abcl
'system
::format-control
1534 #+allegro
'excl
::format-control
1535 #+clisp
'system
::$format-control
1536 #+clozure
'ccl
::format-control
1537 #+(or cmu scl
) 'conditions
::format-control
1538 #+(or clasp ecl mkcl
) 'si
::format-control
1539 #+(or gcl lispworks
) 'conditions
::format-string
1540 #+sbcl
'sb-kernel
:format-control
1541 #-
(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl
) nil
1542 "Name of the slot for FORMAT-CONTROL in simple-condition")
1544 (defun match-condition-p (x condition
)
1545 "Compare received CONDITION to some pattern X:
1546 a symbol naming a condition class,
1547 a simple vector of length 2, arguments to find-symbol* with result as above,
1548 or a string describing the format-control of a simple-condition."
1550 (symbol (typep condition x
))
1552 (ignore-errors (typep condition
(find-symbol* (svref x
0) (svref x
1) nil
))))
1553 (function (funcall x condition
))
1554 (string (and (typep condition
'simple-condition
)
1555 ;; On SBCL, it's always set and the check triggers a warning
1556 #+(or allegro clozure cmu lispworks scl
)
1557 (slot-boundp condition
+simple-condition-format-control-slot
+)
1558 (ignore-errors (equal (simple-condition-format-control condition
) x
))))))
1560 (defun match-any-condition-p (condition conditions
)
1561 "match CONDITION against any of the patterns of CONDITIONS supplied"
1562 (loop :for x
:in conditions
:thereis
(match-condition-p x condition
)))
1564 (defun call-with-muffled-conditions (thunk conditions
)
1565 "calls the THUNK in a context where the CONDITIONS are muffled"
1566 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions
)
1567 (muffle-warning c
)))))
1570 (defmacro with-muffled-conditions
((conditions) &body body
)
1571 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
1572 `(call-with-muffled-conditions #'(lambda () ,@body
) ,conditions
)))
1574 ;;;; ---------------------------------------------------------------------------
1575 ;;;; Access to the Operating System
1577 (uiop/package
:define-package
:uiop
/os
1578 (:nicknames
:asdf
/os
)
1579 (:recycle
:uiop
/os
:asdf
/os
:asdf
)
1580 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
)
1582 #:featurep
#:os-unix-p
#:os-macosx-p
#:os-windows-p
#:os-genera-p
#:detect-os
;; features
1584 #:getenv
#:getenvp
;; environment variables
1585 #:implementation-identifier
;; implementation identifier
1586 #:implementation-type
#:*implementation-type
*
1587 #:operating-system
#:architecture
#:lisp-version-string
1588 #:hostname
#:getcwd
#:chdir
1589 ;; Windows shortcut support
1590 #:read-null-terminated-string
#:read-little-endian
1591 #:parse-file-location-info
#:parse-windows-shortcut
))
1592 (in-package :uiop
/os
)
1595 (with-upgradability ()
1596 (defun featurep (x &optional
(*features
* *features
*))
1597 "Checks whether a feature expression X is true with respect to the *FEATURES* set,
1598 as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
1599 we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
1600 your reader will not have magically used the KEYWORD package, so you need specify
1601 keywords explicitly."
1603 ((atom x
) (and (member x
*features
*) t
))
1604 ((eq :not
(car x
)) (assert (null (cddr x
))) (not (featurep (cadr x
))))
1605 ((eq :or
(car x
)) (some #'featurep
(cdr x
)))
1606 ((eq :and
(car x
)) (every #'featurep
(cdr x
)))
1607 (t (error "Malformed feature specification ~S" x
))))
1609 ;; Starting with UIOP 3.1.5, these are runtime tests.
1610 ;; You may bind *features* with a copy of what your target system offers to test its properties.
1611 (defun os-macosx-p ()
1612 "Is the underlying operating system MacOS X?"
1613 ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
1614 ;; in fact the former implies the latter.
1615 (featurep '(:or
:darwin
(:and
:allegro
:macosx
) (:and
:clisp
:macos
))))
1618 "Is the underlying operating system some Unix variant?"
1619 (or (featurep '(:or
:unix
:cygwin
)) (os-macosx-p)))
1621 (defun os-windows-p ()
1622 "Is the underlying operating system Microsoft Windows?"
1623 (and (not (os-unix-p)) (featurep '(:or
:win32
:windows
:mswindows
:mingw32
:mingw64
))))
1625 (defun os-genera-p ()
1626 "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
1629 (defun os-oldmac-p ()
1630 "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
1634 "Detects the current operating system. Only needs be run at compile-time,
1635 except on ABCL where it might change between FASL compilation and runtime."
1637 :for
(feature . detect
) :in
'((:os-unix . os-unix-p
) (:os-macosx . os-macosx-p
)
1638 (:os-windows . os-windows-p
)
1639 (:genera . os-genera-p
) (:os-oldmac . os-oldmac-p
))
1640 :when
(and (or (not o
) (eq feature
:os-macosx
)) (funcall detect
))
1641 :do
(setf o feature
) (pushnew feature
*features
*)
1642 :else
:do
(setf *features
* (remove feature
*features
*))
1644 (return (or o
(error "Congratulations for trying ASDF on an operating system~%~
1645 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
1647 (defmacro os-cond
(&rest clauses
)
1648 #+abcl
`(cond ,@clauses
)
1649 #-abcl
(loop* :for
(test . body
) :in clauses
:when
(eval test
) :return
`(progn ,@body
)))
1653 ;;;; Environment variables: getting them, and parsing them.
1654 (with-upgradability ()
1656 "Query the environment, as in C getenv.
1657 Beware: may return empty string if a variable is present but empty;
1658 use getenvp to return NIL in such a case."
1659 (declare (ignorable x
))
1660 #+(or abcl clasp clisp ecl xcl
) (ext:getenv x
)
1661 #+allegro
(sys:getenv x
)
1662 #+clozure
(ccl:getenv x
)
1663 #+cmu
(unix:unix-getenv x
)
1664 #+scl
(cdr (assoc x ext
:*environment-list
* :test
#'string
=))
1666 (let* ((buffer (ct:malloc
1))
1667 (cname (ct:lisp-string-to-c-string x
))
1668 (needed-size (win:getenvironmentvariable cname buffer
0))
1669 (buffer1 (ct:malloc
(1+ needed-size
))))
1670 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size
))
1672 (ct:c-string-to-lisp-string buffer1
))
1675 #+gcl
(system:getenv x
)
1677 #+lispworks
(lispworks:environment-variable x
)
1678 #+mcl
(ccl:with-cstrs
((name x
))
1679 (let ((value (_getenv name
)))
1680 (unless (ccl:%null-ptr-p value
)
1681 (ccl:%get-cstring value
))))
1682 #+mkcl
(#.
(or (find-symbol* 'getenv
:si nil
) (find-symbol* 'getenv
:mk-ext nil
)) x
)
1683 #+sbcl
(sb-ext:posix-getenv x
)
1684 #-
(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
1685 (error "~S is not supported on your implementation" 'getenv
))
1687 (defsetf getenv
(x) (val)
1688 "Set an environment variable."
1689 (declare (ignorable x val
))
1690 #+allegro
`(setf (sys:getenv
,x
) ,val
)
1691 #+clisp
`(system::setenv
,x
,val
)
1692 #+clozure
`(ccl:setenv
,x
,val
)
1693 #+cmu
`(unix:unix-setenv
,x
,val
1)
1694 #+ecl
`(ext:setenv
,x
,val
)
1695 #+lispworks
`(hcl:setenv
,x
,val
)
1696 #+mkcl
`(mkcl:setenv
,x
,val
)
1697 #+sbcl
`(progn (require :sb-posix
) (symbol-call :sb-posix
:setenv
,x
,val
1))
1698 #-
(or allegro clisp clozure cmu ecl lispworks mkcl sbcl
)
1699 '(error "~S ~S is not supported on your implementation" 'setf
'getenv
))
1702 "Predicate that is true if the named variable is present in the libc environment,
1703 then returning the non-empty string value of the variable"
1704 (let ((g (getenv x
))) (and (not (emptyp g
)) g
))))
1707 ;;;; implementation-identifier
1709 ;; produce a string to identify current implementation.
1710 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
1711 ;; We're back to runtime checking, for the sake of e.g. ABCL.
1713 (with-upgradability ()
1714 (defun first-feature (feature-sets)
1715 "A helper for various feature detection functions"
1716 (dolist (x feature-sets
)
1717 (multiple-value-bind (short long feature-expr
)
1719 (values (first x
) (second x
) (cons :or
(rest x
)))
1721 (when (featurep feature-expr
)
1722 (return (values short long
))))))
1724 (defun implementation-type ()
1725 "The type of Lisp implementation used, as a short UIOP-standardized keyword"
1727 '(:abcl
(:acl
:allegro
) (:ccl
:clozure
) :clisp
(:corman
:cormanlisp
)
1728 (:cmu
:cmucl
:cmu
) :clasp
:ecl
:gcl
1729 (:lwpe
:lispworks-personal-edition
) (:lw
:lispworks
)
1730 :mcl
:mkcl
:sbcl
:scl
(:smbx
:symbolics
) :xcl
)))
1732 (defvar *implementation-type
* (implementation-type)
1733 "The type of Lisp implementation used, as a short UIOP-standardized keyword")
1735 (defun operating-system ()
1736 "The operating system of the current host"
1739 (:win
:windows
:mswindows
:win32
:mingw32
) ;; try cygwin first!
1740 (:linux
:linux
:linux-target
) ;; for GCL at least, must appear before :bsd
1741 (:macosx
:macosx
:darwin
:darwin-target
:apple
) ; also before :bsd
1742 (:solaris
:solaris
:sunos
)
1743 (:bsd
:bsd
:freebsd
:netbsd
:openbsd
:dragonfly
)
1747 (defun architecture ()
1748 "The CPU architecture of the current host"
1750 '((:x64
:x86-64
:x86_64
:x8664-target
:amd64
(:and
:word-size
=64 :pc386
))
1751 (:x86
:x86
:i386
:i486
:i586
:i686
:pentium3
:pentium4
:pc386
:iapx386
:x8632-target
)
1752 (:ppc64
:ppc64
:ppc64-target
) (:ppc32
:ppc32
:ppc32-target
:ppc
:powerpc
)
1753 :hppa64
:hppa
:sparc64
(:sparc32
:sparc32
:sparc
)
1754 :mipsel
:mipseb
:mips
:alpha
(:arm
:arm
:arm-target
) :imach
1755 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1756 ;; we may have to segregate the code still by architecture.
1757 (:java
:java
:java-1.4
:java-1.5
:java-1.6
:java-1.7
))))
1760 (defun ccl-fasl-version ()
1761 ;; the fasl version is target-dependent from CCL 1.8 on.
1762 (or (let ((s 'ccl
::target-fasl-version
))
1763 (and (fboundp s
) (funcall s
)))
1764 (and (boundp 'ccl
::fasl-version
)
1765 (symbol-value 'ccl
::fasl-version
))
1766 (error "Can't determine fasl version.")))
1768 (defun lisp-version-string ()
1769 "return a string that identifies the current Lisp implementation version"
1770 (let ((s (lisp-implementation-version)))
1771 (car ; as opposed to OR, this idiom prevents some unreachable code warning
1774 (format nil
"~A~@[~A~]~@[~A~]~@[~A~]"
1775 excl
::*common-lisp-version-number
*
1776 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1777 (and (eq excl
:*current-case-mode
* :case-sensitive-lower
) "M")
1778 ;; Note if not using International ACL
1779 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
1780 (excl:ics-target-case
(:-ics
"8"))
1781 (and (member :smp
*features
*) "S"))
1782 #+armedbear
(format nil
"~a-fasl~a" s system
::*fasl-version
*)
1784 (subseq s
0 (position #\space s
)) ; strip build information (date, etc.)
1786 (format nil
"~d.~d-f~d" ; shorten for windows
1787 ccl
::*openmcl-major-version
*
1788 ccl
::*openmcl-minor-version
*
1789 (logand (ccl-fasl-version) #xFF
))
1790 #+cmu
(substitute #\-
#\
/ s
)
1791 #+scl
(format nil
"~A~A" s
1792 ;; ANSI upper case vs lower case.
1793 (ecase ext
:*case-mode
* (:upper
"") (:lower
"l")))
1794 #+clasp
(format nil
"~A-~A"
1795 s
(core:lisp-implementation-id
))
1796 #+(and ecl
(not clasp
)) (format nil
"~A~@[-~A~]" s
1797 (let ((vcs-id (ext:lisp-implementation-vcs-id
)))
1798 (subseq vcs-id
0 (min (length vcs-id
) 8))))
1799 #+gcl
(subseq s
(1+ (position #\space s
)))
1801 (multiple-value-bind (major minor
) (sct:get-system-version
"System")
1802 (format nil
"~D.~D" major minor
))
1803 #+mcl
(subseq s
8) ; strip the leading "Version "
1806 (defun implementation-identifier ()
1807 "Return a string that identifies the ABI of the current implementation,
1808 suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
1810 #\_
#'(lambda (x) (find x
" /:;&^\\|?<>(){}[]$#`'\""))
1811 (format nil
"~(~a~@{~@[-~a~]~}~)"
1812 (or (implementation-type) (lisp-implementation-type))
1813 (or (lisp-version-string) (lisp-implementation-version))
1814 (or (operating-system) (software-type))
1815 (or (architecture) (machine-type))))))
1818 ;;;; Other system information
1820 (with-upgradability ()
1822 "return the hostname of the current host"
1823 ;; Note: untested on RMCL
1824 #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl
) (machine-instance)
1825 #+cormanlisp
"localhost" ;; is there a better way? Does it matter?
1826 #+allegro
(symbol-call :excl.osi
:gethostname
)
1827 #+clisp
(first (split-string (machine-instance) :separator
" "))
1828 #+gcl
(system:gethostname
)))
1831 ;;; Current directory
1832 (with-upgradability ()
1835 (defun parse-unix-namestring* (unix-namestring)
1836 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
1837 (multiple-value-bind (host device directory name type version
)
1838 (lisp::parse-unix-namestring unix-namestring
0 (length unix-namestring
))
1839 (make-pathname :host
(or host lisp
::*unix-host
*) :device device
1840 :directory directory
:name name
:type type
:version version
)))
1843 "Get the current working directory as per POSIX getcwd(3), as a pathname object"
1844 (or #+(or abcl genera xcl
) (truename *default-pathname-defaults
*) ;; d-p-d is canonical!
1845 #+allegro
(excl::current-directory
)
1846 #+clisp
(ext:default-directory
)
1847 #+clozure
(ccl:current-directory
)
1848 #+(or cmu scl
) (#+cmu parse-unix-namestring
* #+scl lisp
::parse-unix-namestring
1849 (strcat (nth-value 1 (unix:unix-current-directory
)) "/"))
1850 #+cormanlisp
(pathname (pl::get-current-directory
)) ;; Q: what type does it return?
1851 #+(or clasp ecl
) (ext:getcwd
)
1852 #+gcl
(let ((*default-pathname-defaults
* #p
"")) (truename #p
""))
1853 #+lispworks
(hcl:get-working-directory
)
1854 #+mkcl
(mk-ext:getcwd
)
1855 #+sbcl
(sb-ext:parse-native-namestring
(sb-unix:posix-getcwd
/))
1856 #+xcl
(extensions:current-directory
)
1857 (error "getcwd not supported on your implementation")))
1860 "Change current directory, as per POSIX chdir(2), to a given pathname object"
1861 (if-let (x (pathname x
))
1862 #+(or abcl genera xcl
) (setf *default-pathname-defaults
* (truename x
)) ;; d-p-d is canonical!
1863 #+allegro
(excl:chdir x
)
1865 #+clozure
(setf (ccl:current-directory
) x
)
1866 #+(or cmu scl
) (unix:unix-chdir
(ext:unix-namestring x
))
1867 #+cormanlisp
(unless (zerop (win32::_chdir
(namestring x
)))
1868 (error "Could not set current directory to ~A" x
))
1869 #+(or clasp ecl
) (ext:chdir x
)
1870 #+gcl
(system:chdir x
)
1871 #+lispworks
(hcl:change-directory x
)
1872 #+mkcl
(mk-ext:chdir x
)
1873 #+sbcl
(progn (require :sb-posix
) (symbol-call :sb-posix
:chdir
(sb-ext:native-namestring x
)))
1874 #-
(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl
)
1875 (error "chdir not supported on your implementation"))))
1878 ;;;; -----------------------------------------------------------------
1879 ;;;; Windows shortcut support. Based on:
1881 ;;;; Jesse Hager: The Windows Shortcut File Format.
1882 ;;;; http://www.wotsit.org/list.asp?fc=13
1884 #-
(or clisp genera
) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
1885 (with-upgradability ()
1886 (defparameter *link-initial-dword
* 76)
1887 (defparameter *link-guid
* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1889 (defun read-null-terminated-string (s)
1890 "Read a null-terminated string from an octet stream S"
1891 ;; note: doesn't play well with UNICODE
1892 (with-output-to-string (out)
1893 (loop :for code
= (read-byte s
)
1895 :do
(write-char (code-char code
) out
))))
1897 (defun read-little-endian (s &optional
(bytes 4))
1898 "Read a number in little-endian format from an byte (octet) stream S,
1899 the number having BYTES octets (defaulting to 4)."
1900 (loop :for i
:from
0 :below bytes
1901 :sum
(ash (read-byte s
) (* 8 i
))))
1903 (defun parse-file-location-info (s)
1904 "helper to parse-windows-shortcut"
1905 (let ((start (file-position s
))
1906 (total-length (read-little-endian s
))
1907 (end-of-header (read-little-endian s
))
1908 (fli-flags (read-little-endian s
))
1909 (local-volume-offset (read-little-endian s
))
1910 (local-offset (read-little-endian s
))
1911 (network-volume-offset (read-little-endian s
))
1912 (remaining-offset (read-little-endian s
)))
1913 (declare (ignore total-length end-of-header local-volume-offset
))
1914 (unless (zerop fli-flags
)
1916 ((logbitp 0 fli-flags
)
1917 (file-position s
(+ start local-offset
)))
1918 ((logbitp 1 fli-flags
)
1919 (file-position s
(+ start
1920 network-volume-offset
1922 (strcat (read-null-terminated-string s
)
1924 (file-position s
(+ start remaining-offset
))
1925 (read-null-terminated-string s
))))))
1927 (defun parse-windows-shortcut (pathname)
1928 "From a .lnk windows shortcut, extract the pathname linked to"
1929 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
1930 (with-open-file (s pathname
:element-type
'(unsigned-byte 8))
1932 (when (and (= (read-little-endian s
) *link-initial-dword
*)
1933 (let ((header (make-array (length *link-guid
*))))
1934 (read-sequence header s
)
1935 (equalp header
*link-guid
*)))
1936 (let ((flags (read-little-endian s
)))
1937 (file-position s
76) ;skip rest of header
1938 (when (logbitp 0 flags
)
1939 ;; skip shell item id list
1940 (let ((length (read-little-endian s
2)))
1941 (file-position s
(+ length
(file-position s
)))))
1944 (parse-file-location-info s
))
1946 (when (logbitp 2 flags
)
1947 ;; skip description string
1948 (let ((length (read-little-endian s
2)))
1949 (file-position s
(+ length
(file-position s
)))))
1950 (when (logbitp 3 flags
)
1951 ;; finally, our pathname
1952 (let* ((length (read-little-endian s
2))
1953 (buffer (make-array length
)))
1954 (read-sequence buffer s
)
1955 (map 'string
#'code-char buffer
)))))))
1957 (declare (ignore c
))
1961 ;;;; -------------------------------------------------------------------------
1962 ;;;; Portability layer around Common Lisp pathnames
1963 ;; This layer allows for portable manipulation of pathname objects themselves,
1964 ;; which all is necessary prior to any access the filesystem or environment.
1966 (uiop/package
:define-package
:uiop
/pathname
1967 (:nicknames
:asdf
/pathname
)
1968 (:recycle
:uiop
/pathname
:asdf
/pathname
:asdf
)
1969 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
)
1971 ;; Making and merging pathnames, portably
1972 #:normalize-pathname-directory-component
#:denormalize-pathname-directory-component
1973 #:merge-pathname-directory-components
#:*unspecific-pathname-type
* #:make-pathname
*
1974 #:make-pathname-component-logical
#:make-pathname-logical
1976 #:nil-pathname
#:*nil-pathname
* #:with-pathname-defaults
1978 #:pathname-equal
#:logical-pathname-p
#:physical-pathname-p
#:physicalize-pathname
1979 #:absolute-pathname-p
#:relative-pathname-p
#:hidden-pathname-p
#:file-pathname-p
1981 #:pathname-directory-pathname
#:pathname-parent-directory-pathname
1982 #:directory-pathname-p
#:ensure-directory-pathname
1983 ;; Parsing filenames
1984 #:component-name-to-pathname-components
1985 #:split-name-type
#:parse-unix-namestring
#:unix-namestring
1986 #:split-unix-namestring-directory-components
1987 ;; Absolute and relative pathnames
1988 #:subpathname
#:subpathname
*
1989 #:ensure-absolute-pathname
1990 #:pathname-root
#:pathname-host-pathname
1991 #:subpathp
#:enough-pathname
#:with-enough-pathname
#:call-with-enough-pathname
1992 ;; Checking constraints
1993 #:ensure-pathname
;; implemented in filesystem.lisp to accommodate for existence constraints
1994 ;; Wildcard pathnames
1995 #:*wild
* #:*wild-file
* #:*wild-directory
* #:*wild-inferiors
* #:*wild-path
* #:wilden
1996 ;; Translate a pathname
1997 #:relativize-directory-component
#:relativize-pathname-directory
1998 #:directory-separator-for-host
#:directorize-pathname-host-device
1999 #:translate-pathname
*
2000 #:*output-translation-function
*))
2001 (in-package :uiop
/pathname
)
2003 ;;; Normalizing pathnames across implementations
2005 (with-upgradability ()
2006 (defun normalize-pathname-directory-component (directory)
2007 "Convert the DIRECTORY component from a format usable by the underlying
2008 implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
2009 that is a list and not a string."
2011 #-
(or cmu sbcl scl
) ;; these implementations already normalize directory components.
2012 ((stringp directory
) `(:absolute
,directory
))
2013 ((or (null directory
)
2014 (and (consp directory
) (member (first directory
) '(:absolute
:relative
))))
2018 (cons :relative directory
))
2020 (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory
))))
2022 (defun denormalize-pathname-directory-component (directory-component)
2023 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
2024 by the underlying implementation's MAKE-PATHNAME and other primitives"
2025 directory-component
)
2027 (defun merge-pathname-directory-components (specified defaults
)
2028 "Helper for MERGE-PATHNAMES* that handles directory components"
2029 (let ((directory (normalize-pathname-directory-component specified
)))
2030 (ecase (first directory
)
2032 (:absolute specified
)
2034 (let ((defdir (normalize-pathname-directory-component defaults
))
2035 (reldir (cdr directory
)))
2039 ((not (eq :back
(first reldir
)))
2040 (append defdir reldir
))
2042 (loop :with defabs
= (first defdir
)
2043 :with defrev
= (reverse (rest defdir
))
2044 :while
(and (eq :back
(car reldir
))
2045 (or (and (eq :absolute defabs
) (null defrev
))
2046 (stringp (car defrev
))))
2047 :do
(pop reldir
) (pop defrev
)
2048 :finally
(return (cons defabs
(append (reverse defrev
) reldir
)))))))))))
2050 ;; Giving :unspecific as :type argument to make-pathname is not portable.
2051 ;; See CLHS make-pathname and 19.2.2.2.3.
2052 ;; This will be :unspecific if supported, or NIL if not.
2053 (defparameter *unspecific-pathname-type
*
2054 #+(or abcl allegro clozure cmu genera lispworks sbcl scl
) :unspecific
2055 #+(or clasp clisp ecl mkcl gcl xcl
#|These haven
't been tested
:|
# cormanlisp mcl
) nil
2056 "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
2058 (defun make-pathname* (&rest keys
&key
(directory nil
)
2059 host
(device () #+allegro devicep
) name type version defaults
2060 #+scl
&allow-other-keys
)
2061 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
2062 tries hard to make a pathname that will actually behave as documented,
2063 despite the peculiarities of each implementation"
2064 ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
2065 (declare (ignorable host device directory name type version defaults
))
2066 (apply 'make-pathname
2068 #+allegro
(when (and devicep
(null device
)) `(:device
:unspecific
))
2071 (defun make-pathname-component-logical (x)
2072 "Make a pathname component suitable for use in a logical-pathname"
2074 ((eql :unspecific
) nil
)
2075 #+clisp
(string (string-upcase x
))
2076 #+clisp
(cons (mapcar 'make-pathname-component-logical x
))
2079 (defun make-pathname-logical (pathname host
)
2080 "Take a PATHNAME's directory, name, type and version components,
2081 and make a new pathname with corresponding components and specified logical HOST"
2084 :directory
(make-pathname-component-logical (pathname-directory pathname
))
2085 :name
(make-pathname-component-logical (pathname-name pathname
))
2086 :type
(make-pathname-component-logical (pathname-type pathname
))
2087 :version
(make-pathname-component-logical (pathname-version pathname
))))
2089 (defun merge-pathnames* (specified &optional
(defaults *default-pathname-defaults
*))
2090 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
2091 if the SPECIFIED pathname does not have an absolute directory,
2092 then the HOST and DEVICE both come from the DEFAULTS, whereas
2093 if the SPECIFIED pathname does have an absolute directory,
2094 then the HOST and DEVICE both come from the SPECIFIED pathname.
2095 This is what users want on a modern Unix or Windows operating system,
2096 unlike the MERGE-PATHNAMES behavior.
2097 Also, if either argument is NIL, then the other argument is returned unmodified;
2098 this is unlike MERGE-PATHNAMES which always merges with a pathname,
2099 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
2100 (when (null specified
) (return-from merge-pathnames
* defaults
))
2101 (when (null defaults
) (return-from merge-pathnames
* specified
))
2103 (ext:resolve-pathname specified defaults
)
2105 (let* ((specified (pathname specified
))
2106 (defaults (pathname defaults
))
2107 (directory (normalize-pathname-directory-component (pathname-directory specified
)))
2108 (name (or (pathname-name specified
) (pathname-name defaults
)))
2109 (type (or (pathname-type specified
) (pathname-type defaults
)))
2110 (version (or (pathname-version specified
) (pathname-version defaults
))))
2111 (labels ((unspecific-handler (p)
2112 (if (typep p
'logical-pathname
) #'make-pathname-component-logical
#'identity
)))
2113 (multiple-value-bind (host device directory unspecific-handler
)
2114 (ecase (first directory
)
2116 (values (pathname-host specified
)
2117 (pathname-device specified
)
2119 (unspecific-handler specified
)))
2121 (values (pathname-host defaults
)
2122 (pathname-device defaults
)
2123 (merge-pathname-directory-components directory
(pathname-directory defaults
))
2124 (unspecific-handler defaults
))))
2125 (make-pathname* :host host
:device device
:directory directory
2126 :name
(funcall unspecific-handler name
)
2127 :type
(funcall unspecific-handler type
)
2128 :version
(funcall unspecific-handler version
))))))
2130 (defun logical-pathname-p (x)
2131 "is X a logical-pathname?"
2132 (typep x
'logical-pathname
))
2134 (defun physical-pathname-p (x)
2135 "is X a pathname that is not a logical-pathname?"
2136 (and (pathnamep x
) (not (logical-pathname-p x
))))
2138 (defun physicalize-pathname (x)
2139 "if X is a logical pathname, use translate-logical-pathname on it."
2140 ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
2141 (let ((p (when x
(pathname x
))))
2142 (if (logical-pathname-p p
) (translate-logical-pathname p
) p
)))
2144 (defun nil-pathname (&optional
(defaults *default-pathname-defaults
*))
2145 "A pathname that is as neutral as possible for use as defaults
2146 when merging, making or parsing pathnames"
2147 ;; 19.2.2.2.1 says a NIL host can mean a default host;
2148 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
2149 ;; strings and lists of strings or :unspecific
2150 ;; But CMUCL decides to die on NIL.
2151 ;; MCL has issues with make-pathname, nil and defaulting
2152 (declare (ignorable defaults
))
2153 #.
`(make-pathname* :directory nil
:name nil
:type nil
:version nil
2154 :device
(or #+(and mkcl unix
) :unspecific
)
2155 :host
(or #+cmu lisp
::*unix-host
* #+(and mkcl unix
) "localhost")
2156 #+scl
,@'(:scheme nil
:scheme-specific-part nil
2157 :username nil
:password nil
:parameters nil
:query nil
:fragment nil
)
2158 ;; the default shouldn't matter, but we really want something physical
2159 #-mcl
,@'(:defaults defaults
)))
2161 (defvar *nil-pathname
* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
2162 "A pathname that is as neutral as possible for use as defaults
2163 when merging, making or parsing pathnames")
2165 (defmacro with-pathname-defaults
((&optional defaults
) &body body
)
2166 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
2167 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
2168 on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
2169 `(let ((*default-pathname-defaults
*
2171 #-
(or abcl genera xcl
) '*nil-pathname
*
2172 #+(or abcl genera xcl
) '*default-pathname-defaults
*)))
2176 ;;; Some pathname predicates
2177 (with-upgradability ()
2178 (defun pathname-equal (p1 p2
)
2179 "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
2180 (when (stringp p1
) (setf p1
(pathname p1
)))
2181 (when (stringp p2
) (setf p2
(pathname p2
)))
2182 (flet ((normalize-component (x)
2183 (unless (member x
'(nil :unspecific
:newest
(:relative
)) :test
'equal
)
2185 (macrolet ((=?
(&rest accessors
)
2187 (reduce 'list
(cons 'normalize-component accessors
)
2188 :initial-value x
:from-end t
)))
2189 `(equal ,(frob 'p1
) ,(frob 'p2
)))))
2190 (or (and (null p1
) (null p2
))
2191 (and (pathnamep p1
) (pathnamep p2
)
2192 (and (=? pathname-host
)
2193 #-
(and mkcl unix
) (=? pathname-device
)
2194 (=? normalize-pathname-directory-component pathname-directory
)
2197 #-mkcl
(=? pathname-version
)))))))
2199 (defun absolute-pathname-p (pathspec)
2200 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2201 possessing an :ABSOLUTE directory component, return the (parsed) pathname.
2202 Otherwise return NIL"
2204 (typep pathspec
'(or null pathname string
))
2205 (let ((pathname (pathname pathspec
)))
2206 (and (eq :absolute
(car (normalize-pathname-directory-component
2207 (pathname-directory pathname
))))
2210 (defun relative-pathname-p (pathspec)
2211 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2212 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2213 Otherwise return NIL"
2215 (typep pathspec
'(or null pathname string
))
2216 (let* ((pathname (pathname pathspec
))
2217 (directory (normalize-pathname-directory-component
2218 (pathname-directory pathname
))))
2219 (when (or (null directory
) (eq :relative
(car directory
)))
2222 (defun hidden-pathname-p (pathname)
2223 "Return a boolean that is true if the pathname is hidden as per Unix style,
2224 i.e. its name starts with a dot."
2225 (and pathname
(equal (first-char (pathname-name pathname
)) #\.
)))
2227 (defun file-pathname-p (pathname)
2228 "Does PATHNAME represent a file, i.e. has a non-null NAME component?
2230 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2232 Note that this does _not_ check to see that PATHNAME points to an
2233 actually-existing file.
2235 Returns the (parsed) PATHNAME when true"
2237 (let* ((pathname (pathname pathname
))
2238 (name (pathname-name pathname
)))
2239 (when (not (member name
'(nil :unspecific
"") :test
'equal
))
2243 ;;; Directory pathnames
2244 (with-upgradability ()
2245 (defun pathname-directory-pathname (pathname)
2246 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2247 and NIL NAME, TYPE and VERSION components"
2249 (make-pathname :name nil
:type nil
:version nil
:defaults pathname
)))
2251 (defun pathname-parent-directory-pathname (pathname)
2252 "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2253 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2254 Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2256 (make-pathname* :name nil
:type nil
:version nil
2257 :directory
(merge-pathname-directory-components
2258 '(:relative
:back
) (pathname-directory pathname
))
2259 :defaults pathname
)))
2261 (defun directory-pathname-p (pathname)
2262 "Does PATHNAME represent a directory?
2264 A directory-pathname is a pathname _without_ a filename. The three
2265 ways that the filename components can be missing are for it to be NIL,
2266 :UNSPECIFIC or the empty string.
2268 Note that this does _not_ check to see that PATHNAME points to an
2269 actually-existing directory."
2271 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
2272 ;; because it rejects apparently legal pathnames as
2273 ;; ill-formed. [2014/02/10:rpg]
2274 (let ((pathname (pathname pathname
)))
2275 (flet ((check-one (x)
2276 (member x
'(nil :unspecific
) :test
'equal
)))
2277 (and (not (wild-pathname-p pathname
))
2278 (check-one (pathname-name pathname
))
2279 (check-one (pathname-type pathname
))
2282 (defun ensure-directory-pathname (pathspec &optional
(on-error 'error
))
2283 "Converts the non-wild pathname designator PATHSPEC to directory form."
2286 (ensure-directory-pathname (pathname pathspec
)))
2287 ((not (pathnamep pathspec
))
2288 (call-function on-error
(compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec
))
2289 ((wild-pathname-p pathspec
)
2290 (call-function on-error
(compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec
))
2291 ((directory-pathname-p pathspec
)
2294 (make-pathname* :directory
(append (or (normalize-pathname-directory-component
2295 (pathname-directory pathspec
))
2297 (list (file-namestring pathspec
)))
2298 :name nil
:type nil
:version nil
:defaults pathspec
)))))
2301 ;;; Parsing filenames
2302 (with-upgradability ()
2303 (defun split-unix-namestring-directory-components
2304 (unix-namestring &key ensure-directory dot-dot
)
2305 "Splits the path string UNIX-NAMESTRING, returning four values:
2306 A flag that is either :absolute or :relative, indicating
2307 how the rest of the values are to be interpreted.
2308 A directory path --- a list of strings and keywords, suitable for
2309 use with MAKE-PATHNAME when prepended with the flag value.
2310 Directory components with an empty name or the name . are removed.
2311 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2312 A last-component, either a file-namestring including type extension,
2313 or NIL in the case of a directory pathname.
2314 A flag that is true iff the unix-style-pathname was just
2315 a file-namestring without / path specification.
2316 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2317 the third return value will be NIL, and final component of the namestring
2318 will be treated as part of the directory path.
2320 An empty string is thus read as meaning a pathname object with all fields nil.
2322 Note that colon characters #\: will NOT be interpreted as host specification.
2323 Absolute pathnames are only appropriate on Unix-style systems.
2325 The intention of this function is to support structured component names,
2326 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2327 (check-type unix-namestring string
)
2328 (check-type dot-dot
(member nil
:back
:up
))
2329 (if (and (not (find #\
/ unix-namestring
)) (not ensure-directory
)
2330 (plusp (length unix-namestring
)))
2331 (values :relative
() unix-namestring t
)
2332 (let* ((components (split-string unix-namestring
:separator
"/"))
2333 (last-comp (car (last components
))))
2334 (multiple-value-bind (relative components
)
2335 (if (equal (first components
) "")
2336 (if (equal (first-char unix-namestring
) #\
/)
2337 (values :absolute
(cdr components
))
2338 (values :relative nil
))
2339 (values :relative components
))
2340 (setf components
(remove-if #'(lambda (x) (member x
'("" ".") :test
#'equal
))
2342 (setf components
(substitute (or dot-dot
:back
) ".." components
:test
#'equal
))
2344 ((equal last-comp
"")
2345 (values relative components nil nil
)) ; "" already removed from components
2347 (values relative components nil nil
))
2349 (values relative
(butlast components
) last-comp nil
)))))))
2351 (defun split-name-type (filename)
2352 "Split a filename into two values NAME and TYPE that are returned.
2353 We assume filename has no directory component.
2354 The last . if any separates name and type from from type,
2355 except that if there is only one . and it is in first position,
2356 the whole filename is the NAME with an empty type.
2357 NAME is always a string.
2358 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2359 (check-type filename string
)
2360 (assert (plusp (length filename
)))
2361 (destructuring-bind (name &optional
(type *unspecific-pathname-type
*))
2362 (split-string filename
:max
2 :separator
".")
2364 (values filename
*unspecific-pathname-type
*)
2365 (values name type
))))
2367 (defun parse-unix-namestring (name &rest keys
&key type defaults dot-dot ensure-directory
2369 "Coerce NAME into a PATHNAME using standard Unix syntax.
2371 Unix syntax is used whether or not the underlying system is Unix;
2372 on such non-Unix systems it is reliably usable only for relative pathnames.
2373 This function is especially useful to manipulate relative pathnames portably,
2374 where it is of crucial to possess a portable pathname syntax independent of the underlying OS.
2375 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2377 When given a PATHNAME object, just return it untouched.
2378 When given NIL, just return NIL.
2379 When given a non-null SYMBOL, first downcase its name and treat it as a string.
2380 When given a STRING, portably decompose it into a pathname as below.
2382 #\\/ separates directory components.
2384 The last #\\/-separated substring is interpreted as follows:
2385 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2386 the string is made the last directory component, and NAME and TYPE are NIL.
2387 if the string is empty, it's the empty pathname with all slots NIL.
2388 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
2389 are separated by SPLIT-NAME-TYPE.
2390 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2392 Directory components with an empty name or the name \".\" are removed.
2393 Any directory named \"..\" is read as DOT-DOT,
2394 which must be one of :BACK or :UP and defaults to :BACK.
2396 HOST, DEVICE and VERSION components are taken from DEFAULTS,
2397 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
2398 No host or device can be specified in the string itself,
2399 which makes it unsuitable for absolute pathnames outside Unix.
2401 For relative pathnames, these components (and hence the defaults) won't matter
2402 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2403 which is an important reason to always use MERGE-PATHNAMES*.
2405 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2406 with those keys, removing TYPE DEFAULTS and DOT-DOT.
2407 When you're manipulating pathnames that are supposed to make sense portably
2408 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2409 to throw an error if the pathname is absolute"
2411 (check-type type
(or null string
(eql :directory
)))
2412 (when ensure-directory
2413 (setf type
:directory
))
2415 ((or null pathname
) (return name
))
2417 (setf name
(string-downcase name
)))
2419 (multiple-value-bind (relative path filename file-only
)
2420 (split-unix-namestring-directory-components
2421 name
:dot-dot dot-dot
:ensure-directory
(eq type
:directory
))
2422 (multiple-value-bind (name type
)
2424 ((or (eq type
:directory
) (null filename
))
2427 (values filename type
))
2429 (split-name-type filename
)))
2430 (apply 'ensure-pathname
2432 :directory
(unless file-only
(cons relative path
))
2433 :name name
:type type
2434 :defaults
(or #-mcl defaults
*nil-pathname
*))
2435 (remove-plist-keys '(:type
:dot-dot
:defaults
) keys
))))))
2437 (defun unix-namestring (pathname)
2438 "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2439 If the PATHNAME is NIL or a STRING, return it unchanged.
2441 This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2442 This is a portable solution for representing relative pathnames,
2443 But unless you are running on a Unix system, it is not a general solution
2444 to representing native pathnames.
2446 An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2447 or if it is a PATHNAME but some of its components are not recognized."
2449 ((or null string
) pathname
)
2451 (with-output-to-string (s)
2452 (flet ((err () #+lispworks
(describe pathname
) (error "Not a valid unix-namestring ~S" pathname
)))
2453 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname
)))
2454 (name (pathname-name pathname
))
2455 (name (and (not (eq name
:unspecific
)) name
))
2456 (type (pathname-type pathname
))
2457 (type (and (not (eq type
:unspecific
)) type
)))
2459 ((member dir
'(nil :unspecific
)))
2460 ((eq dir
'(:relative
)) (princ "./" s
))
2462 (destructuring-bind (relabs &rest dirs
) dir
2463 (or (member relabs
'(:relative
:absolute
)) (err))
2464 (when (eq relabs
:absolute
) (princ #\
/ s
))
2465 (loop :for x
:in dirs
:do
2467 ((member x
'(:back
:up
)) (princ "../" s
))
2468 ((equal x
"") (err))
2469 ;;((member x '("." "..") :test 'equal) (err))
2470 ((stringp x
) (format s
"~A/" x
))
2475 (unless (and (stringp name
) (or (null type
) (stringp type
))) (err))
2476 (format s
"~A~@[.~A~]" name type
))
2478 (or (null type
) (err)))))))))))
2480 ;;; Absolute and relative pathnames
2481 (with-upgradability ()
2482 (defun subpathname (pathname subpath
&key type
)
2483 "This function takes a PATHNAME and a SUBPATH and a TYPE.
2484 If SUBPATH is already a PATHNAME object (not namestring),
2485 and is an absolute pathname at that, it is returned unchanged;
2486 otherwise, SUBPATH is turned into a relative pathname with given TYPE
2487 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2488 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2489 (or (and (pathnamep subpath
) (absolute-pathname-p subpath
))
2490 (merge-pathnames* (parse-unix-namestring subpath
:type type
:want-relative t
)
2491 (pathname-directory-pathname pathname
))))
2493 (defun subpathname* (pathname subpath
&key type
)
2494 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2496 (subpathname (ensure-directory-pathname pathname
) subpath
:type type
)))
2498 (defun pathname-root (pathname)
2499 "return the root directory for the host and device of given PATHNAME"
2500 (make-pathname* :directory
'(:absolute
)
2501 :name nil
:type nil
:version nil
2502 :defaults pathname
;; host device, and on scl, *some*
2503 ;; scheme-specific parts: port username password, not others:
2504 .
#.
(or #+scl
'(:parameters nil
:query nil
:fragment nil
))))
2506 (defun pathname-host-pathname (pathname)
2507 "return a pathname with the same host as given PATHNAME, and all other fields NIL"
2508 (make-pathname* :directory nil
2509 :name nil
:type nil
:version nil
:device nil
2510 :defaults pathname
;; host device, and on scl, *some*
2511 ;; scheme-specific parts: port username password, not others:
2512 .
#.
(or #+scl
'(:parameters nil
:query nil
:fragment nil
))))
2514 (defun ensure-absolute-pathname (path &optional defaults
(on-error 'error
))
2515 "Given a pathname designator PATH, return an absolute pathname as specified by PATH
2516 considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
2517 with a format control-string and other arguments as arguments"
2519 ((absolute-pathname-p path
))
2520 ((stringp path
) (ensure-absolute-pathname (pathname path
) defaults on-error
))
2521 ((not (pathnamep path
)) (call-function on-error
"not a valid pathname designator ~S" path
))
2522 ((let ((default-pathname (if (pathnamep defaults
) defaults
(call-function defaults
))))
2523 (or (if (absolute-pathname-p default-pathname
)
2524 (absolute-pathname-p (merge-pathnames* path default-pathname
))
2525 (call-function on-error
"Default pathname ~S is not an absolute pathname"
2527 (call-function on-error
"Failed to merge ~S with ~S into an absolute pathname"
2528 path default-pathname
))))
2529 (t (call-function on-error
2530 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2533 (defun subpathp (maybe-subpath base-pathname
)
2534 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
2535 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
2536 (and (pathnamep maybe-subpath
) (pathnamep base-pathname
)
2537 (absolute-pathname-p maybe-subpath
) (absolute-pathname-p base-pathname
)
2538 (directory-pathname-p base-pathname
) (not (wild-pathname-p base-pathname
))
2539 (pathname-equal (pathname-root maybe-subpath
) (pathname-root base-pathname
))
2540 (with-pathname-defaults (*nil-pathname
*)
2541 (let ((enough (enough-namestring maybe-subpath base-pathname
)))
2542 (and (relative-pathname-p enough
) (pathname enough
))))))
2544 (defun enough-pathname (maybe-subpath base-pathname
)
2545 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
2546 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
2547 (let ((sub (when maybe-subpath
(pathname maybe-subpath
)))
2548 (base (when base-pathname
(ensure-absolute-pathname (pathname base-pathname
)))))
2549 (or (and base
(subpathp sub base
)) sub
)))
2551 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk
)
2552 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
2553 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
2554 given DEFAULTS-PATHNAME as a base pathname."
2555 (let ((enough (enough-pathname maybe-subpath defaults-pathname
))
2556 (*default-pathname-defaults
* (or defaults-pathname
*default-pathname-defaults
*)))
2557 (funcall thunk enough
)))
2559 (defmacro with-enough-pathname
((pathname-var &key
(pathname pathname-var
)
2560 (defaults *default-pathname-defaults
*))
2562 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
2563 `(call-with-enough-pathname ,pathname
,defaults
#'(lambda (,pathname-var
) ,@body
))))
2566 ;;; Wildcard pathnames
2567 (with-upgradability ()
2568 (defparameter *wild
* (or #+cormanlisp
"*" :wild
)
2569 "Wild component for use with MAKE-PATHNAME")
2570 (defparameter *wild-directory-component
* (or :wild
)
2571 "Wild directory component for use with MAKE-PATHNAME")
2572 (defparameter *wild-inferiors-component
* (or :wild-inferiors
)
2573 "Wild-inferiors directory component for use with MAKE-PATHNAME")
2574 (defparameter *wild-file
*
2575 (make-pathname :directory nil
:name
*wild
* :type
*wild
*
2576 :version
(or #-
(or allegro abcl xcl
) *wild
*))
2577 "A pathname object with wildcards for matching any file in a given directory")
2578 (defparameter *wild-directory
*
2579 (make-pathname* :directory
`(:relative
,*wild-directory-component
*)
2580 :name nil
:type nil
:version nil
)
2581 "A pathname object with wildcards for matching any subdirectory")
2582 (defparameter *wild-inferiors
*
2583 (make-pathname* :directory
`(:relative
,*wild-inferiors-component
*)
2584 :name nil
:type nil
:version nil
)
2585 "A pathname object with wildcards for matching any recursive subdirectory")
2586 (defparameter *wild-path
*
2587 (merge-pathnames* *wild-file
* *wild-inferiors
*)
2588 "A pathname object with wildcards for matching any file in any recursive subdirectory")
2590 (defun wilden (path)
2591 "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
2592 (merge-pathnames* *wild-path
* path
)))
2595 ;;; Translate a pathname
2596 (with-upgradability ()
2597 (defun relativize-directory-component (directory-component)
2598 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
2599 (let ((directory (normalize-pathname-directory-component directory-component
)))
2601 ((stringp directory
)
2602 (list :relative directory
))
2603 ((eq (car directory
) :absolute
)
2604 (cons :relative
(cdr directory
)))
2608 (defun relativize-pathname-directory (pathspec)
2609 "Given a PATHNAME, return a relative pathname with otherwise the same components"
2610 (let ((p (pathname pathspec
)))
2612 :directory
(relativize-directory-component (pathname-directory p
))
2615 (defun directory-separator-for-host (&optional
(pathname *default-pathname-defaults
*))
2616 "Given a PATHNAME, return the character used to delimit directory names on this host and device."
2617 (let ((foo (make-pathname* :directory
'(:absolute
"FOO") :defaults pathname
)))
2618 (last-char (namestring foo
))))
2621 (defun directorize-pathname-host-device (pathname)
2622 "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
2623 added to its DIRECTORY component. This is useful for output translations."
2626 (when (physical-pathname-p pathname
)
2627 (return-from directorize-pathname-host-device pathname
))))
2628 (let* ((root (pathname-root pathname
))
2629 (wild-root (wilden root
))
2630 (absolute-pathname (merge-pathnames* pathname root
))
2631 (separator (directory-separator-for-host root
))
2632 (root-namestring (namestring root
))
2635 #'(lambda (x) (or (eql x
#\
:)
2638 (multiple-value-bind (relative path filename
)
2639 (split-unix-namestring-directory-components root-string
:ensure-directory t
)
2640 (declare (ignore relative filename
))
2642 (make-pathname* :defaults root
:directory
`(:absolute
,@path
))))
2643 (translate-pathname absolute-pathname wild-root
(wilden new-base
))))))
2646 (defun directorize-pathname-host-device (pathname)
2647 (let ((scheme (ext:pathname-scheme pathname
))
2648 (host (pathname-host pathname
))
2649 (port (ext:pathname-port pathname
))
2650 (directory (pathname-directory pathname
)))
2651 (flet ((specificp (x) (and x
(not (eq x
:unspecific
)))))
2652 (if (or (specificp port
)
2653 (and (specificp host
) (plusp (length host
)))
2656 (when (specificp port
)
2657 (setf prefix
(format nil
":~D" port
)))
2658 (when (and (specificp host
) (plusp (length host
)))
2659 (setf prefix
(strcat host prefix
)))
2660 (setf prefix
(strcat ":" prefix
))
2661 (when (specificp scheme
)
2662 (setf prefix
(strcat scheme prefix
)))
2663 (assert (and directory
(eq (first directory
) :absolute
)))
2664 (make-pathname* :directory
`(:absolute
,prefix
,@(rest directory
))
2665 :defaults pathname
)))
2668 (defun* (translate-pathname*) (path absolute-source destination
&optional root source
)
2669 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
2670 PATH is the pathname to be translated.
2671 ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
2672 DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
2673 or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
2674 or an absolute pathname, to be used as destination for translate-pathname.
2675 In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
2676 (declare (ignore source
))
2678 ((functionp destination
)
2679 (funcall destination path absolute-source
))
2682 ((not (pathnamep destination
))
2683 (error "Invalid destination"))
2684 ((not (absolute-pathname-p destination
))
2685 (translate-pathname path absolute-source
(merge-pathnames* destination root
)))
2687 (translate-pathname (directorize-pathname-host-device path
) absolute-source destination
))
2689 (translate-pathname path absolute-source destination
))))
2691 (defvar *output-translation-function
* 'identity
2692 "Hook for output translations.
2694 This function needs to be idempotent, so that actions can work
2695 whether their inputs were translated or not,
2696 which they will be if we are composing operations. e.g. if some
2697 create-lisp-op creates a lisp file from some higher-level input,
2698 you need to still be able to use compile-op on that lisp file."))
2700 ;;;; -------------------------------------------------------------------------
2701 ;;;; Portability layer around Common Lisp filesystem access
2703 (uiop/package
:define-package
:uiop
/filesystem
2704 (:nicknames
:asdf
/filesystem
)
2705 (:recycle
:uiop
/filesystem
:asdf
/pathname
:asdf
)
2706 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
:uiop
/pathname
)
2708 ;; Native namestrings
2709 #:native-namestring
#:parse-native-namestring
2710 ;; Probing the filesystem
2711 #:truename
* #:safe-file-write-date
#:probe-file
* #:directory-exists-p
#:file-exists-p
2712 #:directory
* #:filter-logical-directory-results
#:directory-files
#:subdirectories
2713 #:collect-sub
*directories
2714 ;; Resolving symlinks somewhat
2715 #:truenamize
#:resolve-symlinks
#:*resolve-symlinks
* #:resolve-symlinks
*
2717 #:get-pathname-defaults
#:call-with-current-directory
#:with-current-directory
2718 ;; Environment pathnames
2719 #:inter-directory-separator
#:split-native-pathnames-string
2720 #:getenv-pathname
#:getenv-pathnames
2721 #:getenv-absolute-directory
#:getenv-absolute-directories
2722 #:lisp-implementation-directory
#:lisp-implementation-pathname-p
2723 ;; Simple filesystem operations
2724 #:ensure-all-directories-exist
2725 #:rename-file-overwriting-target
2726 #:delete-file-if-exists
#:delete-empty-directory
#:delete-directory-tree
))
2727 (in-package :uiop
/filesystem
)
2729 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
2730 (with-upgradability ()
2731 (defun native-namestring (x)
2732 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2734 (let ((p (pathname x
)))
2735 #+clozure
(with-pathname-defaults () (ccl:native-translated-namestring p
)) ; see ccl bug 978
2736 #+(or cmu scl
) (ext:unix-namestring p nil
)
2737 #+sbcl
(sb-ext:native-namestring p
)
2738 #-
(or clozure cmu sbcl scl
)
2740 ((os-unix-p) (unix-namestring p
))
2741 (t (namestring p
))))))
2743 (defun parse-native-namestring (string &rest constraints
&key ensure-directory
&allow-other-keys
)
2744 "From a native namestring suitable for use by the operating system, return
2745 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2746 (check-type string
(or string null
))
2749 (with-pathname-defaults ()
2750 #+clozure
(ccl:native-to-pathname string
)
2751 #+sbcl
(sb-ext:parse-native-namestring string
)
2754 ((os-unix-p) (parse-unix-namestring string
:ensure-directory ensure-directory
))
2755 (t (parse-namestring string
))))))
2757 (if ensure-directory
2758 (and pathname
(ensure-directory-pathname pathname
))
2760 (apply 'ensure-pathname pathname constraints
))))
2763 ;;; Probing the filesystem
2764 (with-upgradability ()
2765 (defun truename* (p)
2766 "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
2768 (when (stringp p
) (setf p
(with-pathname-defaults () (parse-namestring p
))))
2770 (or (ignore-errors (truename p
))
2771 ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
2772 ;; a trailing directory separator, causes an error on some lisps.
2773 #+(or clisp gcl
) (if-let (d (ensure-directory-pathname p
)) (ignore-errors (truename d
)))))))
2775 (defun safe-file-write-date (pathname)
2776 "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
2777 ;; If FILE-WRITE-DATE returns NIL, it's possible that
2778 ;; the user or some other agent has deleted an input file.
2779 ;; Also, generated files will not exist at the time planning is done
2780 ;; and calls compute-action-stamp which calls safe-file-write-date.
2781 ;; So it is very possible that we can't get a valid file-write-date,
2782 ;; and we can survive and we will continue the planning
2783 ;; as if the file were very old.
2784 ;; (or should we treat the case in a different, special way?)
2786 (handler-case (file-write-date (physicalize-pathname pathname
))
2787 (file-error () nil
))))
2789 (defun probe-file* (p &key truename
)
2790 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
2791 probes the filesystem for a file or directory with given pathname.
2792 If it exists, return its truename is ENSURE-PATHNAME is true,
2793 or the original (parsed) pathname if it is false (the default)."
2796 (setf p
(funcall 'ensure-pathname p
2799 :ensure-absolute t
:defaults
'get-pathname-defaults
2804 (probe-file p
:follow-symlinks truename
)
2808 (let ((kind (car (si::stat p
))))
2809 (when (eq kind
:link
)
2810 (setf kind
(ignore-errors (car (si::stat
(truename* p
))))))
2815 ((file-pathname-p p
) p
)
2816 ((directory-pathname-p p
)
2817 (subpathname p
(car (last (pathname-directory p
)))))))
2818 (:directory
(ensure-directory-pathname p
)))))
2820 #.
(let* ((fs (or #-os-windows
(find-symbol* '#:file-stat
:posix nil
)))
2821 (pp (find-symbol* '#:probe-pathname
:ext nil
)))
2826 (truename* (ignore-errors (ensure-directory-pathname p
)))))
2828 (fs `(and (,fs p
) p
))
2829 (pp `(nth-value 1 (,pp p
)))
2830 (t '(or (and (truename* p
) p
)
2831 (if-let (d (ensure-directory-pathname p
))
2832 (and (truename* d
) d
)))))))
2833 #-
(or allegro clisp gcl
)
2837 #+(or cmu scl
) (unix:unix-stat
(ext:unix-namestring p
))
2838 #+(and lispworks unix
) (system:get-file-stat p
)
2839 #+sbcl
(sb-unix:unix-stat
(sb-ext:native-namestring p
))
2840 #-
(or cmu
(and lispworks unix
) sbcl scl
) (file-write-date p
)
2843 (defun directory-exists-p (x)
2844 "Is X the name of a directory that exists on the filesystem?"
2846 (excl:probe-directory x
)
2848 (handler-case (ext:probe-directory x
)
2849 (sys::simple-file-error
()
2851 #-
(or allegro clisp
)
2852 (let ((p (probe-file* x
:truename t
)))
2853 (and (directory-pathname-p p
) p
)))
2855 (defun file-exists-p (x)
2856 "Is X the name of a file that exists on the filesystem?"
2857 (let ((p (probe-file* x
:truename t
)))
2858 (and (file-pathname-p p
) p
)))
2860 (defun directory* (pathname-spec &rest keys
&key
&allow-other-keys
)
2861 "Return a list of the entries in a directory by calling DIRECTORY.
2862 Try to override the defaults to not resolving symlinks, if implementation allows."
2863 (apply 'directory pathname-spec
2864 (append keys
'#.
(or #+allegro
'(:directories-are-files nil
:follow-symbolic-links nil
)
2865 #+(or clozure digitool
) '(:follow-links nil
)
2866 #+clisp
'(:circle t
:if-does-not-exist
:ignore
)
2867 #+(or cmu scl
) '(:follow-links nil
:truenamep nil
)
2868 #+lispworks
'(:link-transparency nil
)
2869 #+sbcl
(when (find-symbol* :resolve-symlinks
'#:sb-impl nil
)
2870 '(:resolve-symlinks nil
))))))
2872 (defun filter-logical-directory-results (directory entries merger
)
2873 "Given ENTRIES in a DIRECTORY, remove if the directory is logical
2874 the entries which are physical yet when transformed by MERGER have a different TRUENAME.
2875 This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
2876 (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
2877 (if (logical-pathname-p directory
)
2878 ;; Try hard to not resolve logical-pathname into physical pathnames;
2879 ;; otherwise logical-pathname users/lovers will be disappointed.
2880 ;; If directory* could use some implementation-dependent magic,
2881 ;; we will have logical pathnames already; otherwise,
2882 ;; we only keep pathnames for which specifying the name and
2883 ;; translating the LPN commute.
2884 (loop :for f
:in entries
2885 :for p
= (or (and (logical-pathname-p f
) f
)
2886 (let* ((u (ignore-errors (call-function merger f
))))
2887 ;; The first u avoids a cumbersome (truename u) error.
2888 ;; At this point f should already be a truename,
2889 ;; but isn't quite in CLISP, for it doesn't have :version :newest
2890 (and u
(equal (truename* u
) (truename* f
)) u
)))
2893 :test
'pathname-equal
))
2896 (defun directory-files (directory &optional
(pattern *wild-file
*))
2897 "Return a list of the files in a directory according to the PATTERN.
2898 Subdirectories should NOT be returned.
2899 PATTERN defaults to a pattern carefully chosen based on the implementation;
2900 override the default at your own risk.
2901 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
2902 but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
2903 (let ((dir (pathname directory
)))
2904 (when (logical-pathname-p dir
)
2905 ;; Because of the filtering we do below,
2906 ;; logical pathnames have restrictions on wild patterns.
2907 ;; Not that the results are very portable when you use these patterns on physical pathnames.
2908 (when (wild-pathname-p dir
)
2909 (error "Invalid wild pattern in logical directory ~S" directory
))
2910 (unless (member (pathname-directory pattern
) '(() (:relative
)) :test
'equal
)
2911 (error "Invalid file pattern ~S for logical directory ~S" pattern directory
))
2912 (setf pattern
(make-pathname-logical pattern
(pathname-host dir
))))
2913 (let* ((pat (merge-pathnames* pattern dir
))
2914 (entries (append (ignore-errors (directory* pat
))
2916 (when (equal :wild
(pathname-type pattern
))
2917 (ignore-errors (directory* (make-pathname :type nil
:defaults pat
)))))))
2918 (remove-if 'directory-pathname-p
2919 (filter-logical-directory-results
2922 (make-pathname :defaults dir
2923 :name
(make-pathname-component-logical (pathname-name f
))
2924 :type
(make-pathname-component-logical (pathname-type f
))
2925 :version
(make-pathname-component-logical (pathname-version f
)))))))))
2927 (defun subdirectories (directory)
2928 "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
2929 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
2930 (let* ((directory (ensure-directory-pathname directory
))
2931 #-
(or abcl cormanlisp genera xcl
)
2932 (wild (merge-pathnames*
2933 #-
(or abcl allegro cmu lispworks sbcl scl xcl
)
2935 #+(or abcl allegro cmu lispworks sbcl scl xcl
) "*.*"
2938 #-
(or abcl cormanlisp genera xcl
)
2940 (directory* wild .
#.
(or #+clozure
'(:directories t
:files nil
)
2941 #+mcl
'(:directories t
))))
2942 #+(or abcl xcl
) (system:list-directory directory
)
2943 #+cormanlisp
(cl::directory-subdirs directory
)
2944 #+genera
(fs:directory-list directory
))
2945 #+(or abcl allegro cmu genera lispworks sbcl scl xcl
)
2946 (dirs (loop :for x
:in dirs
2947 :for d
= #+(or abcl xcl
) (extensions:probe-directory x
)
2948 #+allegro
(excl:probe-directory x
)
2949 #+(or cmu sbcl scl
) (directory-pathname-p x
)
2950 #+genera
(getf (cdr x
) :directory
)
2951 #+lispworks
(lw:file-directory-p x
)
2952 :when d
:collect
#+(or abcl allegro xcl
) d
2953 #+genera
(ensure-directory-pathname (first x
))
2954 #+(or cmu lispworks sbcl scl
) x
)))
2955 (filter-logical-directory-results
2957 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory
))
2958 '(:absolute
)))) ; because allegro returns NIL for #p"FOO:"
2960 (let ((dir (normalize-pathname-directory-component (pathname-directory d
))))
2961 (and (consp dir
) (consp (cdr dir
))
2963 :defaults directory
:name nil
:type nil
:version nil
2964 :directory
(append prefix
(make-pathname-component-logical (last dir
)))))))))))
2966 (defun collect-sub*directories
(directory collectp recursep collector
)
2967 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
2968 call-function the COLLECTOR function designator on the directory,
2969 and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
2970 This function will thus let you traverse a filesystem hierarchy,
2971 superseding the functionality of CL-FAD:WALK-DIRECTORY.
2972 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
2973 (when (call-function collectp directory
)
2974 (call-function collector directory
)
2975 (dolist (subdir (subdirectories directory
))
2976 (when (call-function recursep subdir
)
2977 (collect-sub*directories subdir collectp recursep collector
))))))
2979 ;;; Resolving symlinks somewhat
2980 (with-upgradability ()
2981 (defun truenamize (pathname)
2982 "Resolve as much of a pathname as possible"
2984 (when (typep pathname
'(or null logical-pathname
)) (return pathname
))
2986 (unless (absolute-pathname-p p
)
2987 (setf p
(or (absolute-pathname-p (ensure-absolute-pathname p
'get-pathname-defaults nil
))
2989 (when (logical-pathname-p p
) (return p
))
2990 (let ((found (probe-file* p
:truename t
)))
2991 (when found
(return found
)))
2992 (let* ((directory (normalize-pathname-directory-component (pathname-directory p
)))
2993 (up-components (reverse (rest directory
)))
2994 (down-components ()))
2995 (assert (eq :absolute
(first directory
)))
2996 (loop :while up-components
:do
2999 (probe-file* (make-pathname* :directory
`(:absolute
,@(reverse up-components
))
3000 :name nil
:type nil
:version nil
:defaults p
))))
3004 (make-pathname* :directory
`(:relative
,@down-components
)
3006 (ensure-directory-pathname parent
))))
3007 (return simplified
)))
3008 (push (pop up-components
) down-components
)
3009 :finally
(return p
))))))
3011 (defun resolve-symlinks (path)
3012 "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
3013 #-allegro
(truenamize path
)
3015 (if (physical-pathname-p path
)
3016 (or (ignore-errors (excl:pathname-resolve-symbolic-links path
)) path
)
3019 (defvar *resolve-symlinks
* t
3020 "Determine whether or not ASDF resolves symlinks when defining systems.
3023 (defun resolve-symlinks* (path)
3024 "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
3025 (if *resolve-symlinks
*
3026 (and path
(resolve-symlinks path
))
3030 ;;; Check pathname constraints
3031 (with-upgradability ()
3032 (defun ensure-pathname
3035 defaults type dot-dot namestring
3038 want-logical want-physical ensure-physical
3039 want-relative want-absolute ensure-absolute ensure-subpath
3040 want-non-wild want-wild wilden
3041 want-file want-directory ensure-directory
3042 want-existing ensure-directories-exist
3043 truename resolve-symlinks truenamize
3044 &aux
(p pathname
)) ;; mutable working copy, preserve original
3045 "Coerces its argument into a PATHNAME,
3046 optionally doing some transformations and checking specified constraints.
3048 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
3050 If the argument is a STRING, it is first converted to a pathname via
3051 PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
3052 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
3053 or else by using CALL-FUNCTION on the NAMESTRING argument;
3054 if :UNIX is specified (or NIL, the default, which specifies the same thing),
3055 then PARSE-UNIX-NAMESTRING it is called with the keywords
3056 DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
3057 the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
3059 The pathname passed or resulting from parsing the string
3060 is then subjected to all the checks and transformations below are run.
3062 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
3063 The boolean T is an alias for ERROR.
3064 ERROR means that an error will be raised if the constraint is not satisfied.
3065 CERROR means that an continuable error will be raised if the constraint is not satisfied.
3066 IGNORE means just return NIL instead of the pathname.
3068 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
3069 that will be called with the the following arguments:
3070 a generic format string for ensure pathname, the pathname,
3071 the keyword argument corresponding to the failed check or transformation,
3072 a format string for the reason ENSURE-PATHNAME failed,
3073 and a list with arguments to that format string.
3074 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
3075 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
3077 The transformations and constraint checks are done in this order,
3078 which is also the order in the lambda-list:
3080 EMPTY-IS-NIL returns NIL if the argument is an empty string.
3081 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
3082 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
3083 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
3084 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
3085 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
3086 WANT-RELATIVE checks that pathname has a relative directory component
3087 WANT-ABSOLUTE checks that pathname does have an absolute directory component
3088 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
3089 that the result absolute is an absolute pathname indeed.
3090 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
3091 WANT-FILE checks that pathname has a non-nil FILE component
3092 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
3093 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
3094 any file and type components as being actually a last directory component.
3095 WANT-NON-WILD checks that pathname is not a wild pathname
3096 WANT-WILD checks that pathname is a wild pathname
3097 WILDEN merges the pathname with **/*.*.* if it is not wild
3098 WANT-EXISTING checks that a file (or directory) exists with that pathname.
3099 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
3100 TRUENAME replaces the pathname by its truename, or errors if not possible.
3101 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
3102 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
3104 (flet ((report-error (keyword description
&rest arguments
)
3105 (call-function (or on-error
'error
)
3106 "Invalid pathname ~S: ~*~?"
3107 pathname keyword description arguments
)))
3108 (macrolet ((err (constraint &rest arguments
)
3109 `(report-error ',(intern* constraint
:keyword
) ,@arguments
))
3110 (check (constraint condition
&rest arguments
)
3112 (unless ,condition
(err ,constraint
,@arguments
))))
3113 (transform (transform condition expr
)
3115 (,@(if condition
`(when ,condition
) '(progn))
3118 ((or null pathname
))
3120 (when (and (emptyp p
) empty-is-nil
)
3121 (return-from ensure-pathname nil
))
3122 (setf p
(case namestring
3124 (parse-unix-namestring
3125 p
:defaults defaults
:type type
:dot-dot dot-dot
3126 :ensure-directory ensure-directory
:want-relative want-relative
))
3128 (parse-native-namestring p
))
3130 (parse-namestring p
))
3132 (call-function namestring p
))))))
3136 (check want-pathname
(pathnamep p
) "Expected a pathname, not NIL")
3138 (check want-logical
(logical-pathname-p p
) "Expected a logical pathname")
3139 (check want-physical
(physical-pathname-p p
) "Expected a physical pathname")
3140 (transform ensure-physical
() (physicalize-pathname p
))
3141 (check ensure-physical
(physical-pathname-p p
) "Could not translate to a physical pathname")
3142 (check want-relative
(relative-pathname-p p
) "Expected a relative pathname")
3143 (check want-absolute
(absolute-pathname-p p
) "Expected an absolute pathname")
3144 (transform ensure-absolute
(not (absolute-pathname-p p
))
3145 (ensure-absolute-pathname p defaults
(list #'report-error
:ensure-absolute
"~@?")))
3146 (check ensure-absolute
(absolute-pathname-p p
)
3147 "Could not make into an absolute pathname even after merging with ~S" defaults
)
3148 (check ensure-subpath
(absolute-pathname-p defaults
)
3149 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults
)
3150 (check ensure-subpath
(subpathp p defaults
) "is not a sub pathname of ~S" defaults
)
3151 (check want-file
(file-pathname-p p
) "Expected a file pathname")
3152 (check want-directory
(directory-pathname-p p
) "Expected a directory pathname")
3153 (transform ensure-directory
(not (directory-pathname-p p
)) (ensure-directory-pathname p
))
3154 (check want-non-wild
(not (wild-pathname-p p
)) "Expected a non-wildcard pathname")
3155 (check want-wild
(wild-pathname-p p
) "Expected a wildcard pathname")
3156 (transform wilden
(not (wild-pathname-p p
)) (wilden p
))
3158 (let ((existing (probe-file* p
:truename truename
)))
3162 (err want-existing
"Expected an existing pathname"))))
3163 (when ensure-directories-exist
(ensure-directories-exist p
))
3165 (let ((truename (truename* p
)))
3168 (err truename
"Can't get a truename for pathname"))))
3169 (transform resolve-symlinks
() (resolve-symlinks p
))
3170 (transform truenamize
() (truenamize p
))
3174 ;;; Pathname defaults
3175 (with-upgradability ()
3176 (defun get-pathname-defaults (&optional
(defaults *default-pathname-defaults
*))
3177 "Find the actual DEFAULTS to use for pathnames, including
3178 resolving them with respect to GETCWD if the DEFAULTS were relative"
3179 (or (absolute-pathname-p defaults
)
3180 (merge-pathnames* defaults
(getcwd))))
3182 (defun call-with-current-directory (dir thunk
)
3183 "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
3184 Note that this operation is usually NOT thread-safe."
3186 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir
))))
3188 (*default-pathname-defaults
* dir
))
3195 (defmacro with-current-directory
((&optional dir
) &body body
)
3196 "Call BODY while the POSIX current working directory is set to DIR"
3197 `(call-with-current-directory ,dir
#'(lambda () ,@body
))))
3200 ;;; Environment pathnames
3201 (with-upgradability ()
3202 (defun inter-directory-separator ()
3203 "What character does the current OS conventionally uses to separate directories?"
3204 (os-cond ((os-unix-p) #\
:) (t #\
;)))
3206 (defun split-native-pathnames-string (string &rest constraints
&key
&allow-other-keys
)
3207 "Given a string of pathnames specified in native OS syntax, separate them in a list,
3208 check constraints and normalize each one as per ENSURE-PATHNAME,
3209 where an empty string denotes NIL."
3210 (loop :for namestring
:in
(split-string string
:separator
(string (inter-directory-separator)))
3211 :collect
(unless (emptyp namestring
) (apply 'parse-native-namestring namestring constraints
))))
3213 (defun getenv-pathname (x &rest constraints
&key ensure-directory want-directory on-error
&allow-other-keys
)
3214 "Extract a pathname from a user-configured environment variable, as per native OS,
3215 check constraints and normalize as per ENSURE-PATHNAME."
3216 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
3217 (apply 'parse-native-namestring
(getenvp x
)
3218 :ensure-directory
(or ensure-directory want-directory
)
3219 :on-error
(or on-error
3220 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname
,x
))
3222 (defun getenv-pathnames (x &rest constraints
&key on-error
&allow-other-keys
)
3223 "Extract a list of pathname from a user-configured environment variable, as per native OS,
3224 check constraints and normalize each one as per ENSURE-PATHNAME.
3225 Any empty entries in the environment variable X will be returned as NILs."
3226 (unless (getf constraints
:empty-is-nil t
)
3227 (error "Cannot have EMPTY-IS-NIL false for GETENV-PATHNAMES."))
3228 (apply 'split-native-pathnames-string
(getenvp x
)
3229 :on-error
(or on-error
3230 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames
,x
))
3233 (defun getenv-absolute-directory (x)
3234 "Extract an absolute directory pathname from a user-configured environment variable,
3236 (getenv-pathname x
:want-absolute t
:ensure-directory t
))
3237 (defun getenv-absolute-directories (x)
3238 "Extract a list of absolute directories from a user-configured environment variable,
3239 as per native OS. Any empty entries in the environment variable X will be returned as
3241 (getenv-pathnames x
:want-absolute t
:ensure-directory t
))
3243 (defun lisp-implementation-directory (&key truename
)
3244 "Where are the system files of the current installation of the CL implementation?"
3245 (declare (ignorable truename
))
3246 #+(or clasp clozure ecl gcl mkcl sbcl
)
3250 #+(or clasp ecl mkcl
) #p
"SYS:"
3251 #+gcl system
::*system-directory
*
3252 #+sbcl
(if-let (it (find-symbol* :sbcl-homedir-pathname
:sb-int nil
))
3254 (getenv-pathname "SBCL_HOME" :ensure-directory t
)))))
3255 (if (and dir truename
)
3259 (defun lisp-implementation-pathname-p (pathname)
3260 "Is the PATHNAME under the current installation of the CL implementation?"
3261 ;; Other builtin systems are those under the implementation directory
3263 (if-let (impdir (lisp-implementation-directory))
3264 (or (subpathp pathname impdir
)
3265 (when *resolve-symlinks
*
3266 (if-let (truename (truename* pathname
))
3267 (if-let (trueimpdir (truename* impdir
))
3268 (subpathp truename trueimpdir
)))))))
3272 ;;; Simple filesystem operations
3273 (with-upgradability ()
3274 (defun ensure-all-directories-exist (pathnames)
3275 "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
3276 (dolist (pathname pathnames
)
3278 (ensure-directories-exist (physicalize-pathname pathname
)))))
3280 (defun delete-file-if-exists (x)
3281 "Delete a file X if it already exists"
3282 (when x
(handler-case (delete-file x
) (file-error () nil
))))
3284 (defun rename-file-overwriting-target (source target
)
3285 "Rename a file, overwriting any previous file with the TARGET name,
3286 in an atomic way if the implementation allows."
3287 #+clisp
;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
3288 (progn (funcall 'require
"syscalls")
3289 (symbol-call :posix
:copy-file source target
:method
:rename
))
3290 #+(and sbcl os-windows
) (delete-file-if-exists target
) ;; not atomic
3292 (rename-file source target
3293 #+(or clasp clozure ecl
) :if-exists
#+clozure
:rename-and-delete
#+(or clasp ecl
) t
))
3295 (defun delete-empty-directory (directory-pathname)
3296 "Delete an empty directory"
3297 #+(or abcl digitool gcl
) (delete-file directory-pathname
)
3298 #+allegro
(excl:delete-directory directory-pathname
)
3299 #+clisp
(ext:delete-directory directory-pathname
)
3300 #+clozure
(ccl::delete-empty-directory directory-pathname
)
3301 #+(or cmu scl
) (multiple-value-bind (ok errno
)
3302 (unix:unix-rmdir
(native-namestring directory-pathname
))
3304 #+cmu
(error "Error number ~A when trying to delete directory ~A"
3305 errno directory-pathname
)
3306 #+scl
(error "~@<Error deleting ~S: ~A~@:>"
3307 directory-pathname
(unix:get-unix-error-msg errno
))))
3308 #+cormanlisp
(win32:delete-directory directory-pathname
)
3309 #+(or clasp ecl
) (si:rmdir directory-pathname
)
3310 #+genera
(fs:delete-directory directory-pathname
)
3311 #+lispworks
(lw:delete-directory directory-pathname
)
3312 #+mkcl
(mkcl:rmdir directory-pathname
)
3313 #+sbcl
#.
(if-let (dd (find-symbol* :delete-directory
:sb-ext nil
))
3314 `(,dd directory-pathname
) ;; requires SBCL 1.0.44 or later
3315 `(progn (require :sb-posix
) (symbol-call :sb-posix
:rmdir directory-pathname
)))
3316 #+xcl
(symbol-call :uiop
:run-program
`("rmdir" ,(native-namestring directory-pathname
)))
3317 #-
(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl
)
3318 (error "~S not implemented on ~S" 'delete-empty-directory
(implementation-type))) ; genera
3320 (defun delete-directory-tree (directory-pathname &key
(validate nil validatep
) (if-does-not-exist :error
))
3321 "Delete a directory including all its recursive contents, aka rm -rf.
3323 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
3324 a physical non-wildcard directory pathname (not namestring).
3326 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
3327 if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
3329 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
3330 the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
3331 which in practice is thus compulsory, and validates by returning a non-NIL result.
3332 If you're suicidal or extremely confident, just use :VALIDATE T."
3333 (check-type if-does-not-exist
(member :error
:ignore
))
3335 ((not (and (pathnamep directory-pathname
) (directory-pathname-p directory-pathname
)
3336 (physical-pathname-p directory-pathname
) (not (wild-pathname-p directory-pathname
))))
3337 (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
3338 'delete-directory-tree directory-pathname
))
3340 (error "~S was asked to delete ~S but was not provided a validation predicate"
3341 'delete-directory-tree directory-pathname
))
3342 ((not (call-function validate directory-pathname
))
3343 (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
3344 'delete-directory-tree directory-pathname validate
))
3345 ((not (directory-exists-p directory-pathname
))
3346 (ecase if-does-not-exist
3348 (error "~S was asked to delete ~S but the directory does not exist"
3349 'delete-directory-tree directory-pathname
))
3351 #-
(or allegro cmu clozure genera sbcl scl
)
3352 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
3353 ;; except on implementations where we can prevent DIRECTORY from following symlinks;
3354 ;; instead spawn a standard external program to do the dirty work.
3355 (symbol-call :uiop
:run-program
`("rm" "-rf" ,(native-namestring directory-pathname
))))
3357 ;; On supported implementation, call supported system functions
3358 #+allegro
(symbol-call :excl.osi
:delete-directory-and-files
3359 directory-pathname
:if-does-not-exist if-does-not-exist
)
3360 #+clozure
(ccl:delete-directory directory-pathname
)
3361 #+genera
(fs:delete-directory directory-pathname
:confirm nil
)
3362 #+sbcl
#.
(if-let (dd (find-symbol* :delete-directory
:sb-ext nil
))
3363 `(,dd directory-pathname
:recursive t
) ;; requires SBCL 1.0.44 or later
3364 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree
))
3365 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
3366 ;; do things the hard way.
3367 #-
(or allegro clozure genera sbcl
)
3368 (let ((sub*directories
3369 (while-collecting (c)
3370 (collect-sub*directories directory-pathname t t
#'c
))))
3371 (dolist (d (nreverse sub
*directories
))
3372 (map () 'delete-file
(directory-files d
))
3373 (delete-empty-directory d
)))))))
3374 ;;;; ---------------------------------------------------------------------------
3375 ;;;; Utilities related to streams
3377 (uiop/package
:define-package
:uiop
/stream
3378 (:nicknames
:asdf
/stream
)
3379 (:recycle
:uiop
/stream
:asdf
/stream
:asdf
)
3380 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/os
:uiop
/pathname
:uiop
/filesystem
)
3382 #:*default-stream-element-type
*
3383 #:*stdin
* #:setup-stdin
#:*stdout
* #:setup-stdout
#:*stderr
* #:setup-stderr
3384 #:detect-encoding
#:*encoding-detection-hook
* #:always-default-encoding
3385 #:encoding-external-format
#:*encoding-external-format-hook
* #:default-encoding-external-format
3386 #:*default-encoding
* #:*utf-8-external-format
*
3387 #:with-safe-io-syntax
#:call-with-safe-io-syntax
#:safe-read-from-string
3388 #:with-output
#:output-string
#:with-input
#:input-string
3389 #:with-input-file
#:call-with-input-file
#:with-output-file
#:call-with-output-file
3390 #:null-device-pathname
#:call-with-null-input
#:with-null-input
3391 #:call-with-null-output
#:with-null-output
3392 #:finish-outputs
#:format
! #:safe-format
!
3393 #:copy-stream-to-stream
#:concatenate-files
#:copy-file
3394 #:slurp-stream-string
#:slurp-stream-lines
#:slurp-stream-line
3395 #:slurp-stream-forms
#:slurp-stream-form
3396 #:read-file-string
#:read-file-line
#:read-file-lines
#:safe-read-file-line
3397 #:read-file-forms
#:read-file-form
#:safe-read-file-form
3398 #:eval-input
#:eval-thunk
#:standard-eval-thunk
3401 #:*temporary-directory
* #:temporary-directory
#:default-temporary-directory
3402 #:setup-temporary-directory
3403 #:call-with-temporary-file
#:with-temporary-file
3404 #:add-pathname-suffix
#:tmpize-pathname
3405 #:call-with-staging-pathname
#:with-staging-pathname
))
3406 (in-package :uiop
/stream
)
3408 (with-upgradability ()
3409 (defvar *default-stream-element-type
*
3410 (or #+(or abcl cmu cormanlisp scl xcl
) 'character
3411 #+lispworks
'lw
:simple-char
3413 "default element-type for open (depends on the current CL implementation)")
3415 (defvar *stdin
* *standard-input
*
3416 "the original standard input stream at startup")
3418 (defun setup-stdin ()
3420 #.
(or #+clozure
'ccl
::*stdin
*
3421 #+(or cmu scl
) 'system
:*stdin
*
3422 #+(or clasp ecl
) 'ext
::+process-standard-input
+
3423 #+sbcl
'sb-sys
:*stdin
*
3424 '*standard-input
*)))
3426 (defvar *stdout
* *standard-output
*
3427 "the original standard output stream at startup")
3429 (defun setup-stdout ()
3431 #.
(or #+clozure
'ccl
::*stdout
*
3432 #+(or cmu scl
) 'system
:*stdout
*
3433 #+(or clasp ecl
) 'ext
::+process-standard-output
+
3434 #+sbcl
'sb-sys
:*stdout
*
3435 '*standard-output
*)))
3437 (defvar *stderr
* *error-output
*
3438 "the original error output stream at startup")
3440 (defun setup-stderr ()
3442 #.
(or #+allegro
'excl
::*stderr
*
3443 #+clozure
'ccl
::*stderr
*
3444 #+(or cmu scl
) 'system
:*stderr
*
3445 #+(or clasp ecl
) 'ext
::+process-error-output
+
3446 #+sbcl
'sb-sys
:*stderr
*
3449 ;; Run them now. In image.lisp, we'll register them to be run at image restart.
3450 (setup-stdin) (setup-stdout) (setup-stderr))
3453 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
3454 (with-upgradability ()
3455 (defparameter *default-encoding
*
3456 ;; preserve explicit user changes to something other than the legacy default :default
3457 (or (if-let (previous (and (boundp '*default-encoding
*) (symbol-value '*default-encoding
*)))
3458 (unless (eq previous
:default
) previous
))
3460 "Default encoding for source files.
3461 The default value :utf-8 is the portable thing.
3462 The legacy behavior was :default.
3463 If you (asdf:load-system :asdf-encodings) then
3464 you will have autodetection via *encoding-detection-hook* below,
3465 reading emacs-style -*- coding: utf-8 -*- specifications,
3466 and falling back to utf-8 or latin1 if nothing is specified.")
3468 (defparameter *utf-8-external-format
*
3469 (if (featurep :asdf-unicode
)
3470 (or #+clisp charset
:utf-8
:utf-8
)
3472 "Default :external-format argument to pass to CL:OPEN and also
3473 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
3474 On modern implementations, this will decode UTF-8 code points as CL characters.
3475 On legacy implementations, it may fall back on some 8-bit encoding,
3476 with non-ASCII code points being read as several CL characters;
3477 hopefully, if done consistently, that won't affect program behavior too much.")
3479 (defun always-default-encoding (pathname)
3480 "Trivial function to use as *encoding-detection-hook*,
3481 always 'detects' the *default-encoding*"
3482 (declare (ignore pathname
))
3485 (defvar *encoding-detection-hook
* #'always-default-encoding
3486 "Hook for an extension to define a function to automatically detect a file's encoding")
3488 (defun detect-encoding (pathname)
3489 "Detects the encoding of a specified file, going through user-configurable hooks"
3490 (if (and pathname
(not (directory-pathname-p pathname
)) (probe-file* pathname
))
3491 (funcall *encoding-detection-hook
* pathname
)
3492 *default-encoding
*))
3494 (defun default-encoding-external-format (encoding)
3495 "Default, ignorant, function to transform a character ENCODING as a
3496 portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
3497 Load system ASDF-ENCODINGS to hook in a better one."
3499 (:default
:default
) ;; for backward-compatibility only. Explicit usage discouraged.
3500 (:utf-8
*utf-8-external-format
*)
3502 (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
)
3505 (defvar *encoding-external-format-hook
*
3506 #'default-encoding-external-format
3507 "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
3508 from non-default encodings to and implementation-defined external-format's")
3510 (defun encoding-external-format (encoding)
3511 "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
3512 going through all the proper hooks."
3513 (funcall *encoding-external-format-hook
* (or encoding
*default-encoding
*))))
3517 (with-upgradability ()
3518 (defvar *standard-readtable
* (with-standard-io-syntax *readtable
*)
3519 "The standard readtable, implementing the syntax specified by the CLHS.
3520 It must never be modified, though only good implementations will even enforce that.")
3522 (defmacro with-safe-io-syntax
((&key
(package :cl
)) &body body
)
3523 "Establish safe CL reader options around the evaluation of BODY"
3524 `(call-with-safe-io-syntax #'(lambda () (let ((*package
* (find-package ,package
))) ,@body
))))
3526 (defun call-with-safe-io-syntax (thunk &key
(package :cl
))
3527 (with-standard-io-syntax
3528 (let ((*package
* (find-package package
))
3529 (*read-default-float-format
* 'double-float
)
3530 (*print-readably
* nil
)
3534 (defun safe-read-from-string (string &key
(package :cl
) (eof-error-p t
) eof-value
(start 0) end preserve-whitespace
)
3535 "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
3536 (with-safe-io-syntax (:package package
)
3537 (read-from-string string eof-error-p eof-value
:start start
:end end
:preserve-whitespace preserve-whitespace
))))
3540 (with-upgradability ()
3541 (defun call-with-output-file (pathname thunk
3543 (element-type *default-stream-element-type
*)
3544 (external-format *utf-8-external-format
*)
3546 (if-does-not-exist :create
))
3547 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3548 Other keys are accepted but discarded."
3549 (with-open-file (s pathname
:direction
:output
3550 :element-type element-type
3551 :external-format external-format
3552 :if-exists if-exists
3553 :if-does-not-exist if-does-not-exist
)
3556 (defmacro with-output-file
((var pathname
&rest keys
3557 &key element-type external-format if-exists if-does-not-exist
)
3559 (declare (ignore element-type external-format if-exists if-does-not-exist
))
3560 `(call-with-output-file ,pathname
#'(lambda (,var
) ,@body
) ,@keys
))
3562 (defun call-with-output (output function
&key keys
)
3563 "Calls FUNCTION with an actual stream argument,
3564 behaving like FORMAT with respect to how stream designators are interpreted:
3565 If OUTPUT is a STREAM, use it as the stream.
3566 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
3567 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
3568 If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream.
3569 If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE
3570 -- this latter as an extension since ASDF 3.1.
3571 Otherwise, signal an error."
3574 (with-output-to-string (stream) (funcall function stream
)))
3576 (funcall function
*standard-output
*))
3578 (funcall function output
))
3580 (assert (fill-pointer output
))
3581 (with-output-to-string (stream output
) (funcall function stream
)))
3583 (apply 'call-with-output-file output function keys
))))
3585 (defmacro with-output
((output-var &optional
(value output-var
)) &body body
)
3586 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3587 as per FORMAT, and evaluate BODY within the scope of this binding."
3588 `(call-with-output ,value
#'(lambda (,output-var
) ,@body
)))
3590 (defun output-string (string &optional output
)
3591 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3593 (with-output (output) (princ string output
))
3598 (with-upgradability ()
3599 (defun call-with-input-file (pathname thunk
3601 (element-type *default-stream-element-type
*)
3602 (external-format *utf-8-external-format
*)
3603 (if-does-not-exist :error
))
3604 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3605 Other keys are accepted but discarded."
3606 (with-open-file (s pathname
:direction
:input
3607 :element-type element-type
3608 :external-format external-format
3609 :if-does-not-exist if-does-not-exist
)
3612 (defmacro with-input-file
((var pathname
&rest keys
3613 &key element-type external-format if-does-not-exist
)
3615 (declare (ignore element-type external-format if-does-not-exist
))
3616 `(call-with-input-file ,pathname
#'(lambda (,var
) ,@body
) ,@keys
))
3618 (defun call-with-input (input function
&key keys
)
3619 "Calls FUNCTION with an actual stream argument, interpreting
3620 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
3621 and PATHNAME to FILE-STREAM.
3622 If INPUT is a STREAM, use it as the stream.
3623 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
3624 If INPUT is T, use *TERMINAL-IO* as the stream.
3625 If INPUT is a STRING, use it as a string-input-stream.
3626 If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
3627 -- the latter is an extension since ASDF 3.1.
3628 Otherwise, signal an error."
3630 (null (funcall function
*standard-input
*))
3631 ((eql t
) (funcall function
*terminal-io
*))
3632 (stream (funcall function input
))
3633 (string (with-input-from-string (stream input
) (funcall function stream
)))
3634 (pathname (apply 'call-with-input-file input function keys
))))
3636 (defmacro with-input
((input-var &optional
(value input-var
)) &body body
)
3637 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3638 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3639 `(call-with-input ,value
#'(lambda (,input-var
) ,@body
)))
3641 (defun input-string (&optional input
)
3642 "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
3646 (with-input (input) (funcall 'slurp-stream-string input
)))))
3649 (with-upgradability ()
3650 (defun null-device-pathname ()
3651 "Pathname to a bit bucket device that discards any information written to it
3652 and always returns EOF when read from"
3654 ((os-unix-p) #p
"/dev/null")
3655 ((os-windows-p) #p
"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
3656 (t (error "No /dev/null on your OS"))))
3657 (defun call-with-null-input (fun &rest keys
&key element-type external-format if-does-not-exist
)
3658 "Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
3659 (declare (ignore element-type external-format if-does-not-exist
))
3660 (apply 'call-with-input-file
(null-device-pathname) fun keys
))
3661 (defmacro with-null-input
((var &rest keys
3662 &key element-type external-format if-does-not-exist
)
3664 (declare (ignore element-type external-format if-does-not-exist
))
3665 "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
3666 Pass keyword arguments to OPEN."
3667 `(call-with-null-input #'(lambda (,var
) ,@body
) ,@keys
))
3668 (defun call-with-null-output (fun
3669 &key
(element-type *default-stream-element-type
*)
3670 (external-format *utf-8-external-format
*)
3671 (if-exists :overwrite
)
3672 (if-does-not-exist :error
))
3673 "Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
3674 (call-with-output-file
3675 (null-device-pathname) fun
3676 :element-type element-type
:external-format external-format
3677 :if-exists if-exists
:if-does-not-exist if-does-not-exist
))
3678 (defmacro with-null-output
((var &rest keys
3679 &key element-type external-format if-does-not-exist if-exists
)
3681 "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
3682 Pass keyword arguments to OPEN."
3683 (declare (ignore element-type external-format if-exists if-does-not-exist
))
3684 `(call-with-null-output #'(lambda (,var
) ,@body
) ,@keys
)))
3686 ;;; Ensure output buffers are flushed
3687 (with-upgradability ()
3688 (defun finish-outputs (&rest streams
)
3689 "Finish output on the main output streams as well as any specified one.
3690 Useful for portably flushing I/O before user input or program exit."
3691 ;; CCL notably buffers its stream output by default.
3692 (dolist (s (append streams
3693 (list *stdout
* *stderr
* *error-output
* *standard-output
* *trace-output
*
3694 *debug-io
* *terminal-io
* *query-io
*)))
3695 (ignore-errors (finish-output s
)))
3698 (defun format! (stream format
&rest args
)
3699 "Just like format, but call finish-outputs before and after the output."
3700 (finish-outputs stream
)
3701 (apply 'format stream format args
)
3702 (finish-outputs stream
))
3704 (defun safe-format! (stream format
&rest args
)
3705 "Variant of FORMAT that is safe against both
3706 dangerous syntax configuration and errors while printing."
3707 (with-safe-io-syntax ()
3708 (ignore-errors (apply 'format
! stream format args
))
3709 (finish-outputs stream
)))) ; just in case format failed
3712 ;;; Simple Whole-Stream processing
3713 (with-upgradability ()
3714 (defun copy-stream-to-stream (input output
&key element-type buffer-size linewise prefix
)
3715 "Copy the contents of the INPUT stream into the OUTPUT stream.
3716 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3717 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3718 (with-open-stream (input input
)
3720 (loop* :for
(line eof
) = (multiple-value-list (read-line input nil nil
))
3722 (when prefix
(princ prefix output
))
3724 (unless eof
(terpri output
))
3725 (finish-output output
)
3726 (when eof
(return)))
3728 :with buffer-size
= (or buffer-size
8192)
3729 :for buffer
= (make-array (list buffer-size
) :element-type
(or element-type
'character
))
3730 :for end
= (read-sequence buffer input
)
3732 :do
(write-sequence buffer output
:end end
)
3733 (when (< end buffer-size
) (return))))))
3735 (defun concatenate-files (inputs output
)
3736 "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
3737 (with-open-file (o output
:element-type
'(unsigned-byte 8)
3738 :direction
:output
:if-exists
:rename-and-delete
)
3739 (dolist (input inputs
)
3740 (with-open-file (i input
:element-type
'(unsigned-byte 8)
3741 :direction
:input
:if-does-not-exist
:error
)
3742 (copy-stream-to-stream i o
:element-type
'(unsigned-byte 8))))))
3744 (defun copy-file (input output
)
3745 "Copy contents of the INPUT file to the OUTPUT file"
3746 ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
3747 (concatenate-files (list input
) output
))
3749 (defun slurp-stream-string (input &key
(element-type 'character
) stripped
)
3750 "Read the contents of the INPUT stream as a string"
3752 (with-open-stream (input input
)
3753 (with-output-to-string (output)
3754 (copy-stream-to-stream input output
:element-type element-type
)))))
3755 (if stripped
(stripln string
) string
)))
3757 (defun slurp-stream-lines (input &key count
)
3758 "Read the contents of the INPUT stream as a list of lines, return those lines.
3760 Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
3761 from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
3763 Read no more than COUNT lines."
3764 (check-type count
(or null integer
))
3765 (with-open-stream (input input
)
3766 (loop :for n
:from
0
3767 :for l
= (and (or (not count
) (< n count
))
3768 (read-line input nil nil
))
3769 ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
3770 :while l
:collect
(stripln l
))))
3772 (defun slurp-stream-line (input &key
(at 0))
3773 "Read the contents of the INPUT stream as a list of lines,
3774 then return the ACCESS-AT of that list of lines using the AT specifier.
3775 PATH defaults to 0, i.e. return the first line.
3776 PATH is typically an integer, or a list of an integer and a function.
3777 If PATH is NIL, it will return all the lines in the file.
3779 The stream will not be read beyond the Nth lines,
3780 where N is the index specified by path
3781 if path is either an integer or a list that starts with an integer."
3782 (access-at (slurp-stream-lines input
:count
(access-at-count at
)) at
))
3784 (defun slurp-stream-forms (input &key count
)
3785 "Read the contents of the INPUT stream as a list of forms,
3786 and return those forms.
3788 If COUNT is null, read to the end of the stream;
3789 if COUNT is an integer, stop after COUNT forms were read.
3791 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3792 (check-type count
(or null integer
))
3793 (loop :with eof
= '#:eof
3795 :for form
= (if (and count
(>= n count
))
3797 (read-preserving-whitespace input nil eof
))
3798 :until
(eq form eof
) :collect form
))
3800 (defun slurp-stream-form (input &key
(at 0))
3801 "Read the contents of the INPUT stream as a list of forms,
3802 then return the ACCESS-AT of these forms following the AT.
3803 AT defaults to 0, i.e. return the first form.
3804 AT is typically a list of integers.
3805 If AT is NIL, it will return all the forms in the file.
3807 The stream will not be read beyond the Nth form,
3808 where N is the index specified by path,
3809 if path is either an integer or a list that starts with an integer.
3811 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3812 (access-at (slurp-stream-forms input
:count
(access-at-count at
)) at
))
3814 (defun read-file-string (file &rest keys
)
3815 "Open FILE with option KEYS, read its contents as a string"
3816 (apply 'call-with-input-file file
'slurp-stream-string keys
))
3818 (defun read-file-lines (file &rest keys
)
3819 "Open FILE with option KEYS, read its contents as a list of lines
3820 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3821 (apply 'call-with-input-file file
'slurp-stream-lines keys
))
3823 (defun read-file-line (file &rest keys
&key
(at 0) &allow-other-keys
)
3824 "Open input FILE with option KEYS (except AT),
3825 and read its contents as per SLURP-STREAM-LINE with given AT specifier.
3826 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3827 (apply 'call-with-input-file file
3828 #'(lambda (input) (slurp-stream-line input
:at at
))
3829 (remove-plist-key :at keys
)))
3831 (defun read-file-forms (file &rest keys
&key count
&allow-other-keys
)
3832 "Open input FILE with option KEYS (except COUNT),
3833 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
3834 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3835 (apply 'call-with-input-file file
3836 #'(lambda (input) (slurp-stream-forms input
:count count
))
3837 (remove-plist-key :count keys
)))
3839 (defun read-file-form (file &rest keys
&key
(at 0) &allow-other-keys
)
3840 "Open input FILE with option KEYS (except AT),
3841 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
3842 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3843 (apply 'call-with-input-file file
3844 #'(lambda (input) (slurp-stream-form input
:at at
))
3845 (remove-plist-key :at keys
)))
3847 (defun safe-read-file-line (pathname &rest keys
&key
(package :cl
) &allow-other-keys
)
3848 "Reads the specified line from the top of a file using a safe standardized syntax.
3849 Extracts the line using READ-FILE-LINE,
3850 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3851 (with-safe-io-syntax (:package package
)
3852 (apply 'read-file-line pathname
(remove-plist-key :package keys
))))
3854 (defun safe-read-file-form (pathname &rest keys
&key
(package :cl
) &allow-other-keys
)
3855 "Reads the specified form from the top of a file using a safe standardized syntax.
3856 Extracts the form using READ-FILE-FORM,
3857 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3858 (with-safe-io-syntax (:package package
)
3859 (apply 'read-file-form pathname
(remove-plist-key :package keys
))))
3861 (defun eval-input (input)
3862 "Portably read and evaluate forms from INPUT, return the last values."
3864 (loop :with results
:with eof
='#:eof
3865 :for form
= (read input nil eof
)
3866 :until
(eq form eof
)
3867 :do
(setf results
(multiple-value-list (eval form
)))
3868 :finally
(return (apply 'values results
)))))
3870 (defun eval-thunk (thunk)
3871 "Evaluate a THUNK of code:
3872 If a function, FUNCALL it without arguments.
3873 If a constant literal and not a sequence, return it.
3874 If a cons or a symbol, EVAL it.
3875 If a string, repeatedly read and evaluate from it, returning the last values."
3877 ((or boolean keyword number character pathname
) thunk
)
3878 ((or cons symbol
) (eval thunk
))
3879 (function (funcall thunk
))
3880 (string (eval-input thunk
))))
3882 (defun standard-eval-thunk (thunk &key
(package :cl
))
3883 "Like EVAL-THUNK, but in a more standardized evaluation context."
3884 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
3886 (with-safe-io-syntax (:package package
)
3887 (let ((*read-eval
* t
))
3888 (eval-thunk thunk
))))))
3890 (with-upgradability ()
3891 (defun println (x &optional
(stream *standard-output
*))
3892 "Variant of PRINC that also calls TERPRI afterwards"
3893 (princ x stream
) (terpri stream
) (finish-output stream
) (values))
3895 (defun writeln (x &rest keys
&key
(stream *standard-output
*) &allow-other-keys
)
3896 "Variant of WRITE that also calls TERPRI afterwards"
3897 (apply 'write x keys
) (terpri stream
) (finish-output stream
) (values)))
3900 ;;; Using temporary files
3901 (with-upgradability ()
3902 (defun default-temporary-directory ()
3903 "Return a default directory to use for temporary files"
3906 (or (getenv-pathname "TMPDIR" :ensure-directory t
)
3907 (parse-native-namestring "/tmp/")))
3909 (getenv-pathname "TEMP" :ensure-directory t
))
3910 (t (subpathname (user-homedir-pathname) "tmp/"))))
3912 (defvar *temporary-directory
* nil
"User-configurable location for temporary files")
3914 (defun temporary-directory ()
3915 "Return a directory to use for temporary files"
3916 (or *temporary-directory
* (default-temporary-directory)))
3918 (defun setup-temporary-directory ()
3919 "Configure a default temporary directory to use."
3920 (setf *temporary-directory
* (default-temporary-directory))
3921 #+gcl
(setf system
::*tmp-dir
* *temporary-directory
*))
3923 (defun call-with-temporary-file
3925 (want-stream-p t
) (want-pathname-p t
) (direction :io
) keep after
3926 directory
(type "tmp" typep
) prefix
(suffix (when typep
"-tmp"))
3927 (element-type *default-stream-element-type
*)
3928 (external-format *utf-8-external-format
*))
3929 "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
3931 The temporary file's pathname will be based on concatenating
3932 PREFIX (defaults to \"uiop\"), a random alphanumeric string,
3933 and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
3934 and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
3935 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
3937 The file will be open with specified DIRECTION (defaults to :IO),
3938 ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
3939 EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
3940 If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
3941 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
3942 and stream with be closed after the THUNK exits (either normally or abnormally).
3943 If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
3944 THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
3945 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
3946 If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
3947 Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
3948 #+xcl
(declare (ignorable typep
))
3949 (check-type direction
(member :output
:io
))
3950 (assert (or want-stream-p want-pathname-p
))
3952 :with prefix
= (native-namestring
3953 (ensure-absolute-pathname
3955 (or (ensure-pathname directory
:namestring
:native
:ensure-directory t
)
3956 #'temporary-directory
)))
3958 :for counter
:from
(random (expt 36 #-gcl
8 #+gcl
5))
3959 :for pathname
= (parse-native-namestring
3960 (format nil
"~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type
))
3962 ;; TODO: on Unix, do something about umask
3963 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
3964 ;; TODO: on Unix, use CFFI and mkstemp --
3965 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
3966 ;; Can we at least design some hook?
3969 (with-open-file (stream pathname
3970 :direction direction
3971 :element-type element-type
3972 :external-format external-format
3973 :if-exists nil
:if-does-not-exist
:create
)
3977 ;; Note: can't return directly from within with-open-file
3978 ;; or the non-local return causes the file creation to be undone.
3979 (setf results
(multiple-value-list
3981 (funcall thunk stream pathname
)
3982 (funcall thunk stream
)))))))
3985 (after (return (call-function after okp
)))
3986 ((and want-pathname-p
(not want-stream-p
)) (return (call-function thunk okp
)))
3987 (t (return (apply 'values results
)))))
3988 (when (and okp
(not (call-function keep
)))
3989 (ignore-errors (delete-file-if-exists okp
))))))
3991 (defmacro with-temporary-file
((&key
(stream (gensym "STREAM") streamp
)
3992 (pathname (gensym "PATHNAME") pathnamep
)
3993 directory prefix suffix type
3994 keep direction element-type external-format
)
3996 "Evaluate BODY where the symbols specified by keyword arguments
3997 STREAM and PATHNAME (if respectively specified) are bound corresponding
3998 to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
3999 At least one of STREAM or PATHNAME must be specified.
4000 If the STREAM is not specified, it will be closed before the BODY is evaluated.
4001 If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
4002 separates forms run before and after the stream is closed.
4003 The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
4004 Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
4005 (check-type stream symbol
)
4006 (check-type pathname symbol
)
4007 (assert (or streamp pathnamep
))
4008 (let* ((afterp (position :close-stream body
))
4009 (before (if afterp
(subseq body
0 afterp
) body
))
4010 (after (when afterp
(subseq body
(1+ afterp
))))
4011 (beforef (gensym "BEFORE"))
4012 (afterf (gensym "AFTER")))
4013 `(flet (,@(when before
4014 `((,beforef
(,@(when streamp
`(,stream
)) ,@(when pathnamep
`(,pathname
)))
4015 ,@(when after
`((declare (ignorable ,pathname
))))
4019 `((,afterf
(,pathname
) ,@after
))))
4020 #-gcl
(declare (dynamic-extent ,@(when before
`(#',beforef
)) ,@(when after
`(#',afterf
))))
4021 (call-with-temporary-file
4022 ,(when before
`#',beforef
)
4023 :want-stream-p
,streamp
4024 :want-pathname-p
,pathnamep
4025 ,@(when direction
`(:direction
,direction
))
4026 ,@(when directory
`(:directory
,directory
))
4027 ,@(when prefix
`(:prefix
,prefix
))
4028 ,@(when suffix
`(:suffix
,suffix
))
4029 ,@(when type
`(:type
,type
))
4030 ,@(when keep
`(:keep
,keep
))
4031 ,@(when after
`(:after
#',afterf
))
4032 ,@(when element-type
`(:element-type
,element-type
))
4033 ,@(when external-format
`(:external-format
,external-format
))))))
4035 (defun get-temporary-file (&key directory prefix suffix type
)
4036 (with-temporary-file (:pathname pn
:keep t
4037 :directory directory
:prefix prefix
:suffix suffix
:type type
)
4040 ;; Temporary pathnames in simple cases where no contention is assumed
4041 (defun add-pathname-suffix (pathname suffix
&rest keys
)
4042 "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
4043 Further KEYS can be passed to MAKE-PATHNAME."
4044 (apply 'make-pathname
:name
(strcat (pathname-name pathname
) suffix
)
4045 :defaults pathname keys
))
4047 (defun tmpize-pathname (x)
4048 "Return a new pathname modified from X by adding a trivial deterministic suffix"
4049 (add-pathname-suffix x
"-TMP"))
4051 (defun call-with-staging-pathname (pathname fun
)
4052 "Calls FUN with a staging pathname, and atomically
4053 renames the staging pathname to the PATHNAME in the end.
4054 NB: this protects only against failure of the program, not against concurrent attempts.
4055 For the latter case, we ought pick a random suffix and atomically open it."
4056 (let* ((pathname (pathname pathname
))
4057 (staging (tmpize-pathname pathname
)))
4059 (multiple-value-prog1
4060 (funcall fun staging
)
4061 (rename-file-overwriting-target staging pathname
))
4062 (delete-file-if-exists staging
))))
4064 (defmacro with-staging-pathname
((pathname-var &optional
(pathname-value pathname-var
)) &body body
)
4065 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
4066 `(call-with-staging-pathname ,pathname-value
#'(lambda (,pathname-var
) ,@body
))))
4068 ;;;; -------------------------------------------------------------------------
4069 ;;;; Starting, Stopping, Dumping a Lisp image
4071 (uiop/package
:define-package
:uiop
/image
4072 (:nicknames
:asdf
/image
)
4073 (:recycle
:uiop
/image
:asdf
/image
:xcvb-driver
)
4074 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
:uiop
/pathname
:uiop
/stream
:uiop
/os
)
4076 #:*image-dumped-p
* #:raw-command-line-arguments
#:*command-line-arguments
*
4077 #:command-line-arguments
#:raw-command-line-arguments
#:setup-command-line-arguments
#:argv0
4078 #:*lisp-interaction
*
4079 #:*fatal-conditions
* #:fatal-condition-p
#:handle-fatal-condition
4080 #:call-with-fatal-condition-handler
#:with-fatal-condition-handler
4081 #:*image-restore-hook
* #:*image-prelude
* #:*image-entry-point
*
4082 #:*image-postlude
* #:*image-dump-hook
*
4083 #:quit
#:die
#:raw-print-backtrace
#:print-backtrace
#:print-condition-backtrace
4084 #:shell-boolean-exit
4085 #:register-image-restore-hook
#:register-image-dump-hook
4086 #:call-image-restore-hook
#:call-image-dump-hook
4087 #:restore-image
#:dump-image
#:create-image
4089 (in-package :uiop
/image
)
4091 (with-upgradability ()
4092 (defvar *lisp-interaction
* t
4093 "Is this an interactive Lisp environment, or is it batch processing?")
4095 (defvar *command-line-arguments
* nil
4096 "Command-line arguments")
4098 (defvar *image-dumped-p
* nil
; may matter as to how to get to command-line-arguments
4099 "Is this a dumped image? As a standalone executable?")
4101 (defvar *image-restore-hook
* nil
4102 "Functions to call (in reverse order) when the image is restored")
4104 (defvar *image-restored-p
* nil
4105 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
4107 (defvar *image-prelude
* nil
4108 "a form to evaluate, or string containing forms to read and evaluate
4109 when the image is restarted, but before the entry point is called.")
4111 (defvar *image-entry-point
* nil
4112 "a function with which to restart the dumped image when execution is restored from it.")
4114 (defvar *image-postlude
* nil
4115 "a form to evaluate, or string containing forms to read and evaluate
4116 before the image dump hooks are called and before the image is dumped.")
4118 (defvar *image-dump-hook
* nil
4119 "Functions to call (in order) when before an image is dumped")
4121 (defvar *fatal-conditions
* '(error)
4122 "conditions that cause the Lisp image to enter the debugger if interactive,
4123 or to die if not interactive"))
4126 ;;; Exiting properly or im-
4127 (with-upgradability ()
4128 (defun quit (&optional
(code 0) (finish-output t
))
4129 "Quits from the Lisp world, with the given exit status if provided.
4130 This is designed to abstract away the implementation specific quit forms."
4131 (when finish-output
;; essential, for ClozureCL, and for standard compliance.
4133 #+(or abcl xcl
) (ext:quit
:status code
)
4134 #+allegro
(excl:exit code
:quiet t
)
4135 #+(or clasp ecl
) (si:quit code
)
4136 #+clisp
(ext:quit code
)
4137 #+clozure
(ccl:quit code
)
4138 #+cormanlisp
(win32:exitprocess code
)
4139 #+(or cmu scl
) (unix:unix-exit code
)
4140 #+gcl
(system:quit code
)
4141 #+genera
(error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code
)
4142 #+lispworks
(lispworks:quit
:status code
:confirm nil
:return nil
:ignore-errors-p t
)
4143 #+mcl
(progn code
(ccl:quit
)) ;; or should we use FFI to call libc's exit(3) ?
4144 #+mkcl
(mk-ext:quit
:exit-code code
)
4145 #+sbcl
#.
(let ((exit (find-symbol* :exit
:sb-ext nil
))
4146 (quit (find-symbol* :quit
:sb-ext nil
)))
4148 (exit `(,exit
:code code
:abort
(not finish-output
)))
4149 (quit `(,quit
:unix-status code
:recklessly-p
(not finish-output
)))))
4150 #-
(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
4151 (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code
))
4153 (defun die (code format
&rest arguments
)
4154 "Die in error with some error message"
4155 (with-safe-io-syntax ()
4157 (format! *stderr
* "~&~?~&" format arguments
)))
4160 (defun raw-print-backtrace (&key
(stream *debug-io
*) count condition
)
4161 "Print a backtrace, directly accessing the implementation"
4162 (declare (ignorable stream count condition
))
4164 (loop :for i
:from
0
4165 :for frame
:in
(sys:backtrace
(or count most-positive-fixnum
)) :do
4166 (safe-format! stream
"~&~D: ~A~%" i frame
))
4168 (let ((*terminal-io
* stream
)
4169 (*standard-output
* stream
)
4170 (tpl:*zoom-print-circle
* *print-circle
*)
4171 (tpl:*zoom-print-level
* *print-level
*)
4172 (tpl:*zoom-print-length
* *print-length
*))
4173 (tpl:do-command
"zoom"
4174 :from-read-eval-print-loop nil
4177 #+(or clasp ecl mkcl
)
4178 (let* ((top (si:ihs-top
))
4179 (repeats (if count
(min top count
) top
))
4180 (backtrace (loop :for ihs
:from
0 :below top
4181 :collect
(list (si::ihs-fun ihs
)
4182 (si::ihs-env ihs
)))))
4183 (loop :for i
:from
0 :below repeats
4184 :for frame
:in
(nreverse backtrace
) :do
4185 (safe-format! stream
"~&~D: ~S~%" i frame
)))
4187 (system::print-backtrace
:out stream
:limit count
)
4189 (let ((*debug-io
* stream
))
4190 #+clozure
(ccl:print-call-history
:count count
:start-frame-number
1)
4191 #+mcl
(ccl:print-call-history
:detailed-p nil
)
4192 (finish-output stream
))
4194 (let ((debug:*debug-print-level
* *print-level
*)
4195 (debug:*debug-print-length
* *print-length
*))
4196 (debug:backtrace
(or count most-positive-fixnum
) stream
))
4198 (let ((*debug-io
* stream
))
4200 (with-safe-io-syntax ()
4202 (conditions::condition-backtrace condition
)
4203 (system::simple-backtrace
)))))
4205 (let ((dbg::*debugger-stack
*
4206 (dbg::grab-stack nil
:how-many
(or count most-positive-fixnum
)))
4208 (dbg:*debug-print-level
* *print-level
*)
4209 (dbg:*debug-print-length
* *print-length
*))
4210 (dbg:bug-backtrace nil
))
4213 #.
(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil
) :stream
'(or count most-positive-fixnum
))
4216 (loop :for i
:from
0 :below
(or count most-positive-fixnum
)
4217 :for frame
:in
(extensions:backtrace-as-list
) :do
4218 (safe-format! stream
"~&~D: ~S~%" i frame
)))
4220 (defun print-backtrace (&rest keys
&key stream count condition
)
4222 (declare (ignore stream count condition
))
4223 (with-safe-io-syntax (:package
:cl
)
4224 (let ((*print-readably
* nil
)
4226 (*print-miser-width
* 75)
4227 (*print-length
* nil
)
4230 (ignore-errors (apply 'raw-print-backtrace keys
)))))
4232 (defun print-condition-backtrace (condition &key
(stream *stderr
*) count
)
4233 "Print a condition after a backtrace triggered by that condition"
4234 ;; We print the condition *after* the backtrace,
4235 ;; for the sake of who sees the backtrace at a terminal.
4236 ;; It is up to the caller to print the condition *before*, with some context.
4237 (print-backtrace :stream stream
:count count
:condition condition
)
4239 (safe-format! stream
"~&Above backtrace due to this condition:~%~A~&"
4242 (defun fatal-condition-p (condition)
4243 "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
4244 (match-any-condition-p condition
*fatal-conditions
*))
4246 (defun handle-fatal-condition (condition)
4247 "Handle a fatal CONDITION:
4248 depending on whether *LISP-INTERACTION* is set, enter debugger or die"
4251 (invoke-debugger condition
))
4253 (safe-format! *stderr
* "~&Fatal condition:~%~A~%" condition
)
4254 (print-condition-backtrace condition
:stream
*stderr
*)
4255 (die 99 "~A" condition
))))
4257 (defun call-with-fatal-condition-handler (thunk)
4258 "Call THUNK in a context where fatal conditions are appropriately handled"
4259 (handler-bind (((satisfies fatal-condition-p
) #'handle-fatal-condition
))
4262 (defmacro with-fatal-condition-handler
((&optional
) &body body
)
4263 "Execute BODY in a context where fatal conditions are appropriately handled"
4264 `(call-with-fatal-condition-handler #'(lambda () ,@body
)))
4266 (defun shell-boolean-exit (x)
4267 "Quit with a return code that is 0 iff argument X is true"
4271 ;;; Using image hooks
4272 (with-upgradability ()
4273 (defun register-image-restore-hook (hook &optional
(call-now-p t
))
4274 "Regiter a hook function to be run when restoring a dumped image"
4275 (register-hook-function '*image-restore-hook
* hook call-now-p
))
4277 (defun register-image-dump-hook (hook &optional
(call-now-p nil
))
4278 "Register a the hook function to be run before to dump an image"
4279 (register-hook-function '*image-dump-hook
* hook call-now-p
))
4281 (defun call-image-restore-hook ()
4282 "Call the hook functions registered to be run when restoring a dumped image"
4283 (call-functions (reverse *image-restore-hook
*)))
4285 (defun call-image-dump-hook ()
4286 "Call the hook functions registered to be run before to dump an image"
4287 (call-functions *image-dump-hook
*)))
4290 ;;; Proper command-line arguments
4291 (with-upgradability ()
4292 (defun raw-command-line-arguments ()
4293 "Find what the actual command line for this process was."
4294 #+abcl ext
:*command-line-argument-list
* ; Use 1.0.0 or later!
4295 #+allegro
(sys:command-line-arguments
) ; default: :application t
4296 #+(or clasp ecl
) (loop :for i
:from
0 :below
(si:argc
) :collect
(si:argv i
))
4297 #+clisp
(coerce (ext:argv
) 'list
)
4298 #+clozure ccl
:*command-line-argument-list
*
4299 #+(or cmu scl
) extensions
:*command-line-strings
*
4300 #+gcl si
:*command-args
*
4301 #+(or genera mcl
) nil
4302 #+lispworks sys
:*line-arguments-list
*
4303 #+mkcl
(loop :for i
:from
0 :below
(mkcl:argc
) :collect
(mkcl:argv i
))
4304 #+sbcl sb-ext
:*posix-argv
*
4306 #-
(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl
)
4307 (error "raw-command-line-arguments not implemented yet"))
4309 (defun command-line-arguments (&optional
(arguments (raw-command-line-arguments)))
4310 "Extract user arguments from command-line invocation of current process.
4311 Assume the calling conventions of a generated script that uses --
4312 if we are not called from a directly executable image."
4314 #+abcl
(return arguments
)
4315 ;; SBCL and Allegro already separate user arguments from implementation arguments.
4317 (unless (eq *image-dumped-p
* :executable
)
4318 ;; LispWorks command-line processing isn't transparent to the user
4319 ;; unless you create a standalone executable; in that case,
4320 ;; we rely on cl-launch or some other script to set the arguments for us.
4321 #+lispworks
(return *command-line-arguments
*)
4322 ;; On other implementations, on non-standalone executables,
4323 ;; we trust cl-launch or whichever script starts the program
4324 ;; to use -- as a delimiter between implementation arguments and user arguments.
4325 #-lispworks
(setf arguments
(member "--" arguments
:test
'string-equal
)))
4329 "On supported implementations (most that matter), or when invoked by a proper wrapper script,
4330 return a string that for the name with which the program was invoked, i.e. argv[0] in C.
4331 Otherwise, return NIL."
4333 ((eq *image-dumped-p
* :executable
) ; yes, this ARGV0 is our argv0 !
4334 ;; NB: not currently available on ABCL, Corman, Genera, MCL
4335 (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl
)
4336 (first (raw-command-line-arguments))
4337 #+(or clasp ecl
) (si:argv
0) #+mkcl
(mkcl:argv
0)))
4338 (t ;; argv[0] is the name of the interpreter.
4339 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
4340 (getenvp "__CL_ARGV0"))))
4342 (defun setup-command-line-arguments ()
4343 (setf *command-line-arguments
* (command-line-arguments)))
4345 (defun restore-image (&key
4346 (lisp-interaction *lisp-interaction
*)
4347 (restore-hook *image-restore-hook
*)
4348 (prelude *image-prelude
*)
4349 (entry-point *image-entry-point
*)
4350 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
4351 "From a freshly restarted Lisp image, restore the saved Lisp environment
4352 by setting appropriate variables, running various hooks, and calling any specified entry point.
4354 If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
4355 call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
4356 immediately to the surrounding restore process if allowed to continue.
4358 Then, comes the restore process itself:
4359 First, call each function in the RESTORE-HOOK,
4360 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
4361 Second, evaluate the prelude, which is often Lisp text that is read,
4363 Third, call the ENTRY-POINT function, if any is specified, with no argument.
4365 The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
4366 any unhandled error leads to a backtrace and an exit with an error status.
4367 If LISP-INTERACTION is NIL, the process also exits when no error occurs:
4368 if neither restart nor entry function is provided, the program will exit with status 0 (success);
4369 if a function was provided, the program will exit after the function returns (if it returns),
4370 with status 0 if and only if the primary return value of result is generalized boolean true,
4371 and with status 1 if this value is NIL.
4373 If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
4374 of the function will be returned rather than interpreted as a boolean designating an exit code."
4375 (when *image-restored-p
*
4376 (if if-already-restored
4377 (call-function if-already-restored
"Image already ~:[being ~;~]restored"
4378 (eq *image-restored-p
* t
))
4379 (return-from restore-image
)))
4380 (with-fatal-condition-handler ()
4381 (setf *lisp-interaction
* lisp-interaction
)
4382 (setf *image-restore-hook
* restore-hook
)
4383 (setf *image-prelude
* prelude
)
4384 (setf *image-restored-p
* :in-progress
)
4385 (call-image-restore-hook)
4386 (standard-eval-thunk prelude
)
4387 (setf *image-restored-p
* t
)
4388 (let ((results (multiple-value-list
4390 (call-function entry-point
)
4392 (if lisp-interaction
4393 (apply 'values results
)
4394 (shell-boolean-exit (first results
)))))))
4397 ;;; Dumping an image
4399 (with-upgradability ()
4400 (defun dump-image (filename &key output-name executable
4401 (postlude *image-postlude
*)
4402 (dump-hook *image-dump-hook
*)
4403 #+clozure prepend-symbols
#+clozure
(purify t
)
4405 #+(and sbcl os-windows
) application-type
)
4406 "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
4408 First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
4409 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.
4411 If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
4413 Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
4414 or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
4415 ;; Note: at least SBCL saves only global values of variables in the heap image,
4416 ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
4417 (declare (ignorable filename output-name executable
))
4418 (setf *image-dumped-p
* (if executable
:executable t
))
4419 (setf *image-restored-p
* :in-regress
)
4420 (setf *image-postlude
* postlude
)
4421 (standard-eval-thunk *image-postlude
*)
4422 (setf *image-dump-hook
* dump-hook
)
4423 (call-image-dump-hook)
4424 (setf *image-restored-p
* nil
)
4425 #-
(or clisp clozure cmu lispworks sbcl scl
)
4427 (error "Dumping an executable is not supported on this implementation! Aborting."))
4430 (sys:resize-areas
:global-gc t
:pack-heap t
:sift-old-areas t
:tenure t
) ; :new 5000000
4431 (excl:dumplisp
:name filename
:suppress-allegro-cl-banner t
))
4433 (apply #'ext
:saveinitmem filename
4435 :start-package
*package
*
4436 :keep-global-handlers nil
4437 :executable
(if executable
0 t
) ;--- requires clisp 2.48 or later, still catches --clisp-x
4440 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
4441 :norc t
:script nil
:init-function
#'restore-image
)))
4443 (flet ((dump (prepend-kernel)
4444 (ccl:save-application filename
:prepend-kernel prepend-kernel
:purify purify
4445 :toplevel-function
(when executable
#'restore-image
))))
4446 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
4448 (with-temporary-file (:prefix
"ccl-symbols-" :direction
:output
:pathname path
)
4450 (funcall (fdefinition 'ccl
::write-elf-symbols-to-file
) path
)
4456 (setf ext
:*batch-mode
* nil
)
4457 (setf ext
::*gc-run-time
* 0)
4458 (apply 'ext
:save-lisp filename
4459 #+cmu
:executable
#+cmu t
4460 (when executable
'(:init-function restore-image
:process-command-line nil
))))
4463 (si::set-hole-size
500) (si::gbc nil
) (si::sgc-on t
)
4464 (si::save-system filename
))
4467 (lispworks:deliver
'restore-image filename
0 :interface nil
)
4468 (hcl:save-image filename
:environment nil
))
4471 ;;(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
4472 (setf sb-ext
::*gc-run-time
* 0)
4473 (apply 'sb-ext
:save-lisp-and-die filename
4474 :executable t
;--- always include the runtime that goes with the core
4476 (when compression
(list :compression compression
))
4477 ;;--- only save runtime-options for standalone executables
4478 (when executable
(list :toplevel
#'restore-image
:save-runtime-options t
))
4479 #+(and sbcl os-windows
) ;; passing :application-type :gui will disable the console window.
4480 ;; the default is :console - only works with SBCL 1.1.15 or later.
4481 (when application-type
(list :application-type application-type
)))))
4482 #-
(or allegro clisp clozure cmu gcl lispworks sbcl scl
)
4483 (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
4484 'dump-image filename
(nth-value 1 (implementation-type))))
4486 (defun create-image (destination lisp-object-files
4487 &key kind output-name prologue-code epilogue-code extra-object-files
4488 (prelude () preludep
) (postlude () postludep
)
4489 (entry-point () entry-point-p
) build-args no-uiop
)
4490 (declare (ignorable destination lisp-object-files extra-object-files kind output-name
4491 prologue-code epilogue-code prelude preludep postlude postludep
4492 entry-point entry-point-p build-args no-uiop
))
4493 "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
4494 ;; Is it meaningful to run these in the current environment?
4495 ;; only if we also track the object files that constitute the "current" image,
4496 ;; and otherwise simulate dump-image, including quitting at the end.
4497 #-
(or clasp ecl mkcl
) (error "~S not implemented for your implementation (yet)" 'create-image
)
4498 #+(or clasp ecl mkcl
)
4499 (let ((epilogue-code
4504 (when epilogue-code
`(,epilogue-code
))
4505 (when postludep
`((setf *image-postlude
* ',postlude
)))
4506 (when preludep
`((setf *image-prelude
* ',prelude
)))
4507 (when entry-point-p
`((setf *image-entry-point
* ',entry-point
)))
4510 (setf kind
:program
) ;; to ECL, it's just another program.
4511 `((setf *image-dumped-p
* t
)
4512 (si::top-level
#+(or clasp ecl
) t
) (quit)))
4514 `((setf *image-dumped-p
* :executable
)
4516 (restore-image))))))))
4517 (when forms
`(progn ,@forms
))))))
4518 #+(or clasp ecl
) (check-type kind
(member :dll
:lib
:static-library
:program
:object
:fasl
))
4519 (apply #+clasp
'cmp
:builder
#+clasp kind
4520 #+(and ecl
(not clasp
)) 'c
::builder
#+(and ecl
(not clasp
)) kind
4522 ((:dll
) 'compiler
::build-shared-library
)
4523 ((:lib
:static-library
) 'compiler
::build-static-library
)
4524 ((:fasl
) 'compiler
::build-bundle
)
4525 ((:program
) 'compiler
::build-program
))
4526 (pathname destination
)
4527 #+(or clasp ecl
) :lisp-files
#+mkcl
:lisp-object-files
(append lisp-object-files
#+(or clasp ecl
) extra-object-files
)
4528 #+(or clasp ecl
) :init-name
#+(or clasp ecl
) (c::compute-init-name
(or output-name destination
) :kind kind
)
4530 (when prologue-code
`(:prologue-code
,prologue-code
))
4531 (when epilogue-code
`(:epilogue-code
,epilogue-code
))
4532 #+mkcl
(when extra-object-files
`(:object-files
,extra-object-files
))
4536 ;;; Some universal image restore hooks
4537 (with-upgradability ()
4538 (map () 'register-image-restore-hook
4539 '(setup-stdin setup-stdout setup-stderr
4540 setup-command-line-arguments setup-temporary-directory
4542 ;;;; -------------------------------------------------------------------------
4543 ;;;; run-program initially from xcvb-driver.
4545 (uiop/package
:define-package
:uiop
/run-program
4546 (:nicknames
:asdf
/run-program
)
4547 (:recycle
:uiop
/run-program
:asdf
/run-program
:xcvb-driver
)
4548 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
4549 :uiop
/pathname
:uiop
/os
:uiop
/filesystem
:uiop
/stream
)
4551 ;;; Escaping the command invocation madness
4552 #:easy-sh-character-p
#:escape-sh-token
#:escape-sh-command
4553 #:escape-windows-token
#:escape-windows-command
4554 #:escape-token
#:escape-command
4557 #:slurp-input-stream
#:vomit-output-stream
4560 #:subprocess-error-code
#:subprocess-error-command
#:subprocess-error-process
4562 (in-package :uiop
/run-program
)
4564 ;;;; ----- Escaping strings for the shell -----
4566 (with-upgradability ()
4567 (defun requires-escaping-p (token &key good-chars bad-chars
)
4568 "Does this token require escaping, given the specification of
4569 either good chars that don't need escaping or bad chars that do need escaping,
4570 as either a recognizing function or a sequence of characters."
4573 ((and good-chars bad-chars
)
4574 (error "only one of good-chars and bad-chars can be provided"))
4575 ((typep good-chars
'function
)
4576 (complement good-chars
))
4577 ((typep bad-chars
'function
)
4579 ((and good-chars
(typep good-chars
'sequence
))
4580 #'(lambda (c) (not (find c good-chars
))))
4581 ((and bad-chars
(typep bad-chars
'sequence
))
4582 #'(lambda (c) (find c bad-chars
)))
4583 (t (error "requires-escaping-p: no good-char criterion")))
4586 (defun escape-token (token &key stream quote good-chars bad-chars escaper
)
4587 "Call the ESCAPER function on TOKEN string if it needs escaping as per
4588 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
4589 using STREAM as output (or returning result as a string if NIL)"
4590 (if (requires-escaping-p token
:good-chars good-chars
:bad-chars bad-chars
)
4591 (with-output (stream)
4592 (apply escaper token stream
(when quote
`(:quote
,quote
))))
4593 (output-string token stream
)))
4595 (defun escape-windows-token-within-double-quotes (x &optional s
)
4596 "Escape a string token X within double-quotes
4597 for use within a MS Windows command-line, outputing to S."
4598 (labels ((issue (c) (princ c s
))
4599 (issue-backslash (n) (loop :repeat n
:do
(issue #\\))))
4601 :initially
(issue #\") :finally
(issue #\")
4602 :with l
= (length x
) :with i
= 0
4603 :for i
+1 = (1+ i
) :while
(< i l
) :do
4605 ((#\") (issue-backslash 1) (issue #\") (setf i i
+1))
4607 (let* ((j (and (< i
+1 l
) (position-if-not
4608 #'(lambda (c) (eql c
#\\)) x
:start i
+1)))
4612 (issue-backslash (* 2 n
)) (setf i l
))
4613 ((and (< j l
) (eql (char x j
) #\"))
4614 (issue-backslash (1+ (* 2 n
))) (issue #\") (setf i
(1+ j
)))
4616 (issue-backslash n
) (setf i j
)))))
4618 (issue (char x i
)) (setf i i
+1))))))
4620 (defun easy-windows-character-p (x)
4621 "Is X an \"easy\" character that does not require quoting by the shell?"
4622 (or (alphanumericp x
) (find x
"+-_.,@:/=")))
4624 (defun escape-windows-token (token &optional s
)
4625 "Escape a string TOKEN within double-quotes if needed
4626 for use within a MS Windows command-line, outputing to S."
4627 (escape-token token
:stream s
:good-chars
#'easy-windows-character-p
:quote nil
4628 :escaper
'escape-windows-token-within-double-quotes
))
4630 (defun escape-sh-token-within-double-quotes (x s
&key
(quote t
))
4631 "Escape a string TOKEN within double-quotes
4632 for use within a POSIX Bourne shell, outputing to S;
4633 omit the outer double-quotes if key argument :QUOTE is NIL"
4634 (when quote
(princ #\" s
))
4635 (loop :for c
:across x
:do
4636 (when (find c
"$`\\\"") (princ #\\ s
))
4638 (when quote
(princ #\" s
)))
4640 (defun easy-sh-character-p (x)
4641 "Is X an \"easy\" character that does not require quoting by the shell?"
4642 (or (alphanumericp x
) (find x
"+-_.,%@:/=")))
4644 (defun escape-sh-token (token &optional s
)
4645 "Escape a string TOKEN within double-quotes if needed
4646 for use within a POSIX Bourne shell, outputing to S."
4647 (escape-token token
:stream s
:quote
#\" :good-chars
#'easy-sh-character-p
4648 :escaper
'escape-sh-token-within-double-quotes
))
4650 (defun escape-shell-token (token &optional s
)
4651 "Escape a token for the current operating system shell"
4653 ((os-unix-p) (escape-sh-token token s
))
4654 ((os-windows-p) (escape-windows-token token s
))))
4656 (defun escape-command (command &optional s
4657 (escaper 'escape-shell-token
))
4658 "Given a COMMAND as a list of tokens, return a string of the
4659 spaced, escaped tokens, using ESCAPER to escape."
4661 (string (output-string command s
))
4662 (list (with-output (s)
4663 (loop :for first
= t
:then nil
:for token
:in command
:do
4664 (unless first
(princ #\space s
))
4665 (funcall escaper token s
))))))
4667 (defun escape-windows-command (command &optional s
)
4668 "Escape a list of command-line arguments into a string suitable for parsing
4669 by CommandLineToArgv in MS Windows"
4670 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
4671 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
4672 (escape-command command s
'escape-windows-token
))
4674 (defun escape-sh-command (command &optional s
)
4675 "Escape a list of command-line arguments into a string suitable for parsing
4676 by /bin/sh in POSIX"
4677 (escape-command command s
'escape-sh-token
))
4679 (defun escape-shell-command (command &optional stream
)
4680 "Escape a command for the current operating system's shell"
4681 (escape-command command stream
'escape-shell-token
)))
4684 ;;;; Slurping a stream, typically the output of another program
4685 (with-upgradability ()
4686 (defun call-stream-processor (fun processor stream
)
4687 "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
4688 a PROCESSOR specification which is either an atom or a list specifying
4689 a processor an keyword arguments, call the specified processor with
4690 the given STREAM as input"
4691 (if (consp processor
)
4692 (apply fun
(first processor
) stream
(rest processor
))
4693 (funcall fun processor stream
)))
4695 (defgeneric slurp-input-stream
(processor input-stream
&key
)
4697 "SLURP-INPUT-STREAM is a generic function with two positional arguments
4698 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
4699 the contents of the INPUT-STREAM and processes them according to a method
4700 specified by PROCESSOR.
4702 Built-in methods include the following:
4703 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
4704 * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
4705 INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
4706 \(APPLY x <stream> y\)
4707 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
4708 per copy-stream-to-stream, with appropriate keyword arguments.
4709 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
4710 are returned as a string, as per SLURP-STREAM-STRING.
4711 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
4712 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
4713 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
4714 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
4715 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
4717 Programmers are encouraged to define their own methods for this generic function."))
4720 (defmethod slurp-input-stream ((function function
) input-stream
&key
)
4721 (funcall function input-stream
))
4723 (defmethod slurp-input-stream ((list cons
) input-stream
&key
)
4724 (apply (first list
) input-stream
(rest list
)))
4727 (defmethod slurp-input-stream ((output-stream stream
) input-stream
4728 &key linewise prefix
(element-type 'character
) buffer-size
)
4729 (copy-stream-to-stream
4730 input-stream output-stream
4731 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
4733 (defmethod slurp-input-stream ((x (eql 'string
)) stream
&key stripped
)
4734 (slurp-stream-string stream
:stripped stripped
))
4736 (defmethod slurp-input-stream ((x (eql :string
)) stream
&key stripped
)
4737 (slurp-stream-string stream
:stripped stripped
))
4739 (defmethod slurp-input-stream ((x (eql :lines
)) stream
&key count
)
4740 (slurp-stream-lines stream
:count count
))
4742 (defmethod slurp-input-stream ((x (eql :line
)) stream
&key
(at 0))
4743 (slurp-stream-line stream
:at at
))
4745 (defmethod slurp-input-stream ((x (eql :forms
)) stream
&key count
)
4746 (slurp-stream-forms stream
:count count
))
4748 (defmethod slurp-input-stream ((x (eql :form
)) stream
&key
(at 0))
4749 (slurp-stream-form stream
:at at
))
4751 (defmethod slurp-input-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
4752 (apply 'slurp-input-stream
*standard-output
* stream keys
))
4754 (defmethod slurp-input-stream ((x null
) (stream t
) &key
)
4757 (defmethod slurp-input-stream ((pathname pathname
) input
4759 (element-type *default-stream-element-type
*)
4760 (external-format *utf-8-external-format
*)
4761 (if-exists :rename-and-delete
)
4762 (if-does-not-exist :create
)
4765 (with-output-file (output pathname
4766 :element-type element-type
4767 :external-format external-format
4768 :if-exists if-exists
4769 :if-does-not-exist if-does-not-exist
)
4770 (copy-stream-to-stream
4772 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
4774 (defmethod slurp-input-stream (x stream
4775 &key linewise prefix
(element-type 'character
) buffer-size
)
4776 (declare (ignorable stream linewise prefix element-type buffer-size
))
4779 ((functionp x
) (funcall x stream
))
4781 ((output-stream-p x
)
4782 (copy-stream-to-stream
4784 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
4786 (error "Invalid ~S destination ~S" 'slurp-input-stream x
)))))
4789 (with-upgradability ()
4790 (defgeneric vomit-output-stream
(processor output-stream
&key
)
4792 "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
4793 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
4794 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
4796 Built-in methods include the following:
4797 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
4798 * if PROCESSOR is a list, its first element should be a function.
4799 It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
4800 That is (x . y) will be treated as \(APPLY x <stream> y\)
4801 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
4802 per copy-stream-to-stream, with appropriate keyword arguments.
4803 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
4804 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
4806 Programmers are encouraged to define their own methods for this generic function."))
4809 (defmethod vomit-output-stream ((function function
) output-stream
&key
)
4810 (funcall function output-stream
))
4812 (defmethod vomit-output-stream ((list cons
) output-stream
&key
)
4813 (apply (first list
) output-stream
(rest list
)))
4816 (defmethod vomit-output-stream ((input-stream stream
) output-stream
4817 &key linewise prefix
(element-type 'character
) buffer-size
)
4818 (copy-stream-to-stream
4819 input-stream output-stream
4820 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
4822 (defmethod vomit-output-stream ((x string
) stream
&key fresh-line terpri
)
4824 (when fresh-line
(fresh-line stream
))
4825 (when terpri
(terpri stream
))
4828 (defmethod vomit-output-stream ((x (eql t
)) stream
&rest keys
&key
&allow-other-keys
)
4829 (apply 'vomit-output-stream
*standard-input
* stream keys
))
4831 (defmethod vomit-output-stream ((x null
) (stream t
) &key
)
4834 (defmethod vomit-output-stream ((pathname pathname
) input
4836 (element-type *default-stream-element-type
*)
4837 (external-format *utf-8-external-format
*)
4838 (if-exists :rename-and-delete
)
4839 (if-does-not-exist :create
)
4842 (with-output-file (output pathname
4843 :element-type element-type
4844 :external-format external-format
4845 :if-exists if-exists
4846 :if-does-not-exist if-does-not-exist
)
4847 (copy-stream-to-stream
4849 :element-type element-type
:buffer-size buffer-size
:linewise linewise
)))
4851 (defmethod vomit-output-stream (x stream
4852 &key linewise prefix
(element-type 'character
) buffer-size
)
4853 (declare (ignorable stream linewise prefix element-type buffer-size
))
4856 ((functionp x
) (funcall x stream
))
4859 (copy-stream-to-stream
4861 :linewise linewise
:prefix prefix
:element-type element-type
:buffer-size buffer-size
))
4863 (error "Invalid ~S source ~S" 'vomit-output-stream x
)))))
4866 ;;;; ----- Running an external program -----
4867 ;;; Simple variant of run-program with no input, and capturing output
4868 ;;; On some implementations, may output to a temporary file...
4869 (with-upgradability ()
4870 (define-condition subprocess-error
(error)
4871 ((code :initform nil
:initarg
:code
:reader subprocess-error-code
)
4872 (command :initform nil
:initarg
:command
:reader subprocess-error-command
)
4873 (process :initform nil
:initarg
:process
:reader subprocess-error-process
))
4874 (:report
(lambda (condition stream
)
4875 (format stream
"Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
4876 (subprocess-error-process condition
)
4877 (subprocess-error-command condition
)
4878 (subprocess-error-code condition
)))))
4880 ;;; find CMD.exe on windows
4881 (defun %cmd-shell-pathname
()
4884 (strcat (native-namestring (getenv-absolute-directory "WINDIR"))
4885 "System32\\cmd.exe"))
4887 (error "CMD.EXE is not the command shell for this OS."))))
4889 ;;; Internal helpers for run-program
4890 (defun %normalize-command
(command)
4891 "Given a COMMAND as a list or string, transform it in a format suitable
4892 for the implementation's underlying run-program function"
4894 #+os-unix
(string `("/bin/sh" "-c" ,command
))
4895 #+os-unix
(list command
)
4898 #+mkcl
(list "cmd" "/c" command
)
4899 ;; NB: We do NOT add cmd /c here. You might want to.
4900 #+(or allegro clisp
) command
4901 ;; On ClozureCL for Windows, we assume you are using
4902 ;; r15398 or later in 1.9 or later,
4903 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
4904 #+clozure
(cons "cmd" (strcat "/c " command
))
4905 #+sbcl
(list (%cmd-shell-pathname
) "/c" command
)
4906 ;; NB: On other Windows implementations, this is utterly bogus
4907 ;; except in the most trivial cases where no quoting is needed.
4908 ;; Use at your own risk.
4909 #-
(or allegro clisp clozure mkcl sbcl
) (list "cmd" "/c" command
))
4912 #+allegro
(escape-windows-command command
)
4913 #-allegro command
)))
4915 (defun %active-io-specifier-p
(specifier)
4916 "Determines whether a run-program I/O specifier requires Lisp-side processing
4917 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
4918 or whether it's already taken care of by the implementation's underlying run-program."
4919 (not (typep specifier
'(or null string pathname
(member :interactive
:output
)
4920 #+(or cmu
(and sbcl os-unix
) scl
) (or stream
(eql t
))
4921 #+lispworks file-stream
)))) ;; not a type!? comm:socket-stream
4923 (defun %normalize-io-specifier
(specifier &optional role
)
4924 "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent
4925 argument to pass to the internal RUN-PROGRAM"
4926 (declare (ignorable role
))
4927 (etypecase specifier
4928 (null (or #+(or allegro lispworks
) (null-device-pathname)))
4929 (string (parse-native-namestring specifier
))
4930 (pathname specifier
)
4932 ((eql :stream
) :stream
)
4936 #+(or clasp clozure cmu ecl mkcl sbcl scl
) t
)
4937 #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl
)
4939 (if (eq role
:error-output
)
4941 (error "Wrong specifier ~S for role ~S" specifier role
)))))
4943 (defun %interactivep
(input output error-output
)
4944 (member :interactive
(list input output error-output
)))
4947 (defun clisp-exit-code (raw-exit-code)
4948 (typecase raw-exit-code
4950 (integer raw-exit-code
) ; negative: signal
4953 (defun %run-program
(command
4955 &key input
(if-input-does-not-exist :error
)
4956 output
(if-output-exists :overwrite
)
4957 error-output
(if-error-output-exists :overwrite
)
4959 #+allegro separate-streams
4961 "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
4962 It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
4963 INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
4964 to be normalized by %NORMALIZE-IO-SPECIFIER.
4965 It returns a process-info plist with possible keys:
4966 PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
4967 ;; NB: these implementations have unix vs windows set at compile-time.
4968 (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists
))
4969 (assert (not (and wait
(member :stream
(list input output error-output
)))))
4970 #-
(or allegro clisp clozure cmu
(and lispworks os-unix
) mkcl sbcl scl
)
4971 (progn command keys directory
4972 (error "run-program not available"))
4973 #+(or allegro clisp clozure cmu
(and lispworks os-unix
) mkcl sbcl scl
)
4974 (let* ((%command
(%normalize-command command
))
4975 (%input
(%normalize-io-specifier input
:input
))
4976 (%output
(%normalize-io-specifier output
:output
))
4977 (%error-output
(%normalize-io-specifier error-output
:error-output
))
4978 #+(and allegro os-windows
) (interactive (%interactivep input output error-output
))
4981 (multiple-value-list
4983 'excl
:run-shell-command
4984 #+os-unix
(coerce (cons (first %command
) %command
) 'vector
)
4985 #+os-windows %command
4988 :error-output %error-output
4989 :directory directory
:wait wait
4990 #+os-windows
:show-window
#+os-windows
(if interactive nil
:hide
)
4991 :allow-other-keys t keys
))
4993 (with-current-directory (#-
(or sbcl mkcl
) directory
)
4995 (flet ((run (f x
&rest args
)
4996 (multiple-value-list
4997 (apply f x
:input %input
:output %output
4998 :allow-other-keys t
`(,@args
,@keys
)))))
4999 (assert (eq %error-output
:terminal
))
5000 ;;; since we now always return a code, we can't use this code path, anyway!
5002 #+os-windows
(string (run 'ext
:run-shell-command %command
))
5003 (list (run 'ext
:run-program
(car %command
)
5004 :arguments
(cdr %command
)))))
5005 #+(or clasp clozure cmu ecl mkcl sbcl scl
)
5006 (#-
(or clasp ecl mkcl
) progn
#+(or clasp ecl mkcl
) multiple-value-list
5008 '#+(or cmu ecl scl
) ext
:run-program
5009 #+clozure ccl
:run-program
#+sbcl sb-ext
:run-program
#+mkcl mk-ext
:run-program
5010 (car %command
) (cdr %command
)
5013 :error %error-output
5017 #+(or clozure cmu mkcl sbcl scl
)
5018 `(:if-input-does-not-exist
,if-input-does-not-exist
5019 :if-output-exists
,if-output-exists
5020 :if-error-exists
,if-error-output-exists
)
5022 :if-output-does-not-exist
:create
5023 :if-error-does-not-exist
:create
)
5024 #-sbcl keys
#+sbcl
(if directory keys
(remove-plist-key :directory keys
)))))
5025 #+(and lispworks os-unix
) ;; note: only used on Unix in non-interactive case
5026 (multiple-value-list
5028 'system
:run-shell-command
5029 (cons "/usr/bin/env" %command
) ; lispworks wants a full path.
5030 :input %input
:if-input-does-not-exist if-input-does-not-exist
5031 :output %output
:if-output-exists if-output-exists
5032 :error-output %error-output
:if-error-output-exists if-error-output-exists
5033 :wait wait
:save-exit-status t
:allow-other-keys t keys
))))
5034 (process-info-r ()))
5035 (flet ((prop (key value
) (push key process-info-r
) (push value process-info-r
)))
5038 (wait (prop :exit-code
(first process
*)))
5040 (destructuring-bind (in out err pid
) process
*
5042 (when (eq input
:stream
) (prop :input-stream in
))
5043 (when (eq output
:stream
) (prop :output-stream out
))
5044 (when (eq error-output
:stream
) (prop :error-stream err
))))
5046 (prop :process
(third process
*))
5047 (let ((x (first process
*)))
5048 (ecase (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))
5050 (1 (prop :input-stream x
))
5051 (2 (prop :output-stream x
))
5052 (3 (prop :bidir-stream x
))))
5053 (when (eq error-output
:stream
)
5054 (prop :error-stream
(second process
*)))))
5057 (wait (prop :exit-code
(clisp-exit-code (first process
*))))
5059 (ecase (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))
5061 (1 (prop :input-stream
(first process
*)))
5062 (2 (prop :output-stream
(first process
*)))
5063 (3 (prop :bidir-stream
(pop process
*))
5064 (prop :input-stream
(pop process
*))
5065 (prop :output-stream
(pop process
*))))))
5066 #+(or clozure cmu sbcl scl
)
5068 (prop :process process
*)
5069 (when (eq input
:stream
)
5071 #+clozure
(ccl:external-process-input-stream process
*)
5072 #+(or cmu scl
) (ext:process-input process
*)
5073 #+sbcl
(sb-ext:process-input process
*)))
5074 (when (eq output
:stream
)
5075 (prop :output-stream
5076 #+clozure
(ccl:external-process-output-stream process
*)
5077 #+(or cmu scl
) (ext:process-output process
*)
5078 #+sbcl
(sb-ext:process-output process
*)))
5079 (when (eq error-output
:stream
)
5080 (prop :error-output-stream
5081 #+clozure
(ccl:external-process-error-stream process
*)
5082 #+(or cmu scl
) (ext:process-error process
*)
5083 #+sbcl
(sb-ext:process-error process
*))))
5084 #+(or clasp ecl mkcl
)
5085 (destructuring-bind #+(or clasp ecl
) (stream code process
) #+mkcl
(stream process code
) process
*
5086 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
5089 ((null process
*) (prop :exit-code -
1))
5090 (t (prop (case mode
(1 :input-stream
) (2 :output-stream
) (3 :bidir-stream
)) stream
))))
5091 (when code
(prop :exit-code code
))
5092 (when process
(prop :process process
)))
5095 (prop :exit-code
(first process
*))
5096 (let ((mode (+ (if (eq input
:stream
) 1 0) (if (eq output
:stream
) 2 0))))
5098 (prop :process
(first process
*))
5099 (destructuring-bind (x err pid
) process
*
5101 (prop (ecase mode
(1 :input-stream
) (2 :output-stream
) (3 :bidir-stream
)) x
)
5102 (when (eq error-output
:stream
) (prop :error-stream err
))))))
5103 (nreverse process-info-r
))))
5105 (defun %process-info-pid
(process-info)
5106 (let ((process (getf process-info
:process
)))
5107 (declare (ignorable process
))
5108 #+(or allegro lispworks
) process
5109 #+clozure
(ccl::external-process-pid process
)
5110 #+(or clasp ecl
) (si:external-process-pid process
)
5111 #+(or cmu scl
) (ext:process-pid process
)
5112 #+mkcl
(mkcl:process-id process
)
5113 #+sbcl
(sb-ext:process-pid process
)
5114 #-
(or allegro cmu mkcl sbcl scl
) (error "~S not implemented" '%process-info-pid
)))
5116 (defun %wait-process-result
(process-info)
5117 (or (getf process-info
:exit-code
)
5118 (let ((process (getf process-info
:process
)))
5121 #+clozure
(ccl::external-process-wait process
)
5122 #+(or cmu scl
) (ext:process-wait process
)
5123 #+(and (or clasp ecl
) os-unix
) (ext:external-process-wait process
)
5124 #+sbcl
(sb-ext:process-wait process
)
5125 ;; 2- extract result
5126 #+allegro
(sys:reap-os-subprocess
:pid process
:wait t
)
5127 #+clozure
(nth-value 1 (ccl:external-process-status process
))
5128 #+(or cmu scl
) (ext:process-exit-code process
)
5129 #+(or clasp ecl
) (nth-value 1 (ext:external-process-status process
))
5131 (if-let ((stream (or (getf process-info
:input-stream
)
5132 (getf process-info
:output-stream
)
5133 (getf process-info
:bidir-stream
)
5134 (getf process-info
:error-stream
))))
5135 (system:pipe-exit-status stream
:wait t
)
5136 (if-let ((f (find-symbol* :pid-exit-status
:system nil
)))
5137 (funcall f process
:wait t
)))
5138 #+sbcl
(sb-ext:process-exit-code process
)
5139 #+mkcl
(mkcl:join-process process
)))))
5141 (defun %check-result
(exit-code &key command process ignore-error-status
)
5142 (unless ignore-error-status
5143 (unless (eql exit-code
0)
5144 (cerror "IGNORE-ERROR-STATUS"
5145 'subprocess-error
:command command
:code exit-code
:process process
)))
5148 (defun %call-with-program-io
(gf tval stream-easy-p fun direction spec activep returner
5149 &key element-type external-format
&allow-other-keys
)
5150 ;; handle redirection for run-program and system
5151 ;; SPEC is the specification for the subprocess's input or output or error-output
5152 ;; TVAL is the value used if the spec is T
5153 ;; GF is the generic function to call to handle arbitrary values of SPEC
5154 ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
5155 ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
5156 ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
5157 ;; FUN is a function of the new reduced spec and an activity function to call with a stream
5158 ;; when the subprocess is active and communicating through that stream.
5159 ;; ACTIVEP is a boolean true if we will get to run code while the process is running
5160 ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
5161 ;; RETURNER is a function called with the value of the activity.
5162 ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
5163 (declare (ignorable stream-easy-p
))
5164 (let* ((actual-spec (if (eq spec t
) tval spec
))
5165 (activity-spec (if (eq actual-spec
:output
)
5168 (error "~S not allowed as a ~S ~S spec"
5169 :output
'run-program direction
))
5173 (labels ((activity (stream)
5174 (call-function returner
(call-stream-processor gf activity-spec stream
)))
5176 (funcall fun actual-spec nil
))
5179 (funcall fun
:stream
#'activity
)
5180 (with-temporary-file (:pathname tmp
)
5183 (with-output-file (s tmp
:if-exists
:overwrite
5184 :external-format external-format
5185 :element-type element-type
)
5187 (funcall fun tmp nil
))
5188 ((:output
:error-output
)
5189 (multiple-value-prog1 (funcall fun tmp nil
)
5190 (with-input-file (s tmp
5191 :external-format external-format
5192 :element-type element-type
)
5193 (activity s
)))))))))
5194 (typecase activity-spec
5195 ((or null string pathname
(eql :interactive
))
5197 #+(or cmu
(and sbcl os-unix
) scl
) ;; streams are only easy on implementations that try very hard
5199 (if stream-easy-p
(easy-case) (hard-case)))
5203 (defmacro place-setter
(place)
5205 (let ((value (gensym)))
5206 `#'(lambda (,value
) (setf ,place
,value
)))))
5208 (defmacro with-program-input
(((reduced-input-var
5209 &optional
(input-activity-var (gensym) iavp
))
5210 input-form
&key setf stream-easy-p active keys
) &body body
)
5211 `(apply '%call-with-program-io
'vomit-output-stream
*standard-input
* ,stream-easy-p
5212 #'(lambda (,reduced-input-var
,input-activity-var
)
5213 ,@(unless iavp
`((declare (ignore ,input-activity-var
))))
5215 :input
,input-form
,active
(place-setter ,setf
) ,keys
))
5217 (defmacro with-program-output
(((reduced-output-var
5218 &optional
(output-activity-var (gensym) oavp
))
5219 output-form
&key setf stream-easy-p active keys
) &body body
)
5220 `(apply '%call-with-program-io
'slurp-input-stream
*standard-output
* ,stream-easy-p
5221 #'(lambda (,reduced-output-var
,output-activity-var
)
5222 ,@(unless oavp
`((declare (ignore ,output-activity-var
))))
5224 :output
,output-form
,active
(place-setter ,setf
) ,keys
))
5226 (defmacro with-program-error-output
(((reduced-error-output-var
5227 &optional
(error-output-activity-var (gensym) eoavp
))
5228 error-output-form
&key setf stream-easy-p active keys
)
5230 `(apply '%call-with-program-io
'slurp-input-stream
*error-output
* ,stream-easy-p
5231 #'(lambda (,reduced-error-output-var
,error-output-activity-var
)
5232 ,@(unless eoavp
`((declare (ignore ,error-output-activity-var
))))
5234 :error-output
,error-output-form
,active
(place-setter ,setf
) ,keys
))
5236 (defun %use-run-program
(command &rest keys
5237 &key input output error-output ignore-error-status
&allow-other-keys
)
5238 ;; helper for RUN-PROGRAM when using %run-program
5239 #+(or abcl cormanlisp gcl
(and lispworks os-windows
) mcl xcl
)
5241 command keys input output error-output ignore-error-status
;; ignore
5242 (error "Not implemented on this platform"))
5243 (assert (not (member :stream
(list input output error-output
))))
5244 (let* ((active-input-p (%active-io-specifier-p input
))
5245 (active-output-p (%active-io-specifier-p output
))
5246 (active-error-output-p (%active-io-specifier-p error-output
))
5249 (active-output-p :output
)
5250 (active-input-p :input
)
5251 (active-error-output-p :error-output
)
5253 (wait (not activity
))
5254 output-result error-output-result exit-code
)
5255 (with-program-output ((reduced-output output-activity
)
5256 output
:keys keys
:setf output-result
5257 :stream-easy-p t
:active
(eq activity
:output
))
5258 (with-program-error-output ((reduced-error-output error-output-activity
)
5259 error-output
:keys keys
:setf error-output-result
5260 :stream-easy-p t
:active
(eq activity
:error-output
))
5261 (with-program-input ((reduced-input input-activity
)
5263 :stream-easy-p t
:active
(eq activity
:input
))
5265 (apply '%run-program command
5266 :wait wait
:input reduced-input
:output reduced-output
5267 :error-output
(if (eq error-output
:output
) :output reduced-error-output
)
5269 (labels ((get-stream (stream-name &optional fallbackp
)
5270 (or (getf process-info stream-name
)
5272 (getf process-info
:bidir-stream
))))
5273 (run-activity (activity stream-name
&optional fallbackp
)
5274 (if-let (stream (get-stream stream-name fallbackp
))
5275 (funcall activity stream
)
5276 (error 'subprocess-error
5277 :code
`(:missing
,stream-name
)
5278 :command command
:process process-info
))))
5282 (:input
(run-activity input-activity
:input-stream t
))
5283 (:output
(run-activity output-activity
:output-stream t
))
5284 (:error-output
(run-activity error-output-activity
:error-output-stream
)))
5285 (loop :for
(() val
) :on process-info
:by
#'cddr
5286 :when
(streamp val
) :do
(ignore-errors (close val
)))
5288 (%check-result
(%wait-process-result process-info
)
5289 :command command
:process process-info
5290 :ignore-error-status ignore-error-status
))))))))
5291 (values output-result error-output-result exit-code
)))
5293 (defun %normalize-system-command
(command) ;; helper for %USE-SYSTEM
5298 #+(or allegro clisp
)
5299 (strcat (%cmd-shell-pathname
) " /c " command
)
5300 #-
(or allegro clisp
) command
)
5302 (list (escape-shell-command
5304 ((os-unix-p) (cons "exec" command
))
5306 #+(or allegro sbcl clisp
)
5307 (cons (%cmd-shell-pathname
) (cons "/c" command
))
5308 #-
(or allegro sbcl clisp
) command
)
5311 (defun %redirected-system-command
(command in out err directory
) ;; helper for %USE-SYSTEM
5312 (flet ((redirect (spec operator
)
5315 (null (null-device-pathname))
5316 (string (parse-native-namestring spec
))
5319 (assert (equal operator
" 2>"))
5320 (return-from redirect
'(" 2>&1"))))))
5323 (escape-shell-token (native-namestring pathname
)))))))
5324 (let* ((redirections (append (redirect in
" <") (redirect out
" >") (redirect err
" 2>")))
5325 (normalized (%normalize-system-command command
))
5326 (directory (or directory
#+(or abcl xcl
) (getcwd)))
5327 (chdir (when directory
5328 (let ((dir-arg (escape-shell-token (native-namestring directory
))))
5330 ((os-unix-p) `("cd " ,dir-arg
" ; "))
5331 ((os-windows-p) `("cd /d " ,dir-arg
" & ")))))))
5334 ((os-unix-p) `(,@(when redirections
`("exec " ,@redirections
" ; ")) ,@chdir
,normalized
))
5335 ((os-windows-p) `(,@chdir
,@redirections
" " ,normalized
)))))))
5337 (defun %system
(command &rest keys
5338 &key input output error-output directory
&allow-other-keys
)
5339 "A portable abstraction of a low-level call to libc's system()."
5340 (declare (ignorable input output error-output directory keys
))
5341 #+(or allegro clozure cmu
(and lispworks os-unix
) sbcl scl
)
5342 (%wait-process-result
5343 (apply '%run-program
(%normalize-system-command command
) :wait t keys
))
5344 #+(or abcl clasp clisp cormanlisp ecl gcl genera
(and lispworks os-windows
) mkcl xcl
)
5345 (let ((%command
(%redirected-system-command command input output error-output directory
)))
5346 #+(and lispworks os-windows
)
5347 (system:call-system %command
:current-directory directory
:wait t
)
5349 (%wait-process-result
5350 (apply '%run-program %command
:wait t
5351 :input
:interactive
:output
:interactive
:error-output
:interactive keys
))
5352 #-
(or clisp
(and lispworks os-windows
))
5353 (with-current-directory ((os-cond ((not (os-unix-p)) directory
)))
5354 #+abcl
(ext:run-shell-command %command
)
5355 #+cormanlisp
(win32:system %command
)
5356 #+(or clasp ecl
) (let ((*standard-input
* *stdin
*)
5357 (*standard-output
* *stdout
*)
5358 (*error-output
* *stderr
*))
5359 (ext:system %command
))
5360 #+gcl
(system:system %command
)
5361 #+genera
(error "~S not supported on Genera, cannot run ~S"
5363 #+mcl
(ccl::with-cstrs
((%%command %command
)) (_system %%command
))
5364 #+mkcl
(mkcl:system %command
)
5365 #+xcl
(system:%run-shell-command %command
))))
5367 (defun %use-system
(command &rest keys
5368 &key input output error-output ignore-error-status
&allow-other-keys
)
5369 ;; helper for RUN-PROGRAM when using %system
5370 (let (output-result error-output-result exit-code
)
5371 (with-program-output ((reduced-output)
5372 output
:keys keys
:setf output-result
)
5373 (with-program-error-output ((reduced-error-output)
5374 error-output
:keys keys
:setf error-output-result
)
5375 (with-program-input ((reduced-input) input
:keys keys
)
5377 (%check-result
(apply '%system command
5378 :input reduced-input
:output reduced-output
5379 :error-output reduced-error-output keys
)
5381 :ignore-error-status ignore-error-status
)))))
5382 (values output-result error-output-result exit-code
)))
5384 (defun run-program (command &rest keys
5385 &key ignore-error-status
(force-shell nil force-shell-suppliedp
)
5386 (input nil inputp
) (if-input-does-not-exist :error
)
5387 output
(if-output-exists :overwrite
)
5388 (error-output nil error-output-p
) (if-error-output-exists :overwrite
)
5389 (element-type #-clozure
*default-stream-element-type
* #+clozure
'character
)
5390 (external-format *utf-8-external-format
*)
5392 "Run program specified by COMMAND,
5393 either a list of strings specifying a program and list of arguments,
5394 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
5396 Always call a shell (rather than directly execute the command when possible)
5397 if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
5398 specified to be NIL.
5400 Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
5401 unless IGNORE-ERROR-STATUS is specified.
5403 If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device,
5404 the file at that path is used as output.
5405 If it's :INTERACTIVE, output is inherited from the current process;
5406 beware that this may be different from your *STANDARD-OUTPUT*,
5407 and under SLIME will be on your *inferior-lisp* buffer.
5408 If it's T, output goes to your current *STANDARD-OUTPUT* stream.
5409 Otherwise, OUTPUT should be a value that is a suitable first argument to
5410 SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
5411 In this case, RUN-PROGRAM will create a temporary stream for the program output;
5412 the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
5413 using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
5414 The primary value resulting from that call (or NIL if no call was needed)
5415 will be the first value returned by RUN-PROGRAM.
5416 E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
5417 And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
5418 stripped of any ending newline.
5420 ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
5421 as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
5422 Also :OUTPUT means redirecting the error output to the output stream,
5423 in which case NIL is returned.
5425 INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
5426 no value is returned, and T designates the *STANDARD-INPUT*.
5428 Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
5429 to your Lisp implementation, when applicable, for creation of the output stream.
5431 One and only one of the stream slurping or vomiting may or may not happen
5432 in parallel in parallel with the subprocess,
5433 depending on options and implementation,
5434 and with priority being given to output processing.
5435 Other streams are completely produced or consumed
5436 before or after the subprocess is spawned, using temporary files.
5438 RUN-PROGRAM returns 3 values:
5439 0- the result of the OUTPUT slurping if any, or NIL
5440 1- the result of the ERROR-OUTPUT slurping if any, or NIL
5441 2- either 0 if the subprocess exited with success status,
5442 or an indication of failure via the EXIT-CODE of the process"
5443 (declare (ignorable ignore-error-status
))
5444 #-
(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl
)
5445 (error "RUN-PROGRAM not implemented for this Lisp")
5446 ;; per doc string, set FORCE-SHELL to T if we get command as a string. But
5447 ;; don't override user's specified preference. [2015/06/29:rpg]
5448 (when (stringp command
)
5449 (unless force-shell-suppliedp
5450 (setf force-shell t
)))
5451 (flet ((default (x xp output
) (cond (xp x
) ((eq output
:interactive
) :interactive
))))
5452 (apply (if (or force-shell
5453 #+(or clasp clisp ecl
) (or (not ignore-error-status
) t
)
5454 #+clisp
(member error-output
'(:interactive
:output
))
5455 #+(and lispworks os-unix
) (%interactivep input output error-output
)
5456 #+(or abcl cormanlisp gcl
(and lispworks os-windows
) mcl xcl
) t
)
5457 '%use-system
'%use-run-program
)
5459 :input
(default input inputp output
)
5460 :error-output
(default error-output error-output-p output
)
5461 :if-input-does-not-exist if-input-does-not-exist
5462 :if-output-exists if-output-exists
5463 :if-error-output-exists if-error-output-exists
5464 :element-type element-type
:external-format external-format
5466 ;;;; -------------------------------------------------------------------------
5467 ;;;; Support to build (compile and load) Lisp files
5469 (uiop/package
:define-package
:uiop
/lisp-build
5470 (:nicknames
:asdf
/lisp-build
)
5471 (:recycle
:uiop
/lisp-build
:asdf
/lisp-build
:asdf
)
5472 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
5473 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
)
5476 #:*compile-file-warnings-behaviour
* #:*compile-file-failure-behaviour
*
5477 #:*output-translation-function
*
5478 #:*optimization-settings
* #:*previous-optimization-settings
*
5479 #:*base-build-directory
*
5480 #:compile-condition
#:compile-file-error
#:compile-warned-error
#:compile-failed-error
5481 #:compile-warned-warning
#:compile-failed-warning
5482 #:check-lisp-compile-results
#:check-lisp-compile-warnings
5483 #:*uninteresting-conditions
* #:*usual-uninteresting-conditions
*
5484 #:*uninteresting-compiler-conditions
* #:*uninteresting-loader-conditions
*
5486 #+sbcl
#:sb-grovel-unknown-constant-condition
5487 ;; Functions & Macros
5488 #:get-optimization-settings
#:proclaim-optimization-settings
#:with-optimization-settings
5489 #:call-with-muffled-compiler-conditions
#:with-muffled-compiler-conditions
5490 #:call-with-muffled-loader-conditions
#:with-muffled-loader-conditions
5491 #:reify-simple-sexp
#:unreify-simple-sexp
5492 #:reify-deferred-warnings
#:unreify-deferred-warnings
5493 #:reset-deferred-warnings
#:save-deferred-warnings
#:check-deferred-warnings
5494 #:with-saved-deferred-warnings
#:warnings-file-p
#:warnings-file-type
#:*warnings-file-type
*
5495 #:enable-deferred-warnings-check
#:disable-deferred-warnings-check
5496 #:current-lisp-file-pathname
#:load-pathname
5497 #:lispize-pathname
#:compile-file-type
#:call-around-hook
5498 #:compile-file
* #:compile-file-pathname
* #:*compile-check
*
5499 #:load
* #:load-from-string
#:combine-fasls
)
5500 (:intern
#:defaults
#:failure-p
#:warnings-p
#:s
#:y
#:body
))
5501 (in-package :uiop
/lisp-build
)
5503 (with-upgradability ()
5504 (defvar *compile-file-warnings-behaviour
*
5505 (or #+clisp
:ignore
:warn
)
5506 "How should ASDF react if it encounters a warning when compiling a file?
5507 Valid values are :error, :warn, and :ignore.")
5509 (defvar *compile-file-failure-behaviour
*
5510 (or #+(or mkcl sbcl
) :error
#+clisp
:ignore
:warn
)
5511 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
5512 when compiling a file, which includes any non-style-warning warning.
5513 Valid values are :error, :warn, and :ignore.
5514 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
5516 (defvar *base-build-directory
* nil
5517 "When set to a non-null value, it should be an absolute directory pathname,
5518 which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
5519 what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
5520 This can help you produce more deterministic output for FASLs."))
5522 ;;; Optimization settings
5523 (with-upgradability ()
5524 (defvar *optimization-settings
* nil
5525 "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
5526 (defvar *previous-optimization-settings
* nil
5527 "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
5528 (defparameter +optimization-variables
+
5529 ;; TODO: allegro genera corman mcl
5530 (or #+(or abcl xcl
) '(system::*speed
* system
::*space
* system
::*safety
* system
::*debug
*)
5531 #+clisp
'() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
5532 #+clozure
'(ccl::*nx-speed
* ccl
::*nx-space
* ccl
::*nx-safety
*
5533 ccl
::*nx-debug
* ccl
::*nx-cspeed
*)
5534 #+(or cmu scl
) '(c::*default-cookie
*)
5535 #+(and ecl
(not clasp
)) (unless (use-ecl-byte-compiler-p) '(c::*speed
* c
::*space
* c
::*safety
* c
::*debug
*))
5537 #+gcl
'(compiler::*speed
* compiler
::*space
* compiler
::*compiler-new-safety
* compiler
::*debug
*)
5538 #+lispworks
'(compiler::*optimization-level
*)
5539 #+mkcl
'(si::*speed
* si
::*space
* si
::*safety
* si
::*debug
*)
5540 #+sbcl
'(sb-c::*policy
*)))
5541 (defun get-optimization-settings ()
5542 "Get current compiler optimization settings, ready to PROCLAIM again"
5543 #-
(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl
)
5544 (warn "~S does not support ~S. Please help me fix that."
5545 'get-optimization-settings
(implementation-type))
5546 #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl
)
5547 (let ((settings '(speed space safety debug compilation-speed
#+(or cmu scl
) c
::brevity
)))
5548 #.
`(loop #+(or allegro clozure
)
5549 ,@'(:with info
= #+allegro
(sys:declaration-information
'optimize
)
5550 #+clozure
(ccl:declaration-information
'optimize nil
))
5552 ,@(or #+(or abcl clasp ecl gcl mkcl xcl
) '(:for v
:in
+optimization-variables
+))
5553 :for y
= (or #+(or allegro clozure
) (second (assoc x info
)) ; normalize order
5554 #+clisp
(gethash x system
::*optimize
* 1)
5555 #+(or abcl clasp ecl mkcl xcl
) (symbol-value v
)
5556 #+(or cmu scl
) (slot-value c
::*default-cookie
*
5557 (case x
(compilation-speed 'c
::cspeed
)
5559 #+lispworks
(slot-value compiler
::*optimization-level
* x
)
5560 #+sbcl
(sb-c::policy-quality sb-c
::*policy
* x
))
5561 :when y
:collect
(list x y
))))
5562 (defun proclaim-optimization-settings ()
5563 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
5564 (proclaim `(optimize ,@*optimization-settings
*))
5565 (let ((settings (get-optimization-settings)))
5566 (unless (equal *previous-optimization-settings
* settings
)
5567 (setf *previous-optimization-settings
* settings
))))
5568 (defmacro with-optimization-settings
((&optional
(settings *optimization-settings
*)) &body body
)
5569 #+(or allegro clisp
)
5570 (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
5571 `(let ((,previous-settings
(get-optimization-settings)))
5572 ,@(when settings
`((proclaim `(optimize ,@,settings
))))
5573 (unwind-protect (progn ,@body
)
5574 (proclaim `(optimize ,@,previous-settings
)))))
5575 #-
(or allegro clisp
)
5576 `(let ,(loop :for v
:in
+optimization-variables
+ :collect
`(,v
,v
))
5577 ,@(when settings
`((proclaim `(optimize ,@,settings
))))
5581 ;;; Condition control
5582 (with-upgradability ()
5585 (defun sb-grovel-unknown-constant-condition-p (c)
5586 "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
5587 (and (typep c
'sb-int
:simple-style-warning
)
5589 "Couldn't grovel for "
5590 (simple-condition-format-control c
)
5591 " (unknown to the C compiler).")))
5592 (deftype sb-grovel-unknown-constant-condition
()
5593 '(and style-warning
(satisfies sb-grovel-unknown-constant-condition-p
))))
5595 (defvar *usual-uninteresting-conditions
*
5597 ;;#+clozure '(ccl:compiler-warning)
5598 #+cmu
'("Deleting unreachable code.")
5599 #+lispworks
'("~S being redefined in ~A (previously in ~A)."
5600 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
5602 '(sb-c::simple-compiler-note
5603 "&OPTIONAL and &KEY found in the same lambda list: ~S"
5604 #+sb-eval sb-kernel
:lexical-environment-too-complex
5605 sb-kernel
:undefined-alien-style-warning
5606 sb-grovel-unknown-constant-condition
; defined above.
5607 sb-ext
:implicit-generic-function-warning
;; Controversial.
5608 sb-int
:package-at-variance
5609 sb-kernel
:uninteresting-redefinition
5610 ;; BEWARE: the below four are controversial to include here.
5611 sb-kernel
:redefinition-with-defun
5612 sb-kernel
:redefinition-with-defgeneric
5613 sb-kernel
:redefinition-with-defmethod
5614 sb-kernel
::redefinition-with-defmacro
) ; not exported by old SBCLs
5615 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
5616 "A suggested value to which to set or bind *uninteresting-conditions*.")
5618 (defvar *uninteresting-conditions
* '()
5619 "Conditions that may be skipped while compiling or loading Lisp code.")
5620 (defvar *uninteresting-compiler-conditions
* '()
5621 "Additional conditions that may be skipped while compiling Lisp code.")
5622 (defvar *uninteresting-loader-conditions
*
5624 '("Overwriting already existing readtable ~S." ;; from named-readtables
5625 #(#:finalizers-off-warning
:asdf-finalizers
)) ;; from asdf-finalizers
5626 #+clisp
'(clos::simple-gf-replacing-method-warning
))
5627 "Additional conditions that may be skipped while loading Lisp code."))
5629 ;;;; ----- Filtering conditions while building -----
5630 (with-upgradability ()
5631 (defun call-with-muffled-compiler-conditions (thunk)
5632 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
5633 (call-with-muffled-conditions
5634 thunk
(append *uninteresting-conditions
* *uninteresting-compiler-conditions
*)))
5635 (defmacro with-muffled-compiler-conditions
((&optional
) &body body
)
5636 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
5637 `(call-with-muffled-compiler-conditions #'(lambda () ,@body
)))
5638 (defun call-with-muffled-loader-conditions (thunk)
5639 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
5640 (call-with-muffled-conditions
5641 thunk
(append *uninteresting-conditions
* *uninteresting-loader-conditions
*)))
5642 (defmacro with-muffled-loader-conditions
((&optional
) &body body
)
5643 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
5644 `(call-with-muffled-loader-conditions #'(lambda () ,@body
))))
5647 ;;;; Handle warnings and failures
5648 (with-upgradability ()
5649 (define-condition compile-condition
(condition)
5651 :initform nil
:reader compile-condition-context-format
:initarg
:context-format
)
5653 :initform nil
:reader compile-condition-context-arguments
:initarg
:context-arguments
)
5655 :initform nil
:reader compile-condition-description
:initarg
:description
))
5656 (:report
(lambda (c s
)
5657 (format s
(compatfmt "~@<~A~@[ while ~?~]~@:>")
5658 (or (compile-condition-description c
) (type-of c
))
5659 (compile-condition-context-format c
)
5660 (compile-condition-context-arguments c
)))))
5661 (define-condition compile-file-error
(compile-condition error
) ())
5662 (define-condition compile-warned-warning
(compile-condition warning
) ())
5663 (define-condition compile-warned-error
(compile-condition error
) ())
5664 (define-condition compile-failed-warning
(compile-condition warning
) ())
5665 (define-condition compile-failed-error
(compile-condition error
) ())
5667 (defun check-lisp-compile-warnings (warnings-p failure-p
5668 &optional context-format context-arguments
)
5669 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
5670 raise an error or warning as appropriate"
5672 (case *compile-file-failure-behaviour
*
5673 (:warn
(warn 'compile-failed-warning
5674 :description
"Lisp compilation failed"
5675 :context-format context-format
5676 :context-arguments context-arguments
))
5677 (:error
(error 'compile-failed-error
5678 :description
"Lisp compilation failed"
5679 :context-format context-format
5680 :context-arguments context-arguments
))
5683 (case *compile-file-warnings-behaviour
*
5684 (:warn
(warn 'compile-warned-warning
5685 :description
"Lisp compilation had style-warnings"
5686 :context-format context-format
5687 :context-arguments context-arguments
))
5688 (:error
(error 'compile-warned-error
5689 :description
"Lisp compilation had style-warnings"
5690 :context-format context-format
5691 :context-arguments context-arguments
))
5694 (defun check-lisp-compile-results (output warnings-p failure-p
5695 &optional context-format context-arguments
)
5696 "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
5698 (error 'compile-file-error
:context-format context-format
:context-arguments context-arguments
))
5699 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments
)))
5702 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
5704 ;;; To support an implementation, three functions must be implemented:
5705 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
5706 ;;; See their respective docstrings.
5707 (with-upgradability ()
5708 (defun reify-simple-sexp (sexp)
5709 "Given a simple SEXP, return a representation of it as a portable SEXP.
5710 Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
5712 (symbol (reify-symbol sexp
))
5713 ((or number character simple-string pathname
) sexp
)
5714 (cons (cons (reify-simple-sexp (car sexp
)) (reify-simple-sexp (cdr sexp
))))
5715 (simple-vector (vector (mapcar 'reify-simple-sexp
(coerce sexp
'list
))))))
5717 (defun unreify-simple-sexp (sexp)
5718 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
5720 ((or symbol number character simple-string pathname
) sexp
)
5721 (cons (cons (unreify-simple-sexp (car sexp
)) (unreify-simple-sexp (cdr sexp
))))
5722 ((simple-vector 2) (unreify-symbol sexp
))
5723 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp
(aref sexp
0)) 'vector
))))
5727 (defun reify-source-note (source-note)
5729 (with-accessors ((source ccl
::source-note-source
) (filename ccl
:source-note-filename
)
5730 (start-pos ccl
:source-note-start-pos
) (end-pos ccl
:source-note-end-pos
)) source-note
5731 (declare (ignorable source
))
5732 (list :filename filename
:start-pos start-pos
:end-pos end-pos
5733 #|
:source
(reify-source-note source
)|
#))))
5734 (defun unreify-source-note (source-note)
5736 (destructuring-bind (&key filename start-pos end-pos source
) source-note
5737 (ccl::make-source-note
:filename filename
:start-pos start-pos
:end-pos end-pos
5738 :source
(unreify-source-note source
)))))
5739 (defun unsymbolify-function-name (name)
5740 (if-let (setfed (gethash name ccl
::%setf-function-name-inverses%
))
5743 (defun symbolify-function-name (name)
5744 (if (and (consp name
) (eq (first name
) 'setf
))
5745 (let ((setfed (second name
)))
5746 (gethash setfed ccl
::%setf-function-names%
))
5748 (defun reify-function-name (function-name)
5749 (let ((name (or (first function-name
) ;; defun: extract the name
5750 (let ((sec (second function-name
)))
5751 (or (and (atom sec
) sec
) ; scoped method: drop scope
5752 (first sec
)))))) ; method: keep gf name, drop method specializers
5754 (defun unreify-function-name (function-name)
5756 (defun nullify-non-literals (sexp)
5758 ((or number character simple-string symbol pathname
) sexp
)
5759 (cons (cons (nullify-non-literals (car sexp
))
5760 (nullify-non-literals (cdr sexp
))))
5762 (defun reify-deferred-warning (deferred-warning)
5763 (with-accessors ((warning-type ccl
::compiler-warning-warning-type
)
5764 (args ccl
::compiler-warning-args
)
5765 (source-note ccl
:compiler-warning-source-note
)
5766 (function-name ccl
:compiler-warning-function-name
)) deferred-warning
5767 (list :warning-type warning-type
:function-name
(reify-function-name function-name
)
5768 :source-note
(reify-source-note source-note
)
5769 :args
(destructuring-bind (fun &rest more
)
5771 (cons (unsymbolify-function-name fun
)
5772 (nullify-non-literals more
))))))
5773 (defun unreify-deferred-warning (reified-deferred-warning)
5774 (destructuring-bind (&key warning-type function-name source-note args
)
5775 reified-deferred-warning
5776 (make-condition (or (cdr (ccl::assq warning-type ccl
::*compiler-whining-conditions
*))
5777 'ccl
::compiler-warning
)
5778 :function-name
(unreify-function-name function-name
)
5779 :source-note
(unreify-source-note source-note
)
5780 :warning-type warning-type
5781 :args
(destructuring-bind (fun . more
) args
5782 (cons (symbolify-function-name fun
) more
))))))
5784 (defun reify-undefined-warning (warning)
5785 ;; Extracting undefined-warnings from the compilation-unit
5786 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5788 (c::undefined-warning-kind warning
)
5789 (c::undefined-warning-name warning
)
5790 (c::undefined-warning-count warning
)
5793 ;; the lexenv slot can be ignored for reporting purposes
5794 `(:enclosing-source
,(c::compiler-error-context-enclosing-source frob
)
5795 :source
,(c::compiler-error-context-source frob
)
5796 :original-source
,(c::compiler-error-context-original-source frob
)
5797 :context
,(c::compiler-error-context-context frob
)
5798 :file-name
,(c::compiler-error-context-file-name frob
) ; a pathname
5799 :file-position
,(c::compiler-error-context-file-position frob
) ; an integer
5800 :original-source-path
,(c::compiler-error-context-original-source-path frob
)))
5801 (c::undefined-warning-warnings warning
))))
5804 (defun reify-undefined-warning (warning)
5805 ;; Extracting undefined-warnings from the compilation-unit
5806 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5808 (sb-c::undefined-warning-kind warning
)
5809 (sb-c::undefined-warning-name warning
)
5810 (sb-c::undefined-warning-count warning
)
5813 ;; the lexenv slot can be ignored for reporting purposes
5814 `(:enclosing-source
,(sb-c::compiler-error-context-enclosing-source frob
)
5815 :source
,(sb-c::compiler-error-context-source frob
)
5816 :original-source
,(sb-c::compiler-error-context-original-source frob
)
5817 :context
,(sb-c::compiler-error-context-context frob
)
5818 :file-name
,(sb-c::compiler-error-context-file-name frob
) ; a pathname
5819 :file-position
,(sb-c::compiler-error-context-file-position frob
) ; an integer
5820 :original-source-path
,(sb-c::compiler-error-context-original-source-path frob
)))
5821 (sb-c::undefined-warning-warnings warning
))))
5823 (defun reify-deferred-warnings ()
5824 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
5825 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
5826 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
5828 (list :functions-defined excl
::.functions-defined.
5829 :functions-called excl
::.functions-called.
)
5831 (mapcar 'reify-deferred-warning
5832 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5833 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5834 (ccl::deferred-warnings.warnings mdw
))))
5836 (when lisp
::*in-compilation-unit
*
5837 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5838 `(,@(when c
::*undefined-warnings
*
5839 `((c::*undefined-warnings
*
5840 ,@(mapcar #'reify-undefined-warning c
::*undefined-warnings
*))))
5841 ,@(loop :for what
:in
'(c::*compiler-error-count
*
5842 c
::*compiler-warning-count
*
5843 c
::*compiler-note-count
*)
5844 :for value
= (symbol-value what
)
5846 :collect
`(,what .
,value
))))
5848 (when sb-c
::*in-compilation-unit
*
5849 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5850 `(,@(when sb-c
::*undefined-warnings
*
5851 `((sb-c::*undefined-warnings
*
5852 ,@(mapcar #'reify-undefined-warning sb-c
::*undefined-warnings
*))))
5853 ,@(loop :for what
:in
'(sb-c::*aborted-compilation-unit-count
*
5854 sb-c
::*compiler-error-count
*
5855 sb-c
::*compiler-warning-count
*
5856 sb-c
::*compiler-style-warning-count
*
5857 sb-c
::*compiler-note-count
*)
5858 :for value
= (symbol-value what
)
5860 :collect
`(,what .
,value
)))))
5862 (defun unreify-deferred-warnings (reified-deferred-warnings)
5863 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
5864 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
5865 Handle any warning that has been resolved already,
5866 such as an undefined function that has been defined since.
5867 One of three functions required for deferred-warnings support in ASDF."
5868 (declare (ignorable reified-deferred-warnings
))
5870 (destructuring-bind (&key functions-defined functions-called
)
5871 reified-deferred-warnings
5872 (setf excl
::.functions-defined.
5873 (append functions-defined excl
::.functions-defined.
)
5874 excl
::.functions-called.
5875 (append functions-called excl
::.functions-called.
)))
5877 (let ((dw (or ccl
::*outstanding-deferred-warnings
*
5878 (setf ccl
::*outstanding-deferred-warnings
* (ccl::%defer-warnings t
)))))
5879 (appendf (ccl::deferred-warnings.warnings dw
)
5880 (mapcar 'unreify-deferred-warning reified-deferred-warnings
)))
5882 (dolist (item reified-deferred-warnings
)
5883 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5884 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5885 ;; For everything else, it's an integer.
5886 (destructuring-bind (symbol . adjustment
) item
5888 ((c::*undefined-warnings
*)
5889 (setf c
::*undefined-warnings
*
5892 (destructuring-bind (kind name count . rest
) stuff
5893 (unless (case kind
(:function
(fboundp name
)))
5895 (c::make-undefined-warning
5900 (mapcar #'(lambda (x)
5901 (apply #'c
::make-compiler-error-context x
))
5904 c
::*undefined-warnings
*)))
5906 (set symbol
(+ (symbol-value symbol
) adjustment
))))))
5908 (dolist (item reified-deferred-warnings
)
5909 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5910 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5911 ;; For everything else, it's an integer.
5912 (destructuring-bind (symbol . adjustment
) item
5914 ((sb-c::*undefined-warnings
*)
5915 (setf sb-c
::*undefined-warnings
*
5918 (destructuring-bind (kind name count . rest
) stuff
5919 (unless (case kind
(:function
(fboundp name
)))
5921 (sb-c::make-undefined-warning
5926 (mapcar #'(lambda (x)
5927 (apply #'sb-c
::make-compiler-error-context x
))
5930 sb-c
::*undefined-warnings
*)))
5932 (set symbol
(+ (symbol-value symbol
) adjustment
)))))))
5934 (defun reset-deferred-warnings ()
5935 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
5936 One of three functions required for deferred-warnings support in ASDF."
5938 (setf excl
::.functions-defined. nil
5939 excl
::.functions-called. nil
)
5941 (if-let (dw ccl
::*outstanding-deferred-warnings
*)
5942 (let ((mdw (ccl::ensure-merged-deferred-warnings dw
)))
5943 (setf (ccl::deferred-warnings.warnings mdw
) nil
)))
5945 (when lisp
::*in-compilation-unit
*
5946 (setf c
::*undefined-warnings
* nil
5947 c
::*compiler-error-count
* 0
5948 c
::*compiler-warning-count
* 0
5949 c
::*compiler-note-count
* 0))
5951 (when sb-c
::*in-compilation-unit
*
5952 (setf sb-c
::*undefined-warnings
* nil
5953 sb-c
::*aborted-compilation-unit-count
* 0
5954 sb-c
::*compiler-error-count
* 0
5955 sb-c
::*compiler-warning-count
* 0
5956 sb-c
::*compiler-style-warning-count
* 0
5957 sb-c
::*compiler-note-count
* 0)))
5959 (defun save-deferred-warnings (warnings-file)
5960 "Save forward reference conditions so they may be issued at a latter time,
5961 possibly in a different process."
5962 (with-open-file (s warnings-file
:direction
:output
:if-exists
:supersede
5963 :element-type
*default-stream-element-type
*
5964 :external-format
*utf-8-external-format
*)
5965 (with-safe-io-syntax ()
5966 (write (reify-deferred-warnings) :stream s
:pretty t
:readably t
)
5969 (defun warnings-file-type (&optional implementation-type
)
5970 "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
5971 where NIL designates the current one"
5972 (case (or implementation-type
*implementation-type
*)
5973 ((:acl
:allegro
) "allegro-warnings")
5974 ;;((:clisp) "clisp-warnings")
5975 ((:cmu
:cmucl
) "cmucl-warnings")
5976 ((:sbcl
) "sbcl-warnings")
5977 ((:clozure
:ccl
) "ccl-warnings")
5978 ((:scl
) "scl-warnings")))
5980 (defvar *warnings-file-type
* nil
5981 "Pathname type for warnings files, or NIL if disabled")
5983 (defun enable-deferred-warnings-check ()
5984 "Enable the saving of deferred warnings"
5985 (setf *warnings-file-type
* (warnings-file-type)))
5987 (defun disable-deferred-warnings-check ()
5988 "Disable the saving of deferred warnings"
5989 (setf *warnings-file-type
* nil
))
5991 (defun warnings-file-p (file &optional implementation-type
)
5992 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
5993 If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
5994 (if-let (type (if implementation-type
5995 (warnings-file-type implementation-type
)
5996 *warnings-file-type
*))
5997 (equal (pathname-type file
) type
)))
5999 (defun check-deferred-warnings (files &optional context-format context-arguments
)
6000 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
6001 re-intern and raise any warnings that are still meaningful."
6002 (let ((file-errors nil
)
6006 ((warning #'(lambda (c)
6008 (unless (typep c
'style-warning
)
6009 (setf failure-p t
)))))
6010 (with-compilation-unit (:override t
)
6011 (reset-deferred-warnings)
6012 (dolist (file files
)
6013 (unreify-deferred-warnings
6014 (handler-case (safe-read-file-form file
)
6016 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
6017 (push c file-errors
)
6019 (dolist (error file-errors
) (error error
))
6020 (check-lisp-compile-warnings
6021 (or failure-p warnings-p
) failure-p context-format context-arguments
)))
6024 Mini-guide to adding support for deferred warnings on an implementation.
6026 First
, look at what such a warning looks like
:
6030 (and (eval '(lambda () (some-undefined-function))) nil
)
6033 Then you can grep for the condition type in your compiler sources
6034 and see how to catch those that have been deferred
,
6035 and
/or read
, clear and restore the deferred list.
6038 (macroexpand-1 '(with-compilation-unit () foo
))
6041 (defun call-with-saved-deferred-warnings (thunk warnings-file
&key source-namestring
)
6042 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
6043 and save those warnings to the given file for latter use,
6044 possibly in a different process. Otherwise just call THUNK."
6045 (declare (ignorable source-namestring
))
6047 (with-compilation-unit (:override t
#+sbcl
:source-namestring
#+sbcl source-namestring
)
6049 (let (#+sbcl
(sb-c::*undefined-warnings
* nil
))
6050 (multiple-value-prog1
6052 (save-deferred-warnings warnings-file
)))
6053 (reset-deferred-warnings)))
6056 (defmacro with-saved-deferred-warnings
((warnings-file &key source-namestring
) &body body
)
6057 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
6058 `(call-with-saved-deferred-warnings
6059 #'(lambda () ,@body
) ,warnings-file
:source-namestring
,source-namestring
)))
6063 (with-upgradability ()
6064 (defun current-lisp-file-pathname ()
6065 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
6066 (or *compile-file-pathname
* *load-pathname
*))
6068 (defun load-pathname ()
6069 "Portably return the LOAD-PATHNAME of the current source file or fasl"
6070 *load-pathname
*) ;; magic no longer needed for GCL.
6072 (defun lispize-pathname (input-file)
6073 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
6074 (make-pathname :type
"lisp" :defaults input-file
))
6076 (defun compile-file-type (&rest keys
)
6077 "pathname TYPE for lisp FASt Loading files"
6078 (declare (ignorable keys
))
6079 #-
(or clasp ecl mkcl
) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
6080 #+(or clasp ecl mkcl
) (pathname-type (apply 'compile-file-pathname
"foo" keys
)))
6082 (defun call-around-hook (hook function
)
6083 "Call a HOOK around the execution of FUNCTION"
6084 (call-function (or hook
'funcall
) function
))
6086 (defun compile-file-pathname* (input-file &rest keys
&key output-file
&allow-other-keys
)
6087 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
6089 (remove-plist-keys `(#+(or (and allegro
(not (version>= 8 2)))) :external-format
6090 ,@(unless output-file
'(:output-file
))) keys
)))
6091 (if (absolute-pathname-p output-file
)
6092 ;; what cfp should be doing, w/ mp* instead of mp
6093 (let* ((type (pathname-type (apply 'compile-file-type keys
)))
6094 (defaults (make-pathname
6095 :type type
:defaults
(merge-pathnames* input-file
))))
6096 (merge-pathnames* output-file defaults
))
6097 (funcall *output-translation-function
*
6098 (apply 'compile-file-pathname input-file keys
)))))
6100 (defvar *compile-check
* nil
6101 "A hook for user-defined compile-time invariants")
6103 (defun* (compile-file*) (input-file &rest keys
6104 &key
(compile-check *compile-check
*) output-file warnings-file
6105 #+clisp lib-file
#+(or clasp ecl mkcl
) object-file
#+sbcl emit-cfasl
6107 "This function provides a portable wrapper around COMPILE-FILE.
6108 It ensures that the OUTPUT-FILE value is only returned and
6109 the file only actually created if the compilation was successful,
6110 even though your implementation may not do that, and including
6111 an optional call to an user-provided consistency check function COMPILE-CHECK;
6112 it will call this function if not NIL at the end of the compilation
6113 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
6114 where TMP-FILE is the name of a temporary output-file.
6115 It also checks two flags (with legacy british spelling from ASDF1),
6116 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
6117 with appropriate implementation-dependent defaults,
6118 and if a failure (respectively warnings) are reported by COMPILE-FILE
6119 with consider it an error unless the respective behaviour flag
6120 is one of :SUCCESS :WARN :IGNORE.
6121 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
6122 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
6123 On implementations that erroneously do not recognize standard keyword arguments,
6124 it will filter them appropriately."
6125 #+(or clasp ecl
) (when (and object-file
(equal (compile-file-type) (pathname object-file
)))
6126 (format t
"Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
6127 'compile-file
* output-file object-file
)
6128 (rotatef output-file object-file
))
6129 (let* ((keywords (remove-plist-keys
6130 `(:output-file
:compile-check
:warnings-file
6131 #+clisp
:lib-file
#+(or clasp ecl mkcl
) :object-file
) keys
))
6134 (apply 'compile-file-pathname
* input-file
:output-file output-file keywords
)))
6137 (unless (use-ecl-byte-compiler-p)
6139 #+ecl
(compile-file-pathname output-file
:type
:object
)
6140 #+clasp
(compile-file-pathname output-file
:output-type
:object
)
6145 (compile-file-pathname output-file
:fasl-p nil
)))
6146 (tmp-file (tmpize-pathname output-file
))
6148 (cfasl-file (etypecase emit-cfasl
6150 ((eql t
) (make-pathname :type
"cfasl" :defaults output-file
))
6151 (string (parse-namestring emit-cfasl
))
6152 (pathname emit-cfasl
)))
6154 (tmp-cfasl (when cfasl-file
(make-pathname :type
"cfasl" :defaults tmp-file
)))
6156 (tmp-lib (make-pathname :type
"lib" :defaults tmp-file
)))
6157 (multiple-value-bind (output-truename warnings-p failure-p
)
6158 (with-enough-pathname (input-file :defaults
*base-build-directory
*)
6159 (with-saved-deferred-warnings (warnings-file :source-namestring
(namestring input-file
))
6160 (with-muffled-compiler-conditions ()
6161 (or #-
(or clasp ecl mkcl
)
6162 (apply 'compile-file input-file
:output-file tmp-file
6163 #+sbcl
(if emit-cfasl
(list* :emit-cfasl tmp-cfasl keywords
) keywords
)
6165 #+ecl
(apply 'compile-file input-file
:output-file
6167 (list* object-file
:system-p t keywords
)
6168 (list* tmp-file keywords
)))
6169 #+clasp
(apply 'compile-file input-file
:output-file
6171 (list* object-file
:output-type
:object
#|
:system-p t|
# keywords
)
6172 (list* tmp-file keywords
)))
6173 #+mkcl
(apply 'compile-file input-file
6174 :output-file object-file
:fasl-p nil keywords
)))))
6176 ((and output-truename
6177 (flet ((check-flag (flag behaviour
)
6178 (or (not flag
) (member behaviour
'(:success
:warn
:ignore
)))))
6179 (and (check-flag failure-p
*compile-file-failure-behaviour
*)
6180 (check-flag warnings-p
*compile-file-warnings-behaviour
*)))
6182 #+(or clasp ecl mkcl
)
6183 (when (and #+(or clasp ecl
) object-file
)
6184 (setf output-truename
6185 (compiler::build-fasl tmp-file
6186 #+(or clasp ecl
) :lisp-files
#+mkcl
:lisp-object-files
(list object-file
))))
6187 (or (not compile-check
)
6188 (apply compile-check input-file
6189 :output-file
#-
(or clasp ecl
) output-file
#+(or clasp ecl
) tmp-file
6191 (delete-file-if-exists output-file
)
6192 (when output-truename
6193 #+clasp
(when output-truename
(rename-file-overwriting-target tmp-file output-truename
))
6194 #+clisp
(when lib-file
(rename-file-overwriting-target tmp-lib lib-file
))
6195 #+sbcl
(when cfasl-file
(rename-file-overwriting-target tmp-cfasl cfasl-file
))
6196 (rename-file-overwriting-target output-truename output-file
)
6197 (setf output-truename
(truename output-file
)))
6198 #+clasp
(delete-file-if-exists tmp-file
)
6199 #+clisp
(delete-file-if-exists tmp-lib
))
6200 (t ;; error or failed check
6201 (delete-file-if-exists output-truename
)
6202 #+clisp
(delete-file-if-exists tmp-lib
)
6203 #+sbcl
(delete-file-if-exists tmp-cfasl
)
6204 (setf output-truename nil
)))
6205 (values output-truename warnings-p failure-p
))))
6207 (defun load* (x &rest keys
&key
&allow-other-keys
)
6208 "Portable wrapper around LOAD that properly handles loading from a stream."
6209 (with-muffled-loader-conditions ()
6211 ((or pathname string
#-
(or allegro clozure genera
) stream
#+clozure file-stream
)
6212 (apply 'load x keys
))
6213 ;; Genera can't load from a string-input-stream
6214 ;; ClozureCL 1.6 can only load from file input stream
6215 ;; Allegro 5, I don't remember but it must have been broken when I tested.
6216 #+(or allegro clozure genera
)
6217 (stream ;; make do this way
6218 (let ((*package
* *package
*)
6219 (*readtable
* *readtable
*)
6220 (*load-pathname
* nil
)
6221 (*load-truename
* nil
))
6224 (defun load-from-string (string)
6225 "Portably read and evaluate forms from a STRING."
6226 (with-input-from-string (s string
) (load* s
))))
6228 ;;; Links FASLs together
6229 (with-upgradability ()
6230 (defun combine-fasls (inputs output
)
6231 "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
6232 #-
(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl
)
6233 (error "~A does not support ~S~%inputs ~S~%output ~S"
6234 (implementation-type) 'combine-fasls inputs output
)
6235 #+abcl
(funcall 'sys
::concatenate-fasls inputs output
) ; requires ABCL 1.2.0
6236 #+(or allegro clisp cmu sbcl scl xcl
) (concatenate-files inputs output
)
6237 #+clozure
(ccl:fasl-concatenate output inputs
:if-exists
:supersede
)
6242 (loop :for i
:in inputs
6244 :for f
= (add-pathname-suffix
6245 output
(format nil
"-FASL~D" n
))
6248 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))
6249 (eval `(scm:defsystem
:fasls-to-concatenate
6250 (:default-pathname
,(pathname-directory-pathname output
))
6252 ,(loop :for f
:in
(reverse fasls
)
6253 :collect
`(,(namestring f
) :load-only t
))))
6254 (scm:concatenate-system output
:fasls-to-concatenate
))
6255 (loop :for f
:in fasls
:do
(ignore-errors (delete-file f
)))
6256 (ignore-errors (lispworks:delete-system
:fasls-to-concatenate
))))))
6257 ;;;; ---------------------------------------------------------------------------
6258 ;;;; Generic support for configuration files
6260 (uiop/package
:define-package
:uiop
/configuration
6261 (:nicknames
:asdf
/configuration
)
6262 (:recycle
:uiop
/configuration
:asdf
/configuration
:asdf
)
6263 (:use
:uiop
/common-lisp
:uiop
/utility
6264 :uiop
/os
:uiop
/pathname
:uiop
/filesystem
:uiop
/stream
:uiop
/image
:uiop
/lisp-build
)
6266 #:user-configuration-directories
#:system-configuration-directories
;; implemented in backward-driver
6267 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
;; idem
6269 #:xdg-data-home
#:xdg-config-home
#:xdg-data-dirs
#:xdg-config-dirs
6270 #:xdg-cache-home
#:xdg-runtime-dir
#:system-config-pathnames
6271 #:filter-pathname-set
#:xdg-data-pathnames
#:xdg-config-pathnames
6272 #:find-preferred-file
#:xdg-data-pathname
#:xdg-config-pathname
6273 #:validate-configuration-form
#:validate-configuration-file
#:validate-configuration-directory
6274 #:configuration-inheritance-directive-p
6275 #:report-invalid-form
#:invalid-configuration
#:*ignored-configuration-form
* #:*user-cache
*
6276 #:*clear-configuration-hook
* #:clear-configuration
#:register-clear-configuration-hook
6277 #:resolve-location
#:location-designator-p
#:location-function-p
#:*here-directory
*
6278 #:resolve-relative-location
#:resolve-absolute-location
#:upgrade-configuration
))
6279 (in-package :uiop
/configuration
)
6281 (with-upgradability ()
6282 (define-condition invalid-configuration
()
6283 ((form :reader condition-form
:initarg
:form
)
6284 (location :reader condition-location
:initarg
:location
)
6285 (format :reader condition-format
:initarg
:format
)
6286 (arguments :reader condition-arguments
:initarg
:arguments
:initform nil
))
6287 (:report
(lambda (c s
)
6288 (format s
(compatfmt "~@<~? (will be skipped)~@:>")
6289 (condition-format c
)
6290 (list* (condition-form c
) (condition-location c
)
6291 (condition-arguments c
))))))
6293 (defun configuration-inheritance-directive-p (x)
6294 "Is X a configuration inheritance directive?"
6295 (let ((kw '(:inherit-configuration
:ignore-inherited-configuration
)))
6297 (and (length=n-p x
1) (member (car x
) kw
)))))
6299 (defun report-invalid-form (reporter &rest args
)
6300 "Report an invalid form according to REPORTER and various ARGS"
6303 (apply 'error
'invalid-configuration args
))
6305 (apply reporter args
))
6307 (apply 'error reporter args
))
6309 (apply 'apply
(append reporter args
)))))
6311 (defvar *ignored-configuration-form
* nil
6312 "Have configuration forms been ignored while parsing the configuration?")
6314 (defun validate-configuration-form (form tag directive-validator
6315 &key location invalid-form-reporter
)
6316 "Validate a configuration FORM. By default it will raise an error if the
6317 FORM is not valid. Otherwise it will return the validated form.
6318 Arguments control the behavior:
6319 The configuration FORM should be of the form (TAG . <rest>)
6320 Each element of <rest> will be checked by first seeing if it's a configuration inheritance
6321 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
6323 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
6324 reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
6325 the configuration form appeared."
6326 (unless (and (consp form
) (eq (car form
) tag
))
6327 (setf *ignored-configuration-form
* t
)
6328 (report-invalid-form invalid-form-reporter
:form form
:location location
)
6329 (return-from validate-configuration-form nil
))
6330 (loop :with inherit
= 0 :with ignore-invalid-p
= nil
:with x
= (list tag
)
6331 :for directive
:in
(cdr form
)
6333 ((configuration-inheritance-directive-p directive
)
6335 ((eq directive
:ignore-invalid-entries
)
6336 (setf ignore-invalid-p t
) t
)
6337 ((funcall directive-validator directive
)
6342 (setf *ignored-configuration-form
* t
)
6343 (report-invalid-form invalid-form-reporter
:form directive
:location location
)
6345 :do
(push directive x
)
6347 (unless (= inherit
1)
6348 (report-invalid-form invalid-form-reporter
6349 :form form
:location location
6350 ;; we throw away the form and location arguments, hence the ~2*
6351 ;; this is necessary because of the report in INVALID-CONFIGURATION
6352 :format
(compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
6353 One and only one of ~S or ~S is required.~@:>")
6354 :arguments
'(:inherit-configuration
:ignore-inherited-configuration
)))
6355 (return (nreverse x
))))
6357 (defun validate-configuration-file (file validator
&key description
)
6358 "Validate a configuration FILE. The configuration file should have only one s-expression
6359 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
6361 (let ((forms (read-file-forms file
)))
6362 (unless (length=n-p forms
1)
6363 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
6365 (funcall validator
(car forms
) :location file
)))
6367 (defun validate-configuration-directory (directory tag validator
&key invalid-form-reporter
)
6368 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
6369 be applied to the results to yield a configuration form. Current
6370 values of TAG include :source-registry and :output-translations."
6371 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
6374 (directory* (make-pathname :name
*wild
* :type
"conf" :defaults directory
))))
6375 #'string
< :key
#'namestring
)))
6377 ,@(loop :for file
:in files
:append
6378 (loop :with ignore-invalid-p
= nil
6379 :for form
:in
(read-file-forms file
)
6380 :when
(eq form
:ignore-invalid-entries
)
6381 :do
(setf ignore-invalid-p t
)
6383 :when
(funcall validator form
)
6386 :when ignore-invalid-p
6387 :do
(setf *ignored-configuration-form
* t
)
6389 :do
(report-invalid-form invalid-form-reporter
:form form
:location file
)))
6390 :inherit-configuration
)))
6392 (defun resolve-relative-location (x &key ensure-directory wilden
)
6393 "Given a designator X for an relative location, resolve it to a pathname."
6398 (string (parse-unix-namestring
6399 x
:ensure-directory ensure-directory
))
6402 (resolve-relative-location
6403 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
6404 (let* ((car (resolve-relative-location
6405 (car x
) :ensure-directory t
:wilden nil
)))
6407 (resolve-relative-location
6408 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
6410 ((eql :*/) *wild-directory
*)
6411 ((eql :**/) *wild-inferiors
*)
6412 ((eql :*.
*.
*) *wild-file
*)
6413 ((eql :implementation
)
6414 (parse-unix-namestring
6415 (implementation-identifier) :ensure-directory t
))
6416 ((eql :implementation-type
)
6417 (parse-unix-namestring
6418 (string-downcase (implementation-type)) :ensure-directory t
))
6420 (parse-unix-namestring (hostname) :ensure-directory t
)))
6421 :wilden
(and wilden
(not (pathnamep x
)) (not (member x
'(:*/ :**/ :*.
*.
*))))
6424 (defvar *here-directory
* nil
6425 "This special variable is bound to the currect directory during calls to
6426 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
6429 (defvar *user-cache
* nil
6430 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
6432 (defun resolve-absolute-location (x &key ensure-directory wilden
)
6433 "Given a designator X for an absolute location, resolve it to a pathname"
6439 (let ((p #-mcl
(parse-namestring x
)
6440 #+mcl
(probe-posix x
)))
6441 #+mcl
(unless p
(error "POSIX pathname ~S does not exist" x
))
6442 (if ensure-directory
(ensure-directory-pathname p
) p
)))
6444 (return-from resolve-absolute-location
6446 (resolve-absolute-location
6447 (car x
) :ensure-directory ensure-directory
:wilden wilden
)
6449 (resolve-relative-location
6450 (cdr x
) :ensure-directory ensure-directory
:wilden wilden
)
6451 (resolve-absolute-location
6452 (car x
) :ensure-directory t
:wilden nil
)))))
6454 ;; special magic! we return a relative pathname,
6455 ;; but what it means to the output-translations is
6456 ;; "relative to the root of the source pathname's host and device".
6457 (return-from resolve-absolute-location
6458 (let ((p (make-pathname* :directory
'(:relative
))))
6459 (if wilden
(wilden p
) p
))))
6460 ((eql :home
) (user-homedir-pathname))
6461 ((eql :here
) (resolve-absolute-location
6462 (or *here-directory
* (pathname-directory-pathname (load-pathname)))
6463 :ensure-directory t
:wilden nil
))
6464 ((eql :user-cache
) (resolve-absolute-location
6465 *user-cache
* :ensure-directory t
:wilden nil
)))
6466 :wilden
(and wilden
(not (pathnamep x
)))
6467 :resolve-symlinks
*resolve-symlinks
*
6470 ;; Try to override declaration in previous versions of ASDF.
6471 (declaim (ftype (function (t &key
(:directory boolean
) (:wilden boolean
)
6472 (:ensure-directory boolean
)) t
) resolve-location
))
6474 (defun* (resolve-location) (x &key ensure-directory wilden directory
)
6475 "Resolve location designator X into a PATHNAME"
6476 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
6477 (loop* :with dirp
= (or directory ensure-directory
)
6478 :with
(first . rest
) = (if (atom x
) (list x
) x
)
6479 :with path
= (or (resolve-absolute-location
6480 first
:ensure-directory
(and (or dirp rest
) t
)
6481 :wilden
(and wilden
(null rest
)))
6483 :for
(element . morep
) :on rest
6484 :for dir
= (and (or morep dirp
) t
)
6485 :for wild
= (and wilden
(not morep
))
6486 :for sub
= (merge-pathnames*
6487 (resolve-relative-location
6488 element
:ensure-directory dir
:wilden wild
)
6490 :do
(setf path
(if (absolute-pathname-p sub
) (resolve-symlinks* sub
) sub
))
6491 :finally
(return path
)))
6493 (defun location-designator-p (x)
6494 "Is X a designator for a location?"
6495 ;; NIL means "skip this entry", or as an output translation, same as translation input.
6496 ;; T means "any input" for a translation, or as output, same as translation input.
6497 (flet ((absolute-component-p (c)
6498 (typep c
'(or string pathname
6499 (member :root
:home
:here
:user-cache
))))
6500 (relative-component-p (c)
6501 (typep c
'(or string pathname
6502 (member :*/ :**/ :*.
*.
* :implementation
:implementation-type
)))))
6503 (or (typep x
'boolean
)
6504 (absolute-component-p x
)
6505 (and (consp x
) (absolute-component-p (first x
)) (every #'relative-component-p
(rest x
))))))
6507 (defun location-function-p (x)
6508 "Is X the specification of a location function?"
6509 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
6510 (and (length=n-p x
2) (eq (car x
) :function
)))
6512 (defvar *clear-configuration-hook
* '())
6514 (defun register-clear-configuration-hook (hook-function &optional call-now-p
)
6515 "Register a function to be called when clearing configuration"
6516 (register-hook-function '*clear-configuration-hook
* hook-function call-now-p
))
6518 (defun clear-configuration ()
6519 "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
6520 (call-functions *clear-configuration-hook
*))
6522 (register-image-dump-hook 'clear-configuration
)
6524 (defun upgrade-configuration ()
6525 "If a previous version of ASDF failed to read some configuration, try again now."
6526 (when *ignored-configuration-form
*
6527 (clear-configuration)
6528 (setf *ignored-configuration-form
* nil
)))
6531 (defun get-folder-path (folder)
6532 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
6533 this function tries to locate the Windows FOLDER for one of
6534 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
6535 Returns NIL when the folder is not defined (e.g., not on Windows)."
6536 (or #+(and lispworks mswindows
) (sys:get-folder-path folder
)
6537 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
6539 (:local-appdata
(or (getenv-absolute-directory "LOCALAPPDATA")
6540 (subpathname* (get-folder-path :appdata
) "Local")))
6541 (:appdata
(getenv-absolute-directory "APPDATA"))
6542 (:common-appdata
(or (getenv-absolute-directory "ALLUSERSAPPDATA")
6543 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
6546 ;; Support for the XDG Base Directory Specification
6547 (defun xdg-data-home (&rest more
)
6548 "Returns an absolute pathname for the directory containing user-specific data files.
6549 MORE may contain specifications for a subpath relative to this directory: a
6550 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6551 also \"Configuration DSL\"\) in the ASDF manual."
6552 (resolve-absolute-location
6553 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
6555 ((os-windows-p) (get-folder-path :local-appdata
))
6556 (t (subpathname (user-homedir-pathname) ".local/share/"))))
6559 (defun xdg-config-home (&rest more
)
6560 "Returns a pathname for the directory containing user-specific configuration files.
6561 MORE may contain specifications for a subpath relative to this directory: a
6562 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6563 also \"Configuration DSL\"\) in the ASDF manual."
6564 (resolve-absolute-location
6565 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
6567 ((os-windows-p) (xdg-data-home "config/"))
6568 (t (subpathname (user-homedir-pathname) ".config/"))))
6571 (defun xdg-data-dirs (&rest more
)
6572 "The preference-ordered set of additional paths to search for data files.
6573 Returns a list of absolute directory pathnames.
6574 MORE may contain specifications for a subpath relative to these directories: a
6575 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6576 also \"Configuration DSL\"\) in the ASDF manual."
6577 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
6578 (or (getenv-absolute-directories "XDG_DATA_DIRS")
6580 ((os-windows-p) (mapcar 'get-folder-path
'(:appdata
:common-appdata
)))
6581 (t (mapcar 'parse-unix-namestring
'("/usr/local/share/" "/usr/share/")))))))
6583 (defun xdg-config-dirs (&rest more
)
6584 "The preference-ordered set of additional base paths to search for configuration files.
6585 Returns a list of absolute directory pathnames.
6586 MORE may contain specifications for a subpath relative to these directories:
6587 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6588 also \"Configuration DSL\"\) in the ASDF manual."
6589 (mapcar #'(lambda (d) (resolve-location `(,d
,more
)))
6590 (or (getenv-absolute-directories "XDG_CONFIG_DIRS")
6592 ((os-windows-p) (xdg-data-dirs "config/"))
6593 (t (mapcar 'parse-unix-namestring
'("/etc/xdg/")))))))
6595 (defun xdg-cache-home (&rest more
)
6596 "The base directory relative to which user specific non-essential data files should be stored.
6597 Returns an absolute directory pathname.
6598 MORE may contain specifications for a subpath relative to this directory: a
6599 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6600 also \"Configuration DSL\"\) in the ASDF manual."
6601 (resolve-absolute-location
6602 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
6604 ((os-windows-p) (xdg-data-home "cache"))
6605 (t (subpathname* (user-homedir-pathname) ".cache/"))))
6608 (defun xdg-runtime-dir (&rest more
)
6609 "Pathname for user-specific non-essential runtime files and other file objects,
6610 such as sockets, named pipes, etc.
6611 Returns an absolute directory pathname.
6612 MORE may contain specifications for a subpath relative to this directory: a
6613 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6614 also \"Configuration DSL\"\) in the ASDF manual."
6615 ;; The XDG spec says that if not provided by the login system, the application should
6616 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
6617 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more
)))
6619 ;;; NOTE: modified the docstring because "system user configuration
6620 ;;; directories" seems self-contradictory. I'm not sure my wording is right.
6621 (defun system-config-pathnames (&rest more
)
6622 "Return a list of directories where are stored the system's default user configuration information.
6623 MORE may contain specifications for a subpath relative to these directories: a
6624 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6625 also \"Configuration DSL\"\) in the ASDF manual."
6626 (declare (ignorable more
))
6628 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more
))))))
6630 (defun filter-pathname-set (dirs)
6631 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
6632 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs
) :from-end t
:test
'equal
))
6634 (defun xdg-data-pathnames (&rest more
)
6635 "Return a list of absolute pathnames for application data directories. With APP,
6636 returns directory for data for that application, without APP, returns the set of directories
6637 for storing all application configurations.
6638 MORE may contain specifications for a subpath relative to these directories: a
6639 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6640 also \"Configuration DSL\"\) in the ASDF manual."
6641 (filter-pathname-set
6642 `(,(xdg-data-home more
)
6643 ,@(xdg-data-dirs more
))))
6645 (defun xdg-config-pathnames (&rest more
)
6646 "Return a list of pathnames for application configuration.
6647 MORE may contain specifications for a subpath relative to these directories: a
6648 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
6649 also \"Configuration DSL\"\) in the ASDF manual."
6650 (filter-pathname-set
6651 `(,(xdg-config-home more
)
6652 ,@(xdg-config-dirs more
))))
6654 (defun find-preferred-file (files &key
(direction :input
))
6655 "Find first file in the list of FILES that exists (for direction :input or :probe)
6656 or just the first one (for direction :output or :io).
6657 Note that when we say \"file\" here, the files in question may be directories."
6658 (find-if (ecase direction
((:probe
:input
) 'probe-file
*) ((:output
:io
) 'identity
)) files
))
6660 (defun xdg-data-pathname (&optional more
(direction :input
))
6661 (find-preferred-file (xdg-data-pathnames more
) :direction direction
))
6663 (defun xdg-config-pathname (&optional more
(direction :input
))
6664 (find-preferred-file (xdg-config-pathnames more
) :direction direction
))
6666 (defun compute-user-cache ()
6667 "Compute (and return) the location of the default user-cache for translate-output
6668 objects. Side-effects for cached file location computation."
6669 (setf *user-cache
* (xdg-cache-home "common-lisp" :implementation
)))
6670 (register-image-restore-hook 'compute-user-cache
))
6671 ;;;; -------------------------------------------------------------------------
6672 ;;; Hacks for backward-compatibility of the driver
6674 (uiop/package
:define-package
:uiop
/backward-driver
6675 (:nicknames
:asdf
/backward-driver
)
6676 (:recycle
:uiop
/backward-driver
:asdf
/backward-driver
:asdf
)
6677 (:use
:uiop
/common-lisp
:uiop
/package
:uiop
/utility
6678 :uiop
/pathname
:uiop
/stream
:uiop
/os
:uiop
/image
6679 :uiop
/run-program
:uiop
/lisp-build
:uiop
/configuration
)
6681 #:coerce-pathname
#:component-name-to-pathname-components
6682 #+(or clasp ecl mkcl
) #:compile-file-keeping-object
6683 #:user-configuration-directories
#:system-configuration-directories
6684 #:in-first-directory
#:in-user-configuration-directory
#:in-system-configuration-directory
6686 (in-package :uiop
/backward-driver
)
6688 ;;;; Backward compatibility with various pathname functions.
6690 (with-upgradability ()
6691 (defun coerce-pathname (name &key type defaults
)
6692 ;; For backward-compatibility only, for people using internals
6693 ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
6694 ;; Will be removed after 2014-01-16.
6695 ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
6696 (parse-unix-namestring name
:type type
:defaults defaults
))
6698 (defun component-name-to-pathname-components (unix-style-namestring
6699 &key force-directory force-relative
)
6700 ;; Will be removed after 2014-01-16.
6701 ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
6702 (multiple-value-bind (relabs path filename file-only
)
6703 (split-unix-namestring-directory-components
6704 unix-style-namestring
:ensure-directory force-directory
)
6705 (declare (ignore file-only
))
6706 (when (and force-relative
(not (eq relabs
:relative
)))
6707 (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
6708 unix-style-namestring
))
6709 (values relabs path filename
)))
6711 #+(or clasp ecl mkcl
)
6712 (defun compile-file-keeping-object (&rest args
) (apply #'compile-file
* args
))
6714 ;; Backward compatibility for ASDF 2.27 to 3.1.4
6715 (defun user-configuration-directories ()
6716 "Return the current user's list of user configuration directories
6717 for configuring common-lisp.
6718 DEPRECATED. Use uiop:xdg-config-pathnames instead."
6719 (xdg-config-pathnames "common-lisp"))
6720 (defun system-configuration-directories ()
6721 "Return the list of system configuration directories for common-lisp.
6722 DEPRECATED. Use uiop:config-system-pathnames instead."
6723 (system-config-pathnames "common-lisp"))
6724 (defun in-first-directory (dirs x
&key
(direction :input
))
6725 "Finds the first appropriate file named X in the list of DIRS for I/O
6726 in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
6727 If direction is :INPUT or :PROBE, will return the first extant file named
6728 X in one of the DIRS.
6729 If direction is :OUTPUT or :IO, will simply return the file named X in the
6730 first element of DIRS that exists. DEPRECATED."
6731 (find-preferred-file
6732 (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir
) x
)) dirs
)
6733 :direction direction
))
6734 (defun in-user-configuration-directory (x &key
(direction :input
))
6735 "Return the file named X in the user configuration directory for common-lisp.
6737 (xdg-config-pathname `("common-lisp" ,x
) direction
))
6738 (defun in-system-configuration-directory (x &key
(direction :input
))
6739 "Return the pathname for the file named X under the system configuration directory
6740 for common-lisp. DEPRECATED."
6741 (find-preferred-file (system-config-pathnames "common-lisp" x
) :direction direction
)))
6742 ;;;; ---------------------------------------------------------------------------
6743 ;;;; Re-export all the functionality in UIOP
6745 (uiop/package
:define-package
:uiop
/driver
6746 (:nicknames
:uiop
:asdf
/driver
:asdf-driver
:asdf-utils
)
6747 (:use
:uiop
/common-lisp
)
6748 ;; NB: not reexporting uiop/common-lisp
6749 ;; which include all of CL with compatibility modifications on select platforms,
6750 ;; that could cause potential conflicts for packages that would :use (cl uiop)
6751 ;; or :use (closer-common-lisp uiop), etc.
6753 :uiop
/package
:uiop
/utility
6754 :uiop
/os
:uiop
/pathname
:uiop
/stream
:uiop
/filesystem
:uiop
/image
6755 :uiop
/run-program
:uiop
/lisp-build
6756 :uiop
/configuration
:uiop
/backward-driver
))
6758 ;; Provide both lowercase and uppercase, to satisfy more people.
6759 (provide "uiop") (provide "UIOP")
