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

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

Update to ASDF 3.0.2.

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