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

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

Include ASDF 2.30.

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