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

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

Merge ASDF 2.29 from trunk.

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