source: release/1.9/source/tools/asdf.lisp @ 15634

Last change on this file since 15634 was 15634, checked in by rme, 6 years ago

Merge ASDF 2.28 from trunk.

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