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

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

ASDF 3.0.1.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 449.1 KB
Line 
1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2;;; This is ASDF 3.0.1: Another System Definition Facility.
3;;;
4;;; Feedback, bug reports, and patches are all welcome:
5;;; please mail to <asdf-devel@common-lisp.net>.
6;;; Note first that the canonical source for ASDF is presently
7;;; <URL:http://common-lisp.net/project/asdf/>.
8;;;
9;;; If you obtained this copy from anywhere else, and you experience
10;;; trouble using it, or find bugs, you may want to check at the
11;;; location above for a more recent version (and for documentation
12;;; and test files, if your copy came without them) before reporting
13;;; bugs.  There are usually two "supported" revisions - the git master
14;;; branch is the latest development version, whereas the git release
15;;; branch may be slightly older but is considered `stable'
16
17;;; -- LICENSE START
18;;; (This is the MIT / X Consortium license as taken from
19;;;  http://www.opensource.org/licenses/mit-license.html on or about
20;;;  Monday; July 13, 2009)
21;;;
22;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
23;;;
24;;; Permission is hereby granted, free of charge, to any person obtaining
25;;; a copy of this software and associated documentation files (the
26;;; "Software"), to deal in the Software without restriction, including
27;;; without limitation the rights to use, copy, modify, merge, publish,
28;;; distribute, sublicense, and/or sell copies of the Software, and to
29;;; permit persons to whom the Software is furnished to do so, subject to
30;;; the following conditions:
31;;;
32;;; The above copyright notice and this permission notice shall be
33;;; included in all copies or substantial portions of the Software.
34;;;
35;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
36;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
37;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
38;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
39;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
40;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
41;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
42;;;
43;;; -- LICENSE END
44
45;;; The problem with writing a defsystem replacement is bootstrapping:
46;;; we can't use defsystem to compile it.  Hence, all in one file.
47
48#+xcvb (module ())
49
50(in-package :cl-user)
51
52#+cmu
53(eval-when (:load-toplevel :compile-toplevel :execute)
54  (declaim (optimize (speed 1) (safety 3) (debug 3)))
55  (setf ext:*gc-verbose* nil))
56
57#+(or abcl clisp clozure cmu ecl xcl)
58(eval-when (:load-toplevel :compile-toplevel :execute)
59  (unless (member :asdf3 *features*)
60    (let* ((existing-version
61             (when (find-package :asdf)
62               (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
63                   (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
64                     (etypecase ver
65                       (string ver)
66                       (cons (format nil "~{~D~^.~}" ver))
67                       (null "1.0"))))))
68           (first-dot (when existing-version (position #\. existing-version)))
69           (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot))))
70           (existing-major-minor (subseq existing-version 0 second-dot))
71           (existing-version-number (and existing-version (read-from-string existing-major-minor)))
72           (away (format nil "~A-~A" :asdf existing-version)))
73      (when (and existing-version (< existing-version-number
74                                     (or #+abcl 2.25 #+cmu 2.018 #-(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 unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
1518
1519  (defun os-genera-p ()
1520    (or #+genera t))
1521
1522  (defun detect-os ()
1523    (flet ((yes (yes) (pushnew yes *features*))
1524           (no (no) (setf *features* (remove no *features*))))
1525      (cond
1526        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
1527        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
1528        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
1529        (t (error "Congratulations for trying XCVB on an operating system~%~
1530that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
1531
1532  (detect-os))
1533
1534;;;; Environment variables: getting them, and parsing them.
1535
1536(with-upgradability ()
1537  (defun getenv (x)
1538    (declare (ignorable x))
1539    #+(or abcl clisp ecl xcl) (ext:getenv x)
1540    #+allegro (sys:getenv x)
1541    #+clozure (ccl:getenv x)
1542    #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
1543    #+cormanlisp
1544    (let* ((buffer (ct:malloc 1))
1545           (cname (ct:lisp-string-to-c-string x))
1546           (needed-size (win:getenvironmentvariable cname buffer 0))
1547           (buffer1 (ct:malloc (1+ needed-size))))
1548      (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
1549                 nil
1550                 (ct:c-string-to-lisp-string buffer1))
1551        (ct:free buffer)
1552        (ct:free buffer1)))
1553    #+gcl (system:getenv x)
1554    #+genera nil
1555    #+lispworks (lispworks:environment-variable x)
1556    #+mcl (ccl:with-cstrs ((name x))
1557            (let ((value (_getenv name)))
1558              (unless (ccl:%null-ptr-p value)
1559                (ccl:%get-cstring value))))
1560    #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
1561    #+sbcl (sb-ext:posix-getenv x)
1562    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
1563    (error "~S is not supported on your implementation" 'getenv))
1564
1565  (defun getenvp (x)
1566    "Predicate that is true if the named variable is present in the libc environment,
1567then returning the non-empty string value of the variable"
1568    (let ((g (getenv x))) (and (not (emptyp g)) g))))
1569
1570
1571;;;; implementation-identifier
1572;;
1573;; produce a string to identify current implementation.
1574;; Initially stolen from SLIME's SWANK, completely rewritten since.
1575;; We're back to runtime checking, for the sake of e.g. ABCL.
1576
1577(with-upgradability ()
1578  (defun first-feature (feature-sets)
1579    (dolist (x feature-sets)
1580      (multiple-value-bind (short long feature-expr)
1581          (if (consp x)
1582              (values (first x) (second x) (cons :or (rest x)))
1583              (values x x x))
1584        (when (featurep feature-expr)
1585          (return (values short long))))))
1586
1587  (defun implementation-type ()
1588    (first-feature
1589     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
1590       (:cmu :cmucl :cmu) :ecl :gcl
1591       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
1592       :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
1593
1594  (defvar *implementation-type* (implementation-type))
1595
1596  (defun operating-system ()
1597    (first-feature
1598     '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
1599       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
1600       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
1601       (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
1602       :genera)))
1603
1604  (defun architecture ()
1605    (first-feature
1606     '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
1607       (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
1608       (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
1609       :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
1610       :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
1611       ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1612       ;; we may have to segregate the code still by architecture.
1613       (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
1614
1615  #+clozure
1616  (defun ccl-fasl-version ()
1617    ;; the fasl version is target-dependent from CCL 1.8 on.
1618    (or (let ((s 'ccl::target-fasl-version))
1619          (and (fboundp s) (funcall s)))
1620        (and (boundp 'ccl::fasl-version)
1621             (symbol-value 'ccl::fasl-version))
1622        (error "Can't determine fasl version.")))
1623
1624  (defun lisp-version-string ()
1625    (let ((s (lisp-implementation-version)))
1626      (car ; as opposed to OR, this idiom prevents some unreachable code warning
1627       (list
1628        #+allegro
1629        (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
1630                excl::*common-lisp-version-number*
1631                ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1632                (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
1633                ;; Note if not using International ACL
1634                ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
1635                (excl:ics-target-case (:-ics "8"))
1636                (and (member :smp *features*) "S"))
1637        #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
1638        #+clisp
1639        (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
1640        #+clozure
1641        (format nil "~d.~d-f~d" ; shorten for windows
1642                ccl::*openmcl-major-version*
1643                ccl::*openmcl-minor-version*
1644                (logand (ccl-fasl-version) #xFF))
1645        #+cmu (substitute #\- #\/ s)
1646        #+scl (format nil "~A~A" s
1647                      ;; ANSI upper case vs lower case.
1648                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
1649        #+ecl (format nil "~A~@[-~A~]" s
1650                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
1651                        (subseq vcs-id 0 (min (length vcs-id) 8))))
1652        #+gcl (subseq s (1+ (position #\space s)))
1653        #+genera
1654        (multiple-value-bind (major minor) (sct:get-system-version "System")
1655          (format nil "~D.~D" major minor))
1656        #+mcl (subseq s 8) ; strip the leading "Version "
1657        s))))
1658
1659  (defun implementation-identifier ()
1660    (substitute-if
1661     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
1662     (format nil "~(~a~@{~@[-~a~]~}~)"
1663             (or (implementation-type) (lisp-implementation-type))
1664             (or (lisp-version-string) (lisp-implementation-version))
1665             (or (operating-system) (software-type))
1666             (or (architecture) (machine-type))))))
1667
1668
1669;;;; Other system information
1670
1671(with-upgradability ()
1672  (defun hostname ()
1673    ;; Note: untested on RMCL
1674    #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
1675    #+cormanlisp "localhost" ;; is there a better way? Does it matter?
1676    #+allegro (symbol-call :excl.osi :gethostname)
1677    #+clisp (first (split-string (machine-instance) :separator " "))
1678    #+gcl (system:gethostname)))
1679
1680
1681;;; Current directory
1682(with-upgradability ()
1683
1684  #+cmu
1685  (defun parse-unix-namestring* (unix-namestring)
1686    (multiple-value-bind (host device directory name type version)
1687        (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
1688      (make-pathname :host (or host lisp::*unix-host*) :device device
1689                     :directory directory :name name :type type :version version)))
1690
1691  (defun getcwd ()
1692    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
1693    (or #+abcl (parse-namestring
1694                (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
1695        #+allegro (excl::current-directory)
1696        #+clisp (ext:default-directory)
1697        #+clozure (ccl:current-directory)
1698        #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
1699                        (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
1700        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
1701        #+ecl (ext:getcwd)
1702        #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
1703               (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
1704        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
1705        #+lispworks (system:current-directory)
1706        #+mkcl (mk-ext:getcwd)
1707        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
1708        #+xcl (extensions:current-directory)
1709        (error "getcwd not supported on your implementation")))
1710
1711  (defun chdir (x)
1712    "Change current directory, as per POSIX chdir(2), to a given pathname object"
1713    (if-let (x (pathname x))
1714      (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
1715          #+allegro (excl:chdir x)
1716          #+clisp (ext:cd x)
1717          #+clozure (setf (ccl:current-directory) x)
1718          #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
1719          #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
1720                         (error "Could not set current directory to ~A" x))
1721          #+ecl (ext:chdir x)
1722          #+genera (setf *default-pathname-defaults* x)
1723          #+lispworks (hcl:change-directory x)
1724          #+mkcl (mk-ext:chdir x)
1725          #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
1726          (error "chdir not supported on your implementation")))))
1727
1728
1729;;;; -----------------------------------------------------------------
1730;;;; Windows shortcut support.  Based on:
1731;;;;
1732;;;; Jesse Hager: The Windows Shortcut File Format.
1733;;;; http://www.wotsit.org/list.asp?fc=13
1734
1735#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1736(with-upgradability ()
1737  (defparameter *link-initial-dword* 76)
1738  (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1739
1740  (defun read-null-terminated-string (s)
1741    (with-output-to-string (out)
1742      (loop :for code = (read-byte s)
1743            :until (zerop code)
1744            :do (write-char (code-char code) out))))
1745
1746  (defun read-little-endian (s &optional (bytes 4))
1747    (loop :for i :from 0 :below bytes
1748          :sum (ash (read-byte s) (* 8 i))))
1749
1750  (defun parse-file-location-info (s)
1751    (let ((start (file-position s))
1752          (total-length (read-little-endian s))
1753          (end-of-header (read-little-endian s))
1754          (fli-flags (read-little-endian s))
1755          (local-volume-offset (read-little-endian s))
1756          (local-offset (read-little-endian s))
1757          (network-volume-offset (read-little-endian s))
1758          (remaining-offset (read-little-endian s)))
1759      (declare (ignore total-length end-of-header local-volume-offset))
1760      (unless (zerop fli-flags)
1761        (cond
1762          ((logbitp 0 fli-flags)
1763           (file-position s (+ start local-offset)))
1764          ((logbitp 1 fli-flags)
1765           (file-position s (+ start
1766                               network-volume-offset
1767                               #x14))))
1768        (strcat (read-null-terminated-string s)
1769                (progn
1770                  (file-position s (+ start remaining-offset))
1771                  (read-null-terminated-string s))))))
1772
1773  (defun parse-windows-shortcut (pathname)
1774    (with-open-file (s pathname :element-type '(unsigned-byte 8))
1775      (handler-case
1776          (when (and (= (read-little-endian s) *link-initial-dword*)
1777                     (let ((header (make-array (length *link-guid*))))
1778                       (read-sequence header s)
1779                       (equalp header *link-guid*)))
1780            (let ((flags (read-little-endian s)))
1781              (file-position s 76)        ;skip rest of header
1782              (when (logbitp 0 flags)
1783                ;; skip shell item id list
1784                (let ((length (read-little-endian s 2)))
1785                  (file-position s (+ length (file-position s)))))
1786              (cond
1787                ((logbitp 1 flags)
1788                 (parse-file-location-info s))
1789                (t
1790                 (when (logbitp 2 flags)
1791                   ;; skip description string
1792                   (let ((length (read-little-endian s 2)))
1793                     (file-position s (+ length (file-position s)))))
1794                 (when (logbitp 3 flags)
1795                   ;; finally, our pathname
1796                   (let* ((length (read-little-endian s 2))
1797                          (buffer (make-array length)))
1798                     (read-sequence buffer s)
1799                     (map 'string #'code-char buffer)))))))
1800        (end-of-file (c)
1801          (declare (ignore c))
1802          nil)))))
1803
1804
1805;;;; -------------------------------------------------------------------------
1806;;;; Portability layer around Common Lisp pathnames
1807;; This layer allows for portable manipulation of pathname objects themselves,
1808;; which all is necessary prior to any access the filesystem or environment.
1809
1810(uiop/package:define-package :uiop/pathname
1811  (:nicknames :asdf/pathname)
1812  (:recycle :uiop/pathname :asdf/pathname :asdf)
1813  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
1814  (:export
1815   ;; Making and merging pathnames, portably
1816   #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
1817   #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
1818   #:make-pathname-component-logical #:make-pathname-logical
1819   #:merge-pathnames*
1820   #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
1821   ;; Predicates
1822   #:pathname-equal #:logical-pathname-p #:physical-pathname-p
1823   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
1824   ;; Directories
1825   #:pathname-directory-pathname #:pathname-parent-directory-pathname
1826   #:directory-pathname-p #:ensure-directory-pathname
1827   ;; Parsing filenames
1828   #:component-name-to-pathname-components
1829   #:split-name-type #:parse-unix-namestring #:unix-namestring
1830   #:split-unix-namestring-directory-components
1831   ;; Absolute and relative pathnames
1832   #:subpathname #:subpathname*
1833   #:ensure-absolute-pathname
1834   #:pathname-root #:pathname-host-pathname
1835   #:subpathp
1836   ;; Checking constraints
1837   #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
1838   ;; Wildcard pathnames
1839   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
1840   ;; Translate a pathname
1841   #:relativize-directory-component #:relativize-pathname-directory
1842   #:directory-separator-for-host #:directorize-pathname-host-device
1843   #:translate-pathname*
1844   #:*output-translation-function*))
1845(in-package :uiop/pathname)
1846
1847;;; Normalizing pathnames across implementations
1848
1849(with-upgradability ()
1850  (defun normalize-pathname-directory-component (directory)
1851    "Given a pathname directory component, return an equivalent form that is a list"
1852    #+gcl2.6 (setf directory (substitute :back :parent directory))
1853    (cond
1854      #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
1855      ((stringp directory) `(:absolute ,directory))
1856      #+gcl2.6
1857      ((and (consp directory) (eq :root (first directory)))
1858       `(:absolute ,@(rest directory)))
1859      ((or (null directory)
1860           (and (consp directory) (member (first directory) '(:absolute :relative))))
1861       directory)
1862      #+gcl2.6
1863      ((consp directory)
1864       `(:relative ,@directory))
1865      (t
1866       (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
1867
1868  (defun denormalize-pathname-directory-component (directory-component)
1869    #-gcl2.6 directory-component
1870    #+gcl2.6
1871    (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
1872                            directory-component)))
1873      (cond
1874        ((and (consp d) (eq :relative (first d))) (rest d))
1875        ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
1876        (t d))))
1877
1878  (defun merge-pathname-directory-components (specified defaults)
1879    ;; Helper for merge-pathnames* that handles directory components.
1880    (let ((directory (normalize-pathname-directory-component specified)))
1881      (ecase (first directory)
1882        ((nil) defaults)
1883        (:absolute specified)
1884        (:relative
1885         (let ((defdir (normalize-pathname-directory-component defaults))
1886               (reldir (cdr directory)))
1887           (cond
1888             ((null defdir)
1889              directory)
1890             ((not (eq :back (first reldir)))
1891              (append defdir reldir))
1892             (t
1893              (loop :with defabs = (first defdir)
1894                    :with defrev = (reverse (rest defdir))
1895                    :while (and (eq :back (car reldir))
1896                                (or (and (eq :absolute defabs) (null defrev))
1897                                    (stringp (car defrev))))
1898                    :do (pop reldir) (pop defrev)
1899                    :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
1900
1901  ;; Giving :unspecific as :type argument to make-pathname is not portable.
1902  ;; See CLHS make-pathname and 19.2.2.2.3.
1903  ;; This will be :unspecific if supported, or NIL if not.
1904  (defparameter *unspecific-pathname-type*
1905    #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
1906    #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
1907
1908  (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
1909                                      host (device () #+allegro devicep) name type version defaults
1910                                      #+scl &allow-other-keys)
1911    "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
1912   tries hard to make a pathname that will actually behave as documented,
1913   despite the peculiarities of each implementation"
1914    (declare (ignorable host device directory name type version defaults))
1915    (apply 'make-pathname
1916           (append
1917            #+allegro (when (and devicep (null device)) `(:device :unspecific))
1918            #+gcl2.6
1919            (when directoryp
1920              `(:directory ,(denormalize-pathname-directory-component directory)))
1921            keys)))
1922
1923  (defun make-pathname-component-logical (x)
1924    "Make a pathname component suitable for use in a logical-pathname"
1925    (typecase x
1926      ((eql :unspecific) nil)
1927      #+clisp (string (string-upcase x))
1928      #+clisp (cons (mapcar 'make-pathname-component-logical x))
1929      (t x)))
1930
1931  (defun make-pathname-logical (pathname host)
1932    "Take a PATHNAME's directory, name, type and version components,
1933and make a new pathname with corresponding components and specified logical HOST"
1934    (make-pathname*
1935     :host host
1936     :directory (make-pathname-component-logical (pathname-directory pathname))
1937     :name (make-pathname-component-logical (pathname-name pathname))
1938     :type (make-pathname-component-logical (pathname-type pathname))
1939     :version (make-pathname-component-logical (pathname-version pathname))))
1940
1941  (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
1942    "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
1943if the SPECIFIED pathname does not have an absolute directory,
1944then the HOST and DEVICE both come from the DEFAULTS, whereas
1945if the SPECIFIED pathname does have an absolute directory,
1946then the HOST and DEVICE both come from the SPECIFIED.
1947This is what users want on a modern Unix or Windows operating system,
1948unlike the MERGE-PATHNAME behavior.
1949Also, if either argument is NIL, then the other argument is returned unmodified;
1950this is unlike MERGE-PATHNAME which always merges with a pathname,
1951by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
1952    (when (null specified) (return-from merge-pathnames* defaults))
1953    (when (null defaults) (return-from merge-pathnames* specified))
1954    #+scl
1955    (ext:resolve-pathname specified defaults)
1956    #-scl
1957    (let* ((specified (pathname specified))
1958           (defaults (pathname defaults))
1959           (directory (normalize-pathname-directory-component (pathname-directory specified)))
1960           (name (or (pathname-name specified) (pathname-name defaults)))
1961           (type (or (pathname-type specified) (pathname-type defaults)))
1962           (version (or (pathname-version specified) (pathname-version defaults))))
1963      (labels ((unspecific-handler (p)
1964                 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
1965        (multiple-value-bind (host device directory unspecific-handler)
1966            (ecase (first directory)
1967              ((:absolute)
1968               (values (pathname-host specified)
1969                       (pathname-device specified)
1970                       directory
1971                       (unspecific-handler specified)))
1972              ((nil :relative)
1973               (values (pathname-host defaults)
1974                       (pathname-device defaults)
1975                       (merge-pathname-directory-components directory (pathname-directory defaults))
1976                       (unspecific-handler defaults))))
1977          (make-pathname* :host host :device device :directory directory
1978                          :name (funcall unspecific-handler name)
1979                          :type (funcall unspecific-handler type)
1980                          :version (funcall unspecific-handler version))))))
1981
1982  (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
1983    "A pathname that is as neutral as possible for use as defaults
1984   when merging, making or parsing pathnames"
1985    ;; 19.2.2.2.1 says a NIL host can mean a default host;
1986    ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
1987    ;; strings and lists of strings or :unspecific
1988    ;; But CMUCL decides to die on NIL.
1989    #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
1990                       :host (or #+cmu lisp::*unix-host*)
1991                       #+scl ,@'(:scheme nil :scheme-specific-part nil
1992                                 :username nil :password nil :parameters nil :query nil :fragment nil)
1993                       ;; the default shouldn't matter, but we really want something physical
1994                       :defaults defaults))
1995
1996  (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
1997
1998  (defmacro with-pathname-defaults ((&optional defaults) &body body)
1999    `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
2000
2001
2002;;; Some pathname predicates
2003(with-upgradability ()
2004  (defun pathname-equal (p1 p2)
2005    (when (stringp p1) (setf p1 (pathname p1)))
2006    (when (stringp p2) (setf p2 (pathname p2)))
2007    (flet ((normalize-component (x)
2008             (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
2009               x)))
2010      (macrolet ((=? (&rest accessors)
2011                   (flet ((frob (x)
2012                            (reduce 'list (cons 'normalize-component accessors)
2013                                    :initial-value x :from-end t)))
2014                     `(equal ,(frob 'p1) ,(frob 'p2)))))
2015        (or (and (null p1) (null p2))
2016            (and (pathnamep p1) (pathnamep p2)
2017                 (and (=? pathname-host)
2018                      (=? pathname-device)
2019                      (=? normalize-pathname-directory-component pathname-directory)
2020                      (=? pathname-name)
2021                      (=? pathname-type)
2022                      (=? pathname-version)))))))
2023
2024  (defun logical-pathname-p (x)
2025    (typep x 'logical-pathname))
2026
2027  (defun physical-pathname-p (x)
2028    (and (pathnamep x) (not (logical-pathname-p x))))
2029
2030  (defun absolute-pathname-p (pathspec)
2031    "If PATHSPEC is a pathname or namestring object that parses as a pathname
2032possessing an :ABSOLUTE directory component, return the (parsed) pathname.
2033Otherwise return NIL"
2034    (and pathspec
2035         (typep pathspec '(or null pathname string))
2036         (let ((pathname (pathname pathspec)))
2037           (and (eq :absolute (car (normalize-pathname-directory-component
2038                                    (pathname-directory pathname))))
2039                pathname))))
2040
2041  (defun relative-pathname-p (pathspec)
2042    "If PATHSPEC is a pathname or namestring object that parses as a pathname
2043possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2044Otherwise return NIL"
2045    (and pathspec
2046         (typep pathspec '(or null pathname string))
2047         (let* ((pathname (pathname pathspec))
2048                (directory (normalize-pathname-directory-component
2049                            (pathname-directory pathname))))
2050           (when (or (null directory) (eq :relative (car directory)))
2051             pathname))))
2052
2053  (defun hidden-pathname-p (pathname)
2054    "Return a boolean that is true if the pathname is hidden as per Unix style,
2055i.e. its name starts with a dot."
2056    (and pathname (equal (first-char (pathname-name pathname)) #\.)))
2057
2058  (defun file-pathname-p (pathname)
2059    "Does PATHNAME represent a file, i.e. has a non-null NAME component?
2060
2061Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2062
2063Note that this does _not_ check to see that PATHNAME points to an
2064actually-existing file.
2065
2066Returns the (parsed) PATHNAME when true"
2067    (when pathname
2068      (let* ((pathname (pathname pathname))
2069             (name (pathname-name pathname)))
2070        (when (not (member name '(nil :unspecific "") :test 'equal))
2071          pathname)))))
2072
2073
2074;;; Directory pathnames
2075(with-upgradability ()
2076  (defun pathname-directory-pathname (pathname)
2077    "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2078and NIL NAME, TYPE and VERSION components"
2079    (when pathname
2080      (make-pathname :name nil :type nil :version nil :defaults pathname)))
2081
2082  (defun pathname-parent-directory-pathname (pathname)
2083    "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2084i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2085Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2086    (when pathname
2087      (make-pathname* :name nil :type nil :version nil
2088                      :directory (merge-pathname-directory-components
2089                                  '(:relative :back) (pathname-directory pathname))
2090                      :defaults pathname)))
2091
2092  (defun directory-pathname-p (pathname)
2093    "Does PATHNAME represent a directory?
2094
2095A directory-pathname is a pathname _without_ a filename. The three
2096ways that the filename components can be missing are for it to be NIL,
2097:UNSPECIFIC or the empty string.
2098
2099Note that this does _not_ check to see that PATHNAME points to an
2100actually-existing directory."
2101    (when pathname
2102      (let ((pathname (pathname pathname)))
2103        (flet ((check-one (x)
2104                 (member x '(nil :unspecific "") :test 'equal)))
2105          (and (not (wild-pathname-p pathname))
2106               (check-one (pathname-name pathname))
2107               (check-one (pathname-type pathname))
2108               t)))))
2109
2110  (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
2111    "Converts the non-wild pathname designator PATHSPEC to directory form."
2112    (cond
2113      ((stringp pathspec)
2114       (ensure-directory-pathname (pathname pathspec)))
2115      ((not (pathnamep pathspec))
2116       (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
2117      ((wild-pathname-p pathspec)
2118       (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
2119      ((directory-pathname-p pathspec)
2120       pathspec)
2121      (t
2122       (make-pathname* :directory (append (or (normalize-pathname-directory-component
2123                                               (pathname-directory pathspec))
2124                                              (list :relative))
2125                                          (list (file-namestring pathspec)))
2126                       :name nil :type nil :version nil :defaults pathspec)))))
2127
2128
2129;;; Parsing filenames
2130(with-upgradability ()
2131  (defun split-unix-namestring-directory-components
2132      (unix-namestring &key ensure-directory dot-dot)
2133    "Splits the path string UNIX-NAMESTRING, returning four values:
2134A flag that is either :absolute or :relative, indicating
2135   how the rest of the values are to be interpreted.
2136A directory path --- a list of strings and keywords, suitable for
2137   use with MAKE-PATHNAME when prepended with the flag value.
2138   Directory components with an empty name or the name . are removed.
2139   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2140A last-component, either a file-namestring including type extension,
2141   or NIL in the case of a directory pathname.
2142A flag that is true iff the unix-style-pathname was just
2143   a file-namestring without / path specification.
2144ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2145the third return value will be NIL, and final component of the namestring
2146will be treated as part of the directory path.
2147
2148An empty string is thus read as meaning a pathname object with all fields nil.
2149
2150Note that : characters will NOT be interpreted as host specification.
2151Absolute pathnames are only appropriate on Unix-style systems.
2152
2153The intention of this function is to support structured component names,
2154e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2155    (check-type unix-namestring string)
2156    (check-type dot-dot (member nil :back :up))
2157    (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
2158             (plusp (length unix-namestring)))
2159        (values :relative () unix-namestring t)
2160        (let* ((components (split-string unix-namestring :separator "/"))
2161               (last-comp (car (last components))))
2162          (multiple-value-bind (relative components)
2163              (if (equal (first components) "")
2164                  (if (equal (first-char unix-namestring) #\/)
2165                      (values :absolute (cdr components))
2166                      (values :relative nil))
2167                  (values :relative components))
2168            (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
2169                                        components))
2170            (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
2171            (cond
2172              ((equal last-comp "")
2173               (values relative components nil nil)) ; "" already removed from components
2174              (ensure-directory
2175               (values relative components nil nil))
2176              (t
2177               (values relative (butlast components) last-comp nil)))))))
2178
2179  (defun split-name-type (filename)
2180    "Split a filename into two values NAME and TYPE that are returned.
2181We assume filename has no directory component.
2182The last . if any separates name and type from from type,
2183except that if there is only one . and it is in first position,
2184the whole filename is the NAME with an empty type.
2185NAME is always a string.
2186For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2187    (check-type filename string)
2188    (assert (plusp (length filename)))
2189    (destructuring-bind (name &optional (type *unspecific-pathname-type*))
2190        (split-string filename :max 2 :separator ".")
2191      (if (equal name "")
2192          (values filename *unspecific-pathname-type*)
2193          (values name type))))
2194
2195  (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
2196                                &allow-other-keys)
2197    "Coerce NAME into a PATHNAME using standard Unix syntax.
2198
2199Unix syntax is used whether or not the underlying system is Unix;
2200on such non-Unix systems it is only usable but for relative pathnames;
2201but especially to manipulate relative pathnames portably, it is of crucial
2202to possess a portable pathname syntax independent of the underlying OS.
2203This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2204
2205When given a PATHNAME object, just return it untouched.
2206When given NIL, just return NIL.
2207When given a non-null SYMBOL, first downcase its name and treat it as a string.
2208When given a STRING, portably decompose it into a pathname as below.
2209
2210#\\/ separates directory components.
2211
2212The last #\\/-separated substring is interpreted as follows:
22131- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2214 the string is made the last directory component, and NAME and TYPE are NIL.
2215 if the string is empty, it's the empty pathname with all slots NIL.
22162- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
2217 are separated by SPLIT-NAME-TYPE.
22183- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2219
2220Directory components with an empty name the name . are removed.
2221Any directory named .. is read as DOT-DOT,
2222which must be one of :BACK or :UP and defaults to :BACK.
2223
2224HOST, DEVICE and VERSION components are taken from DEFAULTS,
2225which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
2226No host or device can be specified in the string itself,
2227which makes it unsuitable for absolute pathnames outside Unix.
2228
2229For relative pathnames, these components (and hence the defaults) won't matter
2230if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2231which is an important reason to always use MERGE-PATHNAMES*.
2232
2233Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2234with those keys, removing TYPE DEFAULTS and DOT-DOT.
2235When you're manipulating pathnames that are supposed to make sense portably
2236even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2237to throw an error if the pathname is absolute"
2238    (block nil
2239      (check-type type (or null string (eql :directory)))
2240      (when ensure-directory
2241        (setf type :directory))
2242      (etypecase name
2243        ((or null pathname) (return name))
2244        (symbol
2245         (setf name (string-downcase name)))
2246        (string))
2247      (multiple-value-bind (relative path filename file-only)
2248          (split-unix-namestring-directory-components
2249           name :dot-dot dot-dot :ensure-directory (eq type :directory))
2250        (multiple-value-bind (name type)
2251            (cond
2252              ((or (eq type :directory) (null filename))
2253               (values nil nil))
2254              (type
2255               (values filename type))
2256              (t
2257               (split-name-type filename)))
2258          (apply 'ensure-pathname
2259                 (make-pathname*
2260                  :directory (unless file-only (cons relative path))
2261                  :name name :type type
2262                  :defaults (or defaults *nil-pathname*))
2263                 (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
2264
2265  (defun unix-namestring (pathname)
2266    "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2267If the PATHNAME is NIL or a STRING, return it unchanged.
2268
2269This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2270This is a portable solution for representing relative pathnames,
2271But unless you are running on a Unix system, it is not a general solution
2272to representing native pathnames.
2273
2274An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2275or if it is a PATHNAME but some of its components are not recognized."
2276    (etypecase pathname
2277      ((or null string) pathname)
2278      (pathname
2279       (with-output-to-string (s)
2280         (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
2281           (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
2282                  (name (pathname-name pathname))
2283                  (type (pathname-type pathname))
2284                  (type (and (not (eq type :unspecific)) type)))
2285             (cond
2286               ((eq dir ()))
2287               ((eq dir '(:relative)) (princ "./" s))
2288               ((consp dir)
2289                (destructuring-bind (relabs &rest dirs) dir
2290                  (or (member relabs '(:relative :absolute)) (err))
2291                  (when (eq relabs :absolute) (princ #\/ s))
2292                  (loop :for x :in dirs :do
2293                    (cond
2294                      ((member x '(:back :up)) (princ "../" s))
2295                      ((equal x "") (err))
2296                      ;;((member x '("." "..") :test 'equal) (err))
2297                      ((stringp x) (format s "~A/" x))
2298                      (t (err))))))
2299               (t (err)))
2300             (cond
2301               (name
2302                (or (and (stringp name) (or (null type) (stringp type))) (err))
2303                (format s "~A~@[.~A~]" name type))
2304               (t
2305                (or (null type) (err)))))))))))
2306
2307;;; Absolute and relative pathnames
2308(with-upgradability ()
2309  (defun subpathname (pathname subpath &key type)
2310    "This function takes a PATHNAME and a SUBPATH and a TYPE.
2311If SUBPATH is already a PATHNAME object (not namestring),
2312and is an absolute pathname at that, it is returned unchanged;
2313otherwise, SUBPATH is turned into a relative pathname with given TYPE
2314as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2315then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2316    (or (and (pathnamep subpath) (absolute-pathname-p subpath))
2317        (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
2318                          (pathname-directory-pathname pathname))))
2319
2320  (defun subpathname* (pathname subpath &key type)
2321    "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2322    (and pathname
2323         (subpathname (ensure-directory-pathname pathname) subpath :type type)))
2324
2325  (defun pathname-root (pathname)
2326    (make-pathname* :directory '(:absolute)
2327                    :name nil :type nil :version nil
2328                    :defaults pathname ;; host device, and on scl, *some*
2329                    ;; scheme-specific parts: port username password, not others:
2330                    . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2331
2332  (defun pathname-host-pathname (pathname)
2333    (make-pathname* :directory nil
2334                    :name nil :type nil :version nil :device nil
2335                    :defaults pathname ;; host device, and on scl, *some*
2336                    ;; scheme-specific parts: port username password, not others:
2337                    . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2338
2339  (defun subpathp (maybe-subpath base-pathname)
2340    (and (pathnamep maybe-subpath) (pathnamep base-pathname)
2341         (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
2342         (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
2343         (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
2344         (with-pathname-defaults ()
2345           (let ((enough (enough-namestring maybe-subpath base-pathname)))
2346             (and (relative-pathname-p enough) (pathname enough))))))
2347
2348  (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
2349    (cond
2350      ((absolute-pathname-p path))
2351      ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
2352      ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
2353      ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
2354         (or (if (absolute-pathname-p default-pathname)
2355                 (absolute-pathname-p (merge-pathnames* path default-pathname))
2356                 (call-function on-error "Default pathname ~S is not an absolute pathname"
2357                                default-pathname))
2358             (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
2359                            path default-pathname))))
2360      (t (call-function on-error
2361                        "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2362                        path defaults)))))
2363
2364
2365;;; Wildcard pathnames
2366(with-upgradability ()
2367  (defparameter *wild* (or #+cormanlisp "*" :wild))
2368  (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
2369  (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
2370  (defparameter *wild-file*
2371    (make-pathname :directory nil :name *wild* :type *wild*
2372                   :version (or #-(or allegro abcl xcl) *wild*)))
2373  (defparameter *wild-directory*
2374    (make-pathname* :directory `(:relative ,*wild-directory-component*)
2375                    :name nil :type nil :version nil))
2376  (defparameter *wild-inferiors*
2377    (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
2378                    :name nil :type nil :version nil))
2379  (defparameter *wild-path*
2380    (merge-pathnames* *wild-file* *wild-inferiors*))
2381
2382  (defun wilden (path)
2383    (merge-pathnames* *wild-path* path)))
2384
2385
2386;;; Translate a pathname
2387(with-upgradability ()
2388  (defun relativize-directory-component (directory-component)
2389    (let ((directory (normalize-pathname-directory-component directory-component)))
2390      (cond
2391        ((stringp directory)
2392         (list :relative directory))
2393        ((eq (car directory) :absolute)
2394         (cons :relative (cdr directory)))
2395        (t
2396         directory))))
2397
2398  (defun relativize-pathname-directory (pathspec)
2399    (let ((p (pathname pathspec)))
2400      (make-pathname*
2401       :directory (relativize-directory-component (pathname-directory p))
2402       :defaults p)))
2403
2404  (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
2405    (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
2406      (last-char (namestring foo))))
2407
2408  #-scl
2409  (defun directorize-pathname-host-device (pathname)
2410    #+(or unix abcl)
2411    (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
2412      (return-from directorize-pathname-host-device pathname))
2413    (let* ((root (pathname-root pathname))
2414           (wild-root (wilden root))
2415           (absolute-pathname (merge-pathnames* pathname root))
2416           (separator (directory-separator-for-host root))
2417           (root-namestring (namestring root))
2418           (root-string
2419             (substitute-if #\/
2420                            #'(lambda (x) (or (eql x #\:)
2421                                              (eql x separator)))
2422                            root-namestring)))
2423      (multiple-value-bind (relative path filename)
2424          (split-unix-namestring-directory-components root-string :ensure-directory t)
2425        (declare (ignore relative filename))
2426        (let ((new-base
2427                (make-pathname* :defaults root :directory `(:absolute ,@path))))
2428          (translate-pathname absolute-pathname wild-root (wilden new-base))))))
2429
2430  #+scl
2431  (defun directorize-pathname-host-device (pathname)
2432    (let ((scheme (ext:pathname-scheme pathname))
2433          (host (pathname-host pathname))
2434          (port (ext:pathname-port pathname))
2435          (directory (pathname-directory pathname)))
2436      (flet ((specificp (x) (and x (not (eq x :unspecific)))))
2437        (if (or (specificp port)
2438                (and (specificp host) (plusp (length host)))
2439                (specificp scheme))
2440            (let ((prefix ""))
2441              (when (specificp port)
2442                (setf prefix (format nil ":~D" port)))
2443              (when (and (specificp host) (plusp (length host)))
2444                (setf prefix (strcat host prefix)))
2445              (setf prefix (strcat ":" prefix))
2446              (when (specificp scheme)
2447                (setf prefix (strcat scheme prefix)))
2448              (assert (and directory (eq (first directory) :absolute)))
2449              (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
2450                              :defaults pathname)))
2451        pathname)))
2452
2453  (defun* (translate-pathname*) (path absolute-source destination &optional root source)
2454    (declare (ignore source))
2455    (cond
2456      ((functionp destination)
2457       (funcall destination path absolute-source))
2458      ((eq destination t)
2459       path)
2460      ((not (pathnamep destination))
2461       (error "Invalid destination"))
2462      ((not (absolute-pathname-p destination))
2463       (translate-pathname path absolute-source (merge-pathnames* destination root)))
2464      (root
2465       (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
2466      (t
2467       (translate-pathname path absolute-source destination))))
2468
2469  (defvar *output-translation-function* 'identity
2470    "Hook for output translations.
2471
2472This function needs to be idempotent, so that actions can work
2473whether their inputs were translated or not,
2474which they will be if we are composing operations. e.g. if some
2475create-lisp-op creates a lisp file from some higher-level input,
2476you need to still be able to use compile-op on that lisp file."))
2477
2478;;;; -------------------------------------------------------------------------
2479;;;; Portability layer around Common Lisp filesystem access
2480
2481(uiop/package:define-package :uiop/filesystem
2482  (:nicknames :asdf/filesystem)
2483  (:recycle :uiop/filesystem :asdf/pathname :asdf)
2484  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
2485  (:export
2486   ;; Native namestrings
2487   #:native-namestring #:parse-native-namestring
2488   ;; Probing the filesystem
2489   #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
2490   #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
2491   #:collect-sub*directories
2492   ;; Resolving symlinks somewhat
2493   #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
2494   ;; merging with cwd
2495   #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
2496   ;; Environment pathnames
2497   #:inter-directory-separator #:split-native-pathnames-string
2498   #:getenv-pathname #:getenv-pathnames
2499   #:getenv-absolute-directory #:getenv-absolute-directories
2500   #:lisp-implementation-directory #:lisp-implementation-pathname-p
2501   ;; Simple filesystem operations
2502   #:ensure-all-directories-exist
2503   #:rename-file-overwriting-target
2504   #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
2505(in-package :uiop/filesystem)
2506
2507;;; Native namestrings, as seen by the operating system calls rather than Lisp
2508(with-upgradability ()
2509  (defun native-namestring (x)
2510    "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2511    (when x
2512      (let ((p (pathname x)))
2513        #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
2514        #+(or cmu scl) (ext:unix-namestring p nil)
2515        #+sbcl (sb-ext:native-namestring p)
2516        #-(or clozure cmu sbcl scl)
2517        (if (os-unix-p) (unix-namestring p)
2518            (namestring p)))))
2519
2520  (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
2521    "From a native namestring suitable for use by the operating system, return
2522a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2523    (check-type string (or string null))
2524    (let* ((pathname
2525             (when string
2526               (with-pathname-defaults ()
2527                 #+clozure (ccl:native-to-pathname string)
2528                 #+sbcl (sb-ext:parse-native-namestring string)
2529                 #-(or clozure sbcl)
2530                 (if (os-unix-p)
2531                     (parse-unix-namestring string :ensure-directory ensure-directory)
2532                     (parse-namestring string)))))
2533           (pathname
2534             (if ensure-directory
2535                 (and pathname (ensure-directory-pathname pathname))
2536                 pathname)))
2537      (apply 'ensure-pathname pathname constraints))))
2538
2539
2540;;; Probing the filesystem
2541(with-upgradability ()
2542  (defun truename* (p)
2543    ;; avoids both logical-pathname merging and physical resolution issues
2544    (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
2545
2546  (defun safe-file-write-date (pathname)
2547    ;; If FILE-WRITE-DATE returns NIL, it's possible that
2548    ;; the user or some other agent has deleted an input file.
2549    ;; Also, generated files will not exist at the time planning is done
2550    ;; and calls compute-action-stamp which calls safe-file-write-date.
2551    ;; So it is very possible that we can't get a valid file-write-date,
2552    ;; and we can survive and we will continue the planning
2553    ;; as if the file were very old.
2554    ;; (or should we treat the case in a different, special way?)
2555    (and pathname
2556         (handler-case (file-write-date (translate-logical-pathname pathname))
2557           (file-error () nil))))
2558
2559  (defun probe-file* (p &key truename)
2560    "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
2561probes the filesystem for a file or directory with given pathname.
2562If it exists, return its truename is ENSURE-PATHNAME is true,
2563or the original (parsed) pathname if it is false (the default)."
2564    (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
2565      (etypecase p
2566        (null nil)
2567        (string (probe-file* (parse-namestring p) :truename truename))
2568        (pathname
2569         (and (not (wild-pathname-p p))
2570              (handler-case
2571                  (or
2572                   #+allegro
2573                   (probe-file p :follow-symlinks truename)
2574                   #-(or allegro clisp gcl2.6)
2575                   (if truename
2576                       (probe-file p)
2577                       (ignore-errors
2578                        (let ((pp (translate-logical-pathname p)))
2579                          (and
2580                           #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
2581                           #+(and lispworks unix) (system:get-file-stat pp)
2582                           #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
2583                           #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
2584                           p))))
2585                   #+(or clisp gcl2.6)
2586                   #.(flet ((probe (probe)
2587                              `(let ((foundtrue ,probe))
2588                                 (cond
2589                                   (truename foundtrue)
2590                                   (foundtrue p)))))
2591                       #+gcl2.6
2592                       (probe '(or (probe-file p)
2593                                (and (directory-pathname-p p)
2594                                 (ignore-errors
2595                                  (ensure-directory-pathname
2596                                   (truename* (subpathname
2597                                               (ensure-directory-pathname p) ".")))))))
2598                       #+clisp
2599                       (let* ((fs (find-symbol* '#:file-stat :posix nil))
2600                              (pp (find-symbol* '#:probe-pathname :ext nil))
2601                              (resolve (if pp
2602                                           `(ignore-errors (,pp p))
2603                                           '(or (truename* p)
2604                                             (truename* (ignore-errors (ensure-directory-pathname p)))))))
2605                         (if fs
2606                             `(if truename
2607                                  ,resolve
2608                                  (and (ignore-errors (,fs p)) p))
2609                             (probe resolve)))))
2610                (file-error () nil)))))))
2611
2612  (defun directory-exists-p (x)
2613    (let ((p (probe-file* x :truename t)))
2614      (and (directory-pathname-p p) p)))
2615
2616  (defun file-exists-p (x)
2617    (let ((p (probe-file* x :truename t)))
2618      (and (file-pathname-p p) p)))
2619
2620  (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
2621    (apply 'directory pathname-spec
2622           (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
2623                               #+(or clozure digitool) '(:follow-links nil)
2624                               #+clisp '(:circle t :if-does-not-exist :ignore)
2625                               #+(or cmu scl) '(:follow-links nil :truenamep nil)
2626                               #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
2627                                        '(:resolve-symlinks nil))))))
2628
2629  (defun filter-logical-directory-results (directory entries merger)
2630    (if (logical-pathname-p directory)
2631        ;; Try hard to not resolve logical-pathname into physical pathnames;
2632        ;; otherwise logical-pathname users/lovers will be disappointed.
2633        ;; If directory* could use some implementation-dependent magic,
2634        ;; we will have logical pathnames already; otherwise,
2635        ;; we only keep pathnames for which specifying the name and
2636        ;; translating the LPN commute.
2637        (loop :for f :in entries
2638              :for p = (or (and (logical-pathname-p f) f)
2639                           (let* ((u (ignore-errors (funcall merger f))))
2640                             ;; The first u avoids a cumbersome (truename u) error.
2641                             ;; At this point f should already be a truename,
2642                             ;; but isn't quite in CLISP, for it doesn't have :version :newest
2643                             (and u (equal (truename* u) (truename* f)) u)))
2644              :when p :collect p)
2645        entries))
2646
2647  (defun directory-files (directory &optional (pattern *wild-file*))
2648    (let ((dir (pathname directory)))
2649      (when (logical-pathname-p dir)
2650        ;; Because of the filtering we do below,
2651        ;; logical pathnames have restrictions on wild patterns.
2652        ;; Not that the results are very portable when you use these patterns on physical pathnames.
2653        (when (wild-pathname-p dir)
2654          (error "Invalid wild pattern in logical directory ~S" directory))
2655        (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
2656          (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
2657        (setf pattern (make-pathname-logical pattern (pathname-host dir))))
2658      (let* ((pat (merge-pathnames* pattern dir))
2659             (entries (append (ignore-errors (directory* pat))
2660                              #+clisp
2661                              (when (equal :wild (pathname-type pattern))
2662                                (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
2663        (filter-logical-directory-results
2664         directory entries
2665         #'(lambda (f)
2666             (make-pathname :defaults dir
2667                            :name (make-pathname-component-logical (pathname-name f))
2668                            :type (make-pathname-component-logical (pathname-type f))
2669                            :version (make-pathname-component-logical (pathname-version f))))))))
2670
2671  (defun subdirectories (directory)
2672    (let* ((directory (ensure-directory-pathname directory))
2673           #-(or abcl cormanlisp genera xcl)
2674           (wild (merge-pathnames*
2675                  #-(or abcl allegro cmu lispworks sbcl scl xcl)
2676                  *wild-directory*
2677                  #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
2678                  directory))
2679           (dirs
2680             #-(or abcl cormanlisp genera xcl)
2681             (ignore-errors
2682              (directory* wild . #.(or #+clozure '(:directories t :files nil)
2683                                       #+mcl '(:directories t))))
2684             #+(or abcl xcl) (system:list-directory directory)
2685             #+cormanlisp (cl::directory-subdirs directory)
2686             #+genera (fs:directory-list directory))
2687           #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
2688           (dirs (loop :for x :in dirs
2689                       :for d = #+(or abcl xcl) (extensions:probe-directory x)
2690                       #+allegro (excl:probe-directory x)
2691                       #+(or cmu sbcl scl) (directory-pathname-p x)
2692                       #+genera (getf (cdr x) :directory)
2693                       #+lispworks (lw:file-directory-p x)
2694                       :when d :collect #+(or abcl allegro xcl) d
2695                         #+genera (ensure-directory-pathname (first x))
2696                       #+(or cmu lispworks sbcl scl) x)))
2697      (filter-logical-directory-results
2698       directory dirs
2699       (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
2700                         '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
2701         #'(lambda (d)
2702             (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
2703               (and (consp dir) (consp (cdr dir))
2704                    (make-pathname
2705                     :defaults directory :name nil :type nil :version nil
2706                     :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
2707
2708  (defun collect-sub*directories (directory collectp recursep collector)
2709    (when (call-function collectp directory)
2710      (call-function collector directory))
2711    (dolist (subdir (subdirectories directory))
2712      (when (call-function recursep subdir)
2713        (collect-sub*directories subdir collectp recursep collector)))))
2714
2715;;; Resolving symlinks somewhat
2716(with-upgradability ()
2717  (defun truenamize (pathname)
2718    "Resolve as much of a pathname as possible"
2719    (block nil
2720      (when (typep pathname '(or null logical-pathname)) (return pathname))
2721      (let ((p pathname))
2722        (unless (absolute-pathname-p p)
2723          (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
2724                      (return p))))
2725        (when (logical-pathname-p p) (return p))
2726        (let ((found (probe-file* p :truename t)))
2727          (when found (return found)))
2728        (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
2729               (up-components (reverse (rest directory)))
2730               (down-components ()))
2731          (assert (eq :absolute (first directory)))
2732          (loop :while up-components :do
2733            (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
2734                                                         :name nil :type nil :version nil :defaults p)))
2735              (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
2736                                                        :defaults p)
2737                                        (ensure-directory-pathname parent)))
2738              (push (pop up-components) down-components))
2739                :finally (return p))))))
2740
2741  (defun resolve-symlinks (path)
2742    #-allegro (truenamize path)
2743    #+allegro
2744    (if (physical-pathname-p path)
2745        (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
2746        path))
2747
2748  (defvar *resolve-symlinks* t
2749    "Determine whether or not ASDF resolves symlinks when defining systems.
2750Defaults to T.")
2751
2752  (defun resolve-symlinks* (path)
2753    (if *resolve-symlinks*
2754        (and path (resolve-symlinks path))
2755        path)))
2756
2757
2758;;; Check pathname constraints
2759(with-upgradability ()
2760  (defun ensure-pathname
2761      (pathname &key
2762                  on-error
2763                  defaults type dot-dot
2764                  want-pathname
2765                  want-logical want-physical ensure-physical
2766                  want-relative want-absolute ensure-absolute ensure-subpath
2767                  want-non-wild want-wild wilden
2768                  want-file want-directory ensure-directory
2769                  want-existing ensure-directories-exist
2770                  truename resolve-symlinks truenamize
2771       &aux (p pathname)) ;; mutable working copy, preserve original
2772    "Coerces its argument into a PATHNAME,
2773optionally doing some transformations and checking specified constraints.
2774
2775If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
2776
2777If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
2778reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
2779then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
2780and the all the checks and transformations are run.
2781
2782Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
2783The boolean T is an alias for ERROR.
2784ERROR means that an error will be raised if the constraint is not satisfied.
2785CERROR means that an continuable error will be raised if the constraint is not satisfied.
2786IGNORE means just return NIL instead of the pathname.
2787
2788The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
2789that will be called with the the following arguments:
2790a generic format string for ensure pathname, the pathname,
2791the keyword argument corresponding to the failed check or transformation,
2792a format string for the reason ENSURE-PATHNAME failed,
2793and a list with arguments to that format string.
2794If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
2795You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
2796
2797The transformations and constraint checks are done in this order,
2798which is also the order in the lambda-list:
2799
2800WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
2801Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
2802WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
2803WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
2804ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
2805WANT-RELATIVE checks that pathname has a relative directory component
2806WANT-ABSOLUTE checks that pathname does have an absolute directory component
2807ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
2808that the result absolute is an absolute pathname indeed.
2809ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
2810WANT-FILE checks that pathname has a non-nil FILE component
2811WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
2812ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
2813any file and type components as being actually a last directory component.
2814WANT-NON-WILD checks that pathname is not a wild pathname
2815WANT-WILD checks that pathname is a wild pathname
2816WILDEN merges the pathname with **/*.*.* if it is not wild
2817WANT-EXISTING checks that a file (or directory) exists with that pathname.
2818ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
2819TRUENAME replaces the pathname by its truename, or errors if not possible.
2820RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
2821TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
2822    (block nil
2823      (flet ((report-error (keyword description &rest arguments)
2824               (call-function (or on-error 'error)
2825                              "Invalid pathname ~S: ~*~?"
2826                              pathname keyword description arguments)))
2827        (macrolet ((err (constraint &rest arguments)
2828                     `(report-error ',(intern* constraint :keyword) ,@arguments))
2829                   (check (constraint condition &rest arguments)
2830                     `(when ,constraint
2831                        (unless ,condition (err ,constraint ,@arguments))))
2832                   (transform (transform condition expr)
2833                     `(when ,transform
2834                        (,@(if condition `(when ,condition) '(progn))
2835                         (setf p ,expr)))))
2836          (etypecase p
2837            ((or null pathname))
2838            (string
2839             (setf p (parse-unix-namestring
2840                      p :defaults defaults :type type :dot-dot dot-dot
2841                        :ensure-directory ensure-directory :want-relative want-relative))))
2842          (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
2843          (unless (pathnamep p) (return nil))
2844          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
2845          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
2846          (transform ensure-physical () (translate-logical-pathname p))
2847          (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
2848          (check want-relative (relative-pathname-p p) "Expected a relative pathname")
2849          (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
2850          (transform ensure-absolute (not (absolute-pathname-p p))
2851                     (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
2852          (check ensure-absolute (absolute-pathname-p p)
2853                 "Could not make into an absolute pathname even after merging with ~S" defaults)
2854          (check ensure-subpath (absolute-pathname-p defaults)
2855                 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
2856          (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
2857          (check want-file (file-pathname-p p) "Expected a file pathname")
2858          (check want-directory (directory-pathname-p p) "Expected a directory pathname")
2859          (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
2860          (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
2861          (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
2862          (transform wilden (not (wild-pathname-p p)) (wilden p))
2863          (when want-existing
2864            (let ((existing (probe-file* p :truename truename)))
2865              (if existing
2866                  (when truename
2867                    (return existing))
2868                  (err want-existing "Expected an existing pathname"))))
2869          (when ensure-directories-exist (ensure-directories-exist p))
2870          (when truename
2871            (let ((truename (truename* p)))
2872              (if truename
2873                  (return truename)
2874                  (err truename "Can't get a truename for pathname"))))
2875          (transform resolve-symlinks () (resolve-symlinks p))
2876          (transform truenamize () (truenamize p))
2877          p)))))
2878
2879
2880;;; Pathname defaults
2881(with-upgradability ()
2882  (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
2883    (or (absolute-pathname-p defaults)
2884        (merge-pathnames* defaults (getcwd))))
2885
2886  (defun call-with-current-directory (dir thunk)
2887    (if dir
2888        (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
2889               (*default-pathname-defaults* dir)
2890               (cwd (getcwd)))
2891          (chdir dir)
2892          (unwind-protect
2893               (funcall thunk)
2894            (chdir cwd)))
2895        (funcall thunk)))
2896
2897  (defmacro with-current-directory ((&optional dir) &body body)
2898    "Call BODY while the POSIX current working directory is set to DIR"
2899    `(call-with-current-directory ,dir #'(lambda () ,@body))))
2900
2901
2902;;; Environment pathnames
2903(with-upgradability ()
2904  (defun inter-directory-separator ()
2905    (if (os-unix-p) #\: #\;))
2906
2907  (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
2908    (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
2909          :collect (apply 'parse-native-namestring namestring constraints)))
2910
2911  (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
2912    ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
2913    (apply 'parse-native-namestring (getenvp x)
2914           :ensure-directory (or ensure-directory want-directory)
2915           :on-error (or on-error
2916                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
2917           constraints))
2918  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
2919    (apply 'split-native-pathnames-string (getenvp x)
2920           :on-error (or on-error
2921                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
2922           constraints))
2923  (defun getenv-absolute-directory (x)
2924    (getenv-pathname x :want-absolute t :ensure-directory t))
2925  (defun getenv-absolute-directories (x)
2926    (getenv-pathnames x :want-absolute t :ensure-directory t))
2927
2928  (defun lisp-implementation-directory (&key truename)
2929    (declare (ignorable truename))
2930    #+(or clozure ecl gcl mkcl sbcl)
2931    (let ((dir
2932            (ignore-errors
2933             #+clozure #p"ccl:"
2934             #+(or ecl mkcl) #p"SYS:"
2935             #+gcl system::*system-directory*
2936             #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
2937                      (funcall it)
2938                      (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
2939      (if (and dir truename)
2940          (truename* dir)
2941          dir)))
2942
2943  (defun lisp-implementation-pathname-p (pathname)
2944    ;; Other builtin systems are those under the implementation directory
2945    (and (when pathname
2946           (if-let (impdir (lisp-implementation-directory))
2947             (or (subpathp pathname impdir)
2948                 (when *resolve-symlinks*
2949                   (if-let (truename (truename* pathname))
2950                     (if-let (trueimpdir (truename* impdir))
2951                       (subpathp truename trueimpdir)))))))
2952         t)))
2953
2954
2955;;; Simple filesystem operations
2956(with-upgradability ()
2957  (defun ensure-all-directories-exist (pathnames)
2958    (dolist (pathname pathnames)
2959      (when pathname
2960        (ensure-directories-exist (translate-logical-pathname pathname)))))
2961
2962  (defun rename-file-overwriting-target (source target)
2963    #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
2964    (posix:copy-file source target :method :rename)
2965    #-clisp
2966    (rename-file source target
2967                 #+clozure :if-exists #+clozure :rename-and-delete))
2968
2969  (defun delete-file-if-exists (x)
2970    (when x (handler-case (delete-file x) (file-error () nil))))
2971
2972  (defun delete-empty-directory (directory-pathname)
2973    "Delete an empty directory"
2974    #+(or abcl digitool gcl) (delete-file directory-pathname)
2975    #+allegro (excl:delete-directory directory-pathname)
2976    #+clisp (ext:delete-directory directory-pathname)
2977    #+clozure (ccl::delete-empty-directory directory-pathname)
2978    #+(or cmu scl) (multiple-value-bind (ok errno)
2979                       (unix:unix-rmdir (native-namestring directory-pathname))
2980                     (unless ok
2981                       #+cmu (error "Error number ~A when trying to delete directory ~A"
2982                                    errno directory-pathname)
2983                       #+scl (error "~@<Error deleting ~S: ~A~@:>"
2984                                    directory-pathname (unix:get-unix-error-msg errno))))
2985    #+cormanlisp (win32:delete-directory directory-pathname)
2986    #+ecl (si:rmdir directory-pathname)
2987    #+lispworks (lw:delete-directory directory-pathname)
2988    #+mkcl (mkcl:rmdir directory-pathname)
2989    #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
2990               `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
2991               `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
2992    #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
2993    (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
2994
2995  (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
2996    "Delete a directory including all its recursive contents, aka rm -rf.
2997
2998To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
2999a physical non-wildcard directory pathname (not namestring).
3000
3001If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
3002if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
3003
3004Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
3005the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
3006which in practice is thus compulsory, and validates by returning a non-NIL result.
3007If you're suicidal or extremely confident, just use :VALIDATE T."
3008    (check-type if-does-not-exist (member :error :ignore))
3009    (cond
3010      ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
3011                 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
3012       (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
3013              'delete-filesystem-tree directory-pathname))
3014      ((not validatep)
3015       (error "~S was asked to delete ~S but was not provided a validation predicate"
3016              'delete-filesystem-tree directory-pathname))
3017      ((not (call-function validate directory-pathname))
3018       (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
3019              'delete-filesystem-tree directory-pathname validate))
3020      ((not (directory-exists-p directory-pathname))
3021       (ecase if-does-not-exist
3022         (:error
3023          (error "~S was asked to delete ~S but the directory does not exist"
3024              'delete-filesystem-tree directory-pathname))
3025         (:ignore nil)))
3026      #-(or allegro cmu clozure sbcl scl)
3027      ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
3028       ;; except on implementations where we can prevent DIRECTORY from following symlinks;
3029       ;; instead spawn a standard external program to do the dirty work.
3030       (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
3031      (t
3032       ;; On supported implementation, call supported system functions
3033       #+allegro (symbol-call :excl.osi :delete-directory-and-files
3034                              directory-pathname :if-does-not-exist if-does-not-exist)
3035       #+clozure (ccl:delete-directory directory-pathname)
3036       #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
3037       #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
3038                  `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
3039                  '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
3040       ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
3041       ;; do things the hard way.
3042       #-(or allegro clozure genera sbcl)
3043       (let ((sub*directories
3044               (while-collecting (c)
3045                 (collect-sub*directories directory-pathname t t #'c))))
3046             (dolist (d (nreverse sub*directories))
3047               (map () 'delete-file (directory-files d))
3048               (delete-empty-directory d)))))))
3049
3050;;;; ---------------------------------------------------------------------------
3051;;;; Utilities related to streams
3052
3053(uiop/package:define-package :uiop/stream
3054  (:nicknames :asdf/stream)
3055  (:recycle :uiop/stream :asdf/stream :asdf)
3056  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
3057  (:export
3058   #:*default-stream-element-type* #:*stderr* #:setup-stderr
3059   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
3060   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
3061   #:*default-encoding* #:*utf-8-external-format*
3062   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
3063   #:with-output #:output-string #:with-input
3064   #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
3065   #:finish-outputs #:format! #:safe-format!
3066   #:copy-stream-to-stream #:concatenate-files #:copy-file
3067   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
3068   #:slurp-stream-forms #:slurp-stream-form
3069   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
3070   #:eval-input #:eval-thunk #:standard-eval-thunk
3071   ;; Temporary files
3072   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
3073   #:setup-temporary-directory
3074   #:call-with-temporary-file #:with-temporary-file
3075   #:add-pathname-suffix #:tmpize-pathname
3076   #:call-with-staging-pathname #:with-staging-pathname))
3077(in-package :uiop/stream)
3078
3079(with-upgradability ()
3080  (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
3081    "default element-type for open (depends on the current CL implementation)")
3082
3083  (defvar *stderr* *error-output*
3084    "the original error output stream at startup")
3085
3086  (defun setup-stderr ()
3087    (setf *stderr*
3088          #+allegro excl::*stderr*
3089          #+clozure ccl::*stderr*
3090          #-(or allegro clozure) *error-output*))
3091  (setup-stderr))
3092
3093
3094;;; Encodings (mostly hooks only; full support requires asdf-encodings)
3095(with-upgradability ()
3096  (defparameter *default-encoding*
3097    ;; preserve explicit user changes to something other than the legacy default :default
3098    (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
3099          (unless (eq previous :default) previous))
3100        :utf-8)
3101    "Default encoding for source files.
3102The default value :utf-8 is the portable thing.
3103The legacy behavior was :default.
3104If you (asdf:load-system :asdf-encodings) then
3105you will have autodetection via *encoding-detection-hook* below,
3106reading emacs-style -*- coding: utf-8 -*- specifications,
3107and falling back to utf-8 or latin1 if nothing is specified.")
3108
3109  (defparameter *utf-8-external-format*
3110    #+(and asdf-unicode (not clisp)) :utf-8
3111    #+(and asdf-unicode clisp) charset:utf-8
3112    #-asdf-unicode :default
3113    "Default :external-format argument to pass to CL:OPEN and also
3114CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
3115On modern implementations, this will decode UTF-8 code points as CL characters.
3116On legacy implementations, it may fall back on some 8-bit encoding,
3117with non-ASCII code points being read as several CL characters;
3118hopefully, if done consistently, that won't affect program behavior too much.")
3119
3120  (defun always-default-encoding (pathname)
3121    (declare (ignore pathname))
3122    *default-encoding*)
3123
3124  (defvar *encoding-detection-hook* #'always-default-encoding
3125    "Hook for an extension to define a function to automatically detect a file's encoding")
3126
3127  (defun detect-encoding (pathname)
3128    (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
3129        (funcall *encoding-detection-hook* pathname)
3130        *default-encoding*))
3131
3132  (defun default-encoding-external-format (encoding)
3133    (case encoding
3134      (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
3135      (:utf-8 *utf-8-external-format*)
3136      (otherwise
3137       (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
3138       :default)))
3139
3140  (defvar *encoding-external-format-hook*
3141    #'default-encoding-external-format
3142    "Hook for an extension to define a mapping between non-default encodings
3143and implementation-defined external-format's")
3144
3145  (defun encoding-external-format (encoding)
3146    (funcall *encoding-external-format-hook* encoding)))
3147
3148
3149;;; Safe syntax
3150(with-upgradability ()
3151  (defvar *standard-readtable* (copy-readtable nil))
3152
3153  (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
3154    "Establish safe CL reader options around the evaluation of BODY"
3155    `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
3156
3157  (defun call-with-safe-io-syntax (thunk &key (package :cl))
3158    (with-standard-io-syntax
3159      (let ((*package* (find-package package))
3160            (*read-default-float-format* 'double-float)
3161            (*print-readably* nil)
3162            (*read-eval* nil))
3163        (funcall thunk))))
3164
3165  (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
3166    (with-safe-io-syntax (:package package)
3167      (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
3168
3169
3170;;; Output to a stream or string, FORMAT-style
3171(with-upgradability ()
3172  (defun call-with-output (output function)
3173    "Calls FUNCTION with an actual stream argument,
3174behaving like FORMAT with respect to how stream designators are interpreted:
3175If OUTPUT is a stream, use it as the stream.
3176If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
3177If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
3178If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
3179Otherwise, signal an error."
3180    (etypecase output
3181      (null
3182       (with-output-to-string (stream) (funcall function stream)))
3183      ((eql t)
3184       (funcall function *standard-output*))
3185      (stream
3186       (funcall function output))
3187      (string
3188       (assert (fill-pointer output))
3189       (with-output-to-string (stream output) (funcall function stream)))))
3190
3191  (defmacro with-output ((output-var &optional (value output-var)) &body body)
3192    "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3193as per FORMAT, and evaluate BODY within the scope of this binding."
3194    `(call-with-output ,value #'(lambda (,output-var) ,@body)))
3195
3196  (defun output-string (string &optional output)
3197    "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3198    (if output
3199        (with-output (output) (princ string output))
3200        string)))
3201
3202
3203;;; Input helpers
3204(with-upgradability ()
3205  (defun call-with-input (input function)
3206    "Calls FUNCTION with an actual stream argument, interpreting
3207stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
3208If INPUT is a STREAM, use it as the stream.
3209If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
3210If INPUT is T, use *TERMINAL-IO* as the stream.
3211As an extension, if INPUT is a string, use it as a string-input-stream.
3212Otherwise, signal an error."
3213    (etypecase input
3214      (null (funcall function *standard-input*))
3215      ((eql t) (funcall function *terminal-io*))
3216      (stream (funcall function input))
3217      (string (with-input-from-string (stream input) (funcall function stream)))))
3218
3219  (defmacro with-input ((input-var &optional (value input-var)) &body body)
3220    "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3221as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3222    `(call-with-input ,value #'(lambda (,input-var) ,@body)))
3223
3224  (defun call-with-input-file (pathname thunk
3225                               &key
3226                                 (element-type *default-stream-element-type*)
3227                                 (external-format *utf-8-external-format*)
3228                                 (if-does-not-exist :error))
3229    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3230Other keys are accepted but discarded."
3231    #+gcl2.6 (declare (ignore external-format))
3232    (with-open-file (s pathname :direction :input
3233                                :element-type element-type
3234                                #-gcl2.6 :external-format #-gcl2.6 external-format
3235                                :if-does-not-exist if-does-not-exist)
3236      (funcall thunk s)))
3237
3238  (defmacro with-input-file ((var pathname &rest keys
3239                              &key element-type external-format if-does-not-exist)
3240                             &body body)
3241    (declare (ignore element-type external-format if-does-not-exist))
3242    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
3243
3244  (defun call-with-output-file (pathname thunk
3245                                &key
3246                                  (element-type *default-stream-element-type*)
3247                                  (external-format *utf-8-external-format*)
3248                                  (if-exists :error)
3249                                  (if-does-not-exist :create))
3250    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3251Other keys are accepted but discarded."
3252    #+gcl2.6 (declare (ignore external-format))
3253    (with-open-file (s pathname :direction :output
3254                                :element-type element-type
3255                                #-gcl2.6 :external-format #-gcl2.6 external-format
3256                                :if-exists if-exists
3257                                :if-does-not-exist if-does-not-exist)
3258      (funcall thunk s)))
3259
3260  (defmacro with-output-file ((var pathname &rest keys
3261                               &key element-type external-format if-exists if-does-not-exist)
3262                              &body body)
3263    (declare (ignore element-type external-format if-exists if-does-not-exist))
3264    `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
3265
3266;;; Ensure output buffers are flushed
3267(with-upgradability ()
3268  (defun finish-outputs (&rest streams)
3269    "Finish output on the main output streams as well as any specified one.
3270Useful for portably flushing I/O before user input or program exit."
3271    ;; CCL notably buffers its stream output by default.
3272    (dolist (s (append streams
3273                       (list *stderr* *error-output* *standard-output* *trace-output*
3274                             *debug-io* *terminal-io* *debug-io* *query-io*)))
3275      (ignore-errors (finish-output s)))
3276    (values))
3277
3278  (defun format! (stream format &rest args)
3279    "Just like format, but call finish-outputs before and after the output."
3280    (finish-outputs stream)
3281    (apply 'format stream format args)
3282    (finish-output stream))
3283
3284  (defun safe-format! (stream format &rest args)
3285    (with-safe-io-syntax ()
3286      (ignore-errors (apply 'format! stream format args))
3287      (finish-outputs stream)))) ; just in case format failed
3288
3289
3290;;; Simple Whole-Stream processing
3291(with-upgradability ()
3292  (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
3293    "Copy the contents of the INPUT stream into the OUTPUT stream.
3294If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3295Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3296    (with-open-stream (input input)
3297      (if linewise
3298          (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
3299                 :while line :do
3300                 (when prefix (princ prefix output))
3301                 (princ line output)
3302                 (unless eof (terpri output))
3303                 (finish-output output)
3304                 (when eof (return)))
3305          (loop
3306            :with buffer-size = (or buffer-size 8192)
3307            :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
3308            :for end = (read-sequence buffer input)
3309            :until (zerop end)
3310            :do (write-sequence buffer output :end end)
3311                (when (< end buffer-size) (return))))))
3312
3313  (defun concatenate-files (inputs output)
3314    (with-open-file (o output :element-type '(unsigned-byte 8)
3315                              :direction :output :if-exists :rename-and-delete)
3316      (dolist (input inputs)
3317        (with-open-file (i input :element-type '(unsigned-byte 8)
3318                                 :direction :input :if-does-not-exist :error)
3319          (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
3320
3321  (defun copy-file (input output)
3322    ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
3323    (concatenate-files (list input) output))
3324
3325  (defun slurp-stream-string (input &key (element-type 'character))
3326    "Read the contents of the INPUT stream as a string"
3327    (with-open-stream (input input)
3328      (with-output-to-string (output)
3329        (copy-stream-to-stream input output :element-type element-type))))
3330
3331  (defun slurp-stream-lines (input &key count)
3332    "Read the contents of the INPUT stream as a list of lines, return those lines.
3333
3334Read no more than COUNT lines."
3335    (check-type count (or null integer))
3336    (with-open-stream (input input)
3337      (loop :for n :from 0
3338            :for l = (and (or (not count) (< n count))
3339                          (read-line input nil nil))
3340            :while l :collect l)))
3341
3342  (defun slurp-stream-line (input &key (at 0))
3343    "Read the contents of the INPUT stream as a list of lines,
3344then return the ACCESS-AT of that list of lines using the AT specifier.
3345PATH defaults to 0, i.e. return the first line.
3346PATH is typically an integer, or a list of an integer and a function.
3347If PATH is NIL, it will return all the lines in the file.
3348
3349The stream will not be read beyond the Nth lines,
3350where N is the index specified by path
3351if path is either an integer or a list that starts with an integer."
3352    (access-at (slurp-stream-lines input :count (access-at-count at)) at))
3353
3354  (defun slurp-stream-forms (input &key count)
3355    "Read the contents of the INPUT stream as a list of forms,
3356and return those forms.
3357
3358If COUNT is null, read to the end of the stream;
3359if COUNT is an integer, stop after COUNT forms were read.
3360
3361BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3362    (check-type count (or null integer))
3363    (loop :with eof = '#:eof
3364          :for n :from 0
3365          :for form = (if (and count (>= n count))
3366                          eof
3367                          (read-preserving-whitespace input nil eof))
3368          :until (eq form eof) :collect form))
3369
3370  (defun slurp-stream-form (input &key (at 0))
3371    "Read the contents of the INPUT stream as a list of forms,
3372then return the ACCESS-AT of these forms following the AT.
3373AT defaults to 0, i.e. return the first form.
3374AT is typically a list of integers.
3375If AT is NIL, it will return all the forms in the file.
3376
3377The stream will not be read beyond the Nth form,
3378where N is the index specified by path,
3379if path is either an integer or a list that starts with an integer.
3380
3381BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3382    (access-at (slurp-stream-forms input :count (access-at-count at)) at))
3383
3384  (defun read-file-string (file &rest keys)
3385    "Open FILE with option KEYS, read its contents as a string"
3386    (apply 'call-with-input-file file 'slurp-stream-string keys))
3387
3388  (defun read-file-lines (file &rest keys)
3389    "Open FILE with option KEYS, read its contents as a list of lines
3390BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3391    (apply 'call-with-input-file file 'slurp-stream-lines keys))
3392
3393  (defun read-file-forms (file &rest keys &key count &allow-other-keys)
3394    "Open input FILE with option KEYS (except COUNT),
3395and read its contents as per SLURP-STREAM-FORMS with given COUNT.
3396BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3397    (apply 'call-with-input-file file
3398           #'(lambda (input) (slurp-stream-forms input :count count))
3399           (remove-plist-key :count keys)))
3400
3401  (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
3402    "Open input FILE with option KEYS (except AT),
3403and read its contents as per SLURP-STREAM-FORM with given AT specifier.
3404BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3405    (apply 'call-with-input-file file
3406           #'(lambda (input) (slurp-stream-form input :at at))
3407           (remove-plist-key :at keys)))
3408
3409  (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
3410    "Reads the specified form from the top of a file using a safe standardized syntax.
3411Extracts the form using READ-FILE-FORM,
3412within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3413    (with-safe-io-syntax (:package package)
3414      (apply 'read-file-form pathname (remove-plist-key :package keys))))
3415
3416  (defun eval-input (input)
3417    "Portably read and evaluate forms from INPUT, return the last values."
3418    (with-input (input)
3419      (loop :with results :with eof ='#:eof
3420            :for form = (read input nil eof)
3421            :until (eq form eof)
3422            :do (setf results (multiple-value-list (eval form)))
3423            :finally (return (apply 'values results)))))
3424
3425  (defun eval-thunk (thunk)
3426    "Evaluate a THUNK of code:
3427If a function, FUNCALL it without arguments.
3428If a constant literal and not a sequence, return it.
3429If a cons or a symbol, EVAL it.
3430If a string, repeatedly read and evaluate from it, returning the last values."
3431    (etypecase thunk
3432      ((or boolean keyword number character pathname) thunk)
3433      ((or cons symbol) (eval thunk))
3434      (function (funcall thunk))
3435      (string (eval-input thunk))))
3436
3437  (defun standard-eval-thunk (thunk &key (package :cl))
3438    "Like EVAL-THUNK, but in a more standardized evaluation context."
3439    ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
3440    (when thunk
3441      (with-safe-io-syntax (:package package)
3442        (let ((*read-eval* t))
3443          (eval-thunk thunk))))))
3444
3445
3446;;; Using temporary files
3447(with-upgradability ()
3448  (defun default-temporary-directory ()
3449    (or
3450     (when (os-unix-p)
3451       (or (getenv-pathname "TMPDIR" :ensure-directory t)
3452           (parse-native-namestring "/tmp/")))
3453     (when (os-windows-p)
3454       (getenv-pathname "TEMP" :ensure-directory t))
3455     (subpathname (user-homedir-pathname) "tmp/")))
3456
3457  (defvar *temporary-directory* nil)
3458
3459  (defun temporary-directory ()
3460    (or *temporary-directory* (default-temporary-directory)))
3461
3462  (defun setup-temporary-directory ()
3463    (setf *temporary-directory* (default-temporary-directory))
3464    ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
3465    #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
3466
3467  (defun call-with-temporary-file
3468      (thunk &key
3469               prefix keep (direction :io)
3470               (element-type *default-stream-element-type*)
3471               (external-format :default))
3472    #+gcl2.6 (declare (ignorable external-format))
3473    (check-type direction (member :output :io))
3474    (loop
3475      :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
3476      :for counter :from (random (ash 1 32))
3477      :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
3478        ;; TODO: on Unix, do something about umask
3479        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
3480        ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
3481        (with-open-file (stream pathname
3482                                :direction direction
3483                                :element-type element-type
3484                                #-gcl2.6 :external-format #-gcl2.6 external-format
3485                                :if-exists nil :if-does-not-exist :create)
3486          (when stream
3487            (return
3488              (if keep
3489                  (funcall thunk stream pathname)
3490                  (unwind-protect
3491                       (funcall thunk stream pathname)
3492                    (ignore-errors (delete-file pathname)))))))))
3493
3494  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
3495                                    (pathname (gensym "PATHNAME") pathnamep)
3496                                    prefix keep direction element-type external-format)
3497                                 &body body)
3498    "Evaluate BODY where the symbols specified by keyword arguments
3499STREAM and PATHNAME are bound corresponding to a newly created temporary file
3500ready for I/O. Unless KEEP is specified, delete the file afterwards."
3501    (check-type stream symbol)
3502    (check-type pathname symbol)
3503    `(flet ((think (,stream ,pathname)
3504              ,@(unless pathnamep `((declare (ignore ,pathname))))
3505              ,@(unless streamp `((when ,stream (close ,stream))))
3506              ,@body))
3507       #-gcl (declare (dynamic-extent #'think))
3508       (call-with-temporary-file
3509        #'think
3510        ,@(when direction `(:direction ,direction))
3511        ,@(when prefix `(:prefix ,prefix))
3512        ,@(when keep `(:keep ,keep))
3513        ,@(when element-type `(:element-type ,element-type))
3514        ,@(when external-format `(:external-format external-format)))))
3515
3516  ;; Temporary pathnames in simple cases where no contention is assumed
3517  (defun add-pathname-suffix (pathname suffix)
3518    (make-pathname :name (strcat (pathname-name pathname) suffix)
3519                   :defaults pathname))
3520
3521  (defun tmpize-pathname (x)
3522    (add-pathname-suffix x "-ASDF-TMP"))
3523
3524  (defun call-with-staging-pathname (pathname fun)
3525    "Calls fun with a staging pathname, and atomically
3526renames the staging pathname to the pathname in the end.
3527Note: this protects only against failure of the program,
3528not against concurrent attempts.
3529For the latter case, we ought pick random suffix and atomically open it."
3530    (let* ((pathname (pathname pathname))
3531           (staging (tmpize-pathname pathname)))
3532      (unwind-protect
3533           (multiple-value-prog1
3534               (funcall fun staging)
3535             (rename-file-overwriting-target staging pathname))
3536        (delete-file-if-exists staging))))
3537
3538  (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
3539    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
3540
3541;;;; -------------------------------------------------------------------------
3542;;;; Starting, Stopping, Dumping a Lisp image
3543
3544(uiop/package:define-package :uiop/image
3545  (:nicknames :asdf/image)
3546  (:recycle :uiop/image :asdf/image :xcvb-driver)
3547  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
3548  (:export
3549   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
3550   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
3551   #:*lisp-interaction*
3552   #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
3553   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
3554   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
3555   #:*image-postlude* #:*image-dump-hook*
3556   #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
3557   #:shell-boolean-exit
3558   #:register-image-restore-hook #:register-image-dump-hook
3559   #:call-image-restore-hook #:call-image-dump-hook
3560   #:restore-image #:dump-image #:create-image
3561))
3562(in-package :uiop/image)
3563
3564(with-upgradability ()
3565  (defvar *lisp-interaction* t
3566    "Is this an interactive Lisp environment, or is it batch processing?")
3567
3568  (defvar *command-line-arguments* nil
3569    "Command-line arguments")
3570
3571  (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
3572    "Is this a dumped image? As a standalone executable?")
3573
3574  (defvar *image-restore-hook* nil
3575    "Functions to call (in reverse order) when the image is restored")
3576
3577  (defvar *image-restored-p* nil
3578    "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
3579
3580  (defvar *image-prelude* nil
3581    "a form to evaluate, or string containing forms to read and evaluate
3582when the image is restarted, but before the entry point is called.")
3583
3584  (defvar *image-entry-point* nil
3585    "a function with which to restart the dumped image when execution is restored from it.")
3586
3587  (defvar *image-postlude* nil
3588    "a form to evaluate, or string containing forms to read and evaluate
3589before the image dump hooks are called and before the image is dumped.")
3590
3591  (defvar *image-dump-hook* nil
3592    "Functions to call (in order) when before an image is dumped")
3593
3594  (defvar *fatal-conditions* '(error)
3595    "conditions that cause the Lisp image to enter the debugger if interactive,
3596or to die if not interactive"))
3597
3598
3599;;; Exiting properly or im-
3600(with-upgradability ()
3601  (defun quit (&optional (code 0) (finish-output t))
3602    "Quits from the Lisp world, with the given exit status if provided.
3603This is designed to abstract away the implementation specific quit forms."
3604    (when finish-output ;; essential, for ClozureCL, and for standard compliance.
3605      (finish-outputs))
3606    #+(or abcl xcl) (ext:quit :status code)
3607    #+allegro (excl:exit code :quiet t)
3608    #+clisp (ext:quit code)
3609    #+clozure (ccl:quit code)
3610    #+cormanlisp (win32:exitprocess code)
3611    #+(or cmu scl) (unix:unix-exit code)
3612    #+ecl (si:quit code)
3613    #+gcl (lisp:quit code)
3614    #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
3615    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
3616    #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
3617    #+mkcl (mk-ext:quit :exit-code code)
3618    #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
3619                   (quit (find-symbol* :quit :sb-ext nil)))
3620               (cond
3621                 (exit `(,exit :code code :abort (not finish-output)))
3622                 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
3623    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
3624    (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
3625
3626  (defun die (code format &rest arguments)
3627    "Die in error with some error message"
3628    (with-safe-io-syntax ()
3629      (ignore-errors
3630       (fresh-line *stderr*)
3631       (apply #'format *stderr* format arguments)
3632       (format! *stderr* "~&")))
3633    (quit code))
3634
3635  (defun raw-print-backtrace (&key (stream *debug-io*) count)
3636    "Print a backtrace, directly accessing the implementation"
3637    (declare (ignorable stream count))
3638    #+abcl
3639    (let ((*debug-io* stream)) (top-level::backtrace-command count))
3640    #+allegro
3641    (let ((*terminal-io* stream)
3642          (*standard-output* stream)
3643          (tpl:*zoom-print-circle* *print-circle*)
3644          (tpl:*zoom-print-level* *print-level*)
3645          (tpl:*zoom-print-length* *print-length*))
3646      (tpl:do-command "zoom"
3647        :from-read-eval-print-loop nil
3648        :count t
3649        :all t))
3650    #+clisp
3651    (system::print-backtrace :out stream :limit count)
3652    #+(or clozure mcl)
3653    (let ((*debug-io* stream))
3654      (ccl:print-call-history :count count :start-frame-number 1)
3655      (finish-output stream))
3656    #+(or cmu scl)
3657    (let ((debug:*debug-print-level* *print-level*)
3658          (debug:*debug-print-length* *print-length*))
3659      (debug:backtrace most-positive-fixnum stream))
3660    #+ecl
3661    (si::tpl-backtrace)
3662    #+lispworks
3663    (let ((dbg::*debugger-stack*
3664            (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
3665          (*debug-io* stream)
3666          (dbg:*debug-print-level* *print-level*)
3667          (dbg:*debug-print-length* *print-length*))
3668      (dbg:bug-backtrace nil))
3669    #+sbcl
3670    (sb-debug:backtrace
3671     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
3672     stream))
3673
3674  (defun print-backtrace (&rest keys &key stream count)
3675    (declare (ignore stream count))
3676    (with-safe-io-syntax (:package :cl)
3677      (let ((*print-readably* nil)
3678            (*print-circle* t)
3679            (*print-miser-width* 75)
3680            (*print-length* nil)
3681            (*print-level* nil)
3682            (*print-pretty* t))
3683        (ignore-errors (apply 'raw-print-backtrace keys)))))
3684
3685  (defun print-condition-backtrace (condition &key (stream *stderr*) count)
3686    ;; We print the condition *after* the backtrace,
3687    ;; for the sake of who sees the backtrace at a terminal.
3688    ;; It is up to the caller to print the condition *before*, with some context.
3689    (print-backtrace :stream stream :count count)
3690    (when condition
3691      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
3692                    condition)))
3693
3694  (defun fatal-condition-p (condition)
3695    (match-any-condition-p condition *fatal-conditions*))
3696
3697  (defun handle-fatal-condition (condition)
3698    "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
3699    (cond
3700      (*lisp-interaction*
3701       (invoke-debugger condition))
3702      (t
3703       (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
3704       (print-condition-backtrace condition :stream *stderr*)
3705       (die 99 "~A" condition))))
3706
3707  (defun call-with-fatal-condition-handler (thunk)
3708    (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
3709      (funcall thunk)))
3710
3711  (defmacro with-fatal-condition-handler ((&optional) &body body)
3712    `(call-with-fatal-condition-handler #'(lambda () ,@body)))
3713
3714  (defun shell-boolean-exit (x)
3715    "Quit with a return code that is 0 iff argument X is true"
3716    (quit (if x 0 1))))
3717
3718
3719;;; Using image hooks
3720(with-upgradability ()
3721  (defun register-image-restore-hook (hook &optional (call-now-p t))
3722    (register-hook-function '*image-restore-hook* hook call-now-p))
3723
3724  (defun register-image-dump-hook (hook &optional (call-now-p nil))
3725    (register-hook-function '*image-dump-hook* hook call-now-p))
3726
3727  (defun call-image-restore-hook ()
3728    (call-functions (reverse *image-restore-hook*)))
3729
3730  (defun call-image-dump-hook ()
3731    (call-functions *image-dump-hook*)))
3732
3733
3734;;; Proper command-line arguments
3735(with-upgradability ()
3736  (defun raw-command-line-arguments ()
3737    "Find what the actual command line for this process was."
3738    #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
3739    #+allegro (sys:command-line-arguments) ; default: :application t
3740    #+clisp (coerce (ext:argv) 'list)
3741    #+clozure (ccl::command-line-arguments)
3742    #+(or cmu scl) extensions:*command-line-strings*
3743    #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
3744    #+gcl si:*command-args*
3745    #+genera nil
3746    #+lispworks sys:*line-arguments-list*
3747    #+sbcl sb-ext:*posix-argv*
3748    #+xcl system:*argv*
3749    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
3750    (error "raw-command-line-arguments not implemented yet"))
3751
3752  (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
3753    "Extract user arguments from command-line invocation of current process.
3754Assume the calling conventions of a generated script that uses --
3755if we are not called from a directly executable image."
3756    #+abcl arguments
3757    #-abcl
3758    (let* (#-(or sbcl allegro)
3759           (arguments
3760             (if (eq *image-dumped-p* :executable)
3761                 arguments
3762                 (member "--" arguments :test 'string-equal))))
3763      (rest arguments)))
3764
3765  (defun setup-command-line-arguments ()
3766    (setf *command-line-arguments* (command-line-arguments)))
3767
3768  (defun restore-image (&key
3769                          ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
3770                          ((:restore-hook *image-restore-hook*) *image-restore-hook*)
3771                          ((:prelude *image-prelude*) *image-prelude*)
3772                          ((:entry-point *image-entry-point*) *image-entry-point*)
3773                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
3774    (when *image-restored-p*
3775      (if if-already-restored
3776          (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
3777          (return-from restore-image)))
3778    (with-fatal-condition-handler ()
3779      (setf *image-restored-p* :in-progress)
3780      (call-image-restore-hook)
3781      (standard-eval-thunk *image-prelude*)
3782      (setf *image-restored-p* t)
3783      (let ((results (multiple-value-list
3784                      (if *image-entry-point*
3785                          (call-function *image-entry-point*)
3786                          t))))
3787        (if *lisp-interaction*
3788            (apply 'values results)
3789            (shell-boolean-exit (first results)))))))
3790
3791
3792;;; Dumping an image
3793
3794(with-upgradability ()
3795  (defun dump-image (filename &key output-name executable
3796                                ((:postlude *image-postlude*) *image-postlude*)
3797                                ((:dump-hook *image-dump-hook*) *image-dump-hook*)
3798                                #+clozure prepend-symbols #+clozure (purify t))
3799    (declare (ignorable filename output-name executable))
3800    (setf *image-dumped-p* (if executable :executable t))
3801    (setf *image-restored-p* :in-regress)
3802    (standard-eval-thunk *image-postlude*)
3803    (call-image-dump-hook)
3804    (setf *image-restored-p* nil)
3805    #-(or clisp clozure cmu lispworks sbcl scl)
3806    (when executable
3807      (error "Dumping an executable is not supported on this implementation! Aborting."))
3808    #+allegro
3809    (progn
3810      (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
3811      (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
3812    #+clisp
3813    (apply #'ext:saveinitmem filename
3814           :quiet t
3815           :start-package *package*
3816           :keep-global-handlers nil
3817           :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
3818           (when executable
3819             (list
3820              ;; :parse-options nil ;--- requires a non-standard patch to clisp.
3821              :norc t :script nil :init-function #'restore-image)))
3822    #+clozure
3823    (flet ((dump (prepend-kernel)
3824             (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
3825                                            :toplevel-function (when executable #'restore-image))))
3826      ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
3827      (if prepend-symbols
3828          (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
3829            (require 'elf)
3830            (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
3831            (dump path))
3832          (dump t)))
3833    #+(or cmu scl)
3834    (progn
3835      (ext:gc :full t)
3836      (setf ext:*batch-mode* nil)
3837      (setf ext::*gc-run-time* 0)
3838      (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
3839                                     (when executable '(:init-function restore-image :process-command-line nil))))
3840    #+gcl
3841    (progn
3842      (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
3843      (si::save-system filename))
3844    #+lispworks
3845    (if executable
3846        (lispworks:deliver 'restore-image filename 0 :interface nil)
3847        (hcl:save-image filename :environment nil))
3848    #+sbcl
3849    (progn
3850      ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
3851      (setf sb-ext::*gc-run-time* 0)
3852      (apply 'sb-ext:save-lisp-and-die filename
3853             :executable t ;--- always include the runtime that goes with the core
3854             (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
3855    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
3856    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
3857           'dump-image filename (nth-value 1 (implementation-type))))
3858
3859  (defun create-image (destination object-files
3860                       &key kind output-name prologue-code epilogue-code
3861                         (prelude () preludep) (postlude () postludep)
3862                         (entry-point () entry-point-p) build-args)
3863    (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
3864                        prelude preludep postlude postludep entry-point entry-point-p build-args))
3865    ;; Is it meaningful to run these in the current environment?
3866    ;; only if we also track the object files that constitute the "current" image,
3867    ;; and otherwise simulate dump-image, including quitting at the end.
3868    #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
3869    #+ecl
3870    (progn
3871      (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
3872      (apply 'c::builder
3873             kind (pathname destination)
3874             :lisp-files object-files
3875             :init-name (c::compute-init-name (or output-name destination) :kind kind)
3876             :prologue-code prologue-code
3877             :epilogue-code
3878             `(progn
3879                ,epilogue-code
3880                ,@(when (eq kind :program)
3881                    `((setf *image-dumped-p* :executable)
3882                      (restore-image ;; default behavior would be (si::top-level)
3883                       ,@(when preludep `(:prelude ',prelude))
3884                       ,@(when entry-point-p `(:entry-point ',entry-point))))))
3885             build-args))))
3886
3887
3888;;; Some universal image restore hooks
3889(with-upgradability ()
3890  (map () 'register-image-restore-hook
3891       '(setup-temporary-directory setup-stderr setup-command-line-arguments
3892         #+abcl detect-os)))
3893;;;; -------------------------------------------------------------------------
3894;;;; run-program initially from xcvb-driver.
3895
3896(uiop/package:define-package :uiop/run-program
3897  (:nicknames :asdf/run-program)
3898  (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
3899  (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
3900  (:export
3901   ;;; Escaping the command invocation madness
3902   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
3903   #:escape-windows-token #:escape-windows-command
3904   #:escape-token #:escape-command
3905
3906   ;;; run-program
3907   #:slurp-input-stream
3908   #:run-program
3909   #:subprocess-error
3910   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
3911   ))
3912(in-package :uiop/run-program)
3913
3914;;;; ----- Escaping strings for the shell -----
3915
3916(with-upgradability ()
3917  (defun requires-escaping-p (token &key good-chars bad-chars)
3918    "Does this token require escaping, given the specification of
3919either good chars that don't need escaping or bad chars that do need escaping,
3920as either a recognizing function or a sequence of characters."
3921    (some
3922     (cond
3923       ((and good-chars bad-chars)
3924        (error "only one of good-chars and bad-chars can be provided"))
3925       ((functionp good-chars)
3926        (complement good-chars))
3927       ((functionp bad-chars)
3928        bad-chars)
3929       ((and good-chars (typep good-chars 'sequence))
3930        #'(lambda (c) (not (find c good-chars))))
3931       ((and bad-chars (typep bad-chars 'sequence))
3932        #'(lambda (c) (find c bad-chars)))
3933       (t (error "requires-escaping-p: no good-char criterion")))
3934     token))
3935
3936  (defun escape-token (token &key stream quote good-chars bad-chars escaper)
3937    "Call the ESCAPER function on TOKEN string if it needs escaping as per
3938REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
3939using STREAM as output (or returning result as a string if NIL)"
3940    (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
3941        (with-output (stream)
3942          (apply escaper token stream (when quote `(:quote ,quote))))
3943        (output-string token stream)))
3944
3945  (defun escape-windows-token-within-double-quotes (x &optional s)
3946    "Escape a string token X within double-quotes
3947for use within a MS Windows command-line, outputing to S."
3948    (labels ((issue (c) (princ c s))
3949             (issue-backslash (n) (loop :repeat n :do (issue #\\))))
3950      (loop
3951        :initially (issue #\") :finally (issue #\")
3952        :with l = (length x) :with i = 0
3953        :for i+1 = (1+ i) :while (< i l) :do
3954          (case (char x i)
3955            ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
3956            ((#\\)
3957             (let* ((j (and (< i+1 l) (position-if-not
3958                                       #'(lambda (c) (eql c #\\)) x :start i+1)))
3959                    (n (- (or j l) i)))
3960               (cond
3961                 ((null j)
3962                  (issue-backslash (* 2 n)) (setf i l))
3963                 ((and (< j l) (eql (char x j) #\"))
3964                  (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
3965                 (t
3966                  (issue-backslash n) (setf i j)))))
3967            (otherwise
3968             (issue (char x i)) (setf i i+1))))))
3969
3970  (defun escape-windows-token (token &optional s)
3971    "Escape a string TOKEN within double-quotes if needed
3972for use within a MS Windows command-line, outputing to S."
3973    (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
3974                        :escaper 'escape-windows-token-within-double-quotes))
3975
3976  (defun escape-sh-token-within-double-quotes (x s &key (quote t))
3977    "Escape a string TOKEN within double-quotes
3978for use within a POSIX Bourne shell, outputing to S;
3979omit the outer double-quotes if key argument :QUOTE is NIL"
3980    (when quote (princ #\" s))
3981    (loop :for c :across x :do
3982      (when (find c "$`\\\"") (princ #\\ s))
3983      (princ c s))
3984    (when quote (princ #\" s)))
3985
3986  (defun easy-sh-character-p (x)
3987    (or (alphanumericp x) (find x "+-_.,%@:/")))
3988
3989  (defun escape-sh-token (token &optional s)
3990    "Escape a string TOKEN within double-quotes if needed
3991for use within a POSIX Bourne shell, outputing to S."
3992    (escape-token token :stream s :quote #\" :good-chars
3993                  #'easy-sh-character-p
3994                        :escaper 'escape-sh-token-within-double-quotes))
3995
3996  (defun escape-shell-token (token &optional s)
3997    (cond
3998      ((os-unix-p) (escape-sh-token token s))
3999      ((os-windows-p) (escape-windows-token token s))))
4000
4001  (defun escape-command (command &optional s
4002                                  (escaper 'escape-shell-token))
4003    "Given a COMMAND as a list of tokens, return a string of the
4004spaced, escaped tokens, using ESCAPER to escape."
4005    (etypecase command
4006      (string (output-string command s))
4007      (list (with-output (s)
4008              (loop :for first = t :then nil :for token :in command :do
4009                (unless first (princ #\space s))
4010                (funcall escaper token s))))))
4011
4012  (defun escape-windows-command (command &optional s)
4013    "Escape a list of command-line arguments into a string suitable for parsing
4014by CommandLineToArgv in MS Windows"
4015    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
4016    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
4017    (escape-command command s 'escape-windows-token))
4018
4019  (defun escape-sh-command (command &optional s)
4020    "Escape a list of command-line arguments into a string suitable for parsing
4021by /bin/sh in POSIX"
4022    (escape-command command s 'escape-sh-token))
4023
4024  (defun escape-shell-command (command &optional stream)
4025    "Escape a command for the current operating system's shell"
4026    (escape-command command stream 'escape-shell-token)))
4027
4028
4029;;;; Slurping a stream, typically the output of another program
4030(with-upgradability ()
4031  (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
4032
4033  #-(or gcl2.6 genera)
4034  (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
4035    (funcall function input-stream))
4036
4037  (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
4038    (apply (first list) (cons input-stream (rest list))))
4039
4040  #-(or gcl2.6 genera)
4041  (defmethod slurp-input-stream ((output-stream stream) input-stream
4042                                 &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
4043    (copy-stream-to-stream
4044     input-stream output-stream
4045     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
4046
4047  (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
4048    (declare (ignorable x))
4049    (slurp-stream-string stream))
4050
4051  (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
4052    (declare (ignorable x))
4053    (slurp-stream-string stream))
4054
4055  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
4056    (declare (ignorable x))
4057    (slurp-stream-lines stream :count count))
4058
4059  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
4060    (declare (ignorable x))
4061    (slurp-stream-line stream :at at))
4062
4063  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
4064    (declare (ignorable x))
4065    (slurp-stream-forms stream :count count))
4066
4067  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
4068    (declare (ignorable x))
4069    (slurp-stream-form stream :at at))
4070
4071  (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
4072    (declare (ignorable x))
4073    (apply 'slurp-input-stream *standard-output* stream keys))
4074
4075  (defmethod slurp-input-stream ((pathname pathname) input
4076                                 &key
4077                                   (element-type *default-stream-element-type*)
4078                                   (external-format *utf-8-external-format*)
4079                                   (if-exists :rename-and-delete)
4080                                   (if-does-not-exist :create)
4081                                   buffer-size
4082                                   linewise)
4083    (with-output-file (output pathname
4084                              :element-type element-type
4085                              :external-format external-format
4086                              :if-exists if-exists
4087                              :if-does-not-exist if-does-not-exist)
4088      (copy-stream-to-stream
4089       input output
4090       :element-type element-type :buffer-size buffer-size :linewise linewise)))
4091
4092  (defmethod slurp-input-stream (x stream
4093                                 &key linewise prefix (element-type 'character) buffer-size
4094                                 &allow-other-keys)
4095    (declare (ignorable stream linewise prefix element-type buffer-size))
4096    (cond
4097      #+(or gcl2.6 genera)
4098      ((functionp x) (funcall x stream))
4099      #+(or gcl2.6 genera)
4100      ((output-stream-p x)
4101       (copy-stream-to-stream
4102        input-stream output-stream
4103        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
4104      (t
4105       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
4106
4107
4108;;;; ----- Running an external program -----
4109;;; Simple variant of run-program with no input, and capturing output
4110;;; On some implementations, may output to a temporary file...
4111(with-upgradability ()
4112  (define-condition subprocess-error (error)
4113    ((code :initform nil :initarg :code :reader subprocess-error-code)
4114     (command :initform nil :initarg :command :reader subprocess-error-command)
4115     (process :initform nil :initarg :process :reader subprocess-error-process))
4116    (:report (lambda (condition stream)
4117               (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
4118                       (subprocess-error-process condition)
4119                       (subprocess-error-command condition)
4120                       (subprocess-error-code condition)))))
4121
4122  (defun run-program (command
4123                       &key output ignore-error-status force-shell
4124                       (element-type *default-stream-element-type*)
4125                       (external-format :default)
4126                       &allow-other-keys)
4127    "Run program specified by COMMAND,
4128either a list of strings specifying a program and list of arguments,
4129or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
4130
4131Always call a shell (rather than directly execute the command)
4132if FORCE-SHELL is specified.
4133
4134Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
4135unless IGNORE-ERROR-STATUS is specified.
4136
4137If OUTPUT is either NIL or :INTERACTIVE, then
4138return the exit status code of the process that was called.
4139if it was NIL, the output is discarded;
4140if it was :INTERACTIVE, the output and the input are inherited from the current process.
4141
4142Otherwise, the output will be processed by SLURP-INPUT-STREAM,
4143using OUTPUT as the first argument, and return whatever it returns,
4144e.g. using :OUTPUT :STRING will have it return the entire output stream as a string.
4145Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
4146    ;; TODO: specially recognize :output pathname ?
4147    (declare (ignorable ignore-error-status element-type external-format))
4148    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
4149    (error "RUN-PROGRAM not implemented for this Lisp")
4150    (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
4151             (run-program (command &key pipe interactive)
4152               "runs the specified command (a list of program and arguments).
4153              If using a pipe, returns two values: process and stream
4154              If not using a pipe, returns one values: the process result;
4155              also, inherits the output stream."
4156               ;; NB: these implementations have unix vs windows set at compile-time.
4157               (assert (not (and pipe interactive)))
4158               (let* ((wait (not pipe))
4159                      #-(and clisp os-windows)
4160                      (command
4161                        (etypecase command
4162                          #+os-unix (string `("/bin/sh" "-c" ,command))
4163                          #+os-unix (list command)
4164                          #+os-windows
4165                          (string
4166                           ;; NB: We do NOT add cmd /c here. You might want to.
4167                           #+allegro command
4168                           ;; On ClozureCL for Windows, we assume you are using
4169                           ;; r15398 or later in 1.9 or later,
4170                           ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
4171                           #+clozure (cons "cmd" (strcat "/c " command))
4172                           ;; NB: On other Windows implementations, this is utterly bogus
4173                           ;; except in the most trivial cases where no quoting is needed.
4174                           ;; Use at your own risk.
4175                           #-(or allegro clozure) (list "cmd" "/c" command))
4176                          #+os-windows
4177                          (list
4178                           #+(or allegro clozure) (escape-windows-command command)
4179                           #-(or allegro clozure) command)))
4180                      #+(and clozure os-windows) (command (list command))
4181                      (process*
4182                        (multiple-value-list
4183                         #+allegro
4184                         (excl:run-shell-command
4185                          #+os-unix (coerce (cons (first command) command) 'vector)
4186                          #+os-windows command
4187                          :input interactive :output (or (and pipe :stream) interactive) :wait wait
4188                          #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
4189                         #+clisp
4190                         (flet ((run (f &rest args)
4191                                  (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
4192                                                    ,(if pipe :stream :terminal)))))
4193                           (etypecase command
4194                             #+os-windows (run 'ext:run-shell-command command)
4195                             (list (run 'ext:run-program (car command)
4196                                        :arguments (cdr command)))))
4197                         #+lispworks
4198                         (system:run-shell-command
4199                          (cons "/usr/bin/env" command) ; lispworks wants a full path.
4200                          :input interactive :output (or (and pipe :stream) interactive)
4201                          :wait wait :save-exit-status (and pipe t))
4202                         #+(or clozure cmu ecl sbcl scl)
4203                         (#+(or cmu ecl scl) ext:run-program
4204                            #+clozure ccl:run-program
4205                            #+sbcl sb-ext:run-program
4206                            (car command) (cdr command)
4207                            :input interactive :wait wait
4208                            :output (if pipe :stream t)
4209                            . #.(append
4210                                 #+(or clozure cmu ecl sbcl scl) '(:error t)
4211                                 ;; note: :external-format requires a recent SBCL
4212                                 #+sbcl '(:search t :external-format external-format)))))
4213                      (process
4214                        #+allegro (if pipe (third process*) (first process*))
4215                        #+ecl (third process*)
4216                        #-(or allegro ecl) (first process*))
4217                      (stream
4218                        (when pipe
4219                          #+(or allegro lispworks ecl) (first process*)
4220                          #+clisp (first process*)
4221                          #+clozure (ccl::external-process-output process)
4222                          #+(or cmu scl) (ext:process-output process)
4223                          #+sbcl (sb-ext:process-output process))))
4224                 (values process stream)))
4225             #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
4226             (process-result (process pipe)
4227               (declare (ignorable pipe))
4228               ;; 1- wait
4229               #+(and clozure os-unix) (ccl::external-process-wait process)
4230               #+(or cmu scl) (ext:process-wait process)
4231               #+(and ecl os-unix) (ext:external-process-wait process)
4232               #+sbcl (sb-ext:process-wait process)
4233               ;; 2- extract result
4234               #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
4235               #+clisp process
4236               #+clozure (nth-value 1 (ccl:external-process-status process))
4237               #+(or cmu scl) (ext:process-exit-code process)
4238               #+ecl (nth-value 1 (ext:external-process-status process))
4239               #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
4240               #+sbcl (sb-ext:process-exit-code process))
4241             (check-result (exit-code process)
4242               #+clisp
4243               (setf exit-code
4244                     (typecase exit-code (integer exit-code) (null 0) (t -1)))
4245               (unless (or ignore-error-status
4246                           (equal exit-code 0))
4247                 (error 'subprocess-error :command command :code exit-code :process process))
4248               exit-code)
4249             (use-run-program ()
4250               #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
4251               (let* ((interactive (eq output :interactive))
4252                      (pipe (and output (not interactive))))
4253                 (multiple-value-bind (process stream)
4254                     (run-program command :pipe pipe :interactive interactive)
4255                   (if (and output (not interactive))
4256                       (unwind-protect
4257                            (slurp-input-stream output stream)
4258                         (when stream (close stream))
4259                         (check-result (process-result process pipe) process))
4260                       (unwind-protect
4261                            (check-result
4262                             #+(or allegro lispworks) ; when not capturing, returns the exit code!
4263                             process
4264                             #-(or allegro lispworks) (process-result process pipe)
4265                             process))))))
4266             (system-command (command)
4267               (etypecase command
4268                 (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
4269                 (list (escape-shell-command
4270                        (if (os-unix-p) (cons "exec" command) command)))))
4271             (redirected-system-command (command out)
4272               (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
4273                       (system-command command) (native-namestring out)))
4274             (system (command &key interactive)
4275               (declare (ignorable interactive))
4276               #+(or abcl xcl) (ext:run-shell-command command)
4277               #+allegro
4278               (excl:run-shell-command
4279                command :input interactive :output interactive :wait t
4280                        #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
4281               #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
4282               (process-result (run-program command :pipe nil :interactive interactive) nil)
4283               #+ecl (ext:system command)
4284               #+cormanlisp (win32:system command)
4285               #+gcl (lisp:system command)
4286               #+(and lispworks os-windows)
4287               (system:call-system-showing-output
4288                command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
4289               #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
4290               #+mkcl (nth-value 2
4291                                 (mkcl:run-program #+windows command #+windows ()
4292                                                   #-windows "/bin/sh" (list "-c" command)
4293                                                   :input nil :output nil)))
4294             (call-system (command-string &key interactive)
4295               (check-result (system command-string :interactive interactive) nil))
4296             (use-system ()
4297               (let ((interactive (eq output :interactive)))
4298                 (if (and output (not interactive))
4299                     (with-temporary-file (:pathname tmp :direction :output)
4300                       (call-system (redirected-system-command command tmp))
4301                       (with-open-file (stream tmp
4302                                               :direction :input
4303                                               :if-does-not-exist :error
4304                                               :element-type element-type
4305                                               #-gcl2.6 :external-format #-gcl2.6 external-format)
4306                         (slurp-input-stream output stream)))
4307                     (call-system (system-command command) :interactive interactive)))))
4308      (if (and (not force-shell)
4309               #+(or clisp ecl) ignore-error-status
4310               #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
4311          (use-run-program)
4312          (use-system)))))
4313
4314;;;; -------------------------------------------------------------------------
4315;;;; Support to build (compile and load) Lisp files
4316
4317(uiop/package:define-package :uiop/lisp-build
4318  (:nicknames :asdf/lisp-build)
4319  (:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
4320  (:use :uiop/common-lisp :uiop/package :uiop/utility
4321   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
4322  (:export
4323   ;; Variables
4324   #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
4325   #:*output-translation-function*
4326   #:*optimization-settings* #:*previous-optimization-settings*
4327   #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
4328   #:compile-warned-warning #:compile-failed-warning
4329   #:check-lisp-compile-results #:check-lisp-compile-warnings
4330   #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
4331   ;; Types
4332   #+sbcl #:sb-grovel-unknown-constant-condition
4333   ;; Functions & Macros
4334   #:get-optimization-settings #:proclaim-optimization-settings
4335   #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
4336   #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
4337   #:reify-simple-sexp #:unreify-simple-sexp
4338   #:reify-deferred-warnings #:unreify-deferred-warnings
4339   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
4340   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
4341   #:enable-deferred-warnings-check #:disable-deferred-warnings-check
4342   #:current-lisp-file-pathname #:load-pathname
4343   #:lispize-pathname #:compile-file-type #:call-around-hook
4344   #:compile-file* #:compile-file-pathname*
4345   #:load* #:load-from-string #:combine-fasls)
4346  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
4347(in-package :uiop/lisp-build)
4348
4349(with-upgradability ()
4350  (defvar *compile-file-warnings-behaviour*
4351    (or #+clisp :ignore :warn)
4352    "How should ASDF react if it encounters a warning when compiling a file?
4353Valid values are :error, :warn, and :ignore.")
4354
4355  (defvar *compile-file-failure-behaviour*
4356    (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
4357    "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
4358when compiling a file, which includes any non-style-warning warning.
4359Valid values are :error, :warn, and :ignore.
4360Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
4361
4362
4363;;; Optimization settings
4364(with-upgradability ()
4365  (defvar *optimization-settings* nil)
4366  (defvar *previous-optimization-settings* nil)
4367  (defun get-optimization-settings ()
4368    "Get current compiler optimization settings, ready to PROCLAIM again"
4369    #-(or clisp clozure cmu ecl sbcl scl)
4370    (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
4371    #+clozure (ccl:declaration-information 'optimize nil)
4372    #+(or clisp cmu ecl sbcl scl)
4373    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
4374      #.`(loop :for x :in settings
4375               ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
4376                     #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
4377               :for y = (or #+clisp (gethash x system::*optimize*)
4378                            #+(or ecl) (symbol-value v)
4379                            #+(or cmu scl) (funcall f c::*default-cookie*)
4380                            #+sbcl (cdr (assoc x sb-c::*policy*)))
4381               :when y :collect (list x y))))
4382  (defun proclaim-optimization-settings ()
4383    "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
4384    (proclaim `(optimize ,@*optimization-settings*))
4385    (let ((settings (get-optimization-settings)))
4386      (unless (equal *previous-optimization-settings* settings)
4387        (setf *previous-optimization-settings* settings)))))
4388
4389
4390;;; Condition control
4391(with-upgradability ()
4392  #+sbcl
4393  (progn
4394    (defun sb-grovel-unknown-constant-condition-p (c)
4395      (and (typep c 'sb-int:simple-style-warning)
4396           (string-enclosed-p
4397            "Couldn't grovel for "
4398            (simple-condition-format-control c)
4399            " (unknown to the C compiler).")))
4400    (deftype sb-grovel-unknown-constant-condition ()
4401      '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
4402
4403  (defvar *usual-uninteresting-conditions*
4404    (append
4405     ;;#+clozure '(ccl:compiler-warning)
4406     #+cmu '("Deleting unreachable code.")
4407     #+lispworks '("~S being redefined in ~A (previously in ~A)."
4408                   "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4409     #+sbcl
4410     '(sb-c::simple-compiler-note
4411       "&OPTIONAL and &KEY found in the same lambda list: ~S"
4412       #+sb-eval sb-kernel:lexical-environment-too-complex
4413       sb-kernel:undefined-alien-style-warning
4414       sb-grovel-unknown-constant-condition ; defined above.
4415       sb-ext:implicit-generic-function-warning ;; Controversial.
4416       sb-int:package-at-variance
4417       sb-kernel:uninteresting-redefinition
4418       ;; BEWARE: the below four are controversial to include here.
4419       sb-kernel:redefinition-with-defun
4420       sb-kernel:redefinition-with-defgeneric
4421       sb-kernel:redefinition-with-defmethod
4422       sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs