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

Last change on this file since 15830 was 15830, checked in by rme, 7 years ago

ASDF 3.0.1.

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