1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2 ;;; This is ASDF 3.0.2: Another System Definition Facility.
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/>.
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'
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)
22 ;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
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:
32 ;;; The above copyright notice and this permission notice shall be
33 ;;; included in all copies or substantial portions of the Software.
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.
45 ;;; The problem with writing a defsystem replacement is bootstrapping:
46 ;;; we can't use defsystem to compile it. Hence, all in one file.
53 (eval-when (:load-toplevel :compile-toplevel :execute)
54 (declaim (optimize (speed 1) (safety 3) (debug 3)))
55 (setf ext:*gc-verbose* nil))
57 #+(or abcl clisp clozure cmu ecl xcl)
58 (eval-when (:load-toplevel :compile-toplevel :execute)
59 (unless (member :asdf3 *features*)
60 (let* ((existing-version
61 (when (find-package :asdf)
62 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
63 (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
66 (cons (format nil "~{~D~^.~}" ver))
68 (first-dot (when existing-version (position #\. existing-version)))
69 (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot))))
70 (existing-major-minor (subseq existing-version 0 second-dot))
71 (existing-version-number (and existing-version (read-from-string existing-major-minor)))
72 (away (format nil "~A-~A" :asdf existing-version)))
73 (when (and existing-version
74 (< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))
75 (rename-package :asdf away)
77 (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
79 ;;;; ---------------------------------------------------------------------------
80 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
82 ;; See https://bugs.launchpad.net/asdf/+bug/485687
85 (defpackage :uiop/package
86 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
87 ;; This package definition MUST NOT change unless its name too changes;
88 ;; if/when it changes, don't forget to add new functions missing from below.
89 ;; Until then, asdf/package is frozen to forever
90 ;; import and export the same exact symbols as for ASDF 2.27.
91 ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
94 #:find-package* #:find-symbol* #:symbol-call
95 #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
96 #:symbol-shadowing-p #:home-package-p
97 #:symbol-package-name #:standard-common-lisp-symbol-p
98 #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
99 #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
100 #:ensure-package-unused #:delete-package*
101 #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
102 #:package-definition-form #:parse-define-package-form
103 #:ensure-package #:define-package))
105 (in-package :uiop/package)
107 ;;;; General purpose package utilities
109 (eval-when (:load-toplevel :compile-toplevel :execute)
110 (defun find-package* (package-designator &optional (error t))
111 (let ((package (find-package package-designator)))
114 (error (error "No package named ~S" (string package-designator)))
116 (defun find-symbol* (name package-designator &optional (error t))
117 "Find a symbol in a package of given string'ified NAME;
118 unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
119 by letting you supply a symbol or keyword for the name;
120 also works well when the package is not present.
121 If optional ERROR argument is NIL, return NIL instead of an error
122 when the symbol is not found."
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)
128 (status (return (values symbol status)))
129 (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
131 (defun symbol-call (package name &rest args)
132 "Call a function associated with symbol of given name in given package,
133 with given ARGS. Useful when the call is read before the package is loaded,
134 or when loading the package is optional."
135 (apply (find-symbol* name package) args))
136 (defun intern* (name package-designator &optional (error t))
137 (intern (string name) (find-package* package-designator error)))
138 (defun export* (name package-designator)
139 (let* ((package (find-package* package-designator))
140 (symbol (intern* name package)))
141 (export (or symbol (list symbol)) package)))
142 (defun import* (symbol package-designator)
143 (import (or symbol (list symbol)) (find-package* package-designator)))
144 (defun shadowing-import* (symbol package-designator)
145 (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
146 (defun shadow* (name package-designator)
147 (shadow (string name) (find-package* package-designator)))
148 (defun make-symbol* (name)
150 (string (make-symbol name))
151 (symbol (copy-symbol name))))
152 (defun unintern* (name package-designator &optional (error t))
154 (let ((package (find-package* package-designator error)))
156 (multiple-value-bind (symbol status) (find-symbol* name package error)
158 (status (unintern symbol package)
159 (return (values symbol status)))
160 (error (error "symbol ~A not present in package ~A"
161 (string symbol) (package-name package))))))
163 (defun symbol-shadowing-p (symbol package)
164 (and (member symbol (package-shadowing-symbols package)) t))
165 (defun home-package-p (symbol package)
166 (and package (let ((sp (symbol-package symbol)))
167 (and sp (let ((pp (find-package* package)))
168 (and pp (eq sp pp))))))))
171 (eval-when (:load-toplevel :compile-toplevel :execute)
172 (defun symbol-package-name (symbol)
173 (let ((package (symbol-package symbol)))
174 (and package (package-name package))))
175 (defun standard-common-lisp-symbol-p (symbol)
176 (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
177 (and (eq sym symbol) (eq status :external))))
178 (defun reify-package (package &optional package-context)
179 (if (eq package package-context) t
182 ((eql (find-package :cl)) :cl)
183 (package (package-name package)))))
184 (defun unreify-package (package &optional package-context)
187 ((eql t) package-context)
188 ((or symbol string) (find-package package))))
189 (defun reify-symbol (symbol &optional package-context)
191 ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
192 (symbol (vector (symbol-name symbol)
193 (reify-package (symbol-package symbol) package-context)))))
194 (defun unreify-symbol (symbol &optional package-context)
198 (let* ((symbol-name (svref symbol 0))
199 (package-foo (svref symbol 1))
200 (package (unreify-package package-foo package-context)))
201 (if package (intern* symbol-name package)
202 (make-symbol* symbol-name)))))))
204 (eval-when (:load-toplevel :compile-toplevel :execute)
205 (defvar *all-package-happiness* '())
206 (defvar *all-package-fishiness* (list t))
207 (defun record-fishy (info)
208 ;;(format t "~&FISHY: ~S~%" info)
209 (push info *all-package-fishiness*))
210 (defmacro when-package-fishiness (&body body)
211 `(when *all-package-fishiness* ,@body))
212 (defmacro note-package-fishiness (&rest info)
213 `(when-package-fishiness (record-fishy (list ,@info)))))
215 (eval-when (:load-toplevel :compile-toplevel :execute)
217 (defun get-setf-function-symbol (symbol)
218 #+clisp (let ((sym (get symbol 'system::setf-function)))
219 (if sym (values sym :setf-function)
220 (let ((sym (get symbol 'system::setf-expander)))
221 (if sym (values sym :setf-expander)
223 #+clozure (gethash symbol ccl::%setf-function-names%))
225 (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
226 #+clisp (assert (member kind '(:setf-function :setf-expander)))
227 #+clozure (assert (eq kind t))
230 ((null new-setf-symbol)
231 (remprop symbol 'system::setf-function)
232 (remprop symbol 'system::setf-expander))
233 ((eq kind :setf-function)
234 (setf (get symbol 'system::setf-function) new-setf-symbol))
235 ((eq kind :setf-expander)
236 (setf (get symbol 'system::setf-expander) new-setf-symbol))
237 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
238 kind symbol new-setf-symbol)))
241 (gethash symbol ccl::%setf-function-names%) new-setf-symbol
242 (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
244 (defun create-setf-function-symbol (symbol)
245 #+clisp (system::setf-symbol symbol)
246 #+clozure (ccl::construct-setf-function-name symbol))
247 (defun set-dummy-symbol (symbol reason other-symbol)
248 (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
249 (defun make-dummy-symbol (symbol)
250 (let ((dummy (copy-symbol symbol)))
251 (set-dummy-symbol dummy 'replacing symbol)
252 (set-dummy-symbol symbol 'replaced-by dummy)
254 (defun dummy-symbol (symbol)
255 (get symbol 'dummy-symbol))
256 (defun get-dummy-symbol (symbol)
257 (let ((existing (dummy-symbol symbol)))
258 (if existing (values (cdr existing) (car existing))
259 (make-dummy-symbol symbol))))
260 (defun nuke-symbol-in-package (symbol package-designator)
261 (let ((package (find-package* package-designator))
262 (name (symbol-name symbol)))
263 (multiple-value-bind (sym stat) (find-symbol name package)
264 (when (and (member stat '(:internal :external)) (eq symbol sym))
265 (if (symbol-shadowing-p symbol package)
266 (shadowing-import* (get-dummy-symbol symbol) package)
267 (unintern* symbol package))))))
268 (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
270 (multiple-value-bind (setf-symbol kind)
271 (get-setf-function-symbol symbol)
272 (when kind (nuke-symbol setf-symbol)))
273 (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
274 (defun rehome-symbol (symbol package-designator)
275 "Changes the home package of a symbol, also leaving it present in its old home if any"
276 (let* ((name (symbol-name symbol))
277 (package (find-package* package-designator))
278 (old-package (symbol-package symbol))
279 (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
280 (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
281 (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
282 (unless (eq package old-package)
283 (let ((overwritten-symbol-shadowing-p
284 (and overwritten-symbol-status
285 (symbol-shadowing-p overwritten-symbol package))))
286 (note-package-fishiness
288 (when old-package (package-name old-package)) old-status (and shadowing t)
289 (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
292 (shadowing-import* shadowing old-package))
293 (unintern* symbol old-package))
295 (overwritten-symbol-shadowing-p
296 (shadowing-import* symbol package))
298 (when overwritten-symbol-status
299 (unintern* overwritten-symbol package))
300 (import* symbol package)))
302 (shadowing-import* symbol old-package)
303 (import* symbol old-package))
305 (multiple-value-bind (setf-symbol kind)
306 (get-setf-function-symbol symbol)
308 (let* ((setf-function (fdefinition setf-symbol))
309 (new-setf-symbol (create-setf-function-symbol symbol)))
310 (note-package-fishiness
312 name (package-name package)
313 (symbol-name setf-symbol) (symbol-package-name setf-symbol)
314 (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
315 (when (symbol-package setf-symbol)
316 (unintern* setf-symbol (symbol-package setf-symbol)))
317 (setf (fdefinition new-setf-symbol) setf-function)
318 (set-setf-function-symbol new-setf-symbol symbol kind))))
320 (multiple-value-bind (overwritten-setf foundp)
321 (get-setf-function-symbol overwritten-symbol)
323 (unintern overwritten-setf)))
324 (when (eq old-status :external)
325 (export* symbol old-package))
326 (when (eq overwritten-symbol-status :external)
327 (export* symbol package))))
328 (values overwritten-symbol overwritten-symbol-status))))
329 (defun ensure-package-unused (package)
330 (loop :for p :in (package-used-by-list package) :do
331 (unuse-package package p)))
332 (defun delete-package* (package &key nuke)
333 (let ((p (find-package package)))
335 (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
336 (ensure-package-unused p)
337 (delete-package package))))
338 (defun package-names (package)
339 (cons (package-name package) (package-nicknames package)))
340 (defun packages-from-names (names)
341 (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
342 (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
344 (index (random most-positive-fixnum)))
345 (loop :for i :from index
346 :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
347 :thereis (and (not (find-package n)) n)))
348 (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
350 (apply 'fresh-package-name
351 :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
352 (record-fishy (list :rename-away (package-names p) new-name))
353 (rename-package p new-name))))
356 ;;; Communicable representation of symbol and package information
358 (eval-when (:load-toplevel :compile-toplevel :execute)
359 (defun package-definition-form (package-designator
360 &key (nicknamesp t) (usep t)
361 (shadowp t) (shadowing-import-p t)
362 (exportp t) (importp t) internp (error t))
363 (let* ((package (or (find-package* package-designator error)
364 (return-from package-definition-form nil)))
365 (name (package-name package))
366 (nicknames (package-nicknames package))
367 (use (mapcar #'package-name (package-use-list package)))
369 (shadowing-import (make-hash-table :test 'equal))
370 (import (make-hash-table :test 'equal))
374 (loop :for sym :being :the :symbols :in package
375 :for status = (nth-value 1 (find-symbol* sym package)) :do
378 ((:internal :external)
379 (let* ((name (symbol-name sym))
380 (external (eq status :external))
381 (home (symbol-package sym))
382 (home-name (package-name home))
383 (imported (not (eq home package)))
384 (shadowing (symbol-shadowing-p sym package)))
386 ((and shadowing imported)
387 (push name (gethash home-name shadowing-import)))
391 (push name (gethash home-name import))))
396 (t (push name intern)))))))
397 (labels ((sort-names (names)
398 (sort names #'string<))
400 (loop :for k :being :the :hash-keys :of table :collect k))
401 (when-relevant (key value)
402 (when value (list (cons key value))))
403 (import-options (key table)
404 (loop :for i :in (sort-names (table-keys table))
405 :collect `(,key ,i ,@(sort-names (gethash i table))))))
407 ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
408 (:use ,@(and usep (sort-names use)))
409 ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
410 ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
411 ,@(import-options :import-from (and importp import))
412 ,@(when-relevant :export (and exportp (sort-names export)))
413 ,@(when-relevant :intern (and internp (sort-names intern)))))))))
416 ;;; ensure-package, define-package
417 (eval-when (:load-toplevel :compile-toplevel :execute)
418 (defun ensure-shadowing-import (name to-package from-package shadowed imported)
419 (check-type name string)
420 (check-type to-package package)
421 (check-type from-package package)
422 (check-type shadowed hash-table)
423 (check-type imported hash-table)
424 (let ((import-me (find-symbol* name from-package)))
425 (multiple-value-bind (existing status) (find-symbol name to-package)
427 ((gethash name shadowed)
428 (unless (eq import-me existing)
429 (error "Conflicting shadowings for ~A" name)))
431 (setf (gethash name shadowed) t)
432 (setf (gethash name imported) t)
433 (unless (or (null status)
434 (and (member status '(:internal :external))
435 (eq existing import-me)
436 (symbol-shadowing-p existing to-package)))
437 (note-package-fishiness
438 :shadowing-import name
439 (package-name from-package)
440 (or (home-package-p import-me from-package) (symbol-package-name import-me))
441 (package-name to-package) status
442 (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
443 (shadowing-import* import-me to-package))))))
444 (defun ensure-imported (import-me into-package &optional from-package)
445 (check-type import-me symbol)
446 (check-type into-package package)
447 (check-type from-package (or null package))
448 (let ((name (symbol-name import-me)))
449 (multiple-value-bind (existing status) (find-symbol name into-package)
452 (import* import-me into-package))
453 ((eq import-me existing))
455 (let ((shadowing-p (symbol-shadowing-p existing into-package)))
456 (note-package-fishiness
457 :ensure-imported name
458 (and from-package (package-name from-package))
459 (or (home-package-p import-me from-package) (symbol-package-name import-me))
460 (package-name into-package)
462 (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
465 ((or shadowing-p (eq status :inherited))
466 (shadowing-import* import-me into-package))
468 (unintern* existing into-package)
469 (import* import-me into-package))))))))
471 (defun ensure-import (name to-package from-package shadowed imported)
472 (check-type name string)
473 (check-type to-package package)
474 (check-type from-package package)
475 (check-type shadowed hash-table)
476 (check-type imported hash-table)
477 (multiple-value-bind (import-me import-status) (find-symbol name from-package)
478 (when (null import-status)
479 (note-package-fishiness
480 :import-uninterned name (package-name from-package) (package-name to-package))
481 (setf import-me (intern* name from-package)))
482 (multiple-value-bind (existing status) (find-symbol name to-package)
484 ((and imported (gethash name imported))
485 (unless (and status (eq import-me existing))
486 (error "Can't import ~S from both ~S and ~S"
487 name (package-name (symbol-package existing)) (package-name from-package))))
488 ((gethash name shadowed)
489 (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
491 (setf (gethash name imported) t))))
492 (ensure-imported import-me to-package from-package)))
493 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
494 (check-type name string)
495 (check-type symbol symbol)
496 (check-type to-package package)
497 (check-type from-package package)
498 (check-type mixp (member nil t)) ; no cl:boolean on Genera
499 (check-type shadowed hash-table)
500 (check-type imported hash-table)
501 (check-type inherited hash-table)
502 (multiple-value-bind (existing status) (find-symbol name to-package)
503 (let* ((sp (symbol-package symbol))
504 (in (gethash name inherited))
505 (xp (and status (symbol-package existing))))
507 (note-package-fishiness
508 :import-uninterned name
509 (package-name from-package) (package-name to-package) mixp)
510 (import* symbol from-package)
511 (setf sp (package-name from-package)))
513 ((gethash name shadowed))
515 (unless (equal sp (first in))
517 (ensure-shadowing-import name to-package (second in) shadowed imported)
518 (error "Can't inherit ~S from ~S, it is inherited from ~S"
519 name (package-name sp) (package-name (first in))))))
520 ((gethash name imported)
521 (unless (eq symbol existing)
522 (error "Can't inherit ~S from ~S, it is imported from ~S"
523 name (package-name sp) (package-name xp))))
525 (setf (gethash name inherited) (list sp from-package))
526 (when (and status (not (eq sp xp)))
527 (let ((shadowing (symbol-shadowing-p existing to-package)))
528 (note-package-fishiness
530 (package-name from-package)
531 (or (home-package-p symbol from-package) (symbol-package-name symbol))
532 (package-name to-package)
533 (or (home-package-p existing to-package) (symbol-package-name existing)))
534 (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
535 (unintern* existing to-package)))))))))
536 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
537 (check-type name string)
538 (check-type symbol symbol)
539 (check-type to-package package)
540 (check-type from-package package)
541 (check-type shadowed hash-table)
542 (check-type imported hash-table)
543 (check-type inherited hash-table)
544 (unless (gethash name shadowed)
545 (multiple-value-bind (existing status) (find-symbol name to-package)
546 (let* ((sp (symbol-package symbol))
547 (im (gethash name imported))
548 (in (gethash name inherited)))
551 (and status (eq symbol existing))
552 (and in (eq sp (first in))))
553 (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
555 (remhash name inherited)
556 (ensure-shadowing-import name to-package (second in) shadowed imported))
558 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
559 name (package-name from-package)
560 (home-package-p symbol from-package) (symbol-package-name symbol)
561 (package-name to-package)
562 (home-package-p existing to-package) (symbol-package-name existing)))
564 (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
565 (defun recycle-symbol (name recycle exported)
566 (check-type name string)
567 (check-type recycle list)
568 (check-type exported hash-table)
569 (when (gethash name exported) ;; don't bother recycling private symbols
570 (let (recycled foundp)
571 (dolist (r recycle (values recycled foundp))
572 (multiple-value-bind (symbol status) (find-symbol name r)
573 (when (and status (home-package-p symbol r))
576 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
577 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
579 (setf recycled symbol foundp r)))))))))
580 (defun symbol-recycled-p (sym recycle)
581 (check-type sym symbol)
582 (check-type recycle list)
583 (and (member (symbol-package sym) recycle) t))
584 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
585 (check-type name string)
586 (check-type package package)
587 (check-type intern (member nil t)) ; no cl:boolean on Genera
588 (check-type shadowed hash-table)
589 (check-type imported hash-table)
590 (check-type inherited hash-table)
591 (unless (or (gethash name shadowed)
592 (gethash name imported)
593 (gethash name inherited))
594 (multiple-value-bind (existing status)
595 (find-symbol name package)
596 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
598 ((and status (eq existing recycled) (eq previous package)))
600 (rehome-symbol recycled package))
601 ((and status (eq package (symbol-package existing))))
604 (note-package-fishiness
606 (reify-package (symbol-package existing) package)
610 (intern* name package))))))))
611 (declaim (ftype function ensure-exported))
612 (defun ensure-exported-to-user (name symbol to-package &optional recycle)
613 (check-type name string)
614 (check-type symbol symbol)
615 (check-type to-package package)
616 (check-type recycle list)
617 (assert (equal name (symbol-name symbol)))
618 (multiple-value-bind (existing status) (find-symbol name to-package)
619 (unless (and status (eq symbol existing))
622 (let ((shadowing (symbol-shadowing-p existing to-package))
623 (recycled (symbol-recycled-p existing recycle)))
624 (unless (and shadowing (not recycled))
625 (note-package-fishiness
626 :ensure-export name (symbol-package-name symbol)
627 (package-name to-package)
628 (or (home-package-p existing to-package) (symbol-package-name existing))
630 (if (or (eq status :inherited) shadowing)
631 (shadowing-import* symbol to-package)
632 (unintern existing to-package))
634 (when (and accessible (eq status :external))
635 (ensure-exported name symbol to-package recycle))))))
636 (defun ensure-exported (name symbol from-package &optional recycle)
637 (dolist (to-package (package-used-by-list from-package))
638 (ensure-exported-to-user name symbol to-package recycle))
639 (unless (eq from-package (symbol-package symbol))
640 (ensure-imported symbol from-package))
641 (export* name from-package))
642 (defun ensure-export (name from-package &optional recycle)
643 (multiple-value-bind (symbol status) (find-symbol* name from-package)
644 (unless (eq status :external)
645 (ensure-exported name symbol from-package recycle))))
646 (defun ensure-package (name &key
647 nicknames documentation use
648 shadow shadowing-import-from
649 import-from export intern
652 #+(or gcl2.6 genera) (declare (ignore documentation))
653 (let* ((package-name (string name))
654 (nicknames (mapcar #'string nicknames))
655 (names (cons package-name nicknames))
656 (previous (packages-from-names names))
657 (discarded (cdr previous))
659 (package (or (first previous) (make-package package-name :nicknames nicknames)))
660 (recycle (packages-from-names recycle))
661 (use (mapcar 'find-package* use))
662 (mix (mapcar 'find-package* mix))
663 (reexport (mapcar 'find-package* reexport))
664 (shadow (mapcar 'string shadow))
665 (export (mapcar 'string export))
666 (intern (mapcar 'string intern))
667 (unintern (mapcar 'string unintern))
668 (shadowed (make-hash-table :test 'equal)) ; string to bool
669 (imported (make-hash-table :test 'equal)) ; string to bool
670 (exported (make-hash-table :test 'equal)) ; string to bool
671 ;; string to list home package and use package:
672 (inherited (make-hash-table :test 'equal)))
673 (when-package-fishiness (record-fishy package-name))
675 (when documentation (setf (documentation package t) documentation))
676 (loop :for p :in (set-difference (package-use-list package) (append mix use))
677 :do (note-package-fishiness :over-use name (package-names p))
678 (unuse-package p package))
679 (loop :for p :in discarded
680 :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
682 :do (note-package-fishiness :nickname name (package-names p))
683 (cond (n (rename-package p (first n) (rest n)))
684 (t (rename-package-away p)
685 (push p to-delete))))
686 (rename-package package package-name nicknames)
687 (dolist (name unintern)
688 (multiple-value-bind (existing status) (find-symbol name package)
690 (unless (eq status :inherited)
691 (note-package-fishiness
692 :unintern (package-name package) name (symbol-package-name existing) status)
693 (unintern* name package nil)))))
694 (dolist (name export)
695 (setf (gethash name exported) t))
697 (do-external-symbols (sym p)
698 (setf (gethash (string sym) exported) t)))
699 (do-external-symbols (sym package)
700 (let ((name (symbol-name sym)))
701 (unless (gethash name exported)
702 (note-package-fishiness
703 :over-export (package-name package) name
704 (or (home-package-p sym package) (symbol-package-name sym)))
705 (unexport sym package))))
706 (dolist (name shadow)
707 (setf (gethash name shadowed) t)
708 (multiple-value-bind (existing status) (find-symbol name package)
709 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
710 (let ((shadowing (and status (symbol-shadowing-p existing package))))
712 ((eq previous package))
714 (rehome-symbol recycled package))
715 ((or (member status '(nil :inherited))
716 (home-package-p existing package)))
718 (let ((dummy (make-symbol name)))
719 (note-package-fishiness
720 :shadow-imported (package-name package) name
721 (symbol-package-name existing) status shadowing)
722 (shadowing-import* dummy package)
723 (import* dummy package)))))))
724 (shadow* name package))
725 (loop :for (p . syms) :in shadowing-import-from
726 :for pp = (find-package* p) :do
727 (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
729 :for pp = (find-package* p) :do
730 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
731 (loop :for (p . syms) :in import-from
732 :for pp = (find-package p) :do
733 (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
734 (dolist (p (append use mix))
735 (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
736 (use-package p package))
737 (loop :for name :being :the :hash-keys :of exported :do
738 (ensure-symbol name package t recycle shadowed imported inherited exported)
739 (ensure-export name package recycle))
740 (dolist (name intern)
741 (ensure-symbol name package t recycle shadowed imported inherited exported))
742 (do-symbols (sym package)
743 (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
744 (map () 'delete-package* to-delete)
747 (eval-when (:load-toplevel :compile-toplevel :execute)
748 (defun parse-define-package-form (package clauses)
750 :with use-p = nil :with recycle-p = nil
751 :with documentation = nil
752 :for (kw . args) :in clauses
753 :when (eq kw :nicknames) :append args :into nicknames :else
754 :when (eq kw :documentation)
756 (documentation (error "define-package: can't define documentation twice"))
757 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
758 (t (setf documentation (car args)))) :else
759 :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
760 :when (eq kw :shadow) :append args :into shadow :else
761 :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
762 :when (eq kw :import-from) :collect args :into import-from :else
763 :when (eq kw :export) :append args :into export :else
764 :when (eq kw :intern) :append args :into intern :else
765 :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
766 :when (eq kw :mix) :append args :into mix :else
767 :when (eq kw :reexport) :append args :into reexport :else
768 :when (eq kw :unintern) :append args :into unintern :else
769 :do (error "unrecognized define-package keyword ~S" kw)
770 :finally (return `(,package
771 :nicknames ,nicknames :documentation ,documentation
772 :use ,(if use-p use '(:common-lisp))
773 :shadow ,shadow :shadowing-import-from ,shadowing-import-from
774 :import-from ,import-from :export ,export :intern ,intern
775 :recycle ,(if recycle-p recycle (cons package nicknames))
776 :mix ,mix :reexport ,reexport :unintern ,unintern)))))
778 (defmacro define-package (package &rest clauses)
780 `(apply 'ensure-package ',(parse-define-package-form package clauses))))
783 (eval-when (:compile-toplevel :load-toplevel :execute)
785 #+(or clisp ecl gcl) (defpackage ,package (:use))
786 (eval-when (:compile-toplevel :load-toplevel :execute)
789 ;;;; Final tricks to keep various implementations happy.
790 ;; We want most such tricks in common-lisp.lisp,
791 ;; but these need to be done before the define-package form there,
792 ;; that we nevertheless want to be the very first form.
793 (eval-when (:load-toplevel :compile-toplevel :execute)
794 #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
795 (setf excl::*autoload-package-name-alist*
796 (remove "asdf" excl::*autoload-package-name-alist*
797 :test 'equalp :key 'car))
799 ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
800 ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
802 ((or (< system::*gcl-major-version* 2)
803 (and (= system::*gcl-major-version* 2)
804 (< system::*gcl-minor-version* 6)))
805 (error "GCL 2.6 or later required to use ASDF"))
806 ((and (= system::*gcl-major-version* 2)
807 (= system::*gcl-minor-version* 6))
808 (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
809 (pushnew :gcl2.6 *features*))
811 (pushnew :gcl2.7 *features*))))
813 ;; Compatibility with whoever calls asdf/package
814 (define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
815 ;;;; -------------------------------------------------------------------------
816 ;;;; Handle compatibility with multiple implementations.
817 ;;; This file is for papering over the deficiencies and peculiarities
818 ;;; of various Common Lisp implementations.
819 ;;; For implementation-specific access to the system, see os.lisp instead.
820 ;;; A few functions are defined here, but actually exported from utility;
821 ;;; from this package only common-lisp symbols are exported.
823 (uiop/package:define-package :uiop/common-lisp
824 (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
825 (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
826 (:reexport :common-lisp)
827 (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
828 #+allegro (:intern #:*acl-warn-save*)
829 #+cormanlisp (:shadow #:user-homedir-pathname)
832 #:logical-pathname #:translate-logical-pathname
833 #:make-broadcast-stream #:file-namestring)
834 #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
835 #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
836 #+genera (:shadowing-import-from :scl #:boolean)
837 #+genera (:export #:boolean #:ensure-directories-exist)
838 #+mcl (:shadow #:user-homedir-pathname))
839 (in-package :uiop/common-lisp)
841 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
842 (error "ASDF is not supported on your implementation. Please help us port it.")
844 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
847 ;;;; Early meta-level tweaks
849 #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
850 clozure lispworks (and sbcl sb-unicode) scl)
851 (eval-when (:load-toplevel :compile-toplevel :execute)
852 (pushnew :asdf-unicode *features*))
855 (eval-when (:load-toplevel :compile-toplevel :execute)
856 (defparameter *acl-warn-save*
857 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
858 excl:*warn-on-nested-reader-conditionals*))
859 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
860 (setf excl:*warn-on-nested-reader-conditionals* nil))
861 (setf *print-readably* nil))
864 (eval-when (:load-toplevel :compile-toplevel :execute)
865 (deftype logical-pathname () nil)
866 (defun make-broadcast-stream () *error-output*)
867 (defun translate-logical-pathname (x) x)
868 (defun user-homedir-pathname (&optional host)
869 (declare (ignore host))
870 (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
871 (defun file-namestring (p)
872 (setf p (pathname p))
873 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
876 (eval-when (:load-toplevel :compile-toplevel :execute)
877 (setf *load-verbose* nil)
878 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
879 (unless (use-ecl-byte-compiler-p) (require :cmp)))
881 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
882 (eval-when (:load-toplevel :compile-toplevel :execute)
883 (unless (member :ansi-cl *features*)
884 (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
885 (setf compiler::*compiler-default-type* (pathname "")
886 compiler::*lsp-ext* ""))
889 (eval-when (:compile-toplevel :load-toplevel :execute)
890 (shadow 'type-of :uiop/common-lisp)
891 (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
894 (eval-when (:compile-toplevel :load-toplevel :execute)
895 (export 'type-of :uiop/common-lisp)
896 (export 'system:*load-pathname* :uiop/common-lisp))
898 #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
899 (eval-when (:load-toplevel :compile-toplevel :execute)
901 (deftype logical-pathname () nil)
902 (defun type-of (x) (class-name (class-of x)))
903 (defun wild-pathname-p (path) (declare (ignore path)) nil)
904 (defun translate-logical-pathname (x) x)
905 (defvar *compile-file-pathname* nil)
906 (defun pathname-match-p (in-pathname wild-pathname)
907 (declare (ignore in-wildname wild-wildname)) nil)
908 (defun translate-pathname (source from-wildname to-wildname &key)
909 (declare (ignore from-wildname to-wildname)) source)
910 (defun %print-unreadable-object (object stream type identity thunk)
911 (format stream "#<~@[~S ~]" (when type (type-of object)))
913 (format stream "~@[ ~X~]>" (when identity (system:address object))))
914 (defmacro with-standard-io-syntax (&body body)
916 (defmacro with-compilation-unit (options &body body)
917 (declare (ignore options)) `(progn ,@body))
918 (defmacro print-unreadable-object ((object stream &key type identity) &body body)
919 `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
920 (defun ensure-directories-exist (path)
921 (lisp:system (format nil "mkdir -p ~S"
922 (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
925 (eval-when (:load-toplevel :compile-toplevel :execute)
926 (unless (fboundp 'ensure-directories-exist)
927 (defun ensure-directories-exist (path)
928 (fs:create-directories-recursively (pathname path)))))
930 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
932 "(eval-when (:load-toplevel :compile-toplevel :execute)
933 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
934 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
935 ;; Note: ASDF may expect user-homedir-pathname to provide
936 ;; the pathname of the current user's home directory, whereas
937 ;; MCL by default provides the directory from which MCL was started.
938 ;; See http://code.google.com/p/mcl/wiki/Portability
939 (defun user-homedir-pathname ()
940 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
941 (defun probe-posix (posix-namestring)
942 \"If a file exists for the posix namestring, return the pathname\"
943 (ccl::with-cstrs ((cpath posix-namestring))
944 (ccl::rlet ((is-dir :boolean)
946 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
947 (ccl::%path-from-fsref fsref is-dir))))))"))
950 (eval-when (:load-toplevel :compile-toplevel :execute)
952 (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
956 (eval-when (:load-toplevel :compile-toplevel :execute)
957 (defmacro loop* (&rest rest)
958 #-genera `(loop ,@rest)
959 #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
962 ;;;; compatfmt: avoid fancy format directives when unsupported
963 (eval-when (:load-toplevel :compile-toplevel :execute)
964 (defun frob-substrings (string substrings &optional frob)
965 (declare (optimize (speed 0) (safety 3) (debug 3)))
966 (let ((length (length string)) (stream nil))
967 (labels ((emit-string (x &optional (start 0) (end (length x)))
969 (unless stream (setf stream (make-string-output-stream)))
970 (write-string x stream :start start :end end)))
971 (emit-substring (start end)
972 (when (and (zerop start) (= end length))
973 (return-from frob-substrings string))
974 (emit-string string start end))
975 (recurse (substrings start end)
978 ((null substrings) (emit-substring start end))
979 (t (let* ((sub-spec (first substrings))
980 (sub (if (consp sub-spec) (car sub-spec) sub-spec))
981 (fun (if (consp sub-spec) (cdr sub-spec) frob))
982 (found (search sub string :start2 start :end2 end))
983 (more (rest substrings)))
986 (recurse more start found)
989 (string (emit-string fun))
990 (function (funcall fun sub #'emit-string)))
991 (recurse substrings (+ found (length sub)) end))
993 (recurse more start end))))))))
994 (recurse substrings 0 length))
995 (if stream (get-output-stream-string stream) "")))
997 (defmacro compatfmt (format)
999 (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
1000 #-(or gcl genera) format))
1003 ;;;; -------------------------------------------------------------------------
1004 ;;;; General Purpose Utilities for ASDF
1006 (uiop/package:define-package :uiop/utility
1007 (:nicknames :asdf/utility)
1008 (:recycle :uiop/utility :asdf/utility :asdf)
1009 (:use :uiop/common-lisp :uiop/package)
1010 ;; import and reexport a few things defined in :asdf/common-lisp
1011 (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
1012 #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1013 (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
1014 #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1016 ;; magic helper to define debugging functions:
1017 #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
1018 #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
1019 #:if-let ;; basic flow control
1020 #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
1021 #:remove-plist-keys #:remove-plist-key ;; plists
1022 #:emptyp ;; sequences
1023 #:+non-base-chars-exist-p+ ;; characters
1024 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
1025 #:first-char #:last-char #:split-string
1026 #:string-prefix-p #:string-enclosed-p #:string-suffix-p
1027 #:find-class* ;; CLOS
1028 #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
1029 #:earlier-stamp #:stamps-earliest #:earliest-stamp
1030 #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
1031 #:list-to-hash-set ;; hash-table
1032 #:ensure-function #:access-at #:access-at-count ;; functions
1033 #:call-function #:call-functions #:register-hook-function
1034 #:match-condition-p #:match-any-condition-p ;; conditions
1035 #:call-with-muffled-conditions #:with-muffled-conditions
1036 #:lexicographic< #:lexicographic<=
1037 #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
1038 (in-package :uiop/utility)
1040 ;;;; Defining functions in a way compatible with hot-upgrade:
1041 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
1042 ;; thus replacing the function without warning or error
1043 ;; even if the signature and/or generic-ness of the function has changed.
1044 ;; For a generic function, this invalidates any previous DEFMETHOD.
1045 (eval-when (:load-toplevel :compile-toplevel :execute)
1046 (defun undefine-function (function-spec)
1048 ((symbolp function-spec)
1050 (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
1051 (when (typep f 'clos:standard-generic-function)
1052 (loop :for m :in (clos:generic-function-methods f)
1053 :do (remove-method f m))))
1054 (fmakunbound function-spec))
1055 ((and (consp function-spec) (eq (car function-spec) 'setf)
1056 (consp (cdr function-spec)) (null (cddr function-spec)))
1057 #-gcl2.6 (fmakunbound function-spec))
1058 (t (error "bad function spec ~S" function-spec))))
1059 (defun undefine-functions (function-spec-list)
1060 (map () 'undefine-function function-spec-list))
1063 `(defmacro ,def* (name formals &rest rest)
1064 (destructuring-bind (name &key (supersede t))
1065 (if (or (atom name) (eq (car name) 'setf))
1066 (list name :supersede nil)
1068 (declare (ignorable supersede))
1070 ;; undefining the previous function is the portable way
1071 ;; of overriding any incompatible previous gf, except on CLISP.
1072 ;; We usually try to do it only for the functions that need it,
1073 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
1074 ;; (which causes issues in clisp)
1075 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
1076 `((undefine-function ',name)))
1077 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
1078 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
1079 `((declaim (notinline ,name))))
1080 (,',def ,name ,formals ,@rest))))))
1081 (defdef defgeneric* defgeneric)
1082 (defdef defun* defun))
1083 (defmacro with-upgradability ((&optional) &body body)
1084 `(eval-when (:compile-toplevel :load-toplevel :execute)
1085 ,@(loop :for form :in body :collect
1087 (destructuring-bind (car . cdr) form
1089 ((defun) `(defun* ,@cdr))
1091 (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
1092 `(defgeneric* ,@cdr)))
1096 ;;; Magic debugging help. See contrib/debug.lisp
1097 (with-upgradability ()
1098 (defvar *uiop-debug-utility*
1100 (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
1101 (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
1102 "form that evaluates to the pathname to your favorite debugging utilities")
1104 (defmacro uiop-debug (&rest keys)
1105 `(eval-when (:compile-toplevel :load-toplevel :execute)
1106 (load-uiop-debug-utility ,@keys)))
1108 (defun load-uiop-debug-utility (&key package utility-file)
1109 (let* ((*package* (if package (find-package package) *package*))
1110 (keyword (read-from-string
1111 (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
1112 (unless (member keyword *features*)
1113 (let* ((utility-file (or utility-file *uiop-debug-utility*))
1114 (file (ignore-errors (probe-file (eval utility-file)))))
1115 (if file (load file)
1116 (error "Failed to locate debug utility file: ~S" utility-file)))))))
1120 (with-upgradability ()
1121 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
1122 ;; bindings can be (var form) or ((var1 form1) ...)
1123 (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
1126 (variables (mapcar #'car binding-list)))
1128 (if (and ,@variables)
1132 ;;; List manipulation
1133 (with-upgradability ()
1134 (defmacro while-collecting ((&rest collectors) &body body)
1135 "COLLECTORS should be a list of names for collections. A collector
1136 defines a function that, when applied to an argument inside BODY, will
1137 add its argument to the corresponding collection. Returns multiple values,
1138 a list for each collection, in order.
1140 \(while-collecting \(foo bar\)
1141 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
1143 \(bar \(second x\)\)\)\)
1144 Returns two values: \(A B C\) and \(1 2 3\)."
1145 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
1146 (initial-values (mapcar (constantly nil) collectors)))
1147 `(let ,(mapcar #'list vars initial-values)
1148 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
1150 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
1152 (define-modify-macro appendf (&rest args)
1153 append "Append onto list") ;; only to be used on short lists.
1155 (defun length=n-p (x n) ;is it that (= (length x) n) ?
1156 (check-type n (integer 0 *))
1158 :for l = x :then (cdr l)
1159 :for i :downfrom n :do
1161 ((zerop i) (return (null l)))
1162 ((not (consp l)) (return nil)))))
1164 (defun ensure-list (x)
1165 (if (listp x) x (list x))))
1168 ;;; remove a key from a plist, i.e. for keyword argument cleanup
1169 (with-upgradability ()
1170 (defun remove-plist-key (key plist)
1171 "Remove a single key from a plist"
1172 (loop* :for (k v) :on plist :by #'cddr
1174 :append (list k v)))
1176 (defun remove-plist-keys (keys plist)
1177 "Remove a list of keys from a plist"
1178 (loop* :for (k v) :on plist :by #'cddr
1179 :unless (member k keys)
1180 :append (list k v))))
1184 (with-upgradability ()
1186 "Predicate that is true for an empty sequence"
1187 (or (null x) (and (vectorp x) (zerop (length x))))))
1191 (with-upgradability ()
1192 (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
1193 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
1197 (with-upgradability ()
1198 (defun base-string-p (string)
1199 (declare (ignorable string))
1200 (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
1202 (defun strings-common-element-type (strings)
1203 (declare (ignorable strings))
1204 #-non-base-chars-exist-p 'character
1205 #+non-base-chars-exist-p
1206 (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
1207 'base-char 'character))
1209 (defun reduce/strcat (strings &key key start end)
1210 "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
1211 NIL is interpreted as an empty string. A character is interpreted as a string of length one."
1212 (when (or start end) (setf strings (subseq strings start end)))
1213 (when key (setf strings (mapcar key strings)))
1214 (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
1215 :element-type (strings-common-element-type strings))
1217 :for input :in strings
1218 :do (etypecase input
1220 (character (setf (char output pos) input) (incf pos))
1221 (string (replace output input :start1 pos) (incf pos (length input))))
1222 :finally (return output)))
1224 (defun strcat (&rest strings)
1225 (reduce/strcat strings))
1227 (defun first-char (s)
1228 (and (stringp s) (plusp (length s)) (char s 0)))
1230 (defun last-char (s)
1231 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
1233 (defun split-string (string &key max (separator '(#\Space #\Tab)))
1234 "Split STRING into a list of components separated by
1235 any of the characters in the sequence SEPARATOR.
1236 If MAX is specified, then no more than max(1,MAX) components will be returned,
1237 starting the separation from the end, e.g. when called with arguments
1238 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1240 (let ((list nil) (words 0) (end (length string)))
1241 (flet ((separatorp (char) (find char separator))
1242 (done () (return (cons (subseq string 0 end) list))))
1244 :for start = (if (and max (>= words (1- max)))
1246 (position-if #'separatorp string :end end :from-end t))
1247 :do (when (null start) (done))
1248 (push (subseq string (1+ start) end) list)
1250 (setf end start))))))
1252 (defun string-prefix-p (prefix string)
1253 "Does STRING begin with PREFIX?"
1254 (let* ((x (string prefix))
1258 (and (<= lx ly) (string= x y :end2 lx))))
1260 (defun string-suffix-p (string suffix)
1261 "Does STRING end with SUFFIX?"
1262 (let* ((x (string string))
1266 (and (<= ly lx) (string= x y :start1 (- lx ly)))))
1268 (defun string-enclosed-p (prefix string suffix)
1269 "Does STRING begin with PREFIX and end with SUFFIX?"
1270 (and (string-prefix-p prefix string)
1271 (string-suffix-p string suffix))))
1275 (with-upgradability ()
1276 (defun find-class* (x &optional (errorp t) environment)
1278 ((or standard-class built-in-class) x)
1279 #+gcl2.6 (keyword nil)
1280 (symbol (find-class x errorp environment)))))
1283 ;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
1284 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
1285 (deftype stamp () '(or real boolean)))
1286 (with-upgradability ()
1295 (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
1296 (defun stamp*< (&rest list) (stamps< list))
1297 (defun stamp<= (x y) (not (stamp< y x)))
1298 (defun earlier-stamp (x y) (if (stamp< x y) x y))
1299 (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
1300 (defun earliest-stamp (&rest list) (stamps-earliest list))
1301 (defun later-stamp (x y) (if (stamp< x y) y x))
1302 (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
1303 (defun latest-stamp (&rest list) (stamps-latest list))
1304 (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
1308 (with-upgradability ()
1309 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
1310 (dolist (x list h) (setf (gethash x h) t))))
1313 ;;; Function designators
1314 (with-upgradability ()
1315 (defun ensure-function (fun &key (package :cl))
1316 "Coerce the object FUN into a function.
1318 If FUN is a FUNCTION, return it.
1319 If the FUN is a non-sequence literal constant, return constantly that,
1320 i.e. for a boolean keyword character number or pathname.
1321 Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1322 If FUN is a CONS, return the function that applies its CAR
1323 to the appended list of the rest of its CDR and the arguments.
1324 If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1325 and EVAL that in a (FUNCTION ...) context."
1328 ((or boolean keyword character number pathname) (constantly fun))
1329 ((or function symbol) fun)
1330 (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
1331 (string (eval `(function ,(with-standard-io-syntax
1332 (let ((*package* (find-package package)))
1333 (read-from-string fun))))))))
1335 (defun access-at (object at)
1336 "Given an OBJECT and an AT specifier, list of successive accessors,
1337 call each accessor on the result of the previous calls.
1338 An accessor may be an integer, meaning a call to ELT,
1339 a keyword, meaning a call to GETF,
1340 NIL, meaning identity,
1341 a function or other symbol, meaning itself,
1342 or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1343 As a degenerate case, the AT specifier may be an atom of a single such accessor
1345 (flet ((access (object accessor)
1347 (function (funcall accessor object))
1348 (integer (elt object accessor))
1349 (keyword (getf object accessor))
1351 (symbol (funcall accessor object))
1352 (cons (funcall (ensure-function accessor) object)))))
1354 (dolist (accessor at object)
1355 (setf object (access object accessor)))
1356 (access object at))))
1358 (defun access-at-count (at)
1359 "From an AT specification, extract a COUNT of maximum number
1360 of sub-objects to read as per ACCESS-AT"
1364 ((and (consp at) (integerp (first at)))
1367 (defun call-function (function-spec &rest arguments)
1368 (apply (ensure-function function-spec) arguments))
1370 (defun call-functions (function-specs)
1371 (map () 'call-function function-specs))
1373 (defun register-hook-function (variable hook &optional call-now-p)
1374 (pushnew hook (symbol-value variable))
1375 (when call-now-p (call-function hook))))
1378 ;;; Version handling
1379 (with-upgradability ()
1380 (defun unparse-version (version-list)
1381 (format nil "~{~D~^.~}" version-list))
1383 (defun parse-version (version-string &optional on-error)
1384 "Parse a VERSION-STRING as a series of natural integers separated by dots.
1385 Return a (non-null) list of integers if the string is valid;
1386 otherwise return NIL.
1388 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1389 with format arguments explaining why the version is invalid.
1390 ON-ERROR is also called if the version is not canonical
1391 in that it doesn't print back to itself, but the list is returned anyway."
1393 (unless (stringp version-string)
1394 (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
1396 (unless (loop :for prev = nil :then c :for c :across version-string
1397 :always (or (digit-char-p c)
1398 (and (eql c #\.) prev (not (eql prev #\.))))
1399 :finally (return (and c (digit-char-p c))))
1400 (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
1401 'parse-version version-string)
1403 (let* ((version-list
1404 (mapcar #'parse-integer (split-string version-string :separator ".")))
1405 (normalized-version (unparse-version version-list)))
1406 (unless (equal version-string normalized-version)
1407 (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
1410 (defun lexicographic< (< x y)
1411 (cond ((null y) nil)
1413 ((funcall < (car x) (car y)) t)
1414 ((funcall < (car y) (car x)) nil)
1415 (t (lexicographic< < (cdr x) (cdr y)))))
1417 (defun lexicographic<= (< x y)
1418 (not (lexicographic< < y x)))
1420 (defun version< (version1 version2)
1421 (let ((v1 (parse-version version1 nil))
1422 (v2 (parse-version version2 nil)))
1423 (lexicographic< '< v1 v2)))
1425 (defun version<= (version1 version2)
1426 (not (version< version2 version1)))
1428 (defun version-compatible-p (provided-version required-version)
1429 "Is the provided version a compatible substitution for the required-version?
1430 If major versions differ, it's not compatible.
1431 If they are equal, then any later version is compatible,
1432 with later being determined by a lexicographical comparison of minor numbers."
1433 (let ((x (parse-version provided-version nil))
1434 (y (parse-version required-version nil)))
1435 (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
1438 ;;; Condition control
1440 (with-upgradability ()
1441 (defparameter +simple-condition-format-control-slot+
1442 #+abcl 'system::format-control
1443 #+allegro 'excl::format-control
1444 #+clisp 'system::$format-control
1445 #+clozure 'ccl::format-control
1446 #+(or cmu scl) 'conditions::format-control
1447 #+ecl 'si::format-control
1448 #+(or gcl lispworks) 'conditions::format-string
1449 #+sbcl 'sb-kernel:format-control
1450 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
1451 "Name of the slot for FORMAT-CONTROL in simple-condition")
1453 (defun match-condition-p (x condition)
1454 "Compare received CONDITION to some pattern X:
1455 a symbol naming a condition class,
1456 a simple vector of length 2, arguments to find-symbol* with result as above,
1457 or a string describing the format-control of a simple-condition."
1459 (symbol (typep condition x))
1461 (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
1462 (function (funcall x condition))
1463 (string (and (typep condition 'simple-condition)
1464 ;; On SBCL, it's always set and the check triggers a warning
1465 #+(or allegro clozure cmu lispworks scl)
1466 (slot-boundp condition +simple-condition-format-control-slot+)
1467 (ignore-errors (equal (simple-condition-format-control condition) x))))))
1469 (defun match-any-condition-p (condition conditions)
1470 "match CONDITION against any of the patterns of CONDITIONS supplied"
1471 (loop :for x :in conditions :thereis (match-condition-p x condition)))
1473 (defun call-with-muffled-conditions (thunk conditions)
1474 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
1475 (muffle-warning c)))))
1478 (defmacro with-muffled-conditions ((conditions) &body body)
1479 `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
1482 ;;;; ---------------------------------------------------------------------------
1483 ;;;; Access to the Operating System
1485 (uiop/package:define-package :uiop/os
1486 (:nicknames :asdf/os)
1487 (:recycle :uiop/os :asdf/os :asdf)
1488 (:use :uiop/common-lisp :uiop/package :uiop/utility)
1490 #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
1491 #:getenv #:getenvp ;; environment variables
1492 #:implementation-identifier ;; implementation identifier
1493 #:implementation-type #:*implementation-type*
1494 #:operating-system #:architecture #:lisp-version-string
1495 #:hostname #:getcwd #:chdir
1496 ;; Windows shortcut support
1497 #:read-null-terminated-string #:read-little-endian
1498 #:parse-file-location-info #:parse-windows-shortcut))
1499 (in-package :uiop/os)
1502 (with-upgradability ()
1503 (defun featurep (x &optional (*features* *features*))
1505 ((atom x) (and (member x *features*) t))
1506 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
1507 ((eq :or (car x)) (some #'featurep (cdr x)))
1508 ((eq :and (car x)) (every #'featurep (cdr x)))
1509 (t (error "Malformed feature specification ~S" x))))
1512 (or #+abcl (featurep :unix)
1513 #+(and (not abcl) (or unix cygwin darwin)) t))
1515 (defun os-windows-p ()
1516 (or #+abcl (featurep :windows)
1517 #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
1519 (defun os-genera-p ()
1522 (defun os-oldmac-p ()
1527 :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
1528 (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
1529 :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
1530 :else :do (setf *features* (remove feature *features*))
1532 (return (or o (error "Congratulations for trying ASDF on an operating system~%~
1533 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
1537 ;;;; Environment variables: getting them, and parsing them.
1539 (with-upgradability ()
1541 (declare (ignorable x))
1542 #+(or abcl clisp ecl xcl) (ext:getenv x)
1543 #+allegro (sys:getenv x)
1544 #+clozure (ccl:getenv x)
1545 #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
1547 (let* ((buffer (ct:malloc 1))
1548 (cname (ct:lisp-string-to-c-string x))
1549 (needed-size (win:getenvironmentvariable cname buffer 0))
1550 (buffer1 (ct:malloc (1+ needed-size))))
1551 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
1553 (ct:c-string-to-lisp-string buffer1))
1556 #+gcl (system:getenv x)
1558 #+lispworks (lispworks:environment-variable x)
1559 #+mcl (ccl:with-cstrs ((name x))
1560 (let ((value (_getenv name)))
1561 (unless (ccl:%null-ptr-p value)
1562 (ccl:%get-cstring value))))
1563 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
1564 #+sbcl (sb-ext:posix-getenv x)
1565 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
1566 (error "~S is not supported on your implementation" 'getenv))
1569 "Predicate that is true if the named variable is present in the libc environment,
1570 then returning the non-empty string value of the variable"
1571 (let ((g (getenv x))) (and (not (emptyp g)) g))))
1574 ;;;; implementation-identifier
1576 ;; produce a string to identify current implementation.
1577 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
1578 ;; We're back to runtime checking, for the sake of e.g. ABCL.
1580 (with-upgradability ()
1581 (defun first-feature (feature-sets)
1582 (dolist (x feature-sets)
1583 (multiple-value-bind (short long feature-expr)
1585 (values (first x) (second x) (cons :or (rest x)))
1587 (when (featurep feature-expr)
1588 (return (values short long))))))
1590 (defun implementation-type ()
1592 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
1593 (:cmu :cmucl :cmu) :ecl :gcl
1594 (:lwpe :lispworks-personal-edition) (:lw :lispworks)
1595 :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
1597 (defvar *implementation-type* (implementation-type))
1599 (defun operating-system ()
1601 '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
1602 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
1603 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
1604 (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
1607 (defun architecture ()
1609 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
1610 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
1611 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
1612 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
1613 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
1614 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1615 ;; we may have to segregate the code still by architecture.
1616 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
1619 (defun ccl-fasl-version ()
1620 ;; the fasl version is target-dependent from CCL 1.8 on.
1621 (or (let ((s 'ccl::target-fasl-version))
1622 (and (fboundp s) (funcall s)))
1623 (and (boundp 'ccl::fasl-version)
1624 (symbol-value 'ccl::fasl-version))
1625 (error "Can't determine fasl version.")))
1627 (defun lisp-version-string ()
1628 (let ((s (lisp-implementation-version)))
1629 (car ; as opposed to OR, this idiom prevents some unreachable code warning
1632 (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
1633 excl::*common-lisp-version-number*
1634 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1635 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
1636 ;; Note if not using International ACL
1637 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
1638 (excl:ics-target-case (:-ics "8"))
1639 (and (member :smp *features*) "S"))
1640 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
1642 (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
1644 (format nil "~d.~d-f~d" ; shorten for windows
1645 ccl::*openmcl-major-version*
1646 ccl::*openmcl-minor-version*
1647 (logand (ccl-fasl-version) #xFF))
1648 #+cmu (substitute #\- #\/ s)
1649 #+scl (format nil "~A~A" s
1650 ;; ANSI upper case vs lower case.
1651 (ecase ext:*case-mode* (:upper "") (:lower "l")))
1652 #+ecl (format nil "~A~@[-~A~]" s
1653 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
1654 (subseq vcs-id 0 (min (length vcs-id) 8))))
1655 #+gcl (subseq s (1+ (position #\space s)))
1657 (multiple-value-bind (major minor) (sct:get-system-version "System")
1658 (format nil "~D.~D" major minor))
1659 #+mcl (subseq s 8) ; strip the leading "Version "
1662 (defun implementation-identifier ()
1664 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
1665 (format nil "~(~a~@{~@[-~a~]~}~)"
1666 (or (implementation-type) (lisp-implementation-type))
1667 (or (lisp-version-string) (lisp-implementation-version))
1668 (or (operating-system) (software-type))
1669 (or (architecture) (machine-type))))))
1672 ;;;; Other system information
1674 (with-upgradability ()
1676 ;; Note: untested on RMCL
1677 #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
1678 #+cormanlisp "localhost" ;; is there a better way? Does it matter?
1679 #+allegro (symbol-call :excl.osi :gethostname)
1680 #+clisp (first (split-string (machine-instance) :separator " "))
1681 #+gcl (system:gethostname)))
1684 ;;; Current directory
1685 (with-upgradability ()
1688 (defun parse-unix-namestring* (unix-namestring)
1689 (multiple-value-bind (host device directory name type version)
1690 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
1691 (make-pathname :host (or host lisp::*unix-host*) :device device
1692 :directory directory :name name :type type :version version)))
1695 "Get the current working directory as per POSIX getcwd(3), as a pathname object"
1696 (or #+abcl (parse-namestring
1697 (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
1698 #+allegro (excl::current-directory)
1699 #+clisp (ext:default-directory)
1700 #+clozure (ccl:current-directory)
1701 #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
1702 (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
1703 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
1705 #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
1706 (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
1707 #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
1708 #+lispworks (system:current-directory)
1709 #+mkcl (mk-ext:getcwd)
1710 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
1711 #+xcl (extensions:current-directory)
1712 (error "getcwd not supported on your implementation")))
1715 "Change current directory, as per POSIX chdir(2), to a given pathname object"
1716 (if-let (x (pathname x))
1717 (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
1718 #+allegro (excl:chdir x)
1720 #+clozure (setf (ccl:current-directory) x)
1721 #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
1722 #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
1723 (error "Could not set current directory to ~A" x))
1725 #+genera (setf *default-pathname-defaults* x)
1726 #+lispworks (hcl:change-directory x)
1727 #+mkcl (mk-ext:chdir x)
1728 #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
1729 (error "chdir not supported on your implementation")))))
1732 ;;;; -----------------------------------------------------------------
1733 ;;;; Windows shortcut support. Based on:
1735 ;;;; Jesse Hager: The Windows Shortcut File Format.
1736 ;;;; http://www.wotsit.org/list.asp?fc=13
1738 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1739 (with-upgradability ()
1740 (defparameter *link-initial-dword* 76)
1741 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1743 (defun read-null-terminated-string (s)
1744 (with-output-to-string (out)
1745 (loop :for code = (read-byte s)
1747 :do (write-char (code-char code) out))))
1749 (defun read-little-endian (s &optional (bytes 4))
1750 (loop :for i :from 0 :below bytes
1751 :sum (ash (read-byte s) (* 8 i))))
1753 (defun parse-file-location-info (s)
1754 (let ((start (file-position s))
1755 (total-length (read-little-endian s))
1756 (end-of-header (read-little-endian s))
1757 (fli-flags (read-little-endian s))
1758 (local-volume-offset (read-little-endian s))
1759 (local-offset (read-little-endian s))
1760 (network-volume-offset (read-little-endian s))
1761 (remaining-offset (read-little-endian s)))
1762 (declare (ignore total-length end-of-header local-volume-offset))
1763 (unless (zerop fli-flags)
1765 ((logbitp 0 fli-flags)
1766 (file-position s (+ start local-offset)))
1767 ((logbitp 1 fli-flags)
1768 (file-position s (+ start
1769 network-volume-offset
1771 (strcat (read-null-terminated-string s)
1773 (file-position s (+ start remaining-offset))
1774 (read-null-terminated-string s))))))
1776 (defun parse-windows-shortcut (pathname)
1777 (with-open-file (s pathname :element-type '(unsigned-byte 8))
1779 (when (and (= (read-little-endian s) *link-initial-dword*)
1780 (let ((header (make-array (length *link-guid*))))
1781 (read-sequence header s)
1782 (equalp header *link-guid*)))
1783 (let ((flags (read-little-endian s)))
1784 (file-position s 76) ;skip rest of header
1785 (when (logbitp 0 flags)
1786 ;; skip shell item id list
1787 (let ((length (read-little-endian s 2)))
1788 (file-position s (+ length (file-position s)))))
1791 (parse-file-location-info s))
1793 (when (logbitp 2 flags)
1794 ;; skip description string
1795 (let ((length (read-little-endian s 2)))
1796 (file-position s (+ length (file-position s)))))
1797 (when (logbitp 3 flags)
1798 ;; finally, our pathname
1799 (let* ((length (read-little-endian s 2))
1800 (buffer (make-array length)))
1801 (read-sequence buffer s)
1802 (map 'string #'code-char buffer)))))))
1804 (declare (ignore c))
1808 ;;;; -------------------------------------------------------------------------
1809 ;;;; Portability layer around Common Lisp pathnames
1810 ;; This layer allows for portable manipulation of pathname objects themselves,
1811 ;; which all is necessary prior to any access the filesystem or environment.
1813 (uiop/package:define-package :uiop/pathname
1814 (:nicknames :asdf/pathname)
1815 (:recycle :uiop/pathname :asdf/pathname :asdf)
1816 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
1818 ;; Making and merging pathnames, portably
1819 #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
1820 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
1821 #:make-pathname-component-logical #:make-pathname-logical
1823 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
1825 #:pathname-equal #:logical-pathname-p #:physical-pathname-p
1826 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
1828 #:pathname-directory-pathname #:pathname-parent-directory-pathname
1829 #:directory-pathname-p #:ensure-directory-pathname
1830 ;; Parsing filenames
1831 #:component-name-to-pathname-components
1832 #:split-name-type #:parse-unix-namestring #:unix-namestring
1833 #:split-unix-namestring-directory-components
1834 ;; Absolute and relative pathnames
1835 #:subpathname #:subpathname*
1836 #:ensure-absolute-pathname
1837 #:pathname-root #:pathname-host-pathname
1839 ;; Checking constraints
1840 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
1841 ;; Wildcard pathnames
1842 #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
1843 ;; Translate a pathname
1844 #:relativize-directory-component #:relativize-pathname-directory
1845 #:directory-separator-for-host #:directorize-pathname-host-device
1846 #:translate-pathname*
1847 #:*output-translation-function*))
1848 (in-package :uiop/pathname)
1850 ;;; Normalizing pathnames across implementations
1852 (with-upgradability ()
1853 (defun normalize-pathname-directory-component (directory)
1854 "Given a pathname directory component, return an equivalent form that is a list"
1855 #+gcl2.6 (setf directory (substitute :back :parent directory))
1857 #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
1858 ((stringp directory) `(:absolute ,directory))
1860 ((and (consp directory) (eq :root (first directory)))
1861 `(:absolute ,@(rest directory)))
1862 ((or (null directory)
1863 (and (consp directory) (member (first directory) '(:absolute :relative))))
1867 `(:relative ,@directory))
1869 (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
1871 (defun denormalize-pathname-directory-component (directory-component)
1872 #-gcl2.6 directory-component
1874 (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
1875 directory-component)))
1877 ((and (consp d) (eq :relative (first d))) (rest d))
1878 ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
1881 (defun merge-pathname-directory-components (specified defaults)
1882 ;; Helper for merge-pathnames* that handles directory components.
1883 (let ((directory (normalize-pathname-directory-component specified)))
1884 (ecase (first directory)
1886 (:absolute specified)
1888 (let ((defdir (normalize-pathname-directory-component defaults))
1889 (reldir (cdr directory)))
1893 ((not (eq :back (first reldir)))
1894 (append defdir reldir))
1896 (loop :with defabs = (first defdir)
1897 :with defrev = (reverse (rest defdir))
1898 :while (and (eq :back (car reldir))
1899 (or (and (eq :absolute defabs) (null defrev))
1900 (stringp (car defrev))))
1901 :do (pop reldir) (pop defrev)
1902 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
1904 ;; Giving :unspecific as :type argument to make-pathname is not portable.
1905 ;; See CLHS make-pathname and 19.2.2.2.3.
1906 ;; This will be :unspecific if supported, or NIL if not.
1907 (defparameter *unspecific-pathname-type*
1908 #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
1909 #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
1911 (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
1912 host (device () #+allegro devicep) name type version defaults
1913 #+scl &allow-other-keys)
1914 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
1915 tries hard to make a pathname that will actually behave as documented,
1916 despite the peculiarities of each implementation"
1917 ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
1918 (declare (ignorable host device directory name type version defaults))
1919 (apply 'make-pathname
1921 #+allegro (when (and devicep (null device)) `(:device :unspecific))
1924 `(:directory ,(denormalize-pathname-directory-component directory)))
1927 (defun make-pathname-component-logical (x)
1928 "Make a pathname component suitable for use in a logical-pathname"
1930 ((eql :unspecific) nil)
1931 #+clisp (string (string-upcase x))
1932 #+clisp (cons (mapcar 'make-pathname-component-logical x))
1935 (defun make-pathname-logical (pathname host)
1936 "Take a PATHNAME's directory, name, type and version components,
1937 and make a new pathname with corresponding components and specified logical HOST"
1940 :directory (make-pathname-component-logical (pathname-directory pathname))
1941 :name (make-pathname-component-logical (pathname-name pathname))
1942 :type (make-pathname-component-logical (pathname-type pathname))
1943 :version (make-pathname-component-logical (pathname-version pathname))))
1945 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
1946 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
1947 if the SPECIFIED pathname does not have an absolute directory,
1948 then the HOST and DEVICE both come from the DEFAULTS, whereas
1949 if the SPECIFIED pathname does have an absolute directory,
1950 then the HOST and DEVICE both come from the SPECIFIED.
1951 This is what users want on a modern Unix or Windows operating system,
1952 unlike the MERGE-PATHNAME behavior.
1953 Also, if either argument is NIL, then the other argument is returned unmodified;
1954 this is unlike MERGE-PATHNAME which always merges with a pathname,
1955 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
1956 (when (null specified) (return-from merge-pathnames* defaults))
1957 (when (null defaults) (return-from merge-pathnames* specified))
1959 (ext:resolve-pathname specified defaults)
1961 (let* ((specified (pathname specified))
1962 (defaults (pathname defaults))
1963 (directory (normalize-pathname-directory-component (pathname-directory specified)))
1964 (name (or (pathname-name specified) (pathname-name defaults)))
1965 (type (or (pathname-type specified) (pathname-type defaults)))
1966 (version (or (pathname-version specified) (pathname-version defaults))))
1967 (labels ((unspecific-handler (p)
1968 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
1969 (multiple-value-bind (host device directory unspecific-handler)
1970 (ecase (first directory)
1972 (values (pathname-host specified)
1973 (pathname-device specified)
1975 (unspecific-handler specified)))
1977 (values (pathname-host defaults)
1978 (pathname-device defaults)
1979 (merge-pathname-directory-components directory (pathname-directory defaults))
1980 (unspecific-handler defaults))))
1981 (make-pathname* :host host :device device :directory directory
1982 :name (funcall unspecific-handler name)
1983 :type (funcall unspecific-handler type)
1984 :version (funcall unspecific-handler version))))))
1986 (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
1987 "A pathname that is as neutral as possible for use as defaults
1988 when merging, making or parsing pathnames"
1989 ;; 19.2.2.2.1 says a NIL host can mean a default host;
1990 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
1991 ;; strings and lists of strings or :unspecific
1992 ;; But CMUCL decides to die on NIL.
1993 ;; MCL has issues with make-pathname, nil and defaulting
1994 (declare (ignorable defaults))
1995 #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
1996 :host (or #+cmu lisp::*unix-host*)
1997 #+scl ,@'(:scheme nil :scheme-specific-part nil
1998 :username nil :password nil :parameters nil :query nil :fragment nil)
1999 ;; the default shouldn't matter, but we really want something physical
2000 #-mcl ,@'(:defaults defaults)))
2002 (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
2004 (defmacro with-pathname-defaults ((&optional defaults) &body body)
2005 `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
2008 ;;; Some pathname predicates
2009 (with-upgradability ()
2010 (defun pathname-equal (p1 p2)
2011 (when (stringp p1) (setf p1 (pathname p1)))
2012 (when (stringp p2) (setf p2 (pathname p2)))
2013 (flet ((normalize-component (x)
2014 (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
2016 (macrolet ((=? (&rest accessors)
2018 (reduce 'list (cons 'normalize-component accessors)
2019 :initial-value x :from-end t)))
2020 `(equal ,(frob 'p1) ,(frob 'p2)))))
2021 (or (and (null p1) (null p2))
2022 (and (pathnamep p1) (pathnamep p2)
2023 (and (=? pathname-host)
2024 (=? pathname-device)
2025 (=? normalize-pathname-directory-component pathname-directory)
2028 (=? pathname-version)))))))
2030 (defun logical-pathname-p (x)
2031 (typep x 'logical-pathname))
2033 (defun physical-pathname-p (x)
2034 (and (pathnamep x) (not (logical-pathname-p x))))
2036 (defun absolute-pathname-p (pathspec)
2037 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2038 possessing an :ABSOLUTE directory component, return the (parsed) pathname.
2039 Otherwise return NIL"
2041 (typep pathspec '(or null pathname string))
2042 (let ((pathname (pathname pathspec)))
2043 (and (eq :absolute (car (normalize-pathname-directory-component
2044 (pathname-directory pathname))))
2047 (defun relative-pathname-p (pathspec)
2048 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2049 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2050 Otherwise return NIL"
2052 (typep pathspec '(or null pathname string))
2053 (let* ((pathname (pathname pathspec))
2054 (directory (normalize-pathname-directory-component
2055 (pathname-directory pathname))))
2056 (when (or (null directory) (eq :relative (car directory)))
2059 (defun hidden-pathname-p (pathname)
2060 "Return a boolean that is true if the pathname is hidden as per Unix style,
2061 i.e. its name starts with a dot."
2062 (and pathname (equal (first-char (pathname-name pathname)) #\.)))
2064 (defun file-pathname-p (pathname)
2065 "Does PATHNAME represent a file, i.e. has a non-null NAME component?
2067 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2069 Note that this does _not_ check to see that PATHNAME points to an
2070 actually-existing file.
2072 Returns the (parsed) PATHNAME when true"
2074 (let* ((pathname (pathname pathname))
2075 (name (pathname-name pathname)))
2076 (when (not (member name '(nil :unspecific "") :test 'equal))
2080 ;;; Directory pathnames
2081 (with-upgradability ()
2082 (defun pathname-directory-pathname (pathname)
2083 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2084 and NIL NAME, TYPE and VERSION components"
2086 (make-pathname :name nil :type nil :version nil :defaults pathname)))
2088 (defun pathname-parent-directory-pathname (pathname)
2089 "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2090 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2091 Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2093 (make-pathname* :name nil :type nil :version nil
2094 :directory (merge-pathname-directory-components
2095 '(:relative :back) (pathname-directory pathname))
2096 :defaults pathname)))
2098 (defun directory-pathname-p (pathname)
2099 "Does PATHNAME represent a directory?
2101 A directory-pathname is a pathname _without_ a filename. The three
2102 ways that the filename components can be missing are for it to be NIL,
2103 :UNSPECIFIC or the empty string.
2105 Note that this does _not_ check to see that PATHNAME points to an
2106 actually-existing directory."
2108 (let ((pathname (pathname pathname)))
2109 (flet ((check-one (x)
2110 (member x '(nil :unspecific "") :test 'equal)))
2111 (and (not (wild-pathname-p pathname))
2112 (check-one (pathname-name pathname))
2113 (check-one (pathname-type pathname))
2116 (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
2117 "Converts the non-wild pathname designator PATHSPEC to directory form."
2120 (ensure-directory-pathname (pathname pathspec)))
2121 ((not (pathnamep pathspec))
2122 (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
2123 ((wild-pathname-p pathspec)
2124 (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
2125 ((directory-pathname-p pathspec)
2128 (make-pathname* :directory (append (or (normalize-pathname-directory-component
2129 (pathname-directory pathspec))
2131 (list (file-namestring pathspec)))
2132 :name nil :type nil :version nil :defaults pathspec)))))
2135 ;;; Parsing filenames
2136 (with-upgradability ()
2137 (defun split-unix-namestring-directory-components
2138 (unix-namestring &key ensure-directory dot-dot)
2139 "Splits the path string UNIX-NAMESTRING, returning four values:
2140 A flag that is either :absolute or :relative, indicating
2141 how the rest of the values are to be interpreted.
2142 A directory path --- a list of strings and keywords, suitable for
2143 use with MAKE-PATHNAME when prepended with the flag value.
2144 Directory components with an empty name or the name . are removed.
2145 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2146 A last-component, either a file-namestring including type extension,
2147 or NIL in the case of a directory pathname.
2148 A flag that is true iff the unix-style-pathname was just
2149 a file-namestring without / path specification.
2150 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2151 the third return value will be NIL, and final component of the namestring
2152 will be treated as part of the directory path.
2154 An empty string is thus read as meaning a pathname object with all fields nil.
2156 Note that : characters will NOT be interpreted as host specification.
2157 Absolute pathnames are only appropriate on Unix-style systems.
2159 The intention of this function is to support structured component names,
2160 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2161 (check-type unix-namestring string)
2162 (check-type dot-dot (member nil :back :up))
2163 (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
2164 (plusp (length unix-namestring)))
2165 (values :relative () unix-namestring t)
2166 (let* ((components (split-string unix-namestring :separator "/"))
2167 (last-comp (car (last components))))
2168 (multiple-value-bind (relative components)
2169 (if (equal (first components) "")
2170 (if (equal (first-char unix-namestring) #\/)
2171 (values :absolute (cdr components))
2172 (values :relative nil))
2173 (values :relative components))
2174 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
2176 (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
2178 ((equal last-comp "")
2179 (values relative components nil nil)) ; "" already removed from components
2181 (values relative components nil nil))
2183 (values relative (butlast components) last-comp nil)))))))
2185 (defun split-name-type (filename)
2186 "Split a filename into two values NAME and TYPE that are returned.
2187 We assume filename has no directory component.
2188 The last . if any separates name and type from from type,
2189 except that if there is only one . and it is in first position,
2190 the whole filename is the NAME with an empty type.
2191 NAME is always a string.
2192 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2193 (check-type filename string)
2194 (assert (plusp (length filename)))
2195 (destructuring-bind (name &optional (type *unspecific-pathname-type*))
2196 (split-string filename :max 2 :separator ".")
2198 (values filename *unspecific-pathname-type*)
2199 (values name type))))
2201 (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
2203 "Coerce NAME into a PATHNAME using standard Unix syntax.
2205 Unix syntax is used whether or not the underlying system is Unix;
2206 on such non-Unix systems it is only usable but for relative pathnames;
2207 but especially to manipulate relative pathnames portably, it is of crucial
2208 to possess a portable pathname syntax independent of the underlying OS.
2209 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2211 When given a PATHNAME object, just return it untouched.
2212 When given NIL, just return NIL.
2213 When given a non-null SYMBOL, first downcase its name and treat it as a string.
2214 When given a STRING, portably decompose it into a pathname as below.
2216 #\\/ separates directory components.
2218 The last #\\/-separated substring is interpreted as follows:
2219 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2220 the string is made the last directory component, and NAME and TYPE are NIL.
2221 if the string is empty, it's the empty pathname with all slots NIL.
2222 2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
2223 are separated by SPLIT-NAME-TYPE.
2224 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2226 Directory components with an empty name the name . are removed.
2227 Any directory named .. is read as DOT-DOT,
2228 which must be one of :BACK or :UP and defaults to :BACK.
2230 HOST, DEVICE and VERSION components are taken from DEFAULTS,
2231 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
2232 No host or device can be specified in the string itself,
2233 which makes it unsuitable for absolute pathnames outside Unix.
2235 For relative pathnames, these components (and hence the defaults) won't matter
2236 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2237 which is an important reason to always use MERGE-PATHNAMES*.
2239 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2240 with those keys, removing TYPE DEFAULTS and DOT-DOT.
2241 When you're manipulating pathnames that are supposed to make sense portably
2242 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2243 to throw an error if the pathname is absolute"
2245 (check-type type (or null string (eql :directory)))
2246 (when ensure-directory
2247 (setf type :directory))
2249 ((or null pathname) (return name))
2251 (setf name (string-downcase name)))
2253 (multiple-value-bind (relative path filename file-only)
2254 (split-unix-namestring-directory-components
2255 name :dot-dot dot-dot :ensure-directory (eq type :directory))
2256 (multiple-value-bind (name type)
2258 ((or (eq type :directory) (null filename))
2261 (values filename type))
2263 (split-name-type filename)))
2264 (apply 'ensure-pathname
2266 :directory (unless file-only (cons relative path))
2267 :name name :type type
2268 :defaults (or #-mcl defaults *nil-pathname*))
2269 (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
2271 (defun unix-namestring (pathname)
2272 "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2273 If the PATHNAME is NIL or a STRING, return it unchanged.
2275 This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2276 This is a portable solution for representing relative pathnames,
2277 But unless you are running on a Unix system, it is not a general solution
2278 to representing native pathnames.
2280 An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2281 or if it is a PATHNAME but some of its components are not recognized."
2283 ((or null string) pathname)
2285 (with-output-to-string (s)
2286 (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
2287 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
2288 (name (pathname-name pathname))
2289 (type (pathname-type pathname))
2290 (type (and (not (eq type :unspecific)) type)))
2293 ((eq dir '(:relative)) (princ "./" s))
2295 (destructuring-bind (relabs &rest dirs) dir
2296 (or (member relabs '(:relative :absolute)) (err))
2297 (when (eq relabs :absolute) (princ #\/ s))
2298 (loop :for x :in dirs :do
2300 ((member x '(:back :up)) (princ "../" s))
2301 ((equal x "") (err))
2302 ;;((member x '("." "..") :test 'equal) (err))
2303 ((stringp x) (format s "~A/" x))
2308 (or (and (stringp name) (or (null type) (stringp type))) (err))
2309 (format s "~A~@[.~A~]" name type))
2311 (or (null type) (err)))))))))))
2313 ;;; Absolute and relative pathnames
2314 (with-upgradability ()
2315 (defun subpathname (pathname subpath &key type)
2316 "This function takes a PATHNAME and a SUBPATH and a TYPE.
2317 If SUBPATH is already a PATHNAME object (not namestring),
2318 and is an absolute pathname at that, it is returned unchanged;
2319 otherwise, SUBPATH is turned into a relative pathname with given TYPE
2320 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2321 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2322 (or (and (pathnamep subpath) (absolute-pathname-p subpath))
2323 (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
2324 (pathname-directory-pathname pathname))))
2326 (defun subpathname* (pathname subpath &key type)
2327 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2329 (subpathname (ensure-directory-pathname pathname) subpath :type type)))
2331 (defun pathname-root (pathname)
2332 (make-pathname* :directory '(:absolute)
2333 :name nil :type nil :version nil
2334 :defaults pathname ;; host device, and on scl, *some*
2335 ;; scheme-specific parts: port username password, not others:
2336 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2338 (defun pathname-host-pathname (pathname)
2339 (make-pathname* :directory nil
2340 :name nil :type nil :version nil :device nil
2341 :defaults pathname ;; host device, and on scl, *some*
2342 ;; scheme-specific parts: port username password, not others:
2343 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2345 (defun subpathp (maybe-subpath base-pathname)
2346 (and (pathnamep maybe-subpath) (pathnamep base-pathname)
2347 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
2348 (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
2349 (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
2350 (with-pathname-defaults ()
2351 (let ((enough (enough-namestring maybe-subpath base-pathname)))
2352 (and (relative-pathname-p enough) (pathname enough))))))
2354 (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
2356 ((absolute-pathname-p path))
2357 ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
2358 ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
2359 ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
2360 (or (if (absolute-pathname-p default-pathname)
2361 (absolute-pathname-p (merge-pathnames* path default-pathname))
2362 (call-function on-error "Default pathname ~S is not an absolute pathname"
2364 (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
2365 path default-pathname))))
2366 (t (call-function on-error
2367 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2371 ;;; Wildcard pathnames
2372 (with-upgradability ()
2373 (defparameter *wild* (or #+cormanlisp "*" :wild))
2374 (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
2375 (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
2376 (defparameter *wild-file*
2377 (make-pathname :directory nil :name *wild* :type *wild*
2378 :version (or #-(or allegro abcl xcl) *wild*)))
2379 (defparameter *wild-directory*
2380 (make-pathname* :directory `(:relative ,*wild-directory-component*)
2381 :name nil :type nil :version nil))
2382 (defparameter *wild-inferiors*
2383 (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
2384 :name nil :type nil :version nil))
2385 (defparameter *wild-path*
2386 (merge-pathnames* *wild-file* *wild-inferiors*))
2388 (defun wilden (path)
2389 (merge-pathnames* *wild-path* path)))
2392 ;;; Translate a pathname
2393 (with-upgradability ()
2394 (defun relativize-directory-component (directory-component)
2395 (let ((directory (normalize-pathname-directory-component directory-component)))
2397 ((stringp directory)
2398 (list :relative directory))
2399 ((eq (car directory) :absolute)
2400 (cons :relative (cdr directory)))
2404 (defun relativize-pathname-directory (pathspec)
2405 (let ((p (pathname pathspec)))
2407 :directory (relativize-directory-component (pathname-directory p))
2410 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
2411 (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
2412 (last-char (namestring foo))))
2415 (defun directorize-pathname-host-device (pathname)
2417 (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
2418 (return-from directorize-pathname-host-device pathname))
2419 (let* ((root (pathname-root pathname))
2420 (wild-root (wilden root))
2421 (absolute-pathname (merge-pathnames* pathname root))
2422 (separator (directory-separator-for-host root))
2423 (root-namestring (namestring root))
2426 #'(lambda (x) (or (eql x #\:)
2429 (multiple-value-bind (relative path filename)
2430 (split-unix-namestring-directory-components root-string :ensure-directory t)
2431 (declare (ignore relative filename))
2433 (make-pathname* :defaults root :directory `(:absolute ,@path))))
2434 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
2437 (defun directorize-pathname-host-device (pathname)
2438 (let ((scheme (ext:pathname-scheme pathname))
2439 (host (pathname-host pathname))
2440 (port (ext:pathname-port pathname))
2441 (directory (pathname-directory pathname)))
2442 (flet ((specificp (x) (and x (not (eq x :unspecific)))))
2443 (if (or (specificp port)
2444 (and (specificp host) (plusp (length host)))
2447 (when (specificp port)
2448 (setf prefix (format nil ":~D" port)))
2449 (when (and (specificp host) (plusp (length host)))
2450 (setf prefix (strcat host prefix)))
2451 (setf prefix (strcat ":" prefix))
2452 (when (specificp scheme)
2453 (setf prefix (strcat scheme prefix)))
2454 (assert (and directory (eq (first directory) :absolute)))
2455 (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
2456 :defaults pathname)))
2459 (defun* (translate-pathname*) (path absolute-source destination &optional root source)
2460 (declare (ignore source))
2462 ((functionp destination)
2463 (funcall destination path absolute-source))
2466 ((not (pathnamep destination))
2467 (error "Invalid destination"))
2468 ((not (absolute-pathname-p destination))
2469 (translate-pathname path absolute-source (merge-pathnames* destination root)))
2471 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
2473 (translate-pathname path absolute-source destination))))
2475 (defvar *output-translation-function* 'identity
2476 "Hook for output translations.
2478 This function needs to be idempotent, so that actions can work
2479 whether their inputs were translated or not,
2480 which they will be if we are composing operations. e.g. if some
2481 create-lisp-op creates a lisp file from some higher-level input,
2482 you need to still be able to use compile-op on that lisp file."))
2484 ;;;; -------------------------------------------------------------------------
2485 ;;;; Portability layer around Common Lisp filesystem access
2487 (uiop/package:define-package :uiop/filesystem
2488 (:nicknames :asdf/filesystem)
2489 (:recycle :uiop/filesystem :asdf/pathname :asdf)
2490 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
2492 ;; Native namestrings
2493 #:native-namestring #:parse-native-namestring
2494 ;; Probing the filesystem
2495 #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
2496 #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
2497 #:collect-sub*directories
2498 ;; Resolving symlinks somewhat
2499 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
2501 #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
2502 ;; Environment pathnames
2503 #:inter-directory-separator #:split-native-pathnames-string
2504 #:getenv-pathname #:getenv-pathnames
2505 #:getenv-absolute-directory #:getenv-absolute-directories
2506 #:lisp-implementation-directory #:lisp-implementation-pathname-p
2507 ;; Simple filesystem operations
2508 #:ensure-all-directories-exist
2509 #:rename-file-overwriting-target
2510 #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
2511 (in-package :uiop/filesystem)
2513 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
2514 (with-upgradability ()
2515 (defun native-namestring (x)
2516 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2518 (let ((p (pathname x)))
2519 #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
2520 #+(or cmu scl) (ext:unix-namestring p nil)
2521 #+sbcl (sb-ext:native-namestring p)
2522 #-(or clozure cmu sbcl scl)
2523 (if (os-unix-p) (unix-namestring p)
2526 (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
2527 "From a native namestring suitable for use by the operating system, return
2528 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2529 (check-type string (or string null))
2532 (with-pathname-defaults ()
2533 #+clozure (ccl:native-to-pathname string)
2534 #+sbcl (sb-ext:parse-native-namestring string)
2537 (parse-unix-namestring string :ensure-directory ensure-directory)
2538 (parse-namestring string)))))
2540 (if ensure-directory
2541 (and pathname (ensure-directory-pathname pathname))
2543 (apply 'ensure-pathname pathname constraints))))
2546 ;;; Probing the filesystem
2547 (with-upgradability ()
2548 (defun truename* (p)
2549 ;; avoids both logical-pathname merging and physical resolution issues
2550 (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
2552 (defun safe-file-write-date (pathname)
2553 ;; If FILE-WRITE-DATE returns NIL, it's possible that
2554 ;; the user or some other agent has deleted an input file.
2555 ;; Also, generated files will not exist at the time planning is done
2556 ;; and calls compute-action-stamp which calls safe-file-write-date.
2557 ;; So it is very possible that we can't get a valid file-write-date,
2558 ;; and we can survive and we will continue the planning
2559 ;; as if the file were very old.
2560 ;; (or should we treat the case in a different, special way?)
2562 (handler-case (file-write-date (translate-logical-pathname pathname))
2563 (file-error () nil))))
2565 (defun probe-file* (p &key truename)
2566 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
2567 probes the filesystem for a file or directory with given pathname.
2568 If it exists, return its truename is ENSURE-PATHNAME is true,
2569 or the original (parsed) pathname if it is false (the default)."
2570 (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
2573 (string (probe-file* (parse-namestring p) :truename truename))
2575 (and (not (wild-pathname-p p))
2579 (probe-file p :follow-symlinks truename)
2580 #-(or allegro clisp gcl2.6)
2584 (let ((pp (translate-logical-pathname p)))
2586 #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
2587 #+(and lispworks unix) (system:get-file-stat pp)
2588 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
2589 #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
2592 #.(flet ((probe (probe)
2593 `(let ((foundtrue ,probe))
2595 (truename foundtrue)
2598 (probe '(or (probe-file p)
2599 (and (directory-pathname-p p)
2601 (ensure-directory-pathname
2602 (truename* (subpathname
2603 (ensure-directory-pathname p) ".")))))))
2605 (let* ((fs (find-symbol* '#:file-stat :posix nil))
2606 (pp (find-symbol* '#:probe-pathname :ext nil))
2608 `(ignore-errors (,pp p))
2610 (truename* (ignore-errors (ensure-directory-pathname p)))))))
2614 (and (ignore-errors (,fs p)) p))
2616 (file-error () nil)))))))
2618 (defun directory-exists-p (x)
2619 (let ((p (probe-file* x :truename t)))
2620 (and (directory-pathname-p p) p)))
2622 (defun file-exists-p (x)
2623 (let ((p (probe-file* x :truename t)))
2624 (and (file-pathname-p p) p)))
2626 (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
2627 (apply 'directory pathname-spec
2628 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
2629 #+(or clozure digitool) '(:follow-links nil)
2630 #+clisp '(:circle t :if-does-not-exist :ignore)
2631 #+(or cmu scl) '(:follow-links nil :truenamep nil)
2632 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
2633 '(:resolve-symlinks nil))))))
2635 (defun filter-logical-directory-results (directory entries merger)
2636 (if (logical-pathname-p directory)
2637 ;; Try hard to not resolve logical-pathname into physical pathnames;
2638 ;; otherwise logical-pathname users/lovers will be disappointed.
2639 ;; If directory* could use some implementation-dependent magic,
2640 ;; we will have logical pathnames already; otherwise,
2641 ;; we only keep pathnames for which specifying the name and
2642 ;; translating the LPN commute.
2643 (loop :for f :in entries
2644 :for p = (or (and (logical-pathname-p f) f)
2645 (let* ((u (ignore-errors (funcall merger f))))
2646 ;; The first u avoids a cumbersome (truename u) error.
2647 ;; At this point f should already be a truename,
2648 ;; but isn't quite in CLISP, for it doesn't have :version :newest
2649 (and u (equal (truename* u) (truename* f)) u)))
2653 (defun directory-files (directory &optional (pattern *wild-file*))
2654 (let ((dir (pathname directory)))
2655 (when (logical-pathname-p dir)
2656 ;; Because of the filtering we do below,
2657 ;; logical pathnames have restrictions on wild patterns.
2658 ;; Not that the results are very portable when you use these patterns on physical pathnames.
2659 (when (wild-pathname-p dir)
2660 (error "Invalid wild pattern in logical directory ~S" directory))
2661 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
2662 (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
2663 (setf pattern (make-pathname-logical pattern (pathname-host dir))))
2664 (let* ((pat (merge-pathnames* pattern dir))
2665 (entries (append (ignore-errors (directory* pat))
2667 (when (equal :wild (pathname-type pattern))
2668 (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
2669 (filter-logical-directory-results
2672 (make-pathname :defaults dir
2673 :name (make-pathname-component-logical (pathname-name f))
2674 :type (make-pathname-component-logical (pathname-type f))
2675 :version (make-pathname-component-logical (pathname-version f))))))))
2677 (defun subdirectories (directory)
2678 (let* ((directory (ensure-directory-pathname directory))
2679 #-(or abcl cormanlisp genera xcl)
2680 (wild (merge-pathnames*
2681 #-(or abcl allegro cmu lispworks sbcl scl xcl)
2683 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
2686 #-(or abcl cormanlisp genera xcl)
2688 (directory* wild . #.(or #+clozure '(:directories t :files nil)
2689 #+mcl '(:directories t))))
2690 #+(or abcl xcl) (system:list-directory directory)
2691 #+cormanlisp (cl::directory-subdirs directory)
2692 #+genera (fs:directory-list directory))
2693 #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
2694 (dirs (loop :for x :in dirs
2695 :for d = #+(or abcl xcl) (extensions:probe-directory x)
2696 #+allegro (excl:probe-directory x)
2697 #+(or cmu sbcl scl) (directory-pathname-p x)
2698 #+genera (getf (cdr x) :directory)
2699 #+lispworks (lw:file-directory-p x)
2700 :when d :collect #+(or abcl allegro xcl) d
2701 #+genera (ensure-directory-pathname (first x))
2702 #+(or cmu lispworks sbcl scl) x)))
2703 (filter-logical-directory-results
2705 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
2706 '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
2708 (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
2709 (and (consp dir) (consp (cdr dir))
2711 :defaults directory :name nil :type nil :version nil
2712 :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
2714 (defun collect-sub*directories (directory collectp recursep collector)
2715 (when (call-function collectp directory)
2716 (call-function collector directory))
2717 (dolist (subdir (subdirectories directory))
2718 (when (call-function recursep subdir)
2719 (collect-sub*directories subdir collectp recursep collector)))))
2721 ;;; Resolving symlinks somewhat
2722 (with-upgradability ()
2723 (defun truenamize (pathname)
2724 "Resolve as much of a pathname as possible"
2726 (when (typep pathname '(or null logical-pathname)) (return pathname))
2728 (unless (absolute-pathname-p p)
2729 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
2731 (when (logical-pathname-p p) (return p))
2732 (let ((found (probe-file* p :truename t)))
2733 (when found (return found)))
2734 (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
2735 (up-components (reverse (rest directory)))
2736 (down-components ()))
2737 (assert (eq :absolute (first directory)))
2738 (loop :while up-components :do
2739 (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
2740 :name nil :type nil :version nil :defaults p)))
2741 (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
2743 (ensure-directory-pathname parent)))
2744 (push (pop up-components) down-components))
2745 :finally (return p))))))
2747 (defun resolve-symlinks (path)
2748 #-allegro (truenamize path)
2750 (if (physical-pathname-p path)
2751 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
2754 (defvar *resolve-symlinks* t
2755 "Determine whether or not ASDF resolves symlinks when defining systems.
2758 (defun resolve-symlinks* (path)
2759 (if *resolve-symlinks*
2760 (and path (resolve-symlinks path))
2764 ;;; Check pathname constraints
2765 (with-upgradability ()
2766 (defun ensure-pathname
2769 defaults type dot-dot
2771 want-logical want-physical ensure-physical
2772 want-relative want-absolute ensure-absolute ensure-subpath
2773 want-non-wild want-wild wilden
2774 want-file want-directory ensure-directory
2775 want-existing ensure-directories-exist
2776 truename resolve-symlinks truenamize
2777 &aux (p pathname)) ;; mutable working copy, preserve original
2778 "Coerces its argument into a PATHNAME,
2779 optionally doing some transformations and checking specified constraints.
2781 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
2783 If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
2784 reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
2785 then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
2786 and the all the checks and transformations are run.
2788 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
2789 The boolean T is an alias for ERROR.
2790 ERROR means that an error will be raised if the constraint is not satisfied.
2791 CERROR means that an continuable error will be raised if the constraint is not satisfied.
2792 IGNORE means just return NIL instead of the pathname.
2794 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
2795 that will be called with the the following arguments:
2796 a generic format string for ensure pathname, the pathname,
2797 the keyword argument corresponding to the failed check or transformation,
2798 a format string for the reason ENSURE-PATHNAME failed,
2799 and a list with arguments to that format string.
2800 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
2801 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
2803 The transformations and constraint checks are done in this order,
2804 which is also the order in the lambda-list:
2806 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
2807 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
2808 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
2809 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
2810 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
2811 WANT-RELATIVE checks that pathname has a relative directory component
2812 WANT-ABSOLUTE checks that pathname does have an absolute directory component
2813 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
2814 that the result absolute is an absolute pathname indeed.
2815 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
2816 WANT-FILE checks that pathname has a non-nil FILE component
2817 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
2818 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
2819 any file and type components as being actually a last directory component.
2820 WANT-NON-WILD checks that pathname is not a wild pathname
2821 WANT-WILD checks that pathname is a wild pathname
2822 WILDEN merges the pathname with **/*.*.* if it is not wild
2823 WANT-EXISTING checks that a file (or directory) exists with that pathname.
2824 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
2825 TRUENAME replaces the pathname by its truename, or errors if not possible.
2826 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
2827 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
2829 (flet ((report-error (keyword description &rest arguments)
2830 (call-function (or on-error 'error)
2831 "Invalid pathname ~S: ~*~?"
2832 pathname keyword description arguments)))
2833 (macrolet ((err (constraint &rest arguments)
2834 `(report-error ',(intern* constraint :keyword) ,@arguments))
2835 (check (constraint condition &rest arguments)
2837 (unless ,condition (err ,constraint ,@arguments))))
2838 (transform (transform condition expr)
2840 (,@(if condition `(when ,condition) '(progn))
2843 ((or null pathname))
2845 (setf p (parse-unix-namestring
2846 p :defaults defaults :type type :dot-dot dot-dot
2847 :ensure-directory ensure-directory :want-relative want-relative))))
2848 (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
2849 (unless (pathnamep p) (return nil))
2850 (check want-logical (logical-pathname-p p) "Expected a logical pathname")
2851 (check want-physical (physical-pathname-p p) "Expected a physical pathname")
2852 (transform ensure-physical () (translate-logical-pathname p))
2853 (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
2854 (check want-relative (relative-pathname-p p) "Expected a relative pathname")
2855 (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
2856 (transform ensure-absolute (not (absolute-pathname-p p))
2857 (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
2858 (check ensure-absolute (absolute-pathname-p p)
2859 "Could not make into an absolute pathname even after merging with ~S" defaults)
2860 (check ensure-subpath (absolute-pathname-p defaults)
2861 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
2862 (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
2863 (check want-file (file-pathname-p p) "Expected a file pathname")
2864 (check want-directory (directory-pathname-p p) "Expected a directory pathname")
2865 (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
2866 (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
2867 (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
2868 (transform wilden (not (wild-pathname-p p)) (wilden p))
2870 (let ((existing (probe-file* p :truename truename)))
2874 (err want-existing "Expected an existing pathname"))))
2875 (when ensure-directories-exist (ensure-directories-exist p))
2877 (let ((truename (truename* p)))
2880 (err truename "Can't get a truename for pathname"))))
2881 (transform resolve-symlinks () (resolve-symlinks p))
2882 (transform truenamize () (truenamize p))
2886 ;;; Pathname defaults
2887 (with-upgradability ()
2888 (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
2889 (or (absolute-pathname-p defaults)
2890 (merge-pathnames* defaults (getcwd))))
2892 (defun call-with-current-directory (dir thunk)
2894 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
2895 (*default-pathname-defaults* dir)
2903 (defmacro with-current-directory ((&optional dir) &body body)
2904 "Call BODY while the POSIX current working directory is set to DIR"
2905 `(call-with-current-directory ,dir #'(lambda () ,@body))))
2908 ;;; Environment pathnames
2909 (with-upgradability ()
2910 (defun inter-directory-separator ()
2911 (if (os-unix-p) #\: #\;))
2913 (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
2914 (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
2915 :collect (apply 'parse-native-namestring namestring constraints)))
2917 (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
2918 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
2919 (apply 'parse-native-namestring (getenvp x)
2920 :ensure-directory (or ensure-directory want-directory)
2921 :on-error (or on-error
2922 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
2924 (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
2925 (apply 'split-native-pathnames-string (getenvp x)
2926 :on-error (or on-error
2927 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
2929 (defun getenv-absolute-directory (x)
2930 (getenv-pathname x :want-absolute t :ensure-directory t))
2931 (defun getenv-absolute-directories (x)
2932 (getenv-pathnames x :want-absolute t :ensure-directory t))
2934 (defun lisp-implementation-directory (&key truename)
2935 (declare (ignorable truename))
2936 #+(or clozure ecl gcl mkcl sbcl)
2940 #+(or ecl mkcl) #p"SYS:"
2941 #+gcl system::*system-directory*
2942 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
2944 (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
2945 (if (and dir truename)
2949 (defun lisp-implementation-pathname-p (pathname)
2950 ;; Other builtin systems are those under the implementation directory
2952 (if-let (impdir (lisp-implementation-directory))
2953 (or (subpathp pathname impdir)
2954 (when *resolve-symlinks*
2955 (if-let (truename (truename* pathname))
2956 (if-let (trueimpdir (truename* impdir))
2957 (subpathp truename trueimpdir)))))))
2961 ;;; Simple filesystem operations
2962 (with-upgradability ()
2963 (defun ensure-all-directories-exist (pathnames)
2964 (dolist (pathname pathnames)
2966 (ensure-directories-exist (translate-logical-pathname pathname)))))
2968 (defun rename-file-overwriting-target (source target)
2969 #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
2970 (posix:copy-file source target :method :rename)
2972 (rename-file source target
2973 #+clozure :if-exists #+clozure :rename-and-delete))
2975 (defun delete-file-if-exists (x)
2976 (when x (handler-case (delete-file x) (file-error () nil))))
2978 (defun delete-empty-directory (directory-pathname)
2979 "Delete an empty directory"
2980 #+(or abcl digitool gcl) (delete-file directory-pathname)
2981 #+allegro (excl:delete-directory directory-pathname)
2982 #+clisp (ext:delete-directory directory-pathname)
2983 #+clozure (ccl::delete-empty-directory directory-pathname)
2984 #+(or cmu scl) (multiple-value-bind (ok errno)
2985 (unix:unix-rmdir (native-namestring directory-pathname))
2987 #+cmu (error "Error number ~A when trying to delete directory ~A"
2988 errno directory-pathname)
2989 #+scl (error "~@<Error deleting ~S: ~A~@:>"
2990 directory-pathname (unix:get-unix-error-msg errno))))
2991 #+cormanlisp (win32:delete-directory directory-pathname)
2992 #+ecl (si:rmdir directory-pathname)
2993 #+lispworks (lw:delete-directory directory-pathname)
2994 #+mkcl (mkcl:rmdir directory-pathname)
2995 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
2996 `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
2997 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
2998 #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
2999 (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
3001 (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
3002 "Delete a directory including all its recursive contents, aka rm -rf.
3004 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
3005 a physical non-wildcard directory pathname (not namestring).
3007 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
3008 if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
3010 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
3011 the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
3012 which in practice is thus compulsory, and validates by returning a non-NIL result.
3013 If you're suicidal or extremely confident, just use :VALIDATE T."
3014 (check-type if-does-not-exist (member :error :ignore))
3016 ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
3017 (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
3018 (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
3019 'delete-filesystem-tree directory-pathname))
3021 (error "~S was asked to delete ~S but was not provided a validation predicate"
3022 'delete-filesystem-tree directory-pathname))
3023 ((not (call-function validate directory-pathname))
3024 (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
3025 'delete-filesystem-tree directory-pathname validate))
3026 ((not (directory-exists-p directory-pathname))
3027 (ecase if-does-not-exist
3029 (error "~S was asked to delete ~S but the directory does not exist"
3030 'delete-filesystem-tree directory-pathname))
3032 #-(or allegro cmu clozure sbcl scl)
3033 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
3034 ;; except on implementations where we can prevent DIRECTORY from following symlinks;
3035 ;; instead spawn a standard external program to do the dirty work.
3036 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
3038 ;; On supported implementation, call supported system functions
3039 #+allegro (symbol-call :excl.osi :delete-directory-and-files
3040 directory-pathname :if-does-not-exist if-does-not-exist)
3041 #+clozure (ccl:delete-directory directory-pathname)
3042 #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
3043 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
3044 `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
3045 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
3046 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
3047 ;; do things the hard way.
3048 #-(or allegro clozure genera sbcl)
3049 (let ((sub*directories
3050 (while-collecting (c)
3051 (collect-sub*directories directory-pathname t t #'c))))
3052 (dolist (d (nreverse sub*directories))
3053 (map () 'delete-file (directory-files d))
3054 (delete-empty-directory d)))))))
3056 ;;;; ---------------------------------------------------------------------------
3057 ;;;; Utilities related to streams
3059 (uiop/package:define-package :uiop/stream
3060 (:nicknames :asdf/stream)
3061 (:recycle :uiop/stream :asdf/stream :asdf)
3062 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
3064 #:*default-stream-element-type* #:*stderr* #:setup-stderr
3065 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
3066 #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
3067 #:*default-encoding* #:*utf-8-external-format*
3068 #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
3069 #:with-output #:output-string #:with-input
3070 #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
3071 #:finish-outputs #:format! #:safe-format!
3072 #:copy-stream-to-stream #:concatenate-files #:copy-file
3073 #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
3074 #:slurp-stream-forms #:slurp-stream-form
3075 #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
3076 #:eval-input #:eval-thunk #:standard-eval-thunk
3078 #:*temporary-directory* #:temporary-directory #:default-temporary-directory
3079 #:setup-temporary-directory
3080 #:call-with-temporary-file #:with-temporary-file
3081 #:add-pathname-suffix #:tmpize-pathname
3082 #:call-with-staging-pathname #:with-staging-pathname))
3083 (in-package :uiop/stream)
3085 (with-upgradability ()
3086 (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
3087 "default element-type for open (depends on the current CL implementation)")
3089 (defvar *stderr* *error-output*
3090 "the original error output stream at startup")
3092 (defun setup-stderr ()
3094 #+allegro excl::*stderr*
3095 #+clozure ccl::*stderr*
3096 #-(or allegro clozure) *error-output*))
3100 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
3101 (with-upgradability ()
3102 (defparameter *default-encoding*
3103 ;; preserve explicit user changes to something other than the legacy default :default
3104 (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
3105 (unless (eq previous :default) previous))
3107 "Default encoding for source files.
3108 The default value :utf-8 is the portable thing.
3109 The legacy behavior was :default.
3110 If you (asdf:load-system :asdf-encodings) then
3111 you will have autodetection via *encoding-detection-hook* below,
3112 reading emacs-style -*- coding: utf-8 -*- specifications,
3113 and falling back to utf-8 or latin1 if nothing is specified.")
3115 (defparameter *utf-8-external-format*
3116 #+(and asdf-unicode (not clisp)) :utf-8
3117 #+(and asdf-unicode clisp) charset:utf-8
3118 #-asdf-unicode :default
3119 "Default :external-format argument to pass to CL:OPEN and also
3120 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
3121 On modern implementations, this will decode UTF-8 code points as CL characters.
3122 On legacy implementations, it may fall back on some 8-bit encoding,
3123 with non-ASCII code points being read as several CL characters;
3124 hopefully, if done consistently, that won't affect program behavior too much.")
3126 (defun always-default-encoding (pathname)
3127 (declare (ignore pathname))
3130 (defvar *encoding-detection-hook* #'always-default-encoding
3131 "Hook for an extension to define a function to automatically detect a file's encoding")
3133 (defun detect-encoding (pathname)
3134 (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
3135 (funcall *encoding-detection-hook* pathname)
3136 *default-encoding*))
3138 (defun default-encoding-external-format (encoding)
3140 (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
3141 (:utf-8 *utf-8-external-format*)
3143 (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
3146 (defvar *encoding-external-format-hook*
3147 #'default-encoding-external-format
3148 "Hook for an extension to define a mapping between non-default encodings
3149 and implementation-defined external-format's")
3151 (defun encoding-external-format (encoding)
3152 (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
3156 (with-upgradability ()
3157 (defvar *standard-readtable* (copy-readtable nil))
3159 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
3160 "Establish safe CL reader options around the evaluation of BODY"
3161 `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
3163 (defun call-with-safe-io-syntax (thunk &key (package :cl))
3164 (with-standard-io-syntax
3165 (let ((*package* (find-package package))
3166 (*read-default-float-format* 'double-float)
3167 (*print-readably* nil)
3171 (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
3172 (with-safe-io-syntax (:package package)
3173 (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
3176 ;;; Output to a stream or string, FORMAT-style
3177 (with-upgradability ()
3178 (defun call-with-output (output function)
3179 "Calls FUNCTION with an actual stream argument,
3180 behaving like FORMAT with respect to how stream designators are interpreted:
3181 If OUTPUT is a stream, use it as the stream.
3182 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
3183 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
3184 If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
3185 Otherwise, signal an error."
3188 (with-output-to-string (stream) (funcall function stream)))
3190 (funcall function *standard-output*))
3192 (funcall function output))
3194 (assert (fill-pointer output))
3195 (with-output-to-string (stream output) (funcall function stream)))))
3197 (defmacro with-output ((output-var &optional (value output-var)) &body body)
3198 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3199 as per FORMAT, and evaluate BODY within the scope of this binding."
3200 `(call-with-output ,value #'(lambda (,output-var) ,@body)))
3202 (defun output-string (string &optional output)
3203 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3205 (with-output (output) (princ string output))
3210 (with-upgradability ()
3211 (defun call-with-input (input function)
3212 "Calls FUNCTION with an actual stream argument, interpreting
3213 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
3214 If INPUT is a STREAM, use it as the stream.
3215 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
3216 If INPUT is T, use *TERMINAL-IO* as the stream.
3217 As an extension, if INPUT is a string, use it as a string-input-stream.
3218 Otherwise, signal an error."
3220 (null (funcall function *standard-input*))
3221 ((eql t) (funcall function *terminal-io*))
3222 (stream (funcall function input))
3223 (string (with-input-from-string (stream input) (funcall function stream)))))
3225 (defmacro with-input ((input-var &optional (value input-var)) &body body)
3226 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3227 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3228 `(call-with-input ,value #'(lambda (,input-var) ,@body)))
3230 (defun call-with-input-file (pathname thunk
3232 (element-type *default-stream-element-type*)
3233 (external-format *utf-8-external-format*)
3234 (if-does-not-exist :error))
3235 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3236 Other keys are accepted but discarded."
3237 #+gcl2.6 (declare (ignore external-format))
3238 (with-open-file (s pathname :direction :input
3239 :element-type element-type
3240 #-gcl2.6 :external-format #-gcl2.6 external-format
3241 :if-does-not-exist if-does-not-exist)
3244 (defmacro with-input-file ((var pathname &rest keys
3245 &key element-type external-format if-does-not-exist)
3247 (declare (ignore element-type external-format if-does-not-exist))
3248 `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
3250 (defun call-with-output-file (pathname thunk
3252 (element-type *default-stream-element-type*)
3253 (external-format *utf-8-external-format*)
3255 (if-does-not-exist :create))
3256 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3257 Other keys are accepted but discarded."
3258 #+gcl2.6 (declare (ignore external-format))
3259 (with-open-file (s pathname :direction :output
3260 :element-type element-type
3261 #-gcl2.6 :external-format #-gcl2.6 external-format
3262 :if-exists if-exists
3263 :if-does-not-exist if-does-not-exist)
3266 (defmacro with-output-file ((var pathname &rest keys
3267 &key element-type external-format if-exists if-does-not-exist)
3269 (declare (ignore element-type external-format if-exists if-does-not-exist))
3270 `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
3272 ;;; Ensure output buffers are flushed
3273 (with-upgradability ()
3274 (defun finish-outputs (&rest streams)
3275 "Finish output on the main output streams as well as any specified one.
3276 Useful for portably flushing I/O before user input or program exit."
3277 ;; CCL notably buffers its stream output by default.
3278 (dolist (s (append streams
3279 (list *stderr* *error-output* *standard-output* *trace-output*
3280 *debug-io* *terminal-io* *debug-io* *query-io*)))
3281 (ignore-errors (finish-output s)))
3284 (defun format! (stream format &rest args)
3285 "Just like format, but call finish-outputs before and after the output."
3286 (finish-outputs stream)
3287 (apply 'format stream format args)
3288 (finish-output stream))
3290 (defun safe-format! (stream format &rest args)
3291 (with-safe-io-syntax ()
3292 (ignore-errors (apply 'format! stream format args))
3293 (finish-outputs stream)))) ; just in case format failed
3296 ;;; Simple Whole-Stream processing
3297 (with-upgradability ()
3298 (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
3299 "Copy the contents of the INPUT stream into the OUTPUT stream.
3300 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3301 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3302 (with-open-stream (input input)
3304 (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
3306 (when prefix (princ prefix output))
3308 (unless eof (terpri output))
3309 (finish-output output)
3310 (when eof (return)))
3312 :with buffer-size = (or buffer-size 8192)
3313 :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
3314 :for end = (read-sequence buffer input)
3316 :do (write-sequence buffer output :end end)
3317 (when (< end buffer-size) (return))))))
3319 (defun concatenate-files (inputs output)
3320 (with-open-file (o output :element-type '(unsigned-byte 8)
3321 :direction :output :if-exists :rename-and-delete)
3322 (dolist (input inputs)
3323 (with-open-file (i input :element-type '(unsigned-byte 8)
3324 :direction :input :if-does-not-exist :error)
3325 (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
3327 (defun copy-file (input output)
3328 ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
3329 (concatenate-files (list input) output))
3331 (defun slurp-stream-string (input &key (element-type 'character))
3332 "Read the contents of the INPUT stream as a string"
3333 (with-open-stream (input input)
3334 (with-output-to-string (output)
3335 (copy-stream-to-stream input output :element-type element-type))))
3337 (defun slurp-stream-lines (input &key count)
3338 "Read the contents of the INPUT stream as a list of lines, return those lines.
3340 Read no more than COUNT lines."
3341 (check-type count (or null integer))
3342 (with-open-stream (input input)
3343 (loop :for n :from 0
3344 :for l = (and (or (not count) (< n count))
3345 (read-line input nil nil))
3346 :while l :collect l)))
3348 (defun slurp-stream-line (input &key (at 0))
3349 "Read the contents of the INPUT stream as a list of lines,
3350 then return the ACCESS-AT of that list of lines using the AT specifier.
3351 PATH defaults to 0, i.e. return the first line.
3352 PATH is typically an integer, or a list of an integer and a function.
3353 If PATH is NIL, it will return all the lines in the file.
3355 The stream will not be read beyond the Nth lines,
3356 where N is the index specified by path
3357 if path is either an integer or a list that starts with an integer."
3358 (access-at (slurp-stream-lines input :count (access-at-count at)) at))
3360 (defun slurp-stream-forms (input &key count)
3361 "Read the contents of the INPUT stream as a list of forms,
3362 and return those forms.
3364 If COUNT is null, read to the end of the stream;
3365 if COUNT is an integer, stop after COUNT forms were read.
3367 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3368 (check-type count (or null integer))
3369 (loop :with eof = '#:eof
3371 :for form = (if (and count (>= n count))
3373 (read-preserving-whitespace input nil eof))
3374 :until (eq form eof) :collect form))
3376 (defun slurp-stream-form (input &key (at 0))
3377 "Read the contents of the INPUT stream as a list of forms,
3378 then return the ACCESS-AT of these forms following the AT.
3379 AT defaults to 0, i.e. return the first form.
3380 AT is typically a list of integers.
3381 If AT is NIL, it will return all the forms in the file.
3383 The stream will not be read beyond the Nth form,
3384 where N is the index specified by path,
3385 if path is either an integer or a list that starts with an integer.
3387 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3388 (access-at (slurp-stream-forms input :count (access-at-count at)) at))
3390 (defun read-file-string (file &rest keys)
3391 "Open FILE with option KEYS, read its contents as a string"
3392 (apply 'call-with-input-file file 'slurp-stream-string keys))
3394 (defun read-file-lines (file &rest keys)
3395 "Open FILE with option KEYS, read its contents as a list of lines
3396 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3397 (apply 'call-with-input-file file 'slurp-stream-lines keys))
3399 (defun read-file-forms (file &rest keys &key count &allow-other-keys)
3400 "Open input FILE with option KEYS (except COUNT),
3401 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
3402 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3403 (apply 'call-with-input-file file
3404 #'(lambda (input) (slurp-stream-forms input :count count))
3405 (remove-plist-key :count keys)))
3407 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
3408 "Open input FILE with option KEYS (except AT),
3409 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
3410 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3411 (apply 'call-with-input-file file
3412 #'(lambda (input) (slurp-stream-form input :at at))
3413 (remove-plist-key :at keys)))
3415 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
3416 "Reads the specified form from the top of a file using a safe standardized syntax.
3417 Extracts the form using READ-FILE-FORM,
3418 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3419 (with-safe-io-syntax (:package package)
3420 (apply 'read-file-form pathname (remove-plist-key :package keys))))
3422 (defun eval-input (input)
3423 "Portably read and evaluate forms from INPUT, return the last values."
3425 (loop :with results :with eof ='#:eof
3426 :for form = (read input nil eof)
3427 :until (eq form eof)
3428 :do (setf results (multiple-value-list (eval form)))
3429 :finally (return (apply 'values results)))))
3431 (defun eval-thunk (thunk)
3432 "Evaluate a THUNK of code:
3433 If a function, FUNCALL it without arguments.
3434 If a constant literal and not a sequence, return it.
3435 If a cons or a symbol, EVAL it.
3436 If a string, repeatedly read and evaluate from it, returning the last values."
3438 ((or boolean keyword number character pathname) thunk)
3439 ((or cons symbol) (eval thunk))
3440 (function (funcall thunk))
3441 (string (eval-input thunk))))
3443 (defun standard-eval-thunk (thunk &key (package :cl))
3444 "Like EVAL-THUNK, but in a more standardized evaluation context."
3445 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
3447 (with-safe-io-syntax (:package package)
3448 (let ((*read-eval* t))
3449 (eval-thunk thunk))))))
3452 ;;; Using temporary files
3453 (with-upgradability ()
3454 (defun default-temporary-directory ()
3457 (or (getenv-pathname "TMPDIR" :ensure-directory t)
3458 (parse-native-namestring "/tmp/")))
3459 (when (os-windows-p)
3460 (getenv-pathname "TEMP" :ensure-directory t))
3461 (subpathname (user-homedir-pathname) "tmp/")))
3463 (defvar *temporary-directory* nil)
3465 (defun temporary-directory ()
3466 (or *temporary-directory* (default-temporary-directory)))
3468 (defun setup-temporary-directory ()
3469 (setf *temporary-directory* (default-temporary-directory))
3470 ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
3471 #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
3473 (defun call-with-temporary-file
3475 prefix keep (direction :io)
3476 (element-type *default-stream-element-type*)
3477 (external-format :default))
3478 #+gcl2.6 (declare (ignorable external-format))
3479 (check-type direction (member :output :io))
3481 :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
3482 :for counter :from (random (ash 1 32))
3483 :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
3484 ;; TODO: on Unix, do something about umask
3485 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
3486 ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
3487 (with-open-file (stream pathname
3488 :direction direction
3489 :element-type element-type
3490 #-gcl2.6 :external-format #-gcl2.6 external-format
3491 :if-exists nil :if-does-not-exist :create)
3495 (funcall thunk stream pathname)
3497 (funcall thunk stream pathname)
3498 (ignore-errors (delete-file pathname)))))))))
3500 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
3501 (pathname (gensym "PATHNAME") pathnamep)
3502 prefix keep direction element-type external-format)
3504 "Evaluate BODY where the symbols specified by keyword arguments
3505 STREAM and PATHNAME are bound corresponding to a newly created temporary file
3506 ready for I/O. Unless KEEP is specified, delete the file afterwards."
3507 (check-type stream symbol)
3508 (check-type pathname symbol)
3509 `(flet ((think (,stream ,pathname)
3510 ,@(unless pathnamep `((declare (ignore ,pathname))))
3511 ,@(unless streamp `((when ,stream (close ,stream))))
3513 #-gcl (declare (dynamic-extent #'think))
3514 (call-with-temporary-file
3516 ,@(when direction `(:direction ,direction))
3517 ,@(when prefix `(:prefix ,prefix))
3518 ,@(when keep `(:keep ,keep))
3519 ,@(when element-type `(:element-type ,element-type))
3520 ,@(when external-format `(:external-format external-format)))))
3522 ;; Temporary pathnames in simple cases where no contention is assumed
3523 (defun add-pathname-suffix (pathname suffix)
3524 (make-pathname :name (strcat (pathname-name pathname) suffix)
3525 :defaults pathname))
3527 (defun tmpize-pathname (x)
3528 (add-pathname-suffix x "-ASDF-TMP"))
3530 (defun call-with-staging-pathname (pathname fun)
3531 "Calls fun with a staging pathname, and atomically
3532 renames the staging pathname to the pathname in the end.
3533 Note: this protects only against failure of the program,
3534 not against concurrent attempts.
3535 For the latter case, we ought pick random suffix and atomically open it."
3536 (let* ((pathname (pathname pathname))
3537 (staging (tmpize-pathname pathname)))
3539 (multiple-value-prog1
3540 (funcall fun staging)
3541 (rename-file-overwriting-target staging pathname))
3542 (delete-file-if-exists staging))))
3544 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
3545 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
3547 ;;;; -------------------------------------------------------------------------
3548 ;;;; Starting, Stopping, Dumping a Lisp image
3550 (uiop/package:define-package :uiop/image
3551 (:nicknames :asdf/image)
3552 (:recycle :uiop/image :asdf/image :xcvb-driver)
3553 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
3555 #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
3556 #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
3557 #:*lisp-interaction*
3558 #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
3559 #:call-with-fatal-condition-handler #:with-fatal-condition-handler
3560 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
3561 #:*image-postlude* #:*image-dump-hook*
3562 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
3563 #:shell-boolean-exit
3564 #:register-image-restore-hook #:register-image-dump-hook
3565 #:call-image-restore-hook #:call-image-dump-hook
3566 #:restore-image #:dump-image #:create-image
3568 (in-package :uiop/image)
3570 (with-upgradability ()
3571 (defvar *lisp-interaction* t
3572 "Is this an interactive Lisp environment, or is it batch processing?")
3574 (defvar *command-line-arguments* nil
3575 "Command-line arguments")
3577 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
3578 "Is this a dumped image? As a standalone executable?")
3580 (defvar *image-restore-hook* nil
3581 "Functions to call (in reverse order) when the image is restored")
3583 (defvar *image-restored-p* nil
3584 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
3586 (defvar *image-prelude* nil
3587 "a form to evaluate, or string containing forms to read and evaluate
3588 when the image is restarted, but before the entry point is called.")
3590 (defvar *image-entry-point* nil
3591 "a function with which to restart the dumped image when execution is restored from it.")
3593 (defvar *image-postlude* nil
3594 "a form to evaluate, or string containing forms to read and evaluate
3595 before the image dump hooks are called and before the image is dumped.")
3597 (defvar *image-dump-hook* nil
3598 "Functions to call (in order) when before an image is dumped")
3600 (defvar *fatal-conditions* '(error)
3601 "conditions that cause the Lisp image to enter the debugger if interactive,
3602 or to die if not interactive"))
3605 ;;; Exiting properly or im-
3606 (with-upgradability ()
3607 (defun quit (&optional (code 0) (finish-output t))
3608 "Quits from the Lisp world, with the given exit status if provided.
3609 This is designed to abstract away the implementation specific quit forms."
3610 (when finish-output ;; essential, for ClozureCL, and for standard compliance.
3612 #+(or abcl xcl) (ext:quit :status code)
3613 #+allegro (excl:exit code :quiet t)
3614 #+clisp (ext:quit code)
3615 #+clozure (ccl:quit code)
3616 #+cormanlisp (win32:exitprocess code)
3617 #+(or cmu scl) (unix:unix-exit code)
3618 #+ecl (si:quit code)
3619 #+gcl (lisp:quit code)
3620 #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
3621 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
3622 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
3623 #+mkcl (mk-ext:quit :exit-code code)
3624 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
3625 (quit (find-symbol* :quit :sb-ext nil)))
3627 (exit `(,exit :code code :abort (not finish-output)))
3628 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
3629 #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
3630 (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
3632 (defun die (code format &rest arguments)
3633 "Die in error with some error message"
3634 (with-safe-io-syntax ()
3636 (format! *stderr* "~&~?~&" format arguments)))
3639 (defun raw-print-backtrace (&key (stream *debug-io*) count)
3640 "Print a backtrace, directly accessing the implementation"
3641 (declare (ignorable stream count))
3643 (let ((*debug-io* stream)) (top-level::backtrace-command count))
3645 (let ((*terminal-io* stream)
3646 (*standard-output* stream)
3647 (tpl:*zoom-print-circle* *print-circle*)
3648 (tpl:*zoom-print-level* *print-level*)
3649 (tpl:*zoom-print-length* *print-length*))
3650 (tpl:do-command "zoom"
3651 :from-read-eval-print-loop nil
3655 (system::print-backtrace :out stream :limit count)
3657 (let ((*debug-io* stream))
3658 #+clozure (ccl:print-call-history :count count :start-frame-number 1)
3659 #+mcl (ccl:print-call-history :detailed-p nil)
3660 (finish-output stream))
3662 (let ((debug:*debug-print-level* *print-level*)
3663 (debug:*debug-print-length* *print-length*))
3664 (debug:backtrace most-positive-fixnum stream))
3668 (let ((dbg::*debugger-stack*
3669 (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
3671 (dbg:*debug-print-level* *print-level*)
3672 (dbg:*debug-print-length* *print-length*))
3673 (dbg:bug-backtrace nil))
3676 #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
3679 (defun print-backtrace (&rest keys &key stream count)
3680 (declare (ignore stream count))
3681 (with-safe-io-syntax (:package :cl)
3682 (let ((*print-readably* nil)
3684 (*print-miser-width* 75)
3685 (*print-length* nil)
3688 (ignore-errors (apply 'raw-print-backtrace keys)))))
3690 (defun print-condition-backtrace (condition &key (stream *stderr*) count)
3691 ;; We print the condition *after* the backtrace,
3692 ;; for the sake of who sees the backtrace at a terminal.
3693 ;; It is up to the caller to print the condition *before*, with some context.
3694 (print-backtrace :stream stream :count count)
3696 (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
3699 (defun fatal-condition-p (condition)
3700 (match-any-condition-p condition *fatal-conditions*))
3702 (defun handle-fatal-condition (condition)
3703 "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
3706 (invoke-debugger condition))
3708 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
3709 (print-condition-backtrace condition :stream *stderr*)
3710 (die 99 "~A" condition))))
3712 (defun call-with-fatal-condition-handler (thunk)
3713 (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
3716 (defmacro with-fatal-condition-handler ((&optional) &body body)
3717 `(call-with-fatal-condition-handler #'(lambda () ,@body)))
3719 (defun shell-boolean-exit (x)
3720 "Quit with a return code that is 0 iff argument X is true"
3724 ;;; Using image hooks
3725 (with-upgradability ()
3726 (defun register-image-restore-hook (hook &optional (call-now-p t))
3727 (register-hook-function '*image-restore-hook* hook call-now-p))
3729 (defun register-image-dump-hook (hook &optional (call-now-p nil))
3730 (register-hook-function '*image-dump-hook* hook call-now-p))
3732 (defun call-image-restore-hook ()
3733 (call-functions (reverse *image-restore-hook*)))
3735 (defun call-image-dump-hook ()
3736 (call-functions *image-dump-hook*)))
3739 ;;; Proper command-line arguments
3740 (with-upgradability ()
3741 (defun raw-command-line-arguments ()
3742 "Find what the actual command line for this process was."
3743 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
3744 #+allegro (sys:command-line-arguments) ; default: :application t
3745 #+clisp (coerce (ext:argv) 'list)
3746 #+clozure (ccl::command-line-arguments)
3747 #+(or cmu scl) extensions:*command-line-strings*
3748 #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
3749 #+gcl si:*command-args*
3750 #+(or genera mcl) nil
3751 #+lispworks sys:*line-arguments-list*
3752 #+sbcl sb-ext:*posix-argv*
3754 #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
3755 (error "raw-command-line-arguments not implemented yet"))
3757 (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
3758 "Extract user arguments from command-line invocation of current process.
3759 Assume the calling conventions of a generated script that uses --
3760 if we are not called from a directly executable image."
3763 (let* (#-(or sbcl allegro)
3765 (if (eq *image-dumped-p* :executable)
3767 (member "--" arguments :test 'string-equal))))
3770 (defun setup-command-line-arguments ()
3771 (setf *command-line-arguments* (command-line-arguments)))
3773 (defun restore-image (&key
3774 ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
3775 ((:restore-hook *image-restore-hook*) *image-restore-hook*)
3776 ((:prelude *image-prelude*) *image-prelude*)
3777 ((:entry-point *image-entry-point*) *image-entry-point*)
3778 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
3779 (when *image-restored-p*
3780 (if if-already-restored
3781 (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
3782 (return-from restore-image)))
3783 (with-fatal-condition-handler ()
3784 (setf *image-restored-p* :in-progress)
3785 (call-image-restore-hook)
3786 (standard-eval-thunk *image-prelude*)
3787 (setf *image-restored-p* t)
3788 (let ((results (multiple-value-list
3789 (if *image-entry-point*
3790 (call-function *image-entry-point*)
3792 (if *lisp-interaction*
3793 (apply 'values results)
3794 (shell-boolean-exit (first results)))))))
3797 ;;; Dumping an image
3799 (with-upgradability ()
3800 (defun dump-image (filename &key output-name executable
3801 ((:postlude *image-postlude*) *image-postlude*)
3802 ((:dump-hook *image-dump-hook*) *image-dump-hook*)
3803 #+clozure prepend-symbols #+clozure (purify t))
3804 (declare (ignorable filename output-name executable))
3805 (setf *image-dumped-p* (if executable :executable t))
3806 (setf *image-restored-p* :in-regress)
3807 (standard-eval-thunk *image-postlude*)
3808 (call-image-dump-hook)
3809 (setf *image-restored-p* nil)
3810 #-(or clisp clozure cmu lispworks sbcl scl)
3812 (error "Dumping an executable is not supported on this implementation! Aborting."))
3815 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
3816 (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
3818 (apply #'ext:saveinitmem filename
3820 :start-package *package*
3821 :keep-global-handlers nil
3822 :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
3825 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
3826 :norc t :script nil :init-function #'restore-image)))
3828 (flet ((dump (prepend-kernel)
3829 (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
3830 :toplevel-function (when executable #'restore-image))))
3831 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
3833 (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
3835 (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
3841 (setf ext:*batch-mode* nil)
3842 (setf ext::*gc-run-time* 0)
3843 (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
3844 (when executable '(:init-function restore-image :process-command-line nil))))
3847 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
3848 (si::save-system filename))
3851 (lispworks:deliver 'restore-image filename 0 :interface nil)
3852 (hcl:save-image filename :environment nil))
3855 ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
3856 (setf sb-ext::*gc-run-time* 0)
3857 (apply 'sb-ext:save-lisp-and-die filename
3858 :executable t ;--- always include the runtime that goes with the core
3859 (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
3860 #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
3861 (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
3862 'dump-image filename (nth-value 1 (implementation-type))))
3864 (defun create-image (destination object-files
3865 &key kind output-name prologue-code epilogue-code
3866 (prelude () preludep) (postlude () postludep)
3867 (entry-point () entry-point-p) build-args)
3868 (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
3869 prelude preludep postlude postludep entry-point entry-point-p build-args))
3870 ;; Is it meaningful to run these in the current environment?
3871 ;; only if we also track the object files that constitute the "current" image,
3872 ;; and otherwise simulate dump-image, including quitting at the end.
3873 #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
3876 (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
3878 kind (pathname destination)
3879 :lisp-files object-files
3880 :init-name (c::compute-init-name (or output-name destination) :kind kind)
3881 :prologue-code prologue-code
3885 ,@(when (eq kind :program)
3886 `((setf *image-dumped-p* :executable)
3887 (restore-image ;; default behavior would be (si::top-level)
3888 ,@(when preludep `(:prelude ',prelude))
3889 ,@(when entry-point-p `(:entry-point ',entry-point))))))
3893 ;;; Some universal image restore hooks
3894 (with-upgradability ()
3895 (map () 'register-image-restore-hook
3896 '(setup-temporary-directory setup-stderr setup-command-line-arguments
3898 ;;;; -------------------------------------------------------------------------
3899 ;;;; run-program initially from xcvb-driver.
3901 (uiop/package:define-package :uiop/run-program
3902 (:nicknames :asdf/run-program)
3903 (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
3904 (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
3906 ;;; Escaping the command invocation madness
3907 #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
3908 #:escape-windows-token #:escape-windows-command
3909 #:escape-token #:escape-command
3912 #:slurp-input-stream
3915 #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
3917 (in-package :uiop/run-program)
3919 ;;;; ----- Escaping strings for the shell -----
3921 (with-upgradability ()
3922 (defun requires-escaping-p (token &key good-chars bad-chars)
3923 "Does this token require escaping, given the specification of
3924 either good chars that don't need escaping or bad chars that do need escaping,
3925 as either a recognizing function or a sequence of characters."
3928 ((and good-chars bad-chars)
3929 (error "only one of good-chars and bad-chars can be provided"))
3930 ((functionp good-chars)
3931 (complement good-chars))
3932 ((functionp bad-chars)
3934 ((and good-chars (typep good-chars 'sequence))
3935 #'(lambda (c) (not (find c good-chars))))
3936 ((and bad-chars (typep bad-chars 'sequence))
3937 #'(lambda (c) (find c bad-chars)))
3938 (t (error "requires-escaping-p: no good-char criterion")))
3941 (defun escape-token (token &key stream quote good-chars bad-chars escaper)
3942 "Call the ESCAPER function on TOKEN string if it needs escaping as per
3943 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
3944 using STREAM as output (or returning result as a string if NIL)"
3945 (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
3946 (with-output (stream)
3947 (apply escaper token stream (when quote `(:quote ,quote))))
3948 (output-string token stream)))
3950 (defun escape-windows-token-within-double-quotes (x &optional s)
3951 "Escape a string token X within double-quotes
3952 for use within a MS Windows command-line, outputing to S."
3953 (labels ((issue (c) (princ c s))
3954 (issue-backslash (n) (loop :repeat n :do (issue #\\))))
3956 :initially (issue #\") :finally (issue #\")
3957 :with l = (length x) :with i = 0
3958 :for i+1 = (1+ i) :while (< i l) :do
3960 ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
3962 (let* ((j (and (< i+1 l) (position-if-not
3963 #'(lambda (c) (eql c #\\)) x :start i+1)))
3967 (issue-backslash (* 2 n)) (setf i l))
3968 ((and (< j l) (eql (char x j) #\"))
3969 (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
3971 (issue-backslash n) (setf i j)))))
3973 (issue (char x i)) (setf i i+1))))))
3975 (defun escape-windows-token (token &optional s)
3976 "Escape a string TOKEN within double-quotes if needed
3977 for use within a MS Windows command-line, outputing to S."
3978 (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
3979 :escaper 'escape-windows-token-within-double-quotes))
3981 (defun escape-sh-token-within-double-quotes (x s &key (quote t))
3982 "Escape a string TOKEN within double-quotes
3983 for use within a POSIX Bourne shell, outputing to S;
3984 omit the outer double-quotes if key argument :QUOTE is NIL"
3985 (when quote (princ #\" s))
3986 (loop :for c :across x :do
3987 (when (find c "$`\\\"") (princ #\\ s))
3989 (when quote (princ #\" s)))
3991 (defun easy-sh-character-p (x)
3992 (or (alphanumericp x) (find x "+-_.,%@:/")))
3994 (defun escape-sh-token (token &optional s)
3995 "Escape a string TOKEN within double-quotes if needed
3996 for use within a POSIX Bourne shell, outputing to S."
3997 (escape-token token :stream s :quote #\" :good-chars
3998 #'easy-sh-character-p
3999 :escaper 'escape-sh-token-within-double-quotes))
4001 (defun escape-shell-token (token &optional s)
4003 ((os-unix-p) (escape-sh-token token s))
4004 ((os-windows-p) (escape-windows-token token s))))
4006 (defun escape-command (command &optional s
4007 (escaper 'escape-shell-token))
4008 "Given a COMMAND as a list of tokens, return a string of the
4009 spaced, escaped tokens, using ESCAPER to escape."
4011 (string (output-string command s))
4012 (list (with-output (s)
4013 (loop :for first = t :then nil :for token :in command :do
4014 (unless first (princ #\space s))
4015 (funcall escaper token s))))))
4017 (defun escape-windows-command (command &optional s)
4018 "Escape a list of command-line arguments into a string suitable for parsing
4019 by CommandLineToArgv in MS Windows"
4020 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
4021 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
4022 (escape-command command s 'escape-windows-token))
4024 (defun escape-sh-command (command &optional s)
4025 "Escape a list of command-line arguments into a string suitable for parsing
4026 by /bin/sh in POSIX"
4027 (escape-command command s 'escape-sh-token))
4029 (defun escape-shell-command (command &optional stream)
4030 "Escape a command for the current operating system's shell"
4031 (escape-command command stream 'escape-shell-token)))
4034 ;;;; Slurping a stream, typically the output of another program
4035 (with-upgradability ()
4036 (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
4038 #-(or gcl2.6 genera)
4039 (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
4040 (funcall function input-stream))
4042 (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
4043 (apply (first list) (cons input-stream (rest list))))
4045 #-(or gcl2.6 genera)
4046 (defmethod slurp-input-stream ((output-stream stream) input-stream
4047 &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
4048 (copy-stream-to-stream
4049 input-stream output-stream
4050 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
4052 (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
4053 (declare (ignorable x))
4054 (slurp-stream-string stream))
4056 (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
4057 (declare (ignorable x))
4058 (slurp-stream-string stream))
4060 (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
4061 (declare (ignorable x))
4062 (slurp-stream-lines stream :count count))
4064 (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
4065 (declare (ignorable x))
4066 (slurp-stream-line stream :at at))
4068 (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
4069 (declare (ignorable x))
4070 (slurp-stream-forms stream :count count))
4072 (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
4073 (declare (ignorable x))
4074 (slurp-stream-form stream :at at))
4076 (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
4077 (declare (ignorable x))
4078 (apply 'slurp-input-stream *standard-output* stream keys))
4080 (defmethod slurp-input-stream ((pathname pathname) input
4082 (element-type *default-stream-element-type*)
4083 (external-format *utf-8-external-format*)
4084 (if-exists :rename-and-delete)
4085 (if-does-not-exist :create)
4088 (with-output-file (output pathname
4089 :element-type element-type
4090 :external-format external-format
4091 :if-exists if-exists
4092 :if-does-not-exist if-does-not-exist)
4093 (copy-stream-to-stream
4095 :element-type element-type :buffer-size buffer-size :linewise linewise)))
4097 (defmethod slurp-input-stream (x stream
4098 &key linewise prefix (element-type 'character) buffer-size
4100 (declare (ignorable stream linewise prefix element-type buffer-size))
4102 #+(or gcl2.6 genera)
4103 ((functionp x) (funcall x stream))
4104 #+(or gcl2.6 genera)
4105 ((output-stream-p x)
4106 (copy-stream-to-stream
4107 input-stream output-stream
4108 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
4110 (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
4113 ;;;; ----- Running an external program -----
4114 ;;; Simple variant of run-program with no input, and capturing output
4115 ;;; On some implementations, may output to a temporary file...
4116 (with-upgradability ()
4117 (define-condition subprocess-error (error)
4118 ((code :initform nil :initarg :code :reader subprocess-error-code)
4119 (command :initform nil :initarg :command :reader subprocess-error-command)
4120 (process :initform nil :initarg :process :reader subprocess-error-process))
4121 (:report (lambda (condition stream)
4122 (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
4123 (subprocess-error-process condition)
4124 (subprocess-error-command condition)
4125 (subprocess-error-code condition)))))
4127 (defun run-program (command
4128 &key output ignore-error-status force-shell
4129 (element-type *default-stream-element-type*)
4130 (external-format :default)
4132 "Run program specified by COMMAND,
4133 either a list of strings specifying a program and list of arguments,
4134 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
4136 Always call a shell (rather than directly execute the command)
4137 if FORCE-SHELL is specified.
4139 Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
4140 unless IGNORE-ERROR-STATUS is specified.
4142 If OUTPUT is either NIL or :INTERACTIVE, then
4143 return the exit status code of the process that was called.
4144 if it was NIL, the output is discarded;
4145 if it was :INTERACTIVE, the output and the input are inherited from the current process.
4147 Otherwise, OUTPUT should be a value that is a suitable first argument to
4148 SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream
4149 for the program output. The program output, in that stream, will be processed
4150 by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
4151 RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns. E.g., using
4152 :OUTPUT :STRING will have it return the entire output stream as a string. Use
4153 ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
4155 ;; TODO: The current version does not honor :OUTPUT NIL on Allegro. Setting
4156 ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
4157 ;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior
4158 ;; specified for :OUTPUT NIL, one would have to grab up the process output
4159 ;; into a stream and then throw it on the floor. The consequences of
4160 ;; getting this wrong seemed so much worse than having excess output that it
4161 ;; is not currently implemented.
4163 ;; TODO: specially recognize :output pathname ?
4164 (declare (ignorable ignore-error-status element-type external-format))
4165 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
4166 (error "RUN-PROGRAM not implemented for this Lisp")
4167 (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
4168 (run-program (command &key pipe interactive)
4169 "runs the specified command (a list of program and arguments).
4170 If using a pipe, returns two values: process and stream
4171 If not using a pipe, returns one values: the process result;
4172 also, inherits the output stream."
4173 ;; NB: these implementations have unix vs windows set at compile-time.
4174 (assert (not (and pipe interactive)))
4175 (let* ((wait (not pipe))
4176 #-(and clisp os-windows)
4179 #+os-unix (string `("/bin/sh" "-c" ,command))
4180 #+os-unix (list command)
4183 ;; NB: We do NOT add cmd /c here. You might want to.
4185 ;; On ClozureCL for Windows, we assume you are using
4186 ;; r15398 or later in 1.9 or later,
4187 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
4188 #+clozure (cons "cmd" (strcat "/c " command))
4189 ;; NB: On other Windows implementations, this is utterly bogus
4190 ;; except in the most trivial cases where no quoting is needed.
4191 ;; Use at your own risk.
4192 #-(or allegro clozure) (list "cmd" "/c" command))
4195 #+(or allegro clozure) (escape-windows-command command)
4196 #-(or allegro clozure) command)))
4197 #+(and clozure os-windows) (command (list command))
4199 (multiple-value-list
4201 (excl:run-shell-command
4202 #+os-unix (coerce (cons (first command) command) 'vector)
4203 #+os-windows command
4205 :output (and pipe :stream) :wait wait
4206 #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
4208 (flet ((run (f &rest args)
4209 (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
4210 ,(if pipe :stream :terminal)))))
4212 #+os-windows (run 'ext:run-shell-command command)
4213 (list (run 'ext:run-program (car command)
4214 :arguments (cdr command)))))
4216 (system:run-shell-command
4217 (cons "/usr/bin/env" command) ; lispworks wants a full path.
4218 :input interactive :output (or (and pipe :stream) interactive)
4219 :wait wait :save-exit-status (and pipe t))
4220 #+(or clozure cmu ecl sbcl scl)
4221 (#+(or cmu ecl scl) ext:run-program
4222 #+clozure ccl:run-program
4223 #+sbcl sb-ext:run-program
4224 (car command) (cdr command)
4225 :input interactive :wait wait
4226 :output (if pipe :stream t)
4228 #+(or clozure cmu ecl sbcl scl) '(:error t)
4229 ;; note: :external-format requires a recent SBCL
4230 #+sbcl '(:search t :external-format external-format)))))
4232 #+allegro (if pipe (third process*) (first process*))
4233 #+ecl (third process*)
4234 #-(or allegro ecl) (first process*))
4237 #+(or allegro lispworks ecl) (first process*)
4238 #+clisp (first process*)
4239 #+clozure (ccl::external-process-output process)
4240 #+(or cmu scl) (ext:process-output process)
4241 #+sbcl (sb-ext:process-output process))))
4242 (values process stream)))
4243 #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
4244 (process-result (process pipe)
4245 (declare (ignorable pipe))
4247 #+(and clozure os-unix) (ccl::external-process-wait process)
4248 #+(or cmu scl) (ext:process-wait process)
4249 #+(and ecl os-unix) (ext:external-process-wait process)
4250 #+sbcl (sb-ext:process-wait process)
4251 ;; 2- extract result
4252 #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
4254 #+clozure (nth-value 1 (ccl:external-process-status process))
4255 #+(or cmu scl) (ext:process-exit-code process)
4256 #+ecl (nth-value 1 (ext:external-process-status process))
4257 #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
4258 #+sbcl (sb-ext:process-exit-code process))
4259 (check-result (exit-code process)
4262 (typecase exit-code (integer exit-code) (null 0) (t -1)))
4263 (unless (or ignore-error-status
4264 (equal exit-code 0))
4265 (error 'subprocess-error :command command :code exit-code :process process))
4268 #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
4269 (let* ((interactive (eq output :interactive))
4270 (pipe (and output (not interactive))))
4271 (multiple-value-bind (process stream)
4272 (run-program command :pipe pipe :interactive interactive)
4273 (if (and output (not interactive))
4275 (slurp-input-stream output stream)
4276 (when stream (close stream))
4277 (check-result (process-result process pipe) process))
4280 #+(or allegro lispworks) ; when not capturing, returns the exit code!
4282 #-(or allegro lispworks) (process-result process pipe)
4284 (system-command (command)
4286 (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
4287 (list (escape-shell-command
4288 (if (os-unix-p) (cons "exec" command) command)))))
4289 (redirected-system-command (command out)
4290 (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
4291 (system-command command) (native-namestring out)))
4292 (system (command &key interactive)
4293 (declare (ignorable interactive))
4294 #+(or abcl xcl) (ext:run-shell-command command)
4296 (excl:run-shell-command
4300 :error-output :output ; write STDERR to output, too
4302 #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
4303 #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
4304 (process-result (run-program command :pipe nil :interactive interactive) nil)
4305 #+ecl (ext:system command)
4306 #+cormanlisp (win32:system command)
4307 #+gcl (lisp:system command)
4308 #+(and lispworks os-windows)
4309 (system:call-system-showing-output
4310 command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
4311 #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
4313 (mkcl:run-program #+windows command #+windows ()
4314 #-windows "/bin/sh" (list "-c" command)
4315 :input nil :output nil)))
4316 (call-system (command-string &key interactive)
4317 (check-result (system command-string :interactive interactive) nil))
4319 (let ((interactive (eq output :interactive)))
4320 (if (and output (not interactive))
4321 (with-temporary-file (:pathname tmp :direction :output)
4322 (call-system (redirected-system-command command tmp))
4323 (with-open-file (stream tmp
4325 :if-does-not-exist :error
4326 :element-type element-type
4327 #-gcl2.6 :external-format #-gcl2.6 external-format)
4328 (slurp-input-stream output stream)))
4329 (call-system (system-command command) :interactive interactive)))))
4330 (if (and (not force-shell)
4331 #+(or clisp ecl) ignore-error-status
4332 #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
4336 ;;;; -------------------------------------------------------------------------
4337 ;;;; Support to build (compile and load) Lisp files
4339 (uiop/package:define-package :uiop/lisp-build
4340 (:nicknames :asdf/lisp-build)
4341 (:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
4342 (:use :uiop/common-lisp :uiop/package :uiop/utility
4343 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
4346 #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
4347 #:*output-translation-function*
4348 #:*optimization-settings* #:*previous-optimization-settings*
4349 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
4350 #:compile-warned-warning #:compile-failed-warning
4351 #:check-lisp-compile-results #:check-lisp-compile-warnings
4352 #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
4354 #+sbcl #:sb-grovel-unknown-constant-condition
4355 ;; Functions & Macros
4356 #:get-optimization-settings #:proclaim-optimization-settings
4357 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
4358 #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
4359 #:reify-simple-sexp #:unreify-simple-sexp
4360 #:reify-deferred-warnings #:unreify-deferred-warnings
4361 #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
4362 #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
4363 #:enable-deferred-warnings-check #:disable-deferred-warnings-check
4364 #:current-lisp-file-pathname #:load-pathname
4365 #:lispize-pathname #:compile-file-type #:call-around-hook
4366 #:compile-file* #:compile-file-pathname*
4367 #:load* #:load-from-string #:combine-fasls)
4368 (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
4369 (in-package :uiop/lisp-build)
4371 (with-upgradability ()
4372 (defvar *compile-file-warnings-behaviour*
4373 (or #+clisp :ignore :warn)
4374 "How should ASDF react if it encounters a warning when compiling a file?
4375 Valid values are :error, :warn, and :ignore.")
4377 (defvar *compile-file-failure-behaviour*
4378 (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
4379 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
4380 when compiling a file, which includes any non-style-warning warning.
4381 Valid values are :error, :warn, and :ignore.
4382 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
4385 ;;; Optimization settings
4386 (with-upgradability ()
4387 (defvar *optimization-settings* nil)
4388 (defvar *previous-optimization-settings* nil)
4389 (defun get-optimization-settings ()
4390 "Get current compiler optimization settings, ready to PROCLAIM again"
4391 #-(or clisp clozure cmu ecl sbcl scl)
4392 (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
4393 #+clozure (ccl:declaration-information 'optimize nil)
4394 #+(or clisp cmu ecl sbcl scl)
4395 (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
4396 #.`(loop :for x :in settings
4397 ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
4398 #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
4399 :for y = (or #+clisp (gethash x system::*optimize*)
4400 #+(or ecl) (symbol-value v)
4401 #+(or cmu scl) (funcall f c::*default-cookie*)
4402 #+sbcl (cdr (assoc x sb-c::*policy*)))
4403 :when y :collect (list x y))))
4404 (defun proclaim-optimization-settings ()
4405 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
4406 (proclaim `(optimize ,@*optimization-settings*))
4407 (let ((settings (get-optimization-settings)))
4408 (unless (equal *previous-optimization-settings* settings)
4409 (setf *previous-optimization-settings* settings)))))
4412 ;;; Condition control
4413 (with-upgradability ()
4416 (defun sb-grovel-unknown-constant-condition-p (c)
4417 (and (typep c 'sb-int:simple-style-warning)
4419 "Couldn't grovel for "
4420 (simple-condition-format-control c)
4421 " (unknown to the C compiler).")))
4422 (deftype sb-grovel-unknown-constant-condition ()
4423 '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
4425 (defvar *usual-uninteresting-conditions*
4427 ;;#+clozure '(ccl:compiler-warning)
4428 #+cmu '("Deleting unreachable code.")
4429 #+lispworks '("~S being redefined in ~A (previously in ~A)."
4430 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4432 '(sb-c::simple-compiler-note
4433 "&OPTIONAL and &KEY found in the same lambda list: ~S"
4434 #+sb-eval sb-kernel:lexical-environment-too-complex
4435 sb-kernel:undefined-alien-style-warning
4436 sb-grovel-unknown-constant-condition ; defined above.
4437 sb-ext:implicit-generic-function-warning ;; Controversial.
4438 sb-int:package-at-variance
4439 sb-kernel:uninteresting-redefinition
4440 ;; BEWARE: the below four are controversial to include here.
4441 sb-kernel:redefinition-with-defun
4442 sb-kernel:redefinition-with-defgeneric
4443 sb-kernel:redefinition-with-defmethod
4444 sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
4445 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
4446 "A suggested value to which to set or bind *uninteresting-conditions*.")
4448 (defvar *uninteresting-conditions* '()
4449 "Conditions that may be skipped while compiling or loading Lisp code.")
4450 (defvar *uninteresting-compiler-conditions* '()
4451 "Additional conditions that may be skipped while compiling Lisp code.")
4452 (defvar *uninteresting-loader-conditions*
4454 '("Overwriting already existing readtable ~S." ;; from named-readtables
4455 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
4456 #+clisp '(clos::simple-gf-replacing-method-warning))
4457 "Additional conditions that may be skipped while loading Lisp code."))
4459 ;;;; ----- Filtering conditions while building -----
4460 (with-upgradability ()
4461 (defun call-with-muffled-compiler-conditions (thunk)
4462 (call-with-muffled-conditions
4463 thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
4464 (defmacro with-muffled-compiler-conditions ((&optional) &body body)
4465 "Run BODY where uninteresting compiler conditions are muffled"
4466 `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
4467 (defun call-with-muffled-loader-conditions (thunk)
4468 (call-with-muffled-conditions
4469 thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
4470 (defmacro with-muffled-loader-conditions ((&optional) &body body)
4471 "Run BODY where uninteresting compiler and additional loader conditions are muffled"
4472 `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
4475 ;;;; Handle warnings and failures
4476 (with-upgradability ()
4477 (define-condition compile-condition (condition)
4479 :initform nil :reader compile-condition-context-format :initarg :context-format)
4481 :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
4483 :initform nil :reader compile-condition-description :initarg :description))
4484 (:report (lambda (c s)
4485 (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
4486 (or (compile-condition-description c) (type-of c))
4487 (compile-condition-context-format c)
4488 (compile-condition-context-arguments c)))))
4489 (define-condition compile-file-error (compile-condition error) ())
4490 (define-condition compile-warned-warning (compile-condition warning) ())
4491 (define-condition compile-warned-error (compile-condition error) ())
4492 (define-condition compile-failed-warning (compile-condition warning) ())
4493 (define-condition compile-failed-error (compile-condition error) ())
4495 (defun check-lisp-compile-warnings (warnings-p failure-p
4496 &optional context-format context-arguments)
4498 (case *compile-file-failure-behaviour*
4499 (:warn (warn 'compile-failed-warning
4500 :description "Lisp compilation failed"
4501 :context-format context-format
4502 :context-arguments context-arguments))
4503 (:error (error 'compile-failed-error
4504 :description "Lisp compilation failed"
4505 :context-format context-format
4506 :context-arguments context-arguments))
4509 (case *compile-file-warnings-behaviour*
4510 (:warn (warn 'compile-warned-warning
4511 :description "Lisp compilation had style-warnings"
4512 :context-format context-format
4513 :context-arguments context-arguments))
4514 (:error (error 'compile-warned-error
4515 :description "Lisp compilation had style-warnings"
4516 :context-format context-format
4517 :context-arguments context-arguments))
4520 (defun check-lisp-compile-results (output warnings-p failure-p
4521 &optional context-format context-arguments)
4523 (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
4524 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
4527 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
4529 ;;; To support an implementation, three functions must be implemented:
4530 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
4531 ;;; See their respective docstrings.
4532 (with-upgradability ()
4533 (defun reify-simple-sexp (sexp)
4535 (symbol (reify-symbol sexp))
4536 ((or number character simple-string pathname) sexp)
4537 (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
4538 (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
4540 (defun unreify-simple-sexp (sexp)
4542 ((or symbol number character simple-string pathname) sexp)
4543 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
4544 ((simple-vector 2) (unreify-symbol sexp))
4545 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
4549 (defun reify-source-note (source-note)
4551 (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
4552 (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
4553 (declare (ignorable source))
4554 (list :filename filename :start-pos start-pos :end-pos end-pos
4555 #|:source (reify-source-note source)|#))))
4556 (defun unreify-source-note (source-note)
4558 (destructuring-bind (&key filename start-pos end-pos source) source-note
4559 (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
4560 :source (unreify-source-note source)))))
4561 (defun unsymbolify-function-name (name)
4562 (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
4565 (defun symbolify-function-name (name)
4566 (if (and (consp name) (eq (first name) 'setf))
4567 (let ((setfed (second name)))
4568 (gethash setfed ccl::%setf-function-names%))
4570 (defun reify-function-name (function-name)
4571 (let ((name (or (first function-name) ;; defun: extract the name
4572 (let ((sec (second function-name)))
4573 (or (and (atom sec) sec) ; scoped method: drop scope
4574 (first sec)))))) ; method: keep gf name, drop method specializers
4576 (defun unreify-function-name (function-name)
4578 (defun nullify-non-literals (sexp)
4580 ((or number character simple-string symbol pathname) sexp)
4581 (cons (cons (nullify-non-literals (car sexp))
4582 (nullify-non-literals (cdr sexp))))
4584 (defun reify-deferred-warning (deferred-warning)
4585 (with-accessors ((warning-type ccl::compiler-warning-warning-type)
4586 (args ccl::compiler-warning-args)
4587 (source-note ccl:compiler-warning-source-note)
4588 (function-name ccl:compiler-warning-function-name)) deferred-warning
4589 (list :warning-type warning-type :function-name (reify-function-name function-name)
4590 :source-note (reify-source-note source-note)
4591 :args (destructuring-bind (fun &rest more)
4593 (cons (unsymbolify-function-name fun)
4594 (nullify-non-literals more))))))
4595 (defun unreify-deferred-warning (reified-deferred-warning)
4596 (destructuring-bind (&key warning-type function-name source-note args)
4597 reified-deferred-warning
4598 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
4599 'ccl::compiler-warning)
4600 :function-name (unreify-function-name function-name)
4601 :source-note (unreify-source-note source-note)
4602 :warning-type warning-type
4603 :args (destructuring-bind (fun . more) args
4604 (cons (symbolify-function-name fun) more))))))
4606 (defun reify-undefined-warning (warning)
4607 ;; Extracting undefined-warnings from the compilation-unit
4608 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4610 (c::undefined-warning-kind warning)
4611 (c::undefined-warning-name warning)
4612 (c::undefined-warning-count warning)
4615 ;; the lexenv slot can be ignored for reporting purposes
4616 `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
4617 :source ,(c::compiler-error-context-source frob)
4618 :original-source ,(c::compiler-error-context-original-source frob)
4619 :context ,(c::compiler-error-context-context frob)
4620 :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
4621 :file-position ,(c::compiler-error-context-file-position frob) ; an integer
4622 :original-source-path ,(c::compiler-error-context-original-source-path frob)))
4623 (c::undefined-warning-warnings warning))))
4626 (defun reify-undefined-warning (warning)
4627 ;; Extracting undefined-warnings from the compilation-unit
4628 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4630 (sb-c::undefined-warning-kind warning)
4631 (sb-c::undefined-warning-name warning)
4632 (sb-c::undefined-warning-count warning)
4635 ;; the lexenv slot can be ignored for reporting purposes
4636 `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
4637 :source ,(sb-c::compiler-error-context-source frob)
4638 :original-source ,(sb-c::compiler-error-context-original-source frob)
4639 :context ,(sb-c::compiler-error-context-context frob)
4640 :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
4641 :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
4642 :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
4643 (sb-c::undefined-warning-warnings warning))))
4645 (defun reify-deferred-warnings ()
4646 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
4647 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
4648 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
4650 (list :functions-defined excl::.functions-defined.
4651 :functions-called excl::.functions-called.)
4653 (mapcar 'reify-deferred-warning
4654 (if-let (dw ccl::*outstanding-deferred-warnings*)
4655 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
4656 (ccl::deferred-warnings.warnings mdw))))
4658 (when lisp::*in-compilation-unit*
4659 ;; Try to send nothing through the pipe if nothing needs to be accumulated
4660 `(,@(when c::*undefined-warnings*
4661 `((c::*undefined-warnings*
4662 ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
4663 ,@(loop :for what :in '(c::*compiler-error-count*
4664 c::*compiler-warning-count*
4665 c::*compiler-note-count*)
4666 :for value = (symbol-value what)
4668 :collect `(,what . ,value))))
4670 (when sb-c::*in-compilation-unit*
4671 ;; Try to send nothing through the pipe if nothing needs to be accumulated
4672 `(,@(when sb-c::*undefined-warnings*
4673 `((sb-c::*undefined-warnings*
4674 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
4675 ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
4676 sb-c::*compiler-error-count*
4677 sb-c::*compiler-warning-count*
4678 sb-c::*compiler-style-warning-count*
4679 sb-c::*compiler-note-count*)
4680 :for value = (symbol-value what)
4682 :collect `(,what . ,value)))))
4684 (defun unreify-deferred-warnings (reified-deferred-warnings)
4685 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
4686 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
4687 Handle any warning that has been resolved already,
4688 such as an undefined function that has been defined since.
4689 One of three functions required for deferred-warnings support in ASDF."
4690 (declare (ignorable reified-deferred-warnings))
4692 (destructuring-bind (&key functions-defined functions-called)
4693 reified-deferred-warnings
4694 (setf excl::.functions-defined.
4695 (append functions-defined excl::.functions-defined.)
4696 excl::.functions-called.
4697 (append functions-called excl::.functions-called.)))
4699 (let ((dw (or ccl::*outstanding-deferred-warnings*
4700 (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
4701 (appendf (ccl::deferred-warnings.warnings dw)
4702 (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
4704 (dolist (item reified-deferred-warnings)
4705 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
4706 ;; For *undefined-warnings*, the adjustment is a list of initargs.
4707 ;; For everything else, it's an integer.
4708 (destructuring-bind (symbol . adjustment) item
4710 ((c::*undefined-warnings*)
4711 (setf c::*undefined-warnings*
4714 (destructuring-bind (kind name count . rest) stuff
4715 (unless (case kind (:function (fboundp name)))
4717 (c::make-undefined-warning
4722 (mapcar #'(lambda (x)
4723 (apply #'c::make-compiler-error-context x))
4726 c::*undefined-warnings*)))
4728 (set symbol (+ (symbol-value symbol) adjustment))))))
4730 (dolist (item reified-deferred-warnings)
4731 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
4732 ;; For *undefined-warnings*, the adjustment is a list of initargs.
4733 ;; For everything else, it's an integer.
4734 (destructuring-bind (symbol . adjustment) item
4736 ((sb-c::*undefined-warnings*)
4737 (setf sb-c::*undefined-warnings*
4740 (destructuring-bind (kind name count . rest) stuff
4741 (unless (case kind (:function (fboundp name)))
4743 (sb-c::make-undefined-warning
4748 (mapcar #'(lambda (x)
4749 (apply #'sb-c::make-compiler-error-context x))
4752 sb-c::*undefined-warnings*)))
4754 (set symbol (+ (symbol-value symbol) adjustment)))))))
4756 (defun reset-deferred-warnings ()
4757 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
4758 One of three functions required for deferred-warnings support in ASDF."
4760 (setf excl::.functions-defined. nil
4761 excl::.functions-called. nil)
4763 (if-let (dw ccl::*outstanding-deferred-warnings*)
4764 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
4765 (setf (ccl::deferred-warnings.warnings mdw) nil)))
4767 (when lisp::*in-compilation-unit*
4768 (setf c::*undefined-warnings* nil
4769 c::*compiler-error-count* 0
4770 c::*compiler-warning-count* 0
4771 c::*compiler-note-count* 0))
4773 (when sb-c::*in-compilation-unit*
4774 (setf sb-c::*undefined-warnings* nil
4775 sb-c::*aborted-compilation-unit-count* 0
4776 sb-c::*compiler-error-count* 0
4777 sb-c::*compiler-warning-count* 0
4778 sb-c::*compiler-style-warning-count* 0
4779 sb-c::*compiler-note-count* 0)))
4781 (defun save-deferred-warnings (warnings-file)
4782 "Save forward reference conditions so they may be issued at a latter time,
4783 possibly in a different process."
4784 (with-open-file (s warnings-file :direction :output :if-exists :supersede
4785 :element-type *default-stream-element-type*
4786 :external-format *utf-8-external-format*)
4787 (with-safe-io-syntax ()
4788 (write (reify-deferred-warnings) :stream s :pretty t :readably t)
4791 (defun warnings-file-type (&optional implementation-type)
4792 (case (or implementation-type *implementation-type*)
4793 ((:acl :allegro) "allegro-warnings")
4794 ;;((:clisp) "clisp-warnings")
4795 ((:cmu :cmucl) "cmucl-warnings")
4796 ((:sbcl) "sbcl-warnings")
4797 ((:clozure :ccl) "ccl-warnings")
4798 ((:scl) "scl-warnings")))
4800 (defvar *warnings-file-type* nil
4801 "Type for warnings files")
4803 (defun enable-deferred-warnings-check ()
4804 (setf *warnings-file-type* (warnings-file-type)))
4806 (defun disable-deferred-warnings-check ()
4807 (setf *warnings-file-type* nil))
4809 (defun warnings-file-p (file &optional implementation-type)
4810 (if-let (type (if implementation-type
4811 (warnings-file-type implementation-type)
4812 *warnings-file-type*))
4813 (equal (pathname-type file) type)))
4815 (defun check-deferred-warnings (files &optional context-format context-arguments)
4816 (let ((file-errors nil)
4820 ((warning #'(lambda (c)
4822 (unless (typep c 'style-warning)
4823 (setf failure-p t)))))
4824 (with-compilation-unit (:override t)
4825 (reset-deferred-warnings)
4826 (dolist (file files)
4827 (unreify-deferred-warnings
4828 (handler-case (safe-read-file-form file)
4830 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
4831 (push c file-errors)
4833 (dolist (error file-errors) (error error))
4834 (check-lisp-compile-warnings
4835 (or failure-p warnings-p) failure-p context-format context-arguments)))
4838 Mini-guide to adding support for deferred warnings on an implementation.
4840 First, look at what such a warning looks like:
4844 (and (eval '(lambda () (some-undefined-function))) nil)
4847 Then you can grep for the condition type in your compiler sources
4848 and see how to catch those that have been deferred,
4849 and/or read, clear and restore the deferred list.
4852 (macroexpand-1 '(with-compilation-unit () foo))
4855 (defun call-with-saved-deferred-warnings (thunk warnings-file)
4857 (with-compilation-unit (:override t)
4859 (let (#+sbcl (sb-c::*undefined-warnings* nil))
4860 (multiple-value-prog1
4862 (save-deferred-warnings warnings-file)))
4863 (reset-deferred-warnings)))
4866 (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
4867 "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
4868 and saves those warnings to the given file for latter use,
4869 possibly in a different process. Otherwise just run the BODY."
4870 `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
4874 (with-upgradability ()
4875 (defun current-lisp-file-pathname ()
4876 (or *compile-file-pathname* *load-pathname*))
4878 (defun load-pathname ()
4881 (defun lispize-pathname (input-file)
4882 (make-pathname :type "lisp" :defaults input-file))
4884 (defun compile-file-type (&rest keys)
4885 "pathname TYPE for lisp FASt Loading files"
4886 (declare (ignorable keys))
4887 #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
4888 #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
4890 (defun call-around-hook (hook function)
4891 (call-function (or hook 'funcall) function))
4893 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
4895 (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
4896 ,@(unless output-file '(:output-file))) keys)))
4897 (if (absolute-pathname-p output-file)
4898 ;; what cfp should be doing, w/ mp* instead of mp
4899 (let* ((type (pathname-type (apply 'compile-file-type keys)))
4900 (defaults (make-pathname
4901 :type type :defaults (merge-pathnames* input-file))))
4902 (merge-pathnames* output-file defaults))
4903 (funcall *output-translation-function*
4904 (apply 'compile-file-pathname input-file keys)))))
4906 (defun* (compile-file*) (input-file &rest keys
4907 &key compile-check output-file warnings-file
4908 #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
4910 "This function provides a portable wrapper around COMPILE-FILE.
4911 It ensures that the OUTPUT-FILE value is only returned and
4912 the file only actually created if the compilation was successful,
4913 even though your implementation may not do that, and including
4914 an optional call to an user-provided consistency check function COMPILE-CHECK;
4915 it will call this function if not NIL at the end of the compilation
4916 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
4917 where TMP-FILE is the name of a temporary output-file.
4918 It also checks two flags (with legacy british spelling from ASDF1),
4919 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
4920 with appropriate implementation-dependent defaults,
4921 and if a failure (respectively warnings) are reported by COMPILE-FILE
4922 with consider it an error unless the respective behaviour flag
4923 is one of :SUCCESS :WARN :IGNORE.
4924 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
4925 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
4926 On implementations that erroneously do not recognize standard keyword arguments,
4927 it will filter them appropriately."
4928 #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
4929 (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
4930 'compile-file* output-file object-file)
4931 (rotatef output-file object-file))
4932 (let* ((keywords (remove-plist-keys
4933 `(:output-file :compile-check :warnings-file
4934 #+clisp :lib-file #+(or ecl mkcl) :object-file
4935 #+gcl2.6 ,@'(:external-format :print :verbose)) keys))
4938 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
4941 (unless (use-ecl-byte-compiler-p)
4943 (compile-file-pathname output-file :type :object))))
4947 (compile-file-pathname output-file :fasl-p nil)))
4948 (tmp-file (tmpize-pathname output-file))
4950 (cfasl-file (etypecase emit-cfasl
4952 ((eql t) (make-pathname :type "cfasl" :defaults output-file))
4953 (string (parse-namestring emit-cfasl))
4954 (pathname emit-cfasl)))
4956 (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
4958 (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
4959 (multiple-value-bind (output-truename warnings-p failure-p)
4960 (with-saved-deferred-warnings (warnings-file)
4961 (with-muffled-compiler-conditions ()
4963 (apply 'compile-file input-file :output-file tmp-file
4964 #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
4966 #+ecl (apply 'compile-file input-file :output-file
4968 (list* object-file :system-p t keywords)
4969 (list* tmp-file keywords)))
4970 #+mkcl (apply 'compile-file input-file
4971 :output-file object-file :fasl-p nil keywords))))
4973 ((and output-truename
4974 (flet ((check-flag (flag behaviour)
4975 (or (not flag) (member behaviour '(:success :warn :ignore)))))
4976 (and (check-flag failure-p *compile-file-failure-behaviour*)
4977 (check-flag warnings-p *compile-file-warnings-behaviour*)))
4980 (when (and #+ecl object-file)
4981 (setf output-truename
4982 (compiler::build-fasl
4983 tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
4984 (list object-file))))
4985 (or (not compile-check)
4986 (apply compile-check input-file :output-file tmp-file keywords))))
4987 (delete-file-if-exists output-file)
4988 (when output-truename
4989 #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
4990 #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
4991 (rename-file-overwriting-target output-truename output-file)
4992 (setf output-truename (truename output-file)))
4993 #+clisp (delete-file-if-exists tmp-lib))
4994 (t ;; error or failed check
4995 (delete-file-if-exists output-truename)
4996 #+clisp (delete-file-if-exists tmp-lib)
4997 #+sbcl (delete-file-if-exists tmp-cfasl)
4998 (setf output-truename nil)))
4999 (values output-truename warnings-p failure-p))))
5001 (defun load* (x &rest keys &key &allow-other-keys)
5003 ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
5005 #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
5006 ;; GCL 2.6, Genera can't load from a string-input-stream
5007 ;; ClozureCL 1.6 can only load from file input stream
5008 ;; Allegro 5, I don't remember but it must have been broken when I tested.
5009 #+(or allegro clozure gcl2.6 genera)
5010 (stream ;; make do this way
5011 (let ((*package* *package*)
5012 (*readtable* *readtable*)
5013 (*load-pathname* nil)
5014 (*load-truename* nil))
5017 (defun load-from-string (string)
5018 "Portably read and evaluate forms from a STRING."
5019 (with-input-from-string (s string) (load* s))))
5021 ;;; Links FASLs together
5022 (with-upgradability ()
5023 (defun combine-fasls (inputs output)
5024 #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
5025 (error "~A does not support ~S~%inputs ~S~%output ~S"
5026 (implementation-type) 'combine-fasls inputs output)
5027 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
5028 #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
5029 #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
5034 (loop :for i :in inputs
5036 :for f = (add-pathname-suffix
5037 output (format nil "-FASL~D" n))
5040 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
5041 (eval `(scm:defsystem :fasls-to-concatenate
5042 (:default-pathname ,(pathname-directory-pathname output))
5044 ,(loop :for f :in (reverse fasls)
5045 :collect `(,(namestring f) :load-only t))))
5046 (scm:concatenate-system output :fasls-to-concatenate))
5047 (loop :for f :in fasls :do (ignore-errors (delete-file f)))
5048 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
5050 ;;;; ---------------------------------------------------------------------------
5051 ;;;; Generic support for configuration files
5053 (uiop/package:define-package :uiop/configuration
5054 (:nicknames :asdf/configuration)
5055 (:recycle :uiop/configuration :asdf/configuration :asdf)
5056 (:use :uiop/common-lisp :uiop/utility
5057 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
5060 #:user-configuration-directories #:system-configuration-directories
5061 #:in-first-directory
5062 #:in-user-configuration-directory #:in-system-configuration-directory
5063 #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
5064 #:configuration-inheritance-directive-p
5065 #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
5066 #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
5067 #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
5068 #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
5069 (in-package :uiop/configuration)
5071 (with-upgradability ()
5072 (define-condition invalid-configuration ()
5073 ((form :reader condition-form :initarg :form)
5074 (location :reader condition-location :initarg :location)
5075 (format :reader condition-format :initarg :format)
5076 (arguments :reader condition-arguments :initarg :arguments :initform nil))
5077 (:report (lambda (c s)
5078 (format s (compatfmt "~@<~? (will be skipped)~@:>")
5079 (condition-format c)
5080 (list* (condition-form c) (condition-location c)
5081 (condition-arguments c))))))
5083 (defun get-folder-path (folder)
5084 (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
5085 #+(and lispworks mswindows) (sys:get-folder-path folder)
5086 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
5088 (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
5089 (:appdata (getenv-absolute-directory "APPDATA"))
5090 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
5091 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
5093 (defun user-configuration-directories ()
5095 `(,@(when (os-unix-p)
5097 (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
5098 (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
5099 :collect (subpathname* dir "common-lisp/"))))
5100 ,@(when (os-windows-p)
5101 `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
5102 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
5103 ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
5104 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
5105 :from-end t :test 'equal)))
5107 (defun system-configuration-directories ()
5109 ((os-unix-p) '(#p"/etc/common-lisp/"))
5111 (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
5114 (defun in-first-directory (dirs x &key (direction :input))
5115 (loop :with fun = (ecase direction
5116 ((nil :input :probe) 'probe-file*)
5117 ((:output :io) 'identity))
5119 :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
5121 (defun in-user-configuration-directory (x &key (direction :input))
5122 (in-first-directory (user-configuration-directories) x :direction direction))
5123 (defun in-system-configuration-directory (x &key (direction :input))
5124 (in-first-directory (system-configuration-directories) x :direction direction))
5126 (defun configuration-inheritance-directive-p (x)
5127 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
5129 (and (length=n-p x 1) (member (car x) kw)))))
5131 (defun report-invalid-form (reporter &rest args)
5134 (apply 'error 'invalid-configuration args))
5136 (apply reporter args))
5138 (apply 'error reporter args))
5140 (apply 'apply (append reporter args)))))
5142 (defvar *ignored-configuration-form* nil)
5144 (defun validate-configuration-form (form tag directive-validator
5145 &key location invalid-form-reporter)
5146 (unless (and (consp form) (eq (car form) tag))
5147 (setf *ignored-configuration-form* t)
5148 (report-invalid-form invalid-form-reporter :form form :location location)
5149 (return-from validate-configuration-form nil))
5150 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
5151 :for directive :in (cdr form)
5153 ((configuration-inheritance-directive-p directive)
5155 ((eq directive :ignore-invalid-entries)
5156 (setf ignore-invalid-p t) t)
5157 ((funcall directive-validator directive)
5162 (setf *ignored-configuration-form* t)
5163 (report-invalid-form invalid-form-reporter :form directive :location location)
5165 :do (push directive x)
5167 (unless (= inherit 1)
5168 (report-invalid-form invalid-form-reporter
5169 :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
5170 :inherit-configuration :ignore-inherited-configuration)))
5171 (return (nreverse x))))
5173 (defun validate-configuration-file (file validator &key description)
5174 (let ((forms (read-file-forms file)))
5175 (unless (length=n-p forms 1)
5176 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
5178 (funcall validator (car forms) :location file)))
5180 (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
5181 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
5182 be applied to the results to yield a configuration form. Current
5183 values of TAG include :source-registry and :output-translations."
5184 (let ((files (sort (ignore-errors
5187 (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
5188 #'string< :key #'namestring)))
5190 ,@(loop :for file :in files :append
5191 (loop :with ignore-invalid-p = nil
5192 :for form :in (read-file-forms file)
5193 :when (eq form :ignore-invalid-entries)
5194 :do (setf ignore-invalid-p t)
5196 :when (funcall validator form)
5199 :when ignore-invalid-p
5200 :do (setf *ignored-configuration-form* t)
5202 :do (report-invalid-form invalid-form-reporter :form form :location file)))
5203 :inherit-configuration)))
5205 (defun resolve-relative-location (x &key ensure-directory wilden)
5209 (string (parse-unix-namestring
5210 x :ensure-directory ensure-directory))
5213 (resolve-relative-location
5214 (car x) :ensure-directory ensure-directory :wilden wilden)
5215 (let* ((car (resolve-relative-location
5216 (car x) :ensure-directory t :wilden nil)))
5218 (resolve-relative-location
5219 (cdr x) :ensure-directory ensure-directory :wilden wilden)
5221 ((eql :*/) *wild-directory*)
5222 ((eql :**/) *wild-inferiors*)
5223 ((eql :*.*.*) *wild-file*)
5224 ((eql :implementation)
5225 (parse-unix-namestring
5226 (implementation-identifier) :ensure-directory t))
5227 ((eql :implementation-type)
5228 (parse-unix-namestring
5229 (string-downcase (implementation-type)) :ensure-directory t))
5231 (parse-unix-namestring (hostname) :ensure-directory t)))
5232 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
5235 (defvar *here-directory* nil
5236 "This special variable is bound to the currect directory during calls to
5237 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
5240 (defvar *user-cache* nil
5241 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
5243 (defun compute-user-cache ()
5245 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
5247 (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
5248 (when (os-windows-p)
5249 (try (or (get-folder-path :local-appdata)
5250 (get-folder-path :appdata))
5251 "common-lisp" "cache" :implementation))
5252 '(:home ".cache" "common-lisp" :implementation)))))
5253 (register-image-restore-hook 'compute-user-cache)
5255 (defun resolve-absolute-location (x &key ensure-directory wilden)
5260 (let ((p #-mcl (parse-namestring x)
5261 #+mcl (probe-posix x)))
5262 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
5263 (if ensure-directory (ensure-directory-pathname p) p)))
5265 (return-from resolve-absolute-location
5267 (resolve-absolute-location
5268 (car x) :ensure-directory ensure-directory :wilden wilden)
5270 (resolve-relative-location
5271 (cdr x) :ensure-directory ensure-directory :wilden wilden)
5272 (resolve-absolute-location
5273 (car x) :ensure-directory t :wilden nil)))))
5275 ;; special magic! we return a relative pathname,
5276 ;; but what it means to the output-translations is
5277 ;; "relative to the root of the source pathname's host and device".
5278 (return-from resolve-absolute-location
5279 (let ((p (make-pathname* :directory '(:relative))))
5280 (if wilden (wilden p) p))))
5281 ((eql :home) (user-homedir-pathname))
5282 ((eql :here) (resolve-absolute-location
5283 (or *here-directory* (pathname-directory-pathname (load-pathname)))
5284 :ensure-directory t :wilden nil))
5285 ((eql :user-cache) (resolve-absolute-location
5286 *user-cache* :ensure-directory t :wilden nil)))
5287 :wilden (and wilden (not (pathnamep x)))
5288 :resolve-symlinks *resolve-symlinks*
5291 ;; Try to override declaration in previous versions of ASDF.
5292 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
5293 (:ensure-directory boolean)) t) resolve-location))
5295 (defun* (resolve-location) (x &key ensure-directory wilden directory)
5296 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
5297 (loop* :with dirp = (or directory ensure-directory)
5298 :with (first . rest) = (if (atom x) (list x) x)
5299 :with path = (resolve-absolute-location
5300 first :ensure-directory (and (or dirp rest) t)
5301 :wilden (and wilden (null rest)))
5302 :for (element . morep) :on rest
5303 :for dir = (and (or morep dirp) t)
5304 :for wild = (and wilden (not morep))
5305 :for sub = (merge-pathnames*
5306 (resolve-relative-location
5307 element :ensure-directory dir :wilden wild)
5309 :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
5310 :finally (return path)))
5312 (defun location-designator-p (x)
5313 (flet ((absolute-component-p (c)
5314 (typep c '(or string pathname
5315 (member :root :home :here :user-cache))))
5316 (relative-component-p (c)
5317 (typep c '(or string pathname
5318 (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
5319 (or (typep x 'boolean)
5320 (absolute-component-p x)
5321 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
5323 (defun location-function-p (x)
5326 (eq (car x) :function)
5327 (or (symbolp (cadr x))
5328 (and (consp (cadr x))
5329 (eq (caadr x) 'lambda)
5330 (length=n-p (cadadr x) 2)))))
5332 (defvar *clear-configuration-hook* '())
5334 (defun register-clear-configuration-hook (hook-function &optional call-now-p)
5335 (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
5337 (defun clear-configuration ()
5338 (call-functions *clear-configuration-hook*))
5340 (register-image-dump-hook 'clear-configuration)
5342 ;; If a previous version of ASDF failed to read some configuration, try again.
5343 (defun upgrade-configuration ()
5344 (when *ignored-configuration-form*
5345 (clear-configuration)
5346 (setf *ignored-configuration-form* nil))))
5349 ;;;; -------------------------------------------------------------------------
5350 ;;; Hacks for backward-compatibility of the driver
5352 (uiop/package:define-package :uiop/backward-driver
5353 (:nicknames :asdf/backward-driver)
5354 (:recycle :uiop/backward-driver :asdf/backward-driver :asdf)
5355 (:use :uiop/common-lisp :uiop/package :uiop/utility
5356 :uiop/pathname :uiop/stream :uiop/os :uiop/image
5357 :uiop/run-program :uiop/lisp-build
5358 :uiop/configuration)
5360 #:coerce-pathname #:component-name-to-pathname-components
5361 #+(or ecl mkcl) #:compile-file-keeping-object
5363 (in-package :uiop/backward-driver)
5365 ;;;; Backward compatibility with various pathname functions.
5367 (with-upgradability ()
5368 (defun coerce-pathname (name &key type defaults)
5369 ;; For backward-compatibility only, for people using internals
5370 ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
5371 ;; Will be removed after 2014-01-16.
5372 ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
5373 (parse-unix-namestring name :type type :defaults defaults))
5375 (defun component-name-to-pathname-components (unix-style-namestring
5376 &key force-directory force-relative)
5377 ;; Will be removed after 2014-01-16.
5378 ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
5379 (multiple-value-bind (relabs path filename file-only)
5380 (split-unix-namestring-directory-components
5381 unix-style-namestring :ensure-directory force-directory)
5382 (declare (ignore file-only))
5383 (when (and force-relative (not (eq relabs :relative)))
5384 (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
5385 unix-style-namestring))
5386 (values relabs path filename)))
5389 (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
5390 ;;;; ---------------------------------------------------------------------------
5391 ;;;; Re-export all the functionality in asdf/driver
5393 (uiop/package:define-package :uiop/driver
5394 (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
5395 (:use :uiop/common-lisp :uiop/package :uiop/utility
5396 :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
5397 :uiop/run-program :uiop/lisp-build
5398 :uiop/configuration :uiop/backward-driver)
5400 ;; NB: excluding asdf/common-lisp
5401 ;; which include all of CL with compatibility modifications on select platforms.
5402 :uiop/package :uiop/utility
5403 :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
5404 :uiop/run-program :uiop/lisp-build
5405 :uiop/configuration :uiop/backward-driver))
5406 ;;;; -------------------------------------------------------------------------
5407 ;;;; Handle upgrade as forward- and backward-compatibly as possible
5408 ;; See https://bugs.launchpad.net/asdf/+bug/485687
5410 (asdf/package:define-package :asdf/upgrade
5411 (:recycle :asdf/upgrade :asdf)
5412 (:use :asdf/common-lisp :asdf/driver)
5414 #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
5415 #:asdf-message #:*verbose-out*
5416 #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
5417 #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
5418 ;; There will be no symbol left behind!
5420 (:import-from :asdf/package #:intern* #:find-symbol*))
5421 (in-package :asdf/upgrade)
5423 ;;; Special magic to detect if this is an upgrade
5425 (with-upgradability ()
5426 (defun asdf-version ()
5427 "Exported interface to the version of ASDF currently installed. A string.
5428 You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
5429 (when (find-package :asdf)
5430 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
5431 (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
5432 (rev (and revsym (boundp revsym) (symbol-value revsym))))
5435 (cons (format nil "~{~D~^.~}" rev))
5437 (defvar *asdf-version* nil)
5438 (defvar *previous-asdf-versions* nil)
5439 (defvar *verbose-out* nil)
5440 (defun asdf-message (format-string &rest format-args)
5441 (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
5442 (defvar *post-upgrade-cleanup-hook* ())
5443 (defvar *post-upgrade-restart-hook* ())
5444 (defun upgrading-p ()
5445 (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
5446 (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
5447 `(with-upgradability ()
5448 (when (and ,upgrading-p ,@(when when `(,when)))
5449 (handler-bind ((style-warning #'muffle-warning))
5450 (eval '(progn ,@body))))))
5451 (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
5452 ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
5453 ;; can help you do these changes in synch (look at the source for documentation).
5454 ;; Relying on its automation, the version is now redundantly present on top of this file.
5455 ;; "3.4" would be the general branch for major version 3, minor version 4.
5456 ;; "3.4.5" would be an official release in the 3.4 branch.
5457 ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
5458 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
5459 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
5460 (asdf-version "3.0.2")
5461 (existing-version (asdf-version)))
5462 (setf *asdf-version* asdf-version)
5463 (when (and existing-version (not (equal asdf-version existing-version)))
5464 (push existing-version *previous-asdf-versions*)
5465 (when (or *load-verbose* *verbose-out*)
5466 (format *trace-output*
5467 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
5468 existing-version asdf-version)))))
5471 (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
5472 '(#:component-relative-pathname #:component-parent-pathname ;; component
5474 #:find-system #:system-source-file #:system-relative-pathname ;; system
5475 #:find-component ;; find-component
5476 #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
5477 #:component-depends-on #:operation-done-p #:component-depends-on
5478 #:traverse ;; backward-interface
5479 #:operate ;; operate
5480 #:parse-component-form ;; defsystem
5481 #:apply-output-translations ;; output-translations
5482 #:process-output-translations-directive
5483 #:inherit-source-registry #:process-source-registry ;; source-registry
5484 #:process-source-registry-directive
5485 #:trivial-system-p ;; bundle
5486 ;; NB: it's too late to do anything about asdf-driver functions!
5489 '(#:*asdf-revision* #:around #:asdf-method-combination
5490 #:split #:make-collector #:do-dep #:do-one-dep
5491 #:component-self-dependencies
5492 #:resolve-relative-location-component #:resolve-absolute-location-component
5493 #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
5494 (declare (ignorable redefined-functions uninterned-symbols))
5495 (loop :for name :in (append redefined-functions)
5496 :for sym = (find-symbol* name :asdf nil) :do
5498 ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
5499 #-clisp (fmakunbound sym)))
5500 (loop :with asdf = (find-package :asdf)
5501 :for name :in uninterned-symbols
5502 :for sym = (find-symbol* name :asdf nil)
5503 :for base-pkg = (and sym (symbol-package sym)) :do
5506 ((or (eq base-pkg asdf) (not base-pkg))
5507 (unintern* sym asdf)
5510 (unintern* sym base-pkg)
5511 (let ((new (intern* sym base-pkg)))
5512 (shadowing-import new asdf))))))))
5515 ;;; Self-upgrade functions
5517 (with-upgradability ()
5518 (defun asdf-upgrade-error ()
5519 ;; Important notice for whom it concerns. The crux of the matter is that
5520 ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late.
5521 (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~
5522 Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"))
5524 (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
5525 (let ((new-version (asdf-version)))
5526 (unless (equal old-version new-version)
5527 (push new-version *previous-asdf-versions*)
5529 (if (version<= new-version old-version)
5530 (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
5531 old-version new-version)
5532 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
5533 old-version new-version))
5534 (call-functions (reverse *post-upgrade-cleanup-hook*))
5537 (defun upgrade-asdf ()
5538 "Try to upgrade of ASDF. If a different version was used, return T.
5539 We need do that before we operate on anything that may possibly depend on ASDF."
5540 (let ((*load-print* nil)
5541 (*compile-print* nil))
5542 (handler-bind (((or style-warning) #'muffle-warning))
5543 (symbol-call :asdf :load-system :asdf :verbose nil))))
5545 (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
5547 ;;;; -------------------------------------------------------------------------
5550 (asdf/package:define-package :asdf/component
5551 (:recycle :asdf/component :asdf)
5552 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
5554 #:component #:component-find-path
5555 #:component-name #:component-pathname #:component-relative-pathname
5556 #:component-parent #:component-system #:component-parent-pathname
5557 #:child-component #:parent-component #:module
5559 #:source-file #:c-source-file #:java-source-file
5560 #:static-file #:doc-file #:html-file
5562 #:source-file-type #:source-file-explicit-type ;; backward-compatibility
5563 #:component-in-order-to #:component-sideway-dependencies
5564 #:component-if-feature #:around-compile-hook
5565 #:component-description #:component-long-description
5566 #:component-version #:version-satisfies
5567 #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
5568 #:component-operation-times ;; For internal use only.
5569 ;; portable ASDF encoding and implementation-specific external-format
5570 #:component-external-format #:component-encoding
5571 #:component-children-by-name #:component-children #:compute-children-by-name
5572 #:component-build-operation
5573 #:module-default-component-class
5574 #:module-components ;; backward-compatibility. DO NOT USE.
5577 ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
5578 #:name #:version #:description #:long-description #:author #:maintainer #:licence
5579 #:components-by-name #:components
5580 #:children #:children-by-name #:default-component-class
5581 #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
5582 #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
5583 #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
5584 #:%encoding #:properties #:component-properties #:parent))
5585 (in-package :asdf/component)
5587 (with-upgradability ()
5588 (defgeneric component-name (component)
5589 (:documentation "Name of the COMPONENT, unique relative to its parent"))
5590 (defgeneric component-system (component)
5591 (:documentation "Find the top-level system containing COMPONENT"))
5592 (defgeneric component-pathname (component)
5593 (:documentation "Extracts the pathname applicable for a particular component."))
5594 (defgeneric (component-relative-pathname) (component)
5595 (:documentation "Returns a pathname for the component argument intended to be
5596 interpreted relative to the pathname of that component's parent.
5597 Despite the function's name, the return value may be an absolute
5598 pathname, because an absolute pathname may be interpreted relative to
5599 another pathname in a degenerate way."))
5600 (defgeneric component-external-format (component))
5601 (defgeneric component-encoding (component))
5602 (defgeneric version-satisfies (component version))
5603 (defgeneric component-version (component))
5604 (defgeneric (setf component-version) (new-version component))
5605 (defgeneric component-parent (component))
5606 (defmethod component-parent ((component null)) (declare (ignorable component)) nil)
5608 ;; Backward compatible way of computing the FILE-TYPE of a component.
5609 ;; TODO: find users, have them stop using that, remove it for ASDF4.
5610 (defgeneric (source-file-type) (component system)))
5612 (when-upgrading (:when (find-class 'component nil))
5613 (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
5614 (declare (ignorable c initargs)) (values)))
5616 (with-upgradability ()
5617 (defclass component ()
5618 ((name :accessor component-name :initarg :name :type string :documentation
5619 "Component name: designator for a string composed of portable pathname characters")
5620 ;; We might want to constrain version with
5621 ;; :type (and string (satisfies parse-version))
5622 ;; but we cannot until we fix all systems that don't use it correctly!
5623 (version :accessor component-version :initarg :version :initform nil)
5624 (description :accessor component-description :initarg :description :initform nil)
5625 (long-description :accessor component-long-description :initarg :long-description :initform nil)
5626 (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
5627 (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
5628 ;; In the ASDF object model, dependencies exist between *actions*,
5629 ;; where an action is a pair of an operation and a component.
5630 ;; Dependencies are represented as alists of operations
5631 ;; to a list where each entry is a pair of an operation and a list of component specifiers.
5632 ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
5633 ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
5634 ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
5635 ;; and do-first things that modify the current image (such as loading a fasl).
5636 ;; These are now unified because we now correctly propagate timestamps between dependencies.
5637 ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
5638 ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
5639 ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
5640 ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
5641 ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
5642 ;; See our ASDF 2 paper for more complete explanations.
5643 (in-order-to :initform nil :initarg :in-order-to
5644 :accessor component-in-order-to)
5645 ;; methods defined using the "inline" style inside a defsystem form:
5646 ;; need to store them somewhere so we can delete them when the system
5648 (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES.
5649 ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
5650 ;; There is no initform and no direct accessor for this specified pathname,
5651 ;; so we only access the information through appropriate methods, after it has been processed.
5652 ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
5653 (relative-pathname :initarg :pathname)
5654 ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
5655 ;; The slot is but a cache used by component-pathname.
5657 (operation-times :initform (make-hash-table)
5658 :accessor component-operation-times)
5659 (around-compile :initarg :around-compile)
5660 ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
5661 (properties :accessor component-properties :initarg :properties
5663 (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
5664 ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
5665 (parent :initarg :parent :initform nil :reader component-parent)
5667 :initarg :build-operation :initform nil :reader component-build-operation)))
5669 (defun component-find-path (component)
5670 (check-type component (or null component))
5672 (loop :for c = component :then (component-parent c)
5673 :while c :collect (component-name c))))
5675 (defmethod print-object ((c component) stream)
5676 (print-unreadable-object (c stream :type t :identity nil)
5677 (format stream "~{~S~^ ~}" (component-find-path c))))
5679 (defmethod component-system ((component component))
5680 (if-let (system (component-parent component))
5681 (component-system system)
5685 ;;;; Component hierarchy within a system
5686 ;; The tree typically but not necessarily follows the filesystem hierarchy.
5687 (with-upgradability ()
5688 (defclass child-component (component) ())
5690 (defclass file-component (child-component)
5691 ((type :accessor file-type :initarg :type))) ; no default
5692 (defclass source-file (file-component)
5693 ((type :accessor source-file-explicit-type ;; backward-compatibility
5694 :initform nil))) ;; NB: many systems have come to rely on this default.
5695 (defclass c-source-file (source-file)
5696 ((type :initform "c")))
5697 (defclass java-source-file (source-file)
5698 ((type :initform "java")))
5699 (defclass static-file (source-file)
5700 ((type :initform nil)))
5701 (defclass doc-file (static-file) ())
5702 (defclass html-file (doc-file)
5703 ((type :initform "html")))
5705 (defclass parent-component (component)
5708 :initarg :components
5709 :reader module-components ; backward-compatibility
5710 :accessor component-children)
5712 :reader module-components-by-name ; backward-compatibility
5713 :accessor component-children-by-name)
5714 (default-component-class
5716 :initarg :default-component-class
5717 :accessor module-default-component-class))))
5719 (with-upgradability ()
5720 (defun compute-children-by-name (parent &key only-if-needed-p)
5721 (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
5722 (let ((hash (make-hash-table :test 'equal)))
5723 (setf (component-children-by-name parent) hash)
5724 (loop :for c :in (component-children parent)
5725 :for name = (component-name c)
5726 :for previous = (gethash name hash)
5727 :do (when previous (error 'duplicate-names :name name))
5728 (setf (gethash name hash) c))
5731 (when-upgrading (:when (find-class 'module nil))
5732 (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
5733 (declare (ignorable m initargs)) (values))
5734 (defmethod update-instance-for-redefined-class :after
5735 ((m module) added deleted plist &key)
5736 (declare (ignorable m added deleted plist))
5737 (when (and (member 'children added) (member 'components deleted))
5738 (setf (slot-value m 'children)
5739 ;; old ECLs provide an alist instead of a plist(!)
5740 (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
5741 (getf plist 'components)))
5742 (compute-children-by-name m))))
5744 (with-upgradability ()
5745 (defclass module (child-component parent-component)
5746 (#+clisp (components)))) ;; backward compatibility during upgrade only
5749 ;;;; component pathnames
5750 (with-upgradability ()
5751 (defgeneric* (component-parent-pathname) (component))
5752 (defmethod component-parent-pathname (component)
5753 (component-pathname (component-parent component)))
5755 (defmethod component-pathname ((component component))
5756 (if (slot-boundp component 'absolute-pathname)
5757 (slot-value component 'absolute-pathname)
5760 (component-relative-pathname component)
5761 (pathname-directory-pathname (component-parent-pathname component)))))
5762 (unless (or (null pathname) (absolute-pathname-p pathname))
5763 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
5764 pathname (component-find-path component)))
5765 (setf (slot-value component 'absolute-pathname) pathname)
5768 (defmethod component-relative-pathname ((component component))
5769 ;; source-file-type is backward-compatibility with ASDF1;
5770 ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
5771 ;; TODO: track who uses it, and have them not use it anymore.
5772 (parse-unix-namestring
5773 (or (and (slot-boundp component 'relative-pathname)
5774 (slot-value component 'relative-pathname))
5775 (component-name component))
5777 :type (source-file-type component (component-system component))
5778 :defaults (component-parent-pathname component)))
5780 (defmethod source-file-type ((component parent-component) system)
5781 (declare (ignorable component system))
5784 (defmethod source-file-type ((component file-component) system)
5785 (declare (ignorable system))
5786 (file-type component)))
5790 (with-upgradability ()
5791 (defmethod component-encoding ((c component))
5792 (or (loop :for x = c :then (component-parent x)
5793 :while x :thereis (%component-encoding x))
5794 (detect-encoding (component-pathname c))))
5796 (defmethod component-external-format ((c component))
5797 (encoding-external-format (component-encoding c))))
5800 ;;;; around-compile-hook
5801 (with-upgradability ()
5802 (defgeneric around-compile-hook (component))
5803 (defmethod around-compile-hook ((c component))
5805 ((slot-boundp c 'around-compile)
5806 (slot-value c 'around-compile))
5807 ((component-parent c)
5808 (around-compile-hook (component-parent c))))))
5811 ;;;; version-satisfies
5812 (with-upgradability ()
5813 (defmethod version-satisfies ((c component) version)
5814 (unless (and version (slot-boundp c 'version))
5816 (warn "Requested version ~S but component ~S has no version" version c))
5817 (return-from version-satisfies t))
5818 (version-satisfies (component-version c) version))
5820 (defmethod version-satisfies ((cver string) version)
5821 (version<= version cver)))
5824 ;;; all sub-components (of a given type)
5825 (with-upgradability ()
5826 (defun sub-components (component &key (type t))
5827 (while-collecting (c)
5828 (labels ((recurse (x)
5829 (when (if-let (it (component-if-feature x)) (featurep it) t)
5830 (when (typep x type)
5832 (when (typep x 'parent-component)
5833 (map () #'recurse (component-children x))))))
5834 (recurse component)))))
5836 ;;;; -------------------------------------------------------------------------
5839 (asdf/package:define-package :asdf/system
5840 (:recycle :asdf :asdf/system)
5841 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
5843 #:system #:proto-system
5844 #:system-source-file #:system-source-directory #:system-relative-pathname
5846 #:system-description #:system-long-description
5847 #:system-author #:system-maintainer #:system-licence #:system-license
5848 #:system-defsystem-depends-on
5849 #:component-build-pathname #:build-pathname
5850 #:component-entry-point #:entry-point
5851 #:homepage #:system-homepage
5852 #:bug-tracker #:system-bug-tracker
5853 #:mailto #:system-mailto
5854 #:long-name #:system-long-name
5855 #:source-control #:system-source-control
5856 #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
5857 (in-package :asdf/system)
5859 (with-upgradability ()
5860 (defgeneric* (find-system) (system &optional error-p))
5861 (defgeneric* (system-source-file) (system)
5862 (:documentation "Return the source file in which system is defined."))
5863 (defgeneric component-build-pathname (component))
5865 (defgeneric component-entry-point (component))
5866 (defmethod component-entry-point ((c component))
5867 (declare (ignorable c))
5871 ;;;; The system class
5873 (with-upgradability ()
5874 (defclass proto-system () ; slots to keep when resetting a system
5875 ;; To preserve identity for all objects, we'd need keep the components slots
5876 ;; but also to modify parse-component-form to reset the recycled objects.
5877 ((name) (source-file) #|(children) (children-by-names)|#))
5879 (defclass system (module proto-system)
5880 ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
5881 (;; {,long-}description is now inherited from component, but we add the legacy accessors
5882 (description :accessor system-description)
5883 (long-description :accessor system-long-description)
5884 (author :accessor system-author :initarg :author :initform nil)
5885 (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)
5886 (licence :accessor system-licence :initarg :licence
5887 :accessor system-license :initarg :license :initform nil)
5888 (homepage :accessor system-homepage :initarg :homepage :initform nil)
5889 (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil)
5890 (mailto :accessor system-mailto :initarg :mailto :initform nil)
5891 (long-name :accessor system-long-name :initarg :long-name :initform nil)
5892 ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
5893 ;; I'm introducing the slot before the conventions are set for maximum compatibility.
5894 (source-control :accessor system-source-control :initarg :source-control :initform nil)
5895 (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
5897 :initform nil :initarg :build-pathname :accessor component-build-pathname)
5899 :initform nil :initarg :entry-point :accessor component-entry-point)
5900 (source-file :initform nil :initarg :source-file :accessor system-source-file)
5901 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
5903 (defun reset-system (system &rest keys &key &allow-other-keys)
5904 (change-class (change-class system 'proto-system) 'system)
5905 (apply 'reinitialize-instance system keys)))
5910 (with-upgradability ()
5911 (defmethod system-source-file ((system-name string))
5912 (system-source-file (find-system system-name)))
5913 (defmethod system-source-file ((system-name symbol))
5914 (system-source-file (find-system system-name)))
5916 (defun system-source-directory (system-designator)
5917 "Return a pathname object corresponding to the directory
5918 in which the system specification (.asd file) is located."
5919 (pathname-directory-pathname (system-source-file system-designator)))
5921 (defun (system-relative-pathname) (system name &key type)
5922 (subpathname (system-source-directory system) name :type type))
5924 (defmethod component-pathname ((system system))
5925 (let ((pathname (or (call-next-method) (system-source-directory system))))
5926 (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
5927 (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
5928 (setf (slot-value system 'relative-pathname) pathname))
5931 (defmethod component-relative-pathname ((system system))
5932 (parse-unix-namestring
5933 (and (slot-boundp system 'relative-pathname)
5934 (slot-value system 'relative-pathname))
5938 :defaults (system-source-directory system)))
5940 (defmethod component-parent-pathname ((system system))
5941 (system-source-directory system))
5943 (defmethod component-build-pathname ((c component))
5944 (declare (ignorable c))
5947 ;;;; -------------------------------------------------------------------------
5950 (asdf/package:define-package :asdf/cache
5951 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
5952 (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
5953 #:consult-asdf-cache #:do-asdf-cache
5954 #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
5955 (in-package :asdf/cache)
5957 ;;; This stamp cache is useful for:
5958 ;; * consistency of stamps used within a single run
5959 ;; * fewer accesses to the filesystem
5960 ;; * the ability to test with fake timestamps, without touching files
5962 (with-upgradability ()
5963 (defvar *asdf-cache* nil)
5965 (defun set-asdf-cache-entry (key value-list)
5968 (setf (gethash key *asdf-cache*) value-list)
5971 (defun consult-asdf-cache (key &optional thunk)
5973 (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
5975 (apply 'values results)
5976 (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
5977 (call-function thunk)))
5979 (defmacro do-asdf-cache (key &body body)
5980 `(consult-asdf-cache ,key #'(lambda () ,@body)))
5982 (defun call-with-asdf-cache (thunk &key override)
5983 (if (and *asdf-cache* (not override))
5985 (let ((*asdf-cache* (make-hash-table :test 'equal)))
5988 (defmacro with-asdf-cache ((&key override) &body body)
5989 `(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
5991 (defun compute-file-stamp (file)
5992 (safe-file-write-date file))
5994 (defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
5995 (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
5997 (defun get-file-stamp (file)
5998 (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))))
6001 ;;;; -------------------------------------------------------------------------
6002 ;;;; Finding systems
6004 (asdf/package:define-package :asdf/find-system
6005 (:recycle :asdf/find-system :asdf)
6006 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6007 :asdf/component :asdf/system :asdf/cache)
6009 #:remove-entry-from-registry #:coerce-entry-to-directory
6010 #:coerce-name #:primary-system-name #:coerce-filename
6011 #:find-system #:locate-system #:load-asd #:with-system-definitions
6012 #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
6013 #:system-definition-error #:missing-component #:missing-requires #:missing-parent
6014 #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
6015 #:load-system-definition-error #:error-name #:error-pathname #:error-condition
6016 #:*system-definition-search-functions* #:search-for-system-definition
6017 #:*central-registry* #:probe-asd #:sysdef-central-registry-search
6018 #:find-system-if-being-defined #:*systems-being-defined*
6019 #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
6020 #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
6021 #:clear-defined-systems #:*defined-systems*
6022 ;; defined in source-registry, but specially mentioned here:
6023 #:initialize-source-registry #:sysdef-source-registry-search))
6024 (in-package :asdf/find-system)
6026 (with-upgradability ()
6027 (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference
6029 (define-condition system-definition-error (error) ()
6030 ;; [this use of :report should be redundant, but unfortunately it's not.
6031 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
6032 ;; over print-object; this is always conditions::%print-condition for
6033 ;; condition objects, which in turn does inheritance of :report options at
6034 ;; run-time. fortunately, inheritance means we only need this kludge here in
6035 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
6036 #+cmu (:report print-object))
6038 (define-condition missing-component (system-definition-error)
6039 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
6040 (parent :initform nil :reader missing-parent :initarg :parent)))
6042 (define-condition formatted-system-definition-error (system-definition-error)
6043 ((format-control :initarg :format-control :reader format-control)
6044 (format-arguments :initarg :format-arguments :reader format-arguments))
6045 (:report (lambda (c s)
6046 (apply 'format s (format-control c) (format-arguments c)))))
6048 (define-condition load-system-definition-error (system-definition-error)
6049 ((name :initarg :name :reader error-name)
6050 (pathname :initarg :pathname :reader error-pathname)
6051 (condition :initarg :condition :reader error-condition))
6052 (:report (lambda (c s)
6053 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
6054 (error-name c) (error-pathname c) (error-condition c)))))
6056 (defun sysdef-error (format &rest arguments)
6057 (error 'formatted-system-definition-error :format-control
6058 format :format-arguments arguments))
6060 (defun coerce-name (name)
6062 (component (component-name name))
6063 (symbol (string-downcase (symbol-name name)))
6065 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
6067 (defun primary-system-name (name)
6068 ;; When a system name has slashes, the file with defsystem is named by
6069 ;; the first of the slash-separated components.
6070 (first (split-string (coerce-name name) :separator "/")))
6072 (defun coerce-filename (name)
6073 (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
6075 (defvar *defined-systems* (make-hash-table :test 'equal)
6076 "This is a hash table whose keys are strings, being the
6077 names of the systems, and whose values are pairs, the first
6078 element of which is a universal-time indicating when the
6079 system definition was last updated, and the second element
6080 of which is a system object.")
6082 (defun system-registered-p (name)
6083 (gethash (coerce-name name) *defined-systems*))
6085 (defun registered-systems ()
6086 (loop :for registered :being :the :hash-values :of *defined-systems*
6087 :collect (coerce-name (cdr registered))))
6089 (defun register-system (system)
6090 (check-type system system)
6091 (let ((name (component-name system)))
6092 (check-type name string)
6093 (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
6094 (unless (eq system (cdr (gethash name *defined-systems*)))
6095 (setf (gethash name *defined-systems*)
6096 (cons (if-let (file (ignore-errors (system-source-file system)))
6097 (get-file-stamp file))
6100 (defun clear-defined-systems ()
6101 ;; Invalidate all systems but ASDF itself, if registered.
6102 (let ((asdf (cdr (system-registered-p :asdf))))
6103 (setf *defined-systems* (make-hash-table :test 'equal))
6105 (setf (component-version asdf) *asdf-version*)
6106 (setf (builtin-system-p asdf) t)
6107 (register-system asdf)))
6110 (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
6112 (defun clear-system (name)
6113 "Clear the entry for a system in the database of systems previously loaded.
6114 Note that this does NOT in any way cause the code of the system to be unloaded."
6115 ;; There is no "unload" operation in Common Lisp, and
6116 ;; a general such operation cannot be portably written,
6117 ;; considering how much CL relies on side-effects to global data structures.
6118 (remhash (coerce-name name) *defined-systems*))
6120 (defun map-systems (fn)
6121 "Apply FN to each defined system.
6123 FN should be a function of one argument. It will be
6124 called with an object of type asdf:system."
6125 (loop :for registered :being :the :hash-values :of *defined-systems*
6126 :do (funcall fn (cdr registered)))))
6128 ;;; for the sake of keeping things reasonably neat, we adopt a
6129 ;;; convention that functions in this list are prefixed SYSDEF-
6130 (with-upgradability ()
6131 (defvar *system-definition-search-functions* '())
6133 (defun cleanup-system-definition-search-functions ()
6134 (setf *system-definition-search-functions*
6136 ;; Remove known-incompatible sysdef functions from old versions of asdf.
6137 (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf)))
6138 *system-definition-search-functions*)
6139 ;; Tuck our defaults at the end of the list if they were absent.
6140 ;; This is imperfect, in case they were removed on purpose,
6141 ;; but then it will be the responsibility of whoever does that
6142 ;; to upgrade asdf before he does such a thing rather than after.
6143 (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
6144 '(sysdef-central-registry-search
6145 sysdef-source-registry-search
6146 sysdef-preloaded-system-search)))))
6147 (cleanup-system-definition-search-functions)
6149 (defun search-for-system-definition (system)
6150 (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
6151 (cons 'find-system-if-being-defined
6152 *system-definition-search-functions*)))
6154 (defvar *central-registry* nil
6155 "A list of 'system directory designators' ASDF uses to find systems.
6157 A 'system directory designator' is a pathname or an expression
6158 which evaluates to a pathname. For example:
6160 (setf asdf:*central-registry*
6161 (list '*default-pathname-defaults*
6162 #p\"/home/me/cl/systems/\"
6163 #p\"/usr/share/common-lisp/systems/\"))
6165 This is for backward compatibility.
6166 Going forward, we recommend new users should be using the source-registry.
6169 (defun probe-asd (name defaults &key truename)
6171 (when (directory-pathname-p defaults)
6172 (if-let (file (probe-file*
6173 (ensure-absolute-pathname
6174 (parse-unix-namestring name :type "asd")
6175 #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil))
6177 :truename truename))
6179 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
6180 (when (os-windows-p)
6183 :defaults defaults :case :local
6184 :name (strcat name ".asd")
6186 (when (probe-file* shortcut)
6187 (let ((target (parse-windows-shortcut shortcut)))
6189 (return (pathname target))))))))))
6191 (defun sysdef-central-registry-search (system)
6192 (let ((name (primary-system-name system))
6197 (dolist (dir *central-registry*)
6198 (let ((defaults (eval dir))
6201 (cond ((directory-pathname-p defaults)
6202 (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
6207 (let* ((*print-circle* nil)
6210 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>")
6211 system dir defaults)))
6213 (remove-entry-from-registry ()
6214 :report "Remove entry from *central-registry* and continue"
6215 (push dir to-remove))
6216 (coerce-entry-to-directory ()
6217 :test (lambda (c) (declare (ignore c))
6218 (and (not (directory-pathname-p defaults))
6219 (directory-pathname-p
6221 (ensure-directory-pathname defaults)))))
6223 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
6225 (push (cons dir directorized) to-replace))))))))
6227 (dolist (dir to-remove)
6228 (setf *central-registry* (remove dir *central-registry*)))
6229 (dolist (pair to-replace)
6230 (let* ((current (car pair))
6232 (position (position current *central-registry*)))
6233 (setf *central-registry*
6234 (append (subseq *central-registry* 0 position)
6236 (subseq *central-registry* (1+ position))))))))))
6238 (defvar *preloaded-systems* (make-hash-table :test 'equal))
6240 (defun make-preloaded-system (name keys)
6241 (apply 'make-instance (getf keys :class 'system)
6242 :name name :source-file (getf keys :source-file)
6243 (remove-plist-keys '(:class :name :source-file) keys)))
6245 (defun sysdef-preloaded-system-search (requested)
6246 (let ((name (coerce-name requested)))
6247 (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
6249 (make-preloaded-system name keys)))))
6251 (defun register-preloaded-system (system-name &rest keys)
6252 (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
6254 (register-preloaded-system "asdf" :version *asdf-version*)
6255 (register-preloaded-system "asdf-driver" :version *asdf-version*)
6257 (defmethod find-system ((name null) &optional (error-p t))
6258 (declare (ignorable name))
6260 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
6262 (defmethod find-system (name &optional (error-p t))
6263 (find-system (coerce-name name) error-p))
6265 (defvar *systems-being-defined* nil
6266 "A hash-table of systems currently being defined keyed by name, or NIL")
6268 (defun find-system-if-being-defined (name)
6269 (when *systems-being-defined*
6270 (gethash (coerce-name name) *systems-being-defined*)))
6272 (defun call-with-system-definitions (thunk)
6273 (if *systems-being-defined*
6274 (call-with-asdf-cache thunk)
6275 (let ((*systems-being-defined* (make-hash-table :test 'equal)))
6276 (call-with-asdf-cache thunk))))
6278 (defun clear-systems-being-defined ()
6279 (when *systems-being-defined*
6280 (clrhash *systems-being-defined*)))
6282 (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
6284 (defmacro with-system-definitions ((&optional) &body body)
6285 `(call-with-system-definitions #'(lambda () ,@body)))
6287 (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
6288 ;; Tries to load system definition with canonical NAME from PATHNAME.
6289 (with-system-definitions ()
6290 (with-standard-io-syntax
6291 (let ((*package* (find-package :asdf-user))
6292 ;; Note that our backward-compatible *readtable* is
6293 ;; a global readtable that gets globally side-effected. Ouch.
6294 ;; Same for the *print-pprint-dispatch* table.
6295 ;; We should do something about that for ASDF3 if possible, or else ASDF4.
6296 (*readtable* readtable)
6297 (*print-pprint-dispatch* print-pprint-dispatch)
6298 (*print-readably* nil)
6299 (*default-pathname-defaults*
6300 ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
6301 (pathname-directory-pathname (translate-logical-pathname pathname))))
6303 ((error #'(lambda (condition)
6304 (error 'load-system-definition-error
6305 :name name :pathname pathname
6306 :condition condition))))
6307 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
6309 (with-muffled-loader-conditions ()
6310 (load* pathname :external-format external-format)))))))
6312 (defvar *old-asdf-systems* (make-hash-table :test 'equal))
6314 (defun check-not-old-asdf-system (name pathname)
6315 (or (not (equal name "asdf"))
6317 (let* ((version-pathname (subpathname pathname "version.lisp-expr"))
6318 (version (and (probe-file* version-pathname :truename nil)
6319 (read-file-form version-pathname)))
6320 (old-version (asdf-version)))
6321 (or (version<= old-version version)
6323 (if-let (pair (system-registered-p "asdf"))
6324 (system-source-file (cdr pair))))
6325 (key (list pathname old-version)))
6326 (unless (gethash key *old-asdf-systems*)
6327 (setf (gethash key *old-asdf-systems*) t)
6329 You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
6330 or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
6331 ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
6332 Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
6333 and having an old version registered is a configuration error. ~
6334 ASDF will ignore this configured system rather than downgrade itself. ~
6335 In the future, you may want to either: ~
6336 (a) upgrade this configured ASDF to a newer version, ~
6337 (b) install a newer ASDF and register it in front of the former in your configuration, or ~
6338 (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
6339 Note that the older ASDF might be registered implicitly through configuration inherited ~
6340 from your system installation, in which case you might have to specify ~
6341 :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
6342 or other source-registry configuration file, environment variable or lisp parameter. ~
6343 Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
6344 that you might want to upgrade (if a recent enough version is available) ~
6345 or else remove altogether (since most implementations ship with a recent asdf); ~
6346 if you lack the system administration rights to upgrade or remove this package, ~
6347 then you might indeed want to either install and register a more recent version, ~
6348 or use :ignore-inherited-configuration to avoid registering the old one. ~
6349 Please consult ASDF documentation and/or experts.~@:>~%"
6350 old-version old-pathname version pathname)))))))
6352 (defun locate-system (name)
6353 "Given a system NAME designator, try to locate where to load the system from.
6354 Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
6355 FOUNDP is true when a system was found,
6356 either a new unregistered one or a previously registered one.
6357 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
6358 PATHNAME when not null is a path from where to load the system,
6359 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
6360 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
6361 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
6362 (let* ((name (coerce-name name))
6363 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
6364 (previous (cdr in-memory))
6365 (previous (and (typep previous 'system) previous))
6366 (previous-time (car in-memory))
6367 (found (search-for-system-definition name))
6368 (found-system (and (typep found 'system) found))
6369 (pathname (ensure-pathname
6370 (or (and (typep found '(or pathname string)) (pathname found))
6371 (and found-system (system-source-file found-system))
6372 (and previous (system-source-file previous)))
6373 :want-absolute t :resolve-symlinks *resolve-symlinks*))
6374 (foundp (and (or found-system pathname previous) t)))
6375 (check-type found (or null pathname system))
6376 (unless (check-not-old-asdf-system name pathname)
6378 (previous (setf found nil pathname nil))
6380 (setf found (sysdef-preloaded-system-search "asdf"))
6381 (assert (typep found 'system))
6382 (setf found-system found pathname nil))))
6383 (values foundp found-system pathname previous previous-time)))
6385 (defmethod find-system ((name string) &optional (error-p t))
6386 (with-system-definitions ()
6389 (multiple-value-bind (foundp found-system pathname previous previous-time)
6390 (locate-system name)
6391 (assert (eq foundp (and (or found-system pathname previous) t)))
6392 (let ((previous-pathname (and previous (system-source-file previous)))
6393 (system (or previous found-system)))
6394 (when (and found-system (not previous))
6395 (register-system found-system))
6396 (when (and system pathname)
6397 (setf (system-source-file system) pathname))
6399 (let ((stamp (get-file-stamp pathname)))
6402 (or (pathname-equal pathname previous-pathname)
6403 (and pathname previous-pathname
6405 (translate-logical-pathname pathname)
6406 (translate-logical-pathname previous-pathname))))
6407 (stamp<= stamp previous-time))))))
6408 ;; only load when it's a pathname that is different or has newer content, and not an old asdf
6409 (load-asd pathname :name name)))
6410 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
6415 (setf (car in-memory) (get-file-stamp pathname)))
6418 (error 'missing-component :requires name))))))
6419 (reinitialize-source-registry-and-retry ()
6421 (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
6422 (initialize-source-registry)))))))
6424 ;;;; -------------------------------------------------------------------------
6425 ;;;; Finding components
6427 (asdf/package:define-package :asdf/find-component
6428 (:recycle :asdf/find-component :asdf)
6429 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6430 :asdf/component :asdf/system :asdf/find-system)
6433 #:resolve-dependency-name #:resolve-dependency-spec
6434 #:resolve-dependency-combination
6436 #:missing-component #:missing-component-of-version #:retry
6437 #:missing-dependency #:missing-dependency-of-version
6438 #:missing-requires #:missing-parent
6439 #:missing-required-by #:missing-version))
6440 (in-package :asdf/find-component)
6442 ;;;; Missing component conditions
6444 (with-upgradability ()
6445 (define-condition missing-component-of-version (missing-component)
6446 ((version :initform nil :reader missing-version :initarg :version)))
6448 (define-condition missing-dependency (missing-component)
6449 ((required-by :initarg :required-by :reader missing-required-by)))
6451 (defmethod print-object ((c missing-dependency) s)
6452 (format s (compatfmt "~@<~A, required by ~A~@:>")
6453 (call-next-method c nil) (missing-required-by c)))
6455 (define-condition missing-dependency-of-version (missing-dependency
6456 missing-component-of-version)
6459 (defmethod print-object ((c missing-component) s)
6460 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
6461 (missing-requires c)
6462 (when (missing-parent c)
6463 (coerce-name (missing-parent c)))))
6465 (defmethod print-object ((c missing-component-of-version) s)
6466 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
6467 (missing-requires c)
6469 (when (missing-parent c)
6470 (coerce-name (missing-parent c))))))
6473 ;;;; Finding components
6475 (with-upgradability ()
6476 (defgeneric* (find-component) (base path)
6477 (:documentation "Find a component by resolving the PATH starting from BASE parent"))
6478 (defgeneric resolve-dependency-combination (component combinator arguments))
6480 (defmethod find-component ((base string) path)
6481 (let ((s (find-system base nil)))
6482 (and s (find-component s path))))
6484 (defmethod find-component ((base symbol) path)
6486 (base (find-component (coerce-name base) path))
6487 (path (find-component path nil))
6490 (defmethod find-component ((base cons) path)
6491 (find-component (car base) (cons (cdr base) path)))
6493 (defmethod find-component ((parent parent-component) (name string))
6494 (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!!
6495 (values (gethash name (component-children-by-name parent))))
6497 (defmethod find-component (base (name symbol))
6499 (find-component base (coerce-name name))
6502 (defmethod find-component ((c component) (name cons))
6503 (find-component (find-component c (car name)) (cdr name)))
6505 (defmethod find-component (base (actual component))
6506 (declare (ignorable base))
6509 (defun resolve-dependency-name (component name &optional version)
6513 (let ((comp (find-component (component-parent component) name)))
6515 (error 'missing-dependency
6516 :required-by component
6519 (unless (version-satisfies comp version)
6520 (error 'missing-dependency-of-version
6521 :required-by component
6527 (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
6531 (and (typep c 'missing-dependency)
6532 (eq (missing-required-by c) component)
6533 (equal (missing-requires c) name))))))))
6535 (defun resolve-dependency-spec (component dep-spec)
6536 (let ((component (find-component () component)))
6538 (resolve-dependency-name component dep-spec)
6539 (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
6541 (defmethod resolve-dependency-combination (component combinator arguments)
6542 (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
6543 (cons combinator arguments) component))
6545 (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
6546 (declare (ignorable combinator))
6547 (when (featurep (first arguments))
6548 (resolve-dependency-spec component (second arguments))))
6550 (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
6551 (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
6552 (resolve-dependency-name component (first arguments) (second arguments))))
6554 ;;;; -------------------------------------------------------------------------
6557 (asdf/package:define-package :asdf/operation
6558 (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
6559 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
6562 #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
6563 #:build-op ;; THE generic operation
6564 #:*operations* #:make-operation #:find-operation #:feature))
6565 (in-package :asdf/operation)
6567 ;;; Operation Classes
6569 (when-upgrading (:when (find-class 'operation nil))
6570 (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
6571 (declare (ignorable o slot-names initargs)) (values)))
6573 (with-upgradability ()
6574 (defclass operation ()
6575 ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
6576 :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
6578 (defmethod initialize-instance :after ((o operation) &rest initargs
6579 &key force force-not system verbose &allow-other-keys)
6580 (declare (ignorable force force-not system verbose))
6581 (unless (slot-boundp o 'original-initargs)
6582 (setf (operation-original-initargs o) initargs)))
6584 (defmethod print-object ((o operation) stream)
6585 (print-unreadable-object (o stream :type t :identity nil)
6587 (format stream "~{~S~^ ~}" (operation-original-initargs o))))))
6589 ;;; make-operation, find-operation
6591 (with-upgradability ()
6592 (defparameter *operations* (make-hash-table :test 'equal))
6593 (defun make-operation (operation-class &rest initargs)
6594 (let ((key (cons operation-class initargs)))
6595 (multiple-value-bind (operation foundp) (gethash key *operations*)
6596 (if foundp operation
6597 (setf (gethash key *operations*)
6598 (apply 'make-instance operation-class initargs))))))
6600 (defgeneric find-operation (context spec)
6601 (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
6602 (defmethod find-operation (context (spec operation))
6603 (declare (ignorable context))
6605 (defmethod find-operation (context (spec symbol))
6606 (unless (member spec '(nil feature))
6607 ;; NIL designates itself, i.e. absence of operation
6608 ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
6609 (apply 'make-operation spec (operation-original-initargs context))))
6610 (defmethod operation-original-initargs ((context symbol))
6611 (declare (ignorable context))
6614 (defclass build-op (operation) ()))
6617 ;;;; -------------------------------------------------------------------------
6620 (asdf/package:define-package :asdf/action
6621 (:nicknames :asdf-action)
6622 (:recycle :asdf/action :asdf)
6623 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6624 :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
6626 #:action #:define-convenience-action-methods
6627 #:explain #:action-description
6628 #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
6629 #:component-depends-on
6630 #:input-files #:output-files #:output-file #:operation-done-p
6631 #:action-status #:action-stamp #:action-done-p
6632 #:component-operation-time #:mark-operation-done #:compute-action-stamp
6633 #:perform #:perform-with-restarts #:retry #:accept
6634 #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
6635 #:action-path #:find-action #:stamp #:done-p))
6636 (in-package :asdf/action)
6638 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
6639 (deftype action () '(cons operation component))) ;; a step to be performed while building
6641 (with-upgradability ()
6642 (defgeneric traverse-actions (actions &key &allow-other-keys))
6643 (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
6644 (defgeneric required-components (component &key &allow-other-keys)))
6646 ;;;; Reified representation for storage or debugging. Note: dropping original-initargs
6647 (with-upgradability ()
6648 (defun action-path (action)
6649 (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
6650 (defun find-action (path)
6651 (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
6654 ;;;; Convenience methods
6655 (with-upgradability ()
6656 (defmacro define-convenience-action-methods
6657 (function formals &key if-no-operation if-no-component operation-initargs)
6658 (let* ((rest (gensym "REST"))
6659 (found (gensym "FOUND"))
6660 (keyp (equal (last formals) '(&key)))
6661 (formals-no-key (if keyp (butlast formals) formals))
6662 (len (length formals-no-key))
6663 (operation 'operation)
6664 (component 'component)
6665 (opix (position operation formals))
6666 (coix (position component formals))
6667 (prefix (subseq formals 0 opix))
6668 (suffix (subseq formals (1+ coix) len))
6669 (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
6670 (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
6671 (flet ((next-method (o c)
6673 `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
6674 `(,function ,@prefix ,o ,c ,@suffix))))
6676 (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
6679 (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
6680 `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
6681 `(make-operation ,operation))
6682 `(or (find-component () ,component) ,if-no-component))
6684 (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
6685 (if (typep ,component 'component)
6686 (error "No defined method for ~S on ~/asdf-action:format-action/"
6687 ',function (cons ,operation ,component))
6688 (if-let (,found (find-component () ,component))
6689 ,(next-method operation found)
6690 ,if-no-component))))))))
6693 ;;;; self-description
6694 (with-upgradability ()
6695 (defgeneric action-description (operation component)
6696 (:documentation "returns a phrase that describes performing this operation
6697 on this component, e.g. \"loading /a/b/c\".
6698 You can put together sentences using this phrase."))
6699 (defmethod action-description (operation component)
6700 (format nil (compatfmt "~@<~A on ~A~@:>")
6701 (type-of operation) component))
6702 (defgeneric* (explain) (operation component))
6703 (defmethod explain ((o operation) (c component))
6704 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
6705 (define-convenience-action-methods explain (operation component))
6707 (defun format-action (stream action &optional colon-p at-sign-p)
6708 (assert (null colon-p)) (assert (null at-sign-p))
6709 (destructuring-bind (operation . component) action
6710 (princ (action-description operation component) stream))))
6714 (with-upgradability ()
6715 (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
6717 "Returns a list of dependencies needed by the component to perform
6718 the operation. A dependency has one of the following forms:
6720 (<operation> <component>*), where <operation> is an operation designator
6721 with respect to FIND-OPERATION in the context of the OPERATION argument,
6722 and each <component> is a component designator with respect to
6723 FIND-COMPONENT in the context of the COMPONENT argument,
6724 and means that the component depends on
6725 <operation> having been performed on each <component>; or
6727 (FEATURE <feature>), which means that the component depends
6728 on the <feature> expression satisfying FEATUREP.
6729 (This is DEPRECATED -- use :IF-FEATURE instead.)
6731 Methods specialized on subclasses of existing component types
6732 should usually append the results of CALL-NEXT-METHOD to the list."))
6733 (define-convenience-action-methods component-depends-on (operation component))
6735 (defmethod component-depends-on :around ((o operation) (c component))
6736 (do-asdf-cache `(component-depends-on ,o ,c)
6737 (call-next-method)))
6739 (defmethod component-depends-on ((o operation) (c component))
6740 (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
6743 ;;;; upward-operation, downward-operation
6744 ;; These together handle actions that propagate along the component hierarchy.
6745 ;; Downward operations like load-op or compile-op propagate down the hierarchy:
6746 ;; operation on a parent depends-on operation on its children.
6747 ;; By default, an operation propagates itself, but it may propagate another one instead.
6748 (with-upgradability ()
6749 (defclass downward-operation (operation)
6750 ((downward-operation
6751 :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
6752 (defmethod component-depends-on ((o downward-operation) (c parent-component))
6753 `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
6754 ;; Upward operations like prepare-op propagate up the component hierarchy:
6755 ;; operation on a child depends-on operation on its parent.
6756 ;; By default, an operation propagates itself, but it may propagate another one instead.
6757 (defclass upward-operation (operation)
6759 :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
6760 ;; For backward-compatibility reasons, a system inherits from module and is a child-component
6761 ;; so we must guard against this case. ASDF4: remove that.
6762 (defmethod component-depends-on ((o upward-operation) (c child-component))
6763 `(,@(if-let (p (component-parent c))
6764 `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
6765 ;; Sibling operations propagate to siblings in the component hierarchy:
6766 ;; operation on a child depends-on operation on its parent.
6767 ;; By default, an operation propagates itself, but it may propagate another one instead.
6768 (defclass sideway-operation (operation)
6770 :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
6771 (defmethod component-depends-on ((o sideway-operation) (c component))
6772 `((,(or (sideway-operation o) o)
6773 ,@(loop :for dep :in (component-sideway-dependencies c)
6774 :collect (resolve-dependency-spec c dep)))
6775 ,@(call-next-method)))
6776 ;; Selfward operations propagate to themselves a sub-operation:
6777 ;; they depend on some other operation being acted on the same component.
6778 (defclass selfward-operation (operation)
6779 ((selfward-operation
6780 :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
6781 (defmethod component-depends-on ((o selfward-operation) (c component))
6782 `(,@(loop :for op :in (ensure-list (selfward-operation o))
6784 ,@(call-next-method))))
6787 ;;;; Inputs, Outputs, and invisible dependencies
6788 (with-upgradability ()
6789 (defgeneric* (output-files) (operation component))
6790 (defgeneric* (input-files) (operation component))
6791 (defgeneric* (operation-done-p) (operation component)
6792 (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
6793 (define-convenience-action-methods output-files (operation component))
6794 (define-convenience-action-methods input-files (operation component))
6795 (define-convenience-action-methods operation-done-p (operation component))
6797 (defmethod operation-done-p ((o operation) (c component))
6798 (declare (ignorable o c))
6801 (defmethod output-files :around (operation component)
6802 "Translate output files, unless asked not to. Memoize the result."
6803 operation component ;; hush genera, not convinced by declare ignorable(!)
6804 (do-asdf-cache `(output-files ,operation ,component)
6806 (multiple-value-bind (pathnames fixedp) (call-next-method)
6807 ;; 1- Make sure we have absolute pathnames
6808 (let* ((directory (pathname-directory-pathname
6809 (component-pathname (find-component () component))))
6812 :for pathname :in pathnames
6813 :collect (ensure-absolute-pathname pathname directory))))
6814 ;; 2- Translate those pathnames as required
6817 (mapcar *output-translation-function* absolute-pathnames))))
6819 (defmethod output-files ((o operation) (c component))
6820 (declare (ignorable o c))
6822 (defun output-file (operation component)
6823 "The unique output file of performing OPERATION on COMPONENT"
6824 (let ((files (output-files operation component)))
6825 (assert (length=n-p files 1))
6828 (defmethod input-files :around (operation component)
6829 "memoize input files."
6830 (do-asdf-cache `(input-files ,operation ,component)
6831 (call-next-method)))
6833 (defmethod input-files ((o operation) (c component))
6834 (declare (ignorable o c))
6837 (defmethod input-files ((o selfward-operation) (c component))
6838 `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
6839 :append (or (output-files dep-o c) (input-files dep-o c)))
6840 (if-let ((pathname (component-pathname c)))
6841 (and (file-pathname-p pathname) (list pathname))))
6842 ,@(call-next-method))))
6845 ;;;; Done performing
6846 (with-upgradability ()
6847 (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
6848 (define-convenience-action-methods component-operation-time (operation component))
6850 (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
6851 (defgeneric compute-action-stamp (plan operation component &key just-done)
6852 (:documentation "Has this action been successfully done already,
6853 and at what known timestamp has it been done at or will it be done at?
6854 Takes two keywords JUST-DONE and PLAN:
6855 JUST-DONE is a boolean that is true if the action was just successfully performed,
6856 at which point we want compute the actual stamp and warn if files are missing;
6857 otherwise we are making plans, anticipating the effects of the action.
6858 PLAN is a plan object modelling future effects of actions,
6859 or NIL to denote what actually happened.
6861 * a STAMP saying when it was done or will be done,
6862 or T if the action has involves files that need to be recomputed.
6863 * a boolean DONE-P that indicates whether the action has actually been done,
6864 and both its output-files and its in-image side-effects are up to date."))
6866 (defclass action-status ()
6868 :initarg :stamp :reader action-stamp
6869 :documentation "STAMP associated with the ACTION if it has been completed already
6870 in some previous image, or T if it needs to be done.")
6872 :initarg :done-p :reader action-done-p
6873 :documentation "a boolean, true iff the action was already done (before any planned action)."))
6874 (:documentation "Status of an action"))
6876 (defmethod print-object ((status action-status) stream)
6877 (print-unreadable-object (status stream :type t)
6878 (with-slots (stamp done-p) status
6879 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
6881 (defmethod component-operation-time ((o operation) (c component))
6882 (gethash (type-of o) (component-operation-times c)))
6884 (defmethod mark-operation-done ((o operation) (c component))
6885 (setf (gethash (type-of o) (component-operation-times c))
6886 (compute-action-stamp nil o c :just-done t))))
6890 (with-upgradability ()
6891 (defgeneric* (perform-with-restarts) (operation component))
6892 (defgeneric* (perform) (operation component))
6893 (define-convenience-action-methods perform (operation component))
6895 (defmethod perform :before ((o operation) (c component))
6896 (ensure-all-directories-exist (output-files o c)))
6897 (defmethod perform :after ((o operation) (c component))
6898 (mark-operation-done o c))
6899 (defmethod perform ((o operation) (c parent-component))
6900 (declare (ignorable o c))
6902 (defmethod perform ((o operation) (c source-file))
6904 (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
6905 (class-of o) (class-of c)))
6907 (defmethod perform-with-restarts (operation component)
6908 ;; TOO verbose, especially as the default. Add your own :before method
6909 ;; to perform-with-restart or perform if you want that:
6910 #|(explain operation component)|#
6911 (perform operation component))
6912 (defmethod perform-with-restarts :around (operation component)
6915 (return (call-next-method))
6919 (format s (compatfmt "~@<Retry ~A.~@:>")
6920 (action-description operation component))))
6924 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
6925 (action-description operation component)))
6926 (mark-operation-done operation component)
6929 ;;; Generic build operation
6930 (with-upgradability ()
6931 (defmethod component-depends-on ((o build-op) (c component))
6932 `((,(or (component-build-operation c) 'load-op) ,c))))
6934 ;;;; -------------------------------------------------------------------------
6935 ;;;; Actions to build Common Lisp software
6937 (asdf/package:define-package :asdf/lisp-action
6938 (:recycle :asdf/lisp-action :asdf)
6939 (:intern #:proclamations #:flags)
6940 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6941 :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
6942 :asdf/operation :asdf/action)
6945 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
6946 #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
6947 #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
6948 #:call-with-around-compile-hook
6949 #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
6950 #:lisp-compilation-output-files #:flags))
6951 (in-package :asdf/lisp-action)
6954 ;;;; Component classes
6955 (with-upgradability ()
6956 (defclass cl-source-file (source-file)
6957 ((type :initform "lisp")))
6958 (defclass cl-source-file.cl (cl-source-file)
6959 ((type :initform "cl")))
6960 (defclass cl-source-file.lsp (cl-source-file)
6961 ((type :initform "lsp"))))
6964 ;;;; Operation classes
6965 (with-upgradability ()
6966 (defclass basic-load-op (operation) ())
6967 (defclass basic-compile-op (operation)
6968 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
6969 (flags :initarg :flags :accessor compile-op-flags :initform nil))))
6971 ;;; Our default operations: loading into the current lisp image
6972 (with-upgradability ()
6973 (defclass prepare-op (upward-operation sideway-operation)
6974 ((sideway-operation :initform 'load-op)))
6975 (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
6976 ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
6977 ;; so we need to directly depend on prepare-op for its side-effects in the current image.
6978 ((selfward-operation :initform '(prepare-op compile-op))))
6979 (defclass compile-op (basic-compile-op downward-operation selfward-operation)
6980 ((selfward-operation :initform 'prepare-op)
6981 (downward-operation :initform 'load-op)))
6983 (defclass prepare-source-op (upward-operation sideway-operation)
6984 ((sideway-operation :initform 'load-source-op)))
6985 (defclass load-source-op (basic-load-op downward-operation selfward-operation)
6986 ((selfward-operation :initform 'prepare-source-op)))
6988 (defclass test-op (selfward-operation)
6989 ((selfward-operation :initform 'load-op))))
6992 ;;;; prepare-op, compile-op and load-op
6995 (with-upgradability ()
6996 (defmethod action-description ((o prepare-op) (c component))
6997 (declare (ignorable o))
6998 (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
6999 (defmethod perform ((o prepare-op) (c component))
7000 (declare (ignorable o c))
7002 (defmethod input-files ((o prepare-op) (c component))
7003 (declare (ignorable o c))
7005 (defmethod input-files ((o prepare-op) (s system))
7006 (declare (ignorable o))
7007 (if-let (it (system-source-file s)) (list it))))
7010 (with-upgradability ()
7011 (defmethod action-description ((o compile-op) (c component))
7012 (declare (ignorable o))
7013 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
7014 (defmethod action-description ((o compile-op) (c parent-component))
7015 (declare (ignorable o))
7016 (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
7017 (defgeneric call-with-around-compile-hook (component thunk))
7018 (defmethod call-with-around-compile-hook ((c component) function)
7019 (call-around-hook (around-compile-hook c) function))
7020 (defun perform-lisp-compilation (o c)
7021 (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
7022 ;; we consult input-files, the first of which should be the one to compile-file
7023 (input-file (first (input-files o c)))
7024 ;; on some implementations, there are more than one output-file,
7025 ;; but the first one should always be the primary fasl that gets loaded.
7026 (outputs (output-files o c)))
7027 (multiple-value-bind (output warnings-p failure-p)
7032 #+(or ecl mkcl) object-file
7033 warnings-file) outputs
7034 (call-with-around-compile-hook
7035 c #'(lambda (&rest flags)
7036 (with-muffled-compiler-conditions ()
7037 (apply 'compile-file* input-file
7038 :output-file output-file
7039 :external-format (component-external-format c)
7040 :warnings-file warnings-file
7042 #+clisp (list :lib-file lib-file)
7043 #+(or ecl mkcl) (list :object-file object-file)
7044 flags (compile-op-flags o)))))))
7045 (check-lisp-compile-results output warnings-p failure-p
7046 "~/asdf-action::format-action/" (list (cons o c))))))
7048 (defun report-file-p (f)
7049 (equalp (pathname-type f) "build-report"))
7050 (defun perform-lisp-warnings-check (o c)
7051 (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
7052 (actual-warnings-files (loop :for w :in expected-warnings-files
7053 :when (get-file-stamp w)
7055 :else :do (warn "Missing warnings file ~S while ~A"
7056 w (action-description o c)))))
7057 (check-deferred-warnings actual-warnings-files)
7058 (let* ((output (output-files o c))
7059 (report (find-if #'report-file-p output)))
7061 (with-open-file (s report :direction :output :if-exists :supersede)
7062 (format s ":success~%"))))))
7063 (defmethod perform ((o compile-op) (c cl-source-file))
7064 (perform-lisp-compilation o c))
7065 (defun lisp-compilation-output-files (o c)
7066 (let* ((i (first (input-files o c)))
7067 (f (compile-file-pathname
7068 i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
7069 `(,f ;; the fasl is the primary output, in first position
7071 ,@`(,(make-pathname :type "lib" :defaults f))
7073 ,@(unless (use-ecl-byte-compiler-p)
7074 `(,(compile-file-pathname i :type :object)))
7076 ,(compile-file-pathname i :fasl-p nil) ;; object file
7077 ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
7078 `(,(make-pathname :type *warnings-file-type* :defaults f))))))
7079 (defmethod output-files ((o compile-op) (c cl-source-file))
7080 (lisp-compilation-output-files o c))
7081 (defmethod perform ((o compile-op) (c static-file))
7082 (declare (ignorable o c))
7084 (defmethod output-files ((o compile-op) (c static-file))
7085 (declare (ignorable o c))
7087 (defmethod perform ((o compile-op) (c system))
7088 (when (and *warnings-file-type* (not (builtin-system-p c)))
7089 (perform-lisp-warnings-check o c)))
7090 (defmethod input-files ((o compile-op) (c system))
7091 (when (and *warnings-file-type* (not (builtin-system-p c)))
7092 ;; The most correct way to do it would be to use:
7093 ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
7094 ;; but it's expensive and we don't care too much about file order or ASDF extensions.
7095 (loop :for sub :in (sub-components c :type 'cl-source-file)
7096 :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))
7097 (defmethod output-files ((o compile-op) (c system))
7098 (when (and *warnings-file-type* (not (builtin-system-p c)))
7099 (if-let ((pathname (component-pathname c)))
7100 (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
7103 (with-upgradability ()
7104 (defmethod action-description ((o load-op) (c cl-source-file))
7105 (declare (ignorable o))
7106 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
7107 (defmethod action-description ((o load-op) (c parent-component))
7108 (declare (ignorable o))
7109 (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
7110 (defmethod action-description ((o load-op) component)
7111 (declare (ignorable o))
7112 (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
7114 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
7117 (return (call-next-method))
7120 (format s "Recompile ~a and try loading it again"
7121 (component-name c)))
7122 (perform (find-operation o 'compile-op) c)))))
7123 (defun perform-lisp-load-fasl (o c)
7124 (if-let (fasl (first (input-files o c)))
7125 (with-muffled-loader-conditions () (load* fasl))))
7126 (defmethod perform ((o load-op) (c cl-source-file))
7127 (perform-lisp-load-fasl o c))
7128 (defmethod perform ((o load-op) (c static-file))
7129 (declare (ignorable o c))
7133 ;;;; prepare-source-op, load-source-op
7135 ;;; prepare-source-op
7136 (with-upgradability ()
7137 (defmethod action-description ((o prepare-source-op) (c component))
7138 (declare (ignorable o))
7139 (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
7140 (defmethod input-files ((o prepare-source-op) (c component))
7141 (declare (ignorable o c))
7143 (defmethod input-files ((o prepare-source-op) (s system))
7144 (declare (ignorable o))
7145 (if-let (it (system-source-file s)) (list it)))
7146 (defmethod perform ((o prepare-source-op) (c component))
7147 (declare (ignorable o c))
7151 (with-upgradability ()
7152 (defmethod action-description ((o load-source-op) c)
7153 (declare (ignorable o))
7154 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
7155 (defmethod action-description ((o load-source-op) (c parent-component))
7156 (declare (ignorable o))
7157 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
7158 (defun perform-lisp-load-source (o c)
7159 (call-with-around-compile-hook
7161 (with-muffled-loader-conditions ()
7162 (load* (first (input-files o c))
7163 :external-format (component-external-format c))))))
7165 (defmethod perform ((o load-source-op) (c cl-source-file))
7166 (perform-lisp-load-source o c))
7167 (defmethod perform ((o load-source-op) (c static-file))
7168 (declare (ignorable o c))
7170 (defmethod output-files ((o load-source-op) (c component))
7171 (declare (ignorable o c))
7176 (with-upgradability ()
7177 (defmethod perform ((o test-op) (c component))
7178 (declare (ignorable o c))
7180 (defmethod operation-done-p ((o test-op) (c system))
7181 "Testing a system is _never_ done."
7182 (declare (ignorable o c))
7185 ;;;; -------------------------------------------------------------------------
7188 (asdf/package:define-package :asdf/plan
7189 (:recycle :asdf/plan :asdf)
7190 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7191 :asdf/component :asdf/operation :asdf/system
7192 :asdf/cache :asdf/find-system :asdf/find-component
7193 :asdf/operation :asdf/action :asdf/lisp-action)
7195 #:component-operation-time #:mark-operation-done
7196 #:plan-traversal #:sequential-plan #:*default-plan-class*
7197 #:planned-action-status #:plan-action-status #:action-already-done-p
7198 #:circular-dependency #:circular-dependency-actions
7199 #:node-for #:needed-in-image-p
7200 #:action-index #:action-planned-p #:action-valid-p
7201 #:plan-record-dependency
7202 #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
7203 #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
7204 #:visit-dependencies #:compute-action-stamp #:traverse-action
7205 #:circular-dependency #:circular-dependency-actions
7206 #:call-while-visiting-action #:while-visiting-action
7207 #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
7208 #:planned-p #:index #:forced #:forced-not #:total-action-count
7209 #:planned-action-count #:planned-output-action-count #:visited-actions
7210 #:visiting-action-set #:visiting-action-list #:plan-actions-r
7211 #:required-components #:filtered-sequential-plan
7213 #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
7214 #:traverse-actions #:traverse-sub-actions))
7215 (in-package :asdf/plan)
7217 ;;;; Generic plan traversal class
7218 (with-upgradability ()
7219 (defclass plan-traversal ()
7220 ((system :initform nil :initarg :system :accessor plan-system)
7221 (forced :initform nil :initarg :force :accessor plan-forced)
7222 (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
7223 (total-action-count :initform 0 :accessor plan-total-action-count)
7224 (planned-action-count :initform 0 :accessor plan-planned-action-count)
7225 (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
7226 (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
7227 (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)
7228 (visiting-action-list :initform () :accessor plan-visiting-action-list))))
7231 ;;;; Planned action status
7232 (with-upgradability ()
7233 (defgeneric plan-action-status (plan operation component)
7234 (:documentation "Returns the ACTION-STATUS associated to
7235 the action of OPERATION on COMPONENT in the PLAN"))
7237 (defgeneric (setf plan-action-status) (new-status plan operation component)
7238 (:documentation "Sets the ACTION-STATUS associated to
7239 the action of OPERATION on COMPONENT in the PLAN"))
7241 (defclass planned-action-status (action-status)
7243 :initarg :planned-p :reader action-planned-p
7244 :documentation "a boolean, true iff the action was included in the plan.")
7246 :initarg :index :reader action-index
7247 :documentation "an integer, counting all traversed actions in traversal order."))
7248 (:documentation "Status of an action in a plan"))
7250 (defmethod print-object ((status planned-action-status) stream)
7251 (print-unreadable-object (status stream :type t :identity nil)
7252 (with-slots (stamp done-p planned-p index) status
7253 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))
7255 (defmethod action-planned-p (action-status)
7256 (declare (ignorable action-status)) ; default method for non planned-action-status objects
7259 ;; TODO: eliminate NODE-FOR, use CONS.
7260 ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION.
7261 ;; However, see also component-operation-time and mark-operation-done
7262 (defun node-for (o c) (cons (type-of o) c))
7264 (defun action-already-done-p (plan operation component)
7265 (action-done-p (plan-action-status plan operation component)))
7267 (defmethod plan-action-status ((plan null) (o operation) (c component))
7268 (declare (ignorable plan))
7269 (multiple-value-bind (stamp done-p) (component-operation-time o c)
7270 (make-instance 'action-status :stamp stamp :done-p done-p)))
7272 (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
7273 (declare (ignorable plan))
7274 (let ((to (type-of o))
7275 (times (component-operation-times c)))
7276 (if (action-done-p new-status)
7278 (setf (gethash to times) (action-stamp new-status))))
7283 (with-upgradability ()
7284 (defgeneric action-forced-p (plan operation component))
7285 (defgeneric action-forced-not-p (plan operation component))
7287 (defun normalize-forced-systems (x system)
7289 ((member nil :all) x)
7290 (cons (list-to-hash-set (mapcar #'coerce-name x)))
7291 ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
7293 (defun action-override-p (plan operation component override-accessor)
7294 (declare (ignorable operation))
7295 (let* ((override (funcall override-accessor plan)))
7297 (if (typep override 'hash-table)
7298 (gethash (coerce-name (component-system (find-component () component))) override)
7301 (defmethod action-forced-p (plan operation component)
7303 ;; Did the user ask us to re-perform the action?
7304 (action-override-p plan operation component 'plan-forced)
7305 ;; You really can't force a builtin system and :all doesn't apply to it,
7306 ;; except it it's the specifically the system currently being built.
7307 (not (let ((system (component-system component)))
7308 (and (builtin-system-p system)
7309 (not (eq system (plan-system plan))))))))
7311 (defmethod action-forced-not-p (plan operation component)
7313 ;; Did the user ask us to not re-perform the action?
7314 (action-override-p plan operation component 'plan-forced-not)
7315 ;; Force takes precedence over force-not
7316 (not (action-forced-p plan operation component))))
7318 (defmethod action-forced-p ((plan null) operation component)
7319 (declare (ignorable plan operation component))
7322 (defmethod action-forced-not-p ((plan null) operation component)
7323 (declare (ignorable plan operation component))
7328 (with-upgradability ()
7329 (defgeneric action-valid-p (plan operation component)
7330 (:documentation "Is this action valid to include amongst dependencies?"))
7331 (defmethod action-valid-p (plan operation (c component))
7332 (declare (ignorable plan operation))
7333 (if-let (it (component-if-feature c)) (featurep it) t))
7334 (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
7335 (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
7336 (defmethod action-valid-p ((plan null) operation component)
7337 (declare (ignorable plan operation component))
7338 (and operation component t)))
7341 ;;;; Is the action needed in this image?
7342 (with-upgradability ()
7343 (defgeneric needed-in-image-p (operation component)
7344 (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful,
7345 or could it just as well have been done in another Lisp image?"))
7347 (defmethod needed-in-image-p ((o operation) (c component))
7348 ;; We presume that actions that modify the filesystem don't need be run
7349 ;; in the current image if they have already been done in another,
7350 ;; and can be run in another process (e.g. a fork),
7351 ;; whereas those that don't are meant to side-effect the current image and can't.
7352 (not (output-files o c))))
7355 ;;;; Visiting dependencies of an action and computing action stamps
7356 (with-upgradability ()
7357 (defun map-direct-dependencies (operation component fun)
7358 (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
7359 :for dep-o = (find-operation operation dep-o-spec)
7361 :do (loop :for dep-c-spec :in dep-c-specs
7362 :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
7364 :do (funcall fun dep-o dep-c))))
7366 (defun reduce-direct-dependencies (operation component combinator seed)
7367 (map-direct-dependencies
7369 #'(lambda (dep-o dep-c)
7370 (setf seed (funcall combinator dep-o dep-c seed))))
7373 (defun direct-dependencies (operation component)
7374 (reduce-direct-dependencies operation component #'acons nil))
7376 (defun visit-dependencies (plan operation component dependency-stamper &aux stamp)
7377 (map-direct-dependencies
7379 #'(lambda (dep-o dep-c)
7380 (when (action-valid-p plan dep-o dep-c)
7381 (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
7384 (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
7385 ;; In a distant future, get-file-stamp and component-operation-time
7386 ;; shall also be parametrized by the plan, or by a second model object.
7387 (let* ((stamp-lookup #'(lambda (o c)
7388 (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
7389 (out-files (output-files o c))
7390 (in-files (input-files o c))
7391 ;; Three kinds of actions:
7392 (out-op (and out-files t)) ; those that create files on the filesystem
7393 ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
7394 ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
7395 ;; When was the thing last actually done? (Now, or ask.)
7396 (op-time (or just-done (component-operation-time o c)))
7397 ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
7398 (dep-stamp (visit-dependencies plan o c stamp-lookup))
7399 ;; Time stamps from the files at hand, and whether any is missing
7400 (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
7401 (in-stamps (mapcar #'get-file-stamp in-files))
7403 (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
7405 (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
7406 (all-present (not (or missing-in missing-out)))
7407 ;; Has any input changed since we last generated the files?
7408 (earliest-out (stamps-earliest out-stamps))
7409 (latest-in (stamps-latest (cons dep-stamp in-stamps)))
7410 (up-to-date-p (stamp<= latest-in earliest-out))
7411 ;; If everything is up to date, the latest of inputs and outputs is our stamp
7412 (done-stamp (stamps-latest (cons latest-in out-stamps))))
7413 ;; Warn if some files are missing:
7414 ;; either our model is wrong or some other process is messing with our files.
7415 (when (and just-done (not all-present))
7416 (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
7417 ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
7418 (action-description o c)
7419 missing-in (length missing-in) (and missing-in missing-out)
7420 missing-out (length missing-out)))
7421 ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
7422 ;; Any race condition is intrinsic to the limited timestamp resolution.
7423 (if (or just-done ;; The done-stamp is valid: if we're just done, or
7424 ;; if all filesystem effects are up-to-date and there's no invalidating reason.
7425 (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
7426 (values done-stamp ;; return the hard-earned timestamp
7428 out-op ;; a file-creating op is done when all files are up to date
7429 ;; a image-effecting a placeholder op is done when it was actually run,
7430 (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
7431 ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
7435 ;;;; Generic support for plan-traversal
7436 (with-upgradability ()
7437 (defgeneric plan-record-dependency (plan operation component))
7439 (defgeneric call-while-visiting-action (plan operation component function)
7440 (:documentation "Detect circular dependencies"))
7442 (defmethod initialize-instance :after ((plan plan-traversal)
7443 &key (force () fp) (force-not () fnp) system
7445 (with-slots (forced forced-not) plan
7446 (when fp (setf forced (normalize-forced-systems force system)))
7447 (when fnp (setf forced-not (normalize-forced-systems force-not system)))))
7449 (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
7450 (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
7452 (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component))
7453 (or (and (action-forced-not-p plan o c) (plan-action-status nil o c))
7454 (values (gethash (node-for o c) (plan-visited-actions plan)))))
7456 (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system))
7457 (and (not (action-forced-not-p plan o s)) (call-next-method)))
7459 (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
7460 (with-accessors ((action-set plan-visiting-action-set)
7461 (action-list plan-visiting-action-list)) plan
7462 (let ((action (cons operation component)))
7463 (when (gethash action action-set)
7464 (error 'circular-dependency :actions
7465 (member action (reverse action-list) :test 'equal)))
7466 (setf (gethash action action-set) t)
7467 (push action action-list)
7471 (setf (gethash action action-set) nil))))))
7474 ;;;; Actual traversal: traverse-action
7475 (with-upgradability ()
7476 (define-condition circular-dependency (system-definition-error)
7477 ((actions :initarg :actions :reader circular-dependency-actions))
7478 (:report (lambda (c s)
7479 (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
7480 (circular-dependency-actions c)))))
7482 (defmacro while-visiting-action ((p o c) &body body)
7483 `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))
7485 (defgeneric traverse-action (plan operation component needed-in-image-p))
7487 (defmethod traverse-action (plan operation component needed-in-image-p)
7489 (unless (action-valid-p plan operation component) (return nil))
7490 (plan-record-dependency plan operation component)
7491 (let* ((aniip (needed-in-image-p operation component))
7492 (eniip (and aniip needed-in-image-p))
7493 (status (plan-action-status plan operation component)))
7494 (when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
7495 ;; Already visited with sufficient need-in-image level: just return the stamp.
7496 (return (action-stamp status)))
7497 (labels ((visit-action (niip)
7498 (visit-dependencies plan operation component
7499 #'(lambda (o c) (traverse-action plan o c niip)))
7500 (multiple-value-bind (stamp done-p)
7501 (compute-action-stamp plan operation component)
7502 (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
7504 ((and add-to-plan-p (not niip)) ;; if we need to do it,
7505 (visit-action t)) ;; then we need to do it in the image!
7507 (setf (plan-action-status plan operation component)
7509 'planned-action-status
7511 :done-p (and done-p (not add-to-plan-p))
7512 :planned-p add-to-plan-p
7514 (action-index status)
7515 (incf (plan-total-action-count plan)))))
7517 (incf (plan-planned-action-count plan))
7519 (incf (plan-planned-output-action-count plan))))
7521 (while-visiting-action (plan operation component) ; maintain context, handle circularity.
7522 (visit-action eniip)))))))
7525 ;;;; Sequential plans (the default)
7526 (with-upgradability ()
7527 (defclass sequential-plan (plan-traversal)
7528 ((actions-r :initform nil :accessor plan-actions-r)))
7530 (defgeneric plan-actions (plan))
7531 (defmethod plan-actions ((plan list))
7533 (defmethod plan-actions ((plan sequential-plan))
7534 (reverse (plan-actions-r plan)))
7536 (defmethod plan-record-dependency ((plan sequential-plan)
7537 (operation operation) (component component))
7538 (declare (ignorable plan operation component))
7541 (defmethod (setf plan-action-status) :after
7542 (new-status (p sequential-plan) (o operation) (c component))
7543 (when (action-planned-p new-status)
7544 (push (cons o c) (plan-actions-r p)))))
7547 ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
7548 (with-upgradability ()
7549 (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
7551 "Generate and return a plan for performing OPERATION on COMPONENT."))
7552 (define-convenience-action-methods make-plan (plan-class operation component &key))
7554 (defgeneric perform-plan (plan &key))
7555 (defgeneric plan-operates-on-p (plan component))
7557 (defvar *default-plan-class* 'sequential-plan)
7559 (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
7560 (let ((plan (apply 'make-instance
7561 (or plan-class *default-plan-class*)
7562 :system (component-system c) keys)))
7563 (traverse-action plan o c t)
7566 (defmethod perform-plan :around ((plan t) &key)
7567 (let ((*package* *package*)
7568 (*readtable* *readtable*))
7569 (with-compilation-unit () ;; backward-compatibility.
7570 (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
7572 (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
7573 (apply 'perform-plan (plan-actions plan) keys))
7575 (defmethod perform-plan ((steps list) &key force &allow-other-keys)
7576 (loop* :for (o . c) :in steps
7577 :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
7578 :do (perform-with-restarts o c)))
7580 (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
7581 (plan-operates-on-p (plan-actions plan) component-path))
7583 (defmethod plan-operates-on-p ((plan list) (component-path list))
7584 (find component-path (mapcar 'cdr plan)
7585 :test 'equal :key 'component-find-path)))
7588 ;;;; Incidental traversals
7589 (with-upgradability ()
7590 (defclass filtered-sequential-plan (sequential-plan)
7591 ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
7592 (component-type :initform t :initarg :component-type :reader plan-component-type)
7593 (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
7594 (keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
7596 (defmethod initialize-instance :after ((plan filtered-sequential-plan)
7597 &key (force () fp) (force-not () fnp)
7599 (declare (ignore force force-not))
7600 (with-slots (forced forced-not action-filter system) plan
7601 (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
7602 (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
7603 (setf action-filter (ensure-function action-filter))))
7605 (defmethod action-valid-p ((plan filtered-sequential-plan) o c)
7606 (and (funcall (plan-action-filter plan) o c)
7607 (typep c (plan-component-type plan))
7608 (call-next-method)))
7610 (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
7611 (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
7612 (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
7615 (define-convenience-action-methods traverse-sub-actions (operation component &key))
7616 (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
7617 (apply 'traverse-actions (direct-dependencies operation component)
7618 :system (component-system component) keys))
7620 (defmethod plan-actions ((plan filtered-sequential-plan))
7621 (with-slots (keep-operation keep-component) plan
7622 (loop* :for (o . c) :in (call-next-method)
7623 :when (and (typep o keep-operation) (typep c keep-component))
7624 :collect (cons o c))))
7626 (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
7628 (mapcar 'cdr (plan-actions
7629 (apply 'traverse-sub-actions goal-operation system
7630 (remove-plist-key :goal-operation keys))))
7633 ;;;; -------------------------------------------------------------------------
7634 ;;;; Invoking Operations
7636 (asdf/package:define-package :asdf/operate
7637 (:recycle :asdf/operate :asdf)
7638 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7639 :asdf/component :asdf/system :asdf/operation :asdf/action
7640 :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
7643 #:*systems-being-operated*
7645 #:load-system #:load-systems #:compile-system #:test-system #:require-system
7646 #:*load-system-operation* #:module-provide-asdf
7647 #:component-loaded-p #:already-loaded-systems))
7648 (in-package :asdf/operate)
7650 (with-upgradability ()
7651 (defgeneric* (operate) (operation component &key &allow-other-keys)
7653 "Operate does three things:
7655 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
7656 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk).
7657 3. It then calls TRAVERSE with the operation and system as arguments
7659 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code.
7660 If a VERSION argument is supplied, then operate also ensures that the system found
7661 satisfies it using the VERSION-SATISFIES method.
7663 Note that dependencies may cause the operation to invoke other operations on the system
7664 or its components: the new operations will be created with the same initargs as the original one.
7666 The :FORCE or :FORCE-NOT argument to OPERATE can be:
7667 T to force the inside of the specified system to be rebuilt (resp. not),
7668 without recursively forcing the other systems we depend on.
7669 :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
7670 (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
7671 :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
7673 (define-convenience-action-methods
7674 operate (operation component &key)
7675 ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
7676 ;; but swank.asd relies on :force (!).
7677 :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
7678 :if-no-component (error 'missing-component :requires component))
7680 (defvar *systems-being-operated* nil
7681 "A boolean indicating that some systems are being operated on")
7683 (defmethod operate :around (operation component &rest keys
7685 (on-warnings *compile-file-warnings-behaviour*)
7686 (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
7687 (declare (ignorable operation component))
7688 (let* ((systems-being-operated *systems-being-operated*)
7689 (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
7690 (operation-name (reify-symbol (etypecase operation
7691 (operation (type-of operation))
7692 (symbol operation))))
7693 (component-path (typecase component
7694 (component (component-find-path component))
7696 ;; Before we operate on any system, make sure ASDF is up-to-date,
7697 ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
7698 (unless systems-being-operated
7699 (when (upgrade-asdf)
7700 ;; If we were upgraded, restart OPERATE the hardest of ways, for
7701 ;; its function may have been redefined, its symbol uninterned, its package deleted.
7702 (return-from operate
7703 (apply (find-symbol* 'operate :asdf)
7704 (unreify-symbol operation-name)
7705 component-path keys))))
7706 ;; Setup proper bindings around any operate call.
7707 (with-system-definitions ()
7708 (let* ((*verbose-out* (and verbose *standard-output*))
7709 (*compile-file-warnings-behaviour* on-warnings)
7710 (*compile-file-failure-behaviour* on-failure))
7711 (call-next-method)))))
7713 (defmethod operate :before ((operation operation) (component component)
7714 &key version &allow-other-keys)
7715 (let ((system (component-system component)))
7716 (setf (gethash (coerce-name system) *systems-being-operated*) system))
7717 (unless (version-satisfies component version)
7718 (error 'missing-component-of-version :requires component :version version)))
7720 (defmethod operate ((operation operation) (component component)
7721 &rest keys &key plan-class &allow-other-keys)
7722 (let ((plan (apply 'make-plan plan-class operation component keys)))
7723 (apply 'perform-plan plan keys)
7724 (values operation plan)))
7726 (defun oos (operation component &rest args &key &allow-other-keys)
7727 (apply 'operate operation component args))
7729 (setf (documentation 'oos 'function)
7730 (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
7731 (documentation 'operate 'function))))
7734 ;;;; Common operations
7735 (with-upgradability ()
7736 (defvar *load-system-operation* 'load-op
7737 "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
7738 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
7739 or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
7741 This may change in the future as we will implement component-based strategy
7742 for how to load or compile stuff")
7744 (defun build-system (system &rest keys)
7745 "Shorthand for `(operate 'asdf:build-op system)`."
7746 (apply 'operate 'build-op system keys)
7749 (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
7750 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
7751 (declare (ignore force force-not verbose version))
7752 (apply 'operate *load-system-operation* system keys)
7755 (defun load-systems (&rest systems)
7756 "Loading multiple systems at once."
7757 (map () 'load-system systems))
7759 (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
7760 "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
7761 (declare (ignore force force-not verbose version))
7762 (apply 'operate 'compile-op system args)
7765 (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
7766 "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
7767 (declare (ignore force force-not verbose version))
7768 (apply 'operate 'test-op system args)
7772 ;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
7773 ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
7774 (with-upgradability ()
7775 (defun component-loaded-p (c)
7776 (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
7778 (defun already-loaded-systems ()
7779 (remove-if-not 'component-loaded-p (registered-systems)))
7781 (defun require-system (s &rest keys &key &allow-other-keys)
7782 (apply 'load-system s :force-not (already-loaded-systems) keys))
7784 (defvar *modules-being-required* nil)
7786 (defclass require-system (system)
7787 ((module :initarg :module :initform nil :accessor required-module)))
7789 (defmethod perform ((o compile-op) (c require-system))
7790 (declare (ignorable o c))
7793 (defmethod perform ((o load-op) (s require-system))
7794 (declare (ignorable o))
7795 (let* ((module (or (required-module s) (coerce-name s)))
7796 (*modules-being-required* (cons module *modules-being-required*)))
7797 (assert (null (component-children s)))
7800 (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
7801 (declare (ignorable component combinator))
7802 (unless (length=n-p arguments 1)
7803 (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
7804 (cons combinator arguments) component combinator))
7805 (let* ((module (car arguments))
7806 (name (string-downcase module))
7807 (system (find-system name nil)))
7809 ;;(unless (typep system '(or null require-system))
7810 ;; (warn "~S depends on ~S but ~S is registered as a ~S"
7811 ;; component (cons combinator arguments) module (type-of system)))
7812 (or system (let ((system (make-instance 'require-system :name name)))
7813 (register-system system)
7816 (defun module-provide-asdf (name)
7817 (let ((module (string-downcase name)))
7818 (unless (member module *modules-being-required* :test 'equal)
7819 (let ((*modules-being-required* (cons module *modules-being-required*))
7820 #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal)))
7822 ((style-warning #'muffle-warning)
7823 (missing-component (constantly nil))
7824 (error #'(lambda (e)
7825 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
7827 (let ((*verbose-out* (make-broadcast-stream)))
7828 (let ((system (find-system module nil)))
7830 (require-system system :verbose nil)
7834 ;;;; Some upgrade magic
7835 (with-upgradability ()
7836 (defun restart-upgraded-asdf ()
7837 ;; If we're in the middle of something, restart it.
7838 (when *systems-being-defined*
7839 (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
7840 (clrhash *systems-being-defined*)
7841 (dolist (s l) (find-system s nil)))))
7843 (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
7846 ;;;; -------------------------------------------------------------------------
7847 ;;; Internal hacks for backward-compatibility
7849 (asdf/package:define-package :asdf/backward-internals
7850 (:recycle :asdf/backward-internals :asdf)
7851 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7852 :asdf/system :asdf/component :asdf/operation
7853 :asdf/find-system :asdf/action :asdf/lisp-action)
7854 (:export ;; for internal use
7855 #:load-sysdef #:make-temporary-package
7856 #:%refresh-component-inline-methods
7857 #:%resolve-if-component-dep-fails
7858 #:make-sub-operation
7859 #:load-sysdef #:make-temporary-package))
7860 (in-package :asdf/backward-internals)
7862 ;;;; Backward compatibility with "inline methods"
7863 (with-upgradability ()
7864 (defparameter +asdf-methods+
7865 '(perform-with-restarts perform explain output-files operation-done-p))
7867 (defun %remove-component-inline-methods (component)
7868 (dolist (name +asdf-methods+)
7870 ;; this is inefficient as most of the stored
7871 ;; methods will not be for this particular gf
7872 ;; But this is hardly performance-critical
7874 (remove-method (symbol-function name) m))
7875 (component-inline-methods component)))
7876 (component-inline-methods component) nil)
7878 (defun %define-component-inline-methods (ret rest)
7879 (loop* :for (key value) :on rest :by #'cddr
7880 :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
7882 (destructuring-bind (op &rest body) value
7883 (loop :for arg = (pop body)
7885 :collect arg :into qualifiers
7887 (destructuring-bind (o c) arg
7889 (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
7890 (component-inline-methods ret)))))))
7892 (defun %refresh-component-inline-methods (component rest)
7893 ;; clear methods, then add the new ones
7894 (%remove-component-inline-methods component)
7895 (%define-component-inline-methods component rest)))
7897 ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
7898 ;; and the companion asdf:feature pseudo-dependency.
7899 ;; This won't recurse into dependencies to accumulate feature conditions.
7900 ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
7901 ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
7902 (with-upgradability ()
7903 (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
7904 (asdf-message "The system definition for ~S uses deprecated ~
7905 ASDF option :IF-COMPONENT-DEP-DAILS. ~
7906 Starting with ASDF 3, please use :IF-FEATURE instead"
7907 (coerce-name (component-system component)))
7908 ;; This only supports the pattern of use of the "feature" seen in the wild
7909 (check-type component parent-component)
7910 (check-type if-component-dep-fails (member :fail :ignore :try-next))
7911 (unless (eq if-component-dep-fails :fail)
7912 (loop :with o = (make-operation 'compile-op)
7913 :for c :in (component-children component) :do
7914 (loop* :for (feature? feature) :in (component-depends-on o c)
7915 :when (eq feature? 'feature) :do
7916 (setf (component-if-feature c) feature))))))
7918 (when-upgrading (:when (fboundp 'make-sub-operation))
7919 (defun make-sub-operation (c o dep-c dep-o)
7920 (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
7924 (with-upgradability ()
7925 (defun load-sysdef (name pathname)
7926 (load-asd pathname :name name))
7928 (defun make-temporary-package ()
7929 ;; For loading a .asd file, we dont't make a temporary package anymore,
7930 ;; but use ASDF-USER. I'd like to have this function do this,
7931 ;; but since whoever uses it is likely to delete-package the result afterwards,
7932 ;; this would be a bad idea, so preserve the old behavior.
7933 (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
7936 ;;;; -------------------------------------------------------------------------
7939 (asdf/package:define-package :asdf/defsystem
7940 (:recycle :asdf/defsystem :asdf)
7941 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7942 :asdf/component :asdf/system :asdf/cache
7943 :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
7944 :asdf/backward-internals)
7946 #:defsystem #:register-system-definition
7947 #:class-for-type #:*default-component-class*
7948 #:determine-system-directory #:parse-component-form
7949 #:duplicate-names #:non-toplevel-system #:non-system-system
7950 #:sysdef-error-component #:check-component-input))
7951 (in-package :asdf/defsystem)
7954 (with-upgradability ()
7955 (defun determine-system-directory (pathname)
7956 ;; The defsystem macro calls this function to determine
7957 ;; the pathname of a system as follows:
7958 ;; 1. if the pathname argument is an pathname object (NOT a namestring),
7959 ;; that is already an absolute pathname, return it.
7960 ;; 2. otherwise, the directory containing the LOAD-PATHNAME
7961 ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
7962 ;; if it is indeed available and an absolute pathname, then
7963 ;; the PATHNAME argument is normalized to a relative pathname
7964 ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
7965 ;; and merged into that DIRECTORY as per SUBPATHNAME.
7966 ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
7967 ;; and may be from within the EVAL-WHEN of a file compilation.
7968 ;; If no absolute pathname was found, we return NIL.
7969 (check-type pathname (or null string pathname))
7970 (pathname-directory-pathname
7972 (ensure-absolute-pathname
7973 (parse-unix-namestring pathname :type :directory)
7974 #'(lambda () (ensure-absolute-pathname
7975 (load-pathname) 'get-pathname-defaults nil))
7980 (with-upgradability ()
7981 (defvar *default-component-class* 'cl-source-file)
7983 (defun class-for-type (parent type)
7984 (or (loop :for symbol :in (list
7986 (find-symbol* type *package* nil)
7987 (find-symbol* type :asdf/interface nil)
7988 (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
7989 :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
7991 (#-cormanlisp subtypep #+cormanlisp cl::subclassp
7992 class (find-class* 'component)))
7994 (and (eq type :file)
7996 (or (loop :for p = parent :then (component-parent p) :while p
7997 :thereis (module-default-component-class p))
7998 *default-component-class*) nil))
7999 (sysdef-error "don't recognize component type ~A" type))))
8003 (with-upgradability ()
8004 (define-condition duplicate-names (system-definition-error)
8005 ((name :initarg :name :reader duplicate-names-name))
8006 (:report (lambda (c s)
8007 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
8008 (duplicate-names-name c)))))
8010 (define-condition non-system-system (system-definition-error)
8011 ((name :initarg :name :reader non-system-system-name)
8012 (class-name :initarg :class-name :reader non-system-system-class-name))
8013 (:report (lambda (c s)
8014 (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
8015 (non-system-system-name c) (non-system-system-class-name c) 'system))))
8017 (define-condition non-toplevel-system (system-definition-error)
8018 ((parent :initarg :parent :reader non-toplevel-system-parent)
8019 (name :initarg :name :reader non-toplevel-system-name))
8020 (:report (lambda (c s)
8021 (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
8022 (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
8024 (defun sysdef-error-component (msg type name value)
8025 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
8028 (defun check-component-input (type name weakly-depends-on
8029 depends-on components)
8030 "A partial test of the values of a component."
8031 (unless (listp depends-on)
8032 (sysdef-error-component ":depends-on must be a list."
8033 type name depends-on))
8034 (unless (listp weakly-depends-on)
8035 (sysdef-error-component ":weakly-depends-on must be a list."
8036 type name weakly-depends-on))
8037 (unless (listp components)
8038 (sysdef-error-component ":components must be NIL or a list of components."
8039 type name components)))
8041 (defun* (normalize-version) (form &key pathname component parent)
8042 (labels ((invalid (&optional (continuation "using NIL instead"))
8043 (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
8044 form component parent pathname continuation))
8045 (invalid-parse (control &rest args)
8046 (unless (builtin-system-p (find-component parent component))
8047 (apply 'warn control args)
8049 (if-let (v (typecase form
8050 ((or string null) form)
8052 (invalid "Substituting a string")
8053 (format nil "~D" form)) ;; 1.0 becomes "1.0"
8057 (destructuring-bind (subpath &key (at 0)) (rest form)
8058 (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
8060 (destructuring-bind (subpath &key (at 0)) (rest form)
8061 (read-file-lines (subpathname pathname subpath) :at at)))
8066 (if-let (pv (parse-version v #'invalid-parse))
8067 (unparse-version pv)
8071 ;;; Main parsing function
8072 (with-upgradability ()
8073 (defun* (parse-component-form) (parent options &key previous-serial-component)
8075 (type name &rest rest &key
8076 (builtin-system-p () bspp)
8077 ;; the following list of keywords is reproduced below in the
8078 ;; remove-plist-keys form. important to keep them in sync
8079 components pathname perform explain output-files operation-done-p
8080 weakly-depends-on depends-on serial
8081 do-first if-component-dep-fails version
8083 &allow-other-keys) options
8084 (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
8085 (check-component-input type name weakly-depends-on depends-on components)
8087 (find-component parent name)
8088 (not ;; ignore the same object when rereading the defsystem
8089 (typep (find-component parent name)
8090 (class-for-type parent type))))
8091 (error 'duplicate-names :name name))
8092 (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
8093 (let* ((name (coerce-name name))
8096 ,@(when parent `(:parent ,parent))
8097 ,@(remove-plist-keys
8098 '(:components :pathname :if-component-dep-fails :version
8099 :perform :explain :output-files :operation-done-p
8100 :weakly-depends-on :depends-on :serial)
8102 (component (find-component parent name))
8103 (class (class-for-type parent type)))
8104 (when (and parent (subtypep class 'system))
8105 (error 'non-toplevel-system :parent parent :name name))
8106 (if component ; preserve identity
8107 (apply 'reinitialize-instance component args)
8108 (setf component (apply 'make-instance class args)))
8109 (component-pathname component) ; eagerly compute the absolute pathname
8110 (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
8111 (when (and (typep component 'system) (not bspp))
8112 (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
8113 (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
8114 ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
8115 ;; A better fix is required.
8116 (setf (slot-value component 'version) version)
8117 (when (typep component 'parent-component)
8118 (setf (component-children component)
8120 :with previous-component = nil
8121 :for c-form :in components
8122 :for c = (parse-component-form component c-form
8123 :previous-serial-component previous-component)
8124 :for name = (component-name c)
8126 :when serial :do (setf previous-component name)))
8127 (compute-children-by-name component))
8128 (when previous-serial-component
8129 (push previous-serial-component depends-on))
8130 (when weakly-depends-on
8131 ;; ASDF4: deprecate this feature and remove it.
8133 (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
8134 ;; Used by POIU. ASDF4: rename to component-depends-on?
8135 (setf (component-sideway-dependencies component) depends-on)
8136 (%refresh-component-inline-methods component rest)
8137 (when if-component-dep-fails
8138 (%resolve-if-component-dep-fails if-component-dep-fails component))
8141 (defun register-system-definition
8142 (name &rest options &key pathname (class 'system) (source-file () sfp)
8143 defsystem-depends-on &allow-other-keys)
8144 ;; The system must be registered before we parse the body,
8145 ;; otherwise we recur when trying to find an existing system
8146 ;; of the same name to reuse options (e.g. pathname) from.
8147 ;; To avoid infinite recursion in cases where you defsystem a system
8148 ;; that is registered to a different location to find-system,
8149 ;; we also need to remember it in a special variable *systems-being-defined*.
8150 (with-system-definitions ()
8151 (let* ((name (coerce-name name))
8152 (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
8153 (registered (system-registered-p name))
8154 (registered! (if registered
8155 (rplaca registered (get-file-stamp source-file))
8157 (make-instance 'system :name name :source-file source-file))))
8158 (system (reset-system (cdr registered!)
8159 :name name :source-file source-file))
8160 (component-options (remove-plist-key :class options))
8161 (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
8162 (resolve-dependency-spec nil spec))))
8163 (setf (gethash name *systems-being-defined*) system)
8164 (apply 'load-systems defsystem-dependencies)
8165 ;; We change-class AFTER we loaded the defsystem-depends-on
8166 ;; since the class might be defined as part of those.
8167 (let ((class (class-for-type nil class)))
8168 (unless (subtypep class 'system)
8169 (error 'non-system-system :name name :class-name (class-name class)))
8170 (unless (eq (type-of system) class)
8171 (change-class system class)))
8172 (parse-component-form
8175 :pathname (determine-system-directory pathname)
8176 component-options)))))
8178 (defmacro defsystem (name &body options)
8179 `(apply 'register-system-definition ',name ',options)))
8180 ;;;; -------------------------------------------------------------------------
8183 (asdf/package:define-package :asdf/bundle
8184 (:recycle :asdf/bundle :asdf)
8185 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8186 :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
8187 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
8189 #:bundle-op #:bundle-op-build-args #:bundle-type
8190 #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
8191 #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
8192 #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
8193 #:lib-op #:monolithic-lib-op
8194 #:dll-op #:monolithic-dll-op
8195 #:binary-op #:monolithic-binary-op
8196 #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
8197 #:user-system-p #:user-system #:trivial-system-p
8199 #:register-pre-built-system
8200 #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
8201 (in-package :asdf/bundle)
8203 (with-upgradability ()
8204 (defclass bundle-op (operation)
8205 ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
8206 (name-suffix :initarg :name-suffix :initform nil)
8207 (bundle-type :initform :no-output-file :reader bundle-type)
8208 #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
8209 #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
8210 #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
8212 (defclass bundle-compile-op (bundle-op basic-compile-op)
8214 (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
8216 ;; create a single fasl for the entire library
8217 (defclass basic-fasl-op (bundle-compile-op)
8218 ((bundle-type :initform :fasl)))
8219 (defclass prepare-fasl-op (sideway-operation)
8220 ((sideway-operation :initform 'load-fasl-op)))
8221 (defclass fasl-op (basic-fasl-op selfward-operation)
8222 ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
8223 (defclass load-fasl-op (basic-load-op selfward-operation)
8224 ((selfward-operation :initform '(prepare-op fasl-op))))
8226 ;; NB: since the monolithic-op's can't be sideway-operation's,
8227 ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
8228 ;; we'd have to have the monolithic-op not inherit from the main op,
8229 ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
8231 (defclass no-ld-flags-op (operation) ())
8233 (defclass lib-op (bundle-compile-op no-ld-flags-op)
8234 ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
8235 (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
8236 #-(or ecl mkcl) "just compile the system"))
8238 (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op)
8239 ((bundle-type :initform :dll))
8240 (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
8242 (defclass binary-op (basic-compile-op selfward-operation)
8243 ((selfward-operation :initform '(fasl-op lib-op)))
8244 (:documentation "produce fasl and asd files for the system"))
8246 (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
8248 (defclass monolithic-bundle-op (monolithic-op bundle-op)
8249 ((prologue-code :accessor monolithic-op-prologue-code)
8250 (epilogue-code :accessor monolithic-op-epilogue-code)))
8252 (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
8254 (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
8256 (defclass monolithic-binary-op (monolithic-op binary-op)
8257 ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
8258 (:documentation "produce fasl and asd files for combined system and dependencies."))
8260 (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
8261 (:documentation "Create a single fasl for the system and its dependencies."))
8263 (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-op)
8264 ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
8265 (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
8266 #-(or ecl mkcl) "Compile a system and its dependencies."))
8268 (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op)
8269 ((bundle-type :initform :dll))
8270 (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
8272 (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
8273 #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
8274 ((bundle-type :initform :program)
8275 #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
8276 (:documentation "create an executable file from the system and its dependencies"))
8278 (defun bundle-pathname-type (bundle-type)
8279 (etypecase bundle-type
8280 ((eql :no-output-file) nil) ;; should we error out instead?
8281 ((or null string) bundle-type)
8282 ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
8284 ((member :binary :dll :lib :shared-library :static-library :program :object :program)
8285 (compile-file-type :type bundle-type))
8286 ((eql :binary) "image")
8287 ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
8288 ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
8289 ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
8291 (defun bundle-output-files (o c)
8292 (when (input-files o c)
8293 (let ((bundle-type (bundle-type o)))
8294 (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
8295 (let ((name (or (component-build-pathname c)
8296 (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
8297 (type (bundle-pathname-type bundle-type)))
8298 (values (list (subpathname (component-pathname c) name :type type))
8299 (eq (type-of o) (component-build-operation c))))))))
8301 (defmethod output-files ((o bundle-op) (c system))
8302 (bundle-output-files o c))
8305 (defmethod perform ((o program-op) (c system))
8306 (let ((output-file (output-file o c)))
8307 (setf *image-entry-point* (ensure-function (component-entry-point c)))
8308 (dump-image output-file :executable t)))
8310 (defclass compiled-file (file-component)
8311 ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
8313 (defclass precompiled-system (system)
8314 ((build-pathname :initarg :fasl)))
8316 (defclass prebuilt-system (system)
8317 ((build-pathname :initarg :static-library :initarg :lib
8318 :accessor prebuilt-system-static-library))))
8324 ;;; This operation takes all components from one or more systems and
8325 ;;; creates a single output file, which may be
8326 ;;; a FASL, a statically linked library, a shared library, etc.
8327 ;;; The different targets are defined by specialization.
8329 (with-upgradability ()
8330 (defun operation-monolithic-p (op)
8331 (typep op 'monolithic-op))
8333 (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
8334 &key (name-suffix nil name-suffix-p)
8336 (declare (ignorable initargs name-suffix))
8337 (unless name-suffix-p
8338 (setf (slot-value instance 'name-suffix)
8339 (unless (typep instance 'program-op)
8340 (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
8341 (when (typep instance 'monolithic-bundle-op)
8342 (destructuring-bind (&rest original-initargs
8343 &key lisp-files prologue-code epilogue-code
8345 (operation-original-initargs instance)
8346 (setf (operation-original-initargs instance)
8347 (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
8348 (monolithic-op-prologue-code instance) prologue-code
8349 (monolithic-op-epilogue-code instance) epilogue-code)
8350 #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
8351 #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
8352 (setf (bundle-op-build-args instance)
8353 (remove-plist-keys '(:type :monolithic :name-suffix)
8354 (operation-original-initargs instance))))
8356 (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
8357 (declare (ignorable o))
8358 (let ((args (call-next-method)))
8359 (remf args :ld-flags)
8362 (defun bundlable-file-p (pathname)
8363 (let ((type (pathname-type pathname)))
8364 (declare (ignorable type))
8365 (or #+ecl (or (equalp type (compile-file-type :type :object))
8366 (equalp type (compile-file-type :type :static-library)))
8367 #+mkcl (equalp type (compile-file-type :fasl-p nil))
8368 #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
8370 (defgeneric* (trivial-system-p) (component))
8372 (defun user-system-p (s)
8373 (and (typep s 'system)
8374 (not (builtin-system-p s))
8375 (not (trivial-system-p s)))))
8377 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
8378 (deftype user-system () '(and system (satisfies user-system-p))))
8381 ;;; First we handle monolithic bundles.
8382 ;;; These are standalone systems which contain everything,
8383 ;;; including other ASDF systems required by the current one.
8384 ;;; A PROGRAM is always monolithic.
8386 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
8388 (with-upgradability ()
8389 (defmethod component-depends-on ((o bundle-compile-op) (c system))
8390 `(,(if (operation-monolithic-p o)
8391 `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
8392 ,@(required-components c :other-systems t :component-type 'system
8393 :goal-operation (find-operation o 'load-op)
8394 :keep-operation 'compile-op))
8396 ,@(required-components c :other-systems nil :component-type '(not system)
8397 :goal-operation (find-operation o 'load-op)
8398 :keep-operation 'compile-op)))
8399 ,@(call-next-method)))
8401 (defmethod component-depends-on :around ((o bundle-op) (c component))
8402 (declare (ignorable o c))
8403 (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
8405 (call-next-method)))
8407 (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
8408 ;; This file selects output files from direct dependencies;
8409 ;; your component-depends-on method better gathered the correct dependencies in the correct order.
8410 (while-collecting (collect)
8411 (map-direct-dependencies
8412 o c #'(lambda (sub-o sub-c)
8413 (loop :for f :in (funcall key sub-o sub-c)
8414 :when (funcall test f) :do (collect f))))))
8416 (defmethod input-files ((o bundle-compile-op) (c system))
8417 (unless (eq (bundle-type o) :no-output-file)
8418 (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
8420 (defun select-bundle-operation (type &optional monolithic)
8423 (if monolithic 'monolithic-binary-op 'binary-op))
8424 ((:dll :shared-library)
8425 (if monolithic 'monolithic-dll-op 'dll-op))
8426 ((:lib :static-library)
8427 (if monolithic 'monolithic-lib-op 'lib-op))
8429 (if monolithic 'monolithic-fasl-op 'fasl-op))
8433 (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
8434 (move-here nil move-here-p)
8436 (let* ((operation-name (select-bundle-operation type monolithic))
8437 (move-here-path (if (and move-here
8438 (typep move-here '(or pathname string)))
8439 (pathname move-here)
8440 (system-relative-pathname system "asdf-output/")))
8441 (operation (apply #'operate operation-name
8443 (remove-plist-keys '(:monolithic :type :move-here) args)))
8444 (system (find-system system))
8445 (files (and system (output-files operation system))))
8446 (if (or move-here (and (null move-here-p)
8447 (member operation-name '(:program :binary))))
8448 (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
8450 :for new-f = (make-pathname :name (pathname-name f)
8451 :type (pathname-type f)
8452 :defaults dest-path)
8453 :do (rename-file-overwriting-target f new-f)
8460 ;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
8462 (with-upgradability ()
8463 (defmethod component-depends-on ((o load-fasl-op) (c system))
8464 (declare (ignorable o))
8465 `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
8466 :collect (resolve-dependency-spec c dep)))
8467 (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
8468 ,@(call-next-method)))
8470 (defmethod input-files ((o load-fasl-op) (c system))
8471 (when (user-system-p c)
8472 (output-files (find-operation o 'fasl-op) c)))
8474 (defmethod perform ((o load-fasl-op) c)
8475 (declare (ignorable o c))
8478 (defmethod perform ((o load-fasl-op) (c system))
8479 (when (input-files o c)
8480 (perform-lisp-load-fasl o c)))
8482 (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
8483 (mark-operation-done (find-operation o 'load-op) c)))
8486 ;;; PRECOMPILED FILES
8488 ;;; This component can be used to distribute ASDF systems in precompiled form.
8489 ;;; Only useful when the dependencies have also been precompiled.
8491 (with-upgradability ()
8492 (defmethod trivial-system-p ((s system))
8493 (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
8495 (defmethod output-files (o (c compiled-file))
8496 (declare (ignorable o c))
8498 (defmethod input-files (o (c compiled-file))
8499 (declare (ignorable o))
8500 (component-pathname c))
8501 (defmethod perform ((o load-op) (c compiled-file))
8502 (perform-lisp-load-fasl o c))
8503 (defmethod perform ((o load-source-op) (c compiled-file))
8504 (perform (find-operation o 'load-op) c))
8505 (defmethod perform ((o load-fasl-op) (c compiled-file))
8506 (perform (find-operation o 'load-op) c))
8507 (defmethod perform ((o operation) (c compiled-file))
8508 (declare (ignorable o c))
8512 ;;; Pre-built systems
8514 (with-upgradability ()
8515 (defmethod trivial-system-p ((s prebuilt-system))
8516 (declare (ignorable s))
8519 (defmethod perform ((o lib-op) (c prebuilt-system))
8520 (declare (ignorable o c))
8523 (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
8524 (declare (ignorable o c))
8527 (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
8528 (declare (ignorable o))
8533 ;;; PREBUILT SYSTEM CREATOR
8535 (with-upgradability ()
8536 (defmethod output-files ((o binary-op) (s system))
8537 (list (make-pathname :name (component-name s) :type "asd"
8538 :defaults (component-pathname s))))
8540 (defmethod perform ((o binary-op) (s system))
8541 (let* ((inputs (input-files o s))
8542 (fasl (first inputs))
8543 (library (second inputs))
8544 (asd (first (output-files o s)))
8545 (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
8547 (if (operation-monolithic-p o)
8548 (remove-if-not 'builtin-system-p
8549 (required-components s :component-type 'system
8550 :keep-operation 'load-op))
8551 (while-collecting (x) ;; resolve the sideway-dependencies of s
8552 (map-direct-dependencies
8555 (when (and (typep o 'load-op) (typep c 'system))
8557 (depends-on (mapcar 'coerce-name dependencies)))
8558 (when (pathname-equal asd (system-source-file s))
8559 (cerror "overwrite the asd file"
8560 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
8562 (with-open-file (s asd :direction :output :if-exists :supersede
8563 :if-does-not-exist :create)
8564 (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
8565 (operation-monolithic-p o) name)
8566 (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
8567 (lisp-implementation-type)
8568 (lisp-implementation-version)
8572 (let ((*package* (find-package :asdf-user)))
8573 (pprint `(defsystem ,name
8574 :class prebuilt-system
8575 :depends-on ,depends-on
8576 :components ((:compiled-file ,(pathname-name fasl)))
8577 ,@(when library `(:lib ,(file-namestring library))))
8582 (defmethod perform ((o bundle-compile-op) (c system))
8583 (let* ((input-files (input-files o c))
8584 (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
8585 (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
8586 (output-files (output-files o c))
8587 (output-file (first output-files)))
8588 (assert (eq (not input-files) (not output-files)))
8590 (when non-fasl-files
8591 (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
8592 (implementation-type) non-fasl-files))
8593 (when (and (typep o 'monolithic-bundle-op)
8594 (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
8595 (error "prologue-code and epilogue-code are not supported on ~A"
8596 (implementation-type)))
8597 (with-staging-pathname (output-file)
8598 (combine-fasls fasl-files output-file)))))
8600 (defmethod input-files ((o load-op) (s precompiled-system))
8601 (declare (ignorable o))
8602 (bundle-output-files (find-operation o 'fasl-op) s))
8604 (defmethod perform ((o load-op) (s precompiled-system))
8605 (perform-lisp-load-fasl o s))
8607 (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
8608 (declare (ignorable o))
8609 `((load-op ,s) ,@(call-next-method))))
8612 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
8613 (asdf:load-system :precompiled-asdf-utils)
8617 (with-upgradability ()
8618 (defun uiop-library-file ()
8619 (or (and (find-system :uiop nil)
8620 (system-source-directory :uiop)
8622 (operate 'lib-op :uiop)
8623 (output-file 'lib-op :uiop)))
8624 (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
8625 (defmethod input-files :around ((o program-op) (c system))
8626 (let ((files (call-next-method))
8627 (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
8628 (unless (or (and (find-system :uiop nil)
8629 (system-source-directory :uiop)
8630 (plan-operates-on-p plan '("uiop")))
8631 (and (system-source-directory :asdf)
8632 (plan-operates-on-p plan '("asdf"))))
8633 (pushnew (uiop-library-file) files :test 'pathname-equal))
8636 (defun register-pre-built-system (name)
8637 (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
8640 (with-upgradability ()
8641 (defmethod perform ((o bundle-compile-op) (c system))
8642 (let* ((object-files (input-files o c))
8643 (output (output-files o c))
8644 (bundle (first output))
8645 (kind (bundle-type o)))
8648 bundle (append object-files (bundle-op-lisp-files o))
8650 :entry-point (component-entry-point c)
8652 (when (typep o 'monolithic-bundle-op)
8653 (monolithic-op-prologue-code o))
8655 (when (typep o 'monolithic-bundle-op)
8656 (monolithic-op-epilogue-code o))
8657 :build-args (bundle-op-build-args o))))))
8660 (with-upgradability ()
8661 (defmethod perform ((o lib-op) (s system))
8662 (apply #'compiler::build-static-library (output-file o c)
8663 :lisp-object-files (input-files o s) (bundle-op-build-args o)))
8665 (defmethod perform ((o basic-fasl-op) (s system))
8666 (apply #'compiler::build-bundle (output-file o c) ;; second???
8667 :lisp-object-files (input-files o s) (bundle-op-build-args o)))
8669 (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
8670 (declare (ignore force verbose version))
8671 (apply #'operate 'binary-op system args)))
8672 ;;;; -------------------------------------------------------------------------
8673 ;;;; Concatenate-source
8675 (asdf/package:define-package :asdf/concatenate-source
8676 (:recycle :asdf/concatenate-source :asdf)
8677 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8678 :asdf/component :asdf/operation
8679 :asdf/system :asdf/find-system :asdf/defsystem
8680 :asdf/action :asdf/lisp-action :asdf/bundle)
8682 #:concatenate-source-op
8683 #:load-concatenated-source-op
8684 #:compile-concatenated-source-op
8685 #:load-compiled-concatenated-source-op
8686 #:monolithic-concatenate-source-op
8687 #:monolithic-load-concatenated-source-op
8688 #:monolithic-compile-concatenated-source-op
8689 #:monolithic-load-compiled-concatenated-source-op))
8690 (in-package :asdf/concatenate-source)
8693 ;;; Concatenate sources
8695 (with-upgradability ()
8696 (defclass basic-concatenate-source-op (bundle-op)
8697 ((bundle-type :initform "lisp")))
8698 (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
8699 (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
8700 (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
8702 (defclass concatenate-source-op (basic-concatenate-source-op) ())
8703 (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
8704 ((selfward-operation :initform '(prepare-op concatenate-source-op))))
8705 (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
8706 ((selfward-operation :initform '(prepare-op concatenate-source-op))))
8707 (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
8708 ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
8710 (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
8711 (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
8712 ((selfward-operation :initform 'monolithic-concatenate-source-op)))
8713 (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
8714 ((selfward-operation :initform 'monolithic-concatenate-source-op)))
8715 (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
8716 ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
8718 (defmethod input-files ((operation basic-concatenate-source-op) (s system))
8719 (loop :with encoding = (or (component-encoding s) *default-encoding*)
8720 :with other-encodings = '()
8721 :with around-compile = (around-compile-hook s)
8722 :with other-around-compile = '()
8723 :for c :in (required-components
8724 s :goal-operation 'compile-op
8725 :keep-operation 'compile-op
8726 :other-systems (operation-monolithic-p operation))
8728 (when (typep c 'cl-source-file)
8729 (let ((e (component-encoding c)))
8730 (unless (equal e encoding)
8731 (pushnew e other-encodings :test 'equal)))
8732 (let ((a (around-compile-hook c)))
8733 (unless (equal a around-compile)
8734 (pushnew a other-around-compile :test 'equal)))
8735 (input-files (make-operation 'compile-op) c)) :into inputs
8737 (when other-encodings
8738 (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
8739 operation encoding other-encodings))
8740 (when other-around-compile
8741 (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
8742 operation around-compile other-around-compile))
8744 (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
8745 (lisp-compilation-output-files o s))
8747 (defmethod perform ((o basic-concatenate-source-op) (s system))
8748 (let ((inputs (input-files o s))
8749 (output (output-file o s)))
8750 (concatenate-files inputs output)))
8751 (defmethod perform ((o basic-load-concatenated-source-op) (s system))
8752 (perform-lisp-load-source o s))
8753 (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
8754 (perform-lisp-compilation o s))
8755 (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
8756 (perform-lisp-load-fasl o s)))
8758 ;;;; ---------------------------------------------------------------------------
8759 ;;;; asdf-output-translations
8761 (asdf/package:define-package :asdf/output-translations
8762 (:recycle :asdf/output-translations :asdf)
8763 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
8765 #:*output-translations* #:*output-translations-parameter*
8766 #:invalid-output-translation
8767 #:output-translations #:output-translations-initialized-p
8768 #:initialize-output-translations #:clear-output-translations
8769 #:disable-output-translations #:ensure-output-translations
8770 #:apply-output-translations
8771 #:validate-output-translations-directive #:validate-output-translations-form
8772 #:validate-output-translations-file #:validate-output-translations-directory
8773 #:parse-output-translations-string #:wrapping-output-translations
8774 #:user-output-translations-pathname #:system-output-translations-pathname
8775 #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
8776 #:environment-output-translations #:process-output-translations
8777 #:compute-output-translations
8778 #+abcl #:translate-jar-pathname
8780 (in-package :asdf/output-translations)
8782 (when-upgrading () (undefine-function '(setf output-translations)))
8784 (with-upgradability ()
8785 (define-condition invalid-output-translation (invalid-configuration warning)
8786 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
8788 (defvar *output-translations* ()
8789 "Either NIL (for uninitialized), or a list of one element,
8790 said element itself being a sorted list of mappings.
8791 Each mapping is a pair of a source pathname and destination pathname,
8792 and the order is by decreasing length of namestring of the source pathname.")
8794 (defun output-translations ()
8795 (car *output-translations*))
8797 (defun set-output-translations (new-value)
8798 (setf *output-translations*
8800 (stable-sort (copy-list new-value) #'>
8805 (let ((directory (pathname-directory (car x))))
8806 (if (listp directory) (length directory) 0))))))))
8809 (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
8811 (defsetf output-translations set-output-translations)
8813 (defun output-translations-initialized-p ()
8814 (and *output-translations* t))
8816 (defun clear-output-translations ()
8817 "Undoes any initialization of the output translations."
8818 (setf *output-translations* '())
8820 (register-clear-configuration-hook 'clear-output-translations)
8822 (defun validate-output-translations-directive (directive)
8823 (or (member directive '(:enable-user-cache :disable-cache nil))
8824 (and (consp directive)
8825 (or (and (length=n-p directive 2)
8826 (or (and (eq (first directive) :include)
8827 (typep (second directive) '(or string pathname null)))
8828 (and (location-designator-p (first directive))
8829 (or (location-designator-p (second directive))
8830 (location-function-p (second directive))))))
8831 (and (length=n-p directive 1)
8832 (location-designator-p (first directive)))))))
8834 (defun validate-output-translations-form (form &key location)
8835 (validate-configuration-form
8837 :output-translations
8838 'validate-output-translations-directive
8839 :location location :invalid-form-reporter 'invalid-output-translation))
8841 (defun validate-output-translations-file (file)
8842 (validate-configuration-file
8843 file 'validate-output-translations-form :description "output translations"))
8845 (defun validate-output-translations-directory (directory)
8846 (validate-configuration-directory
8847 directory :output-translations 'validate-output-translations-directive
8848 :invalid-form-reporter 'invalid-output-translation))
8850 (defun parse-output-translations-string (string &key location)
8852 ((or (null string) (equal string ""))
8853 '(:output-translations :inherit-configuration))
8854 ((not (stringp string))
8855 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
8856 ((eql (char string 0) #\")
8857 (parse-output-translations-string (read-from-string string) :location location))
8858 ((eql (char string 0) #\()
8859 (validate-output-translations-form (read-from-string string) :location location))
8863 :with directives = ()
8865 :with end = (length string)
8867 :with separator = (inter-directory-separator)
8868 :for i = (or (position separator string :start start) end) :do
8869 (let ((s (subseq string start i)))
8872 (push (list source (if (equal "" s) nil s)) directives)
8876 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
8879 (push :inherit-configuration directives))
8885 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
8888 (push :ignore-inherited-configuration directives))
8889 (return `(:output-translations ,@(nreverse directives)))))))))
8891 (defparameter *default-output-translations*
8892 '(environment-output-translations
8893 user-output-translations-pathname
8894 user-output-translations-directory-pathname
8895 system-output-translations-pathname
8896 system-output-translations-directory-pathname))
8898 (defun wrapping-output-translations ()
8899 `(:output-translations
8900 ;; Some implementations have precompiled ASDF systems,
8901 ;; so we must disable translations for implementation paths.
8902 #+(or #|clozure|# ecl mkcl sbcl)
8903 ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
8904 (when h `(((,h ,*wild-path*) ()))))
8905 #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
8906 ;; All-import, here is where we want user stuff to be:
8907 :inherit-configuration
8908 ;; These are for convenience, and can be overridden by the user:
8909 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
8910 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
8911 ;; We enable the user cache by default, and here is the place we do:
8912 :enable-user-cache))
8914 (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
8915 (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
8917 (defun user-output-translations-pathname (&key (direction :input))
8918 (in-user-configuration-directory *output-translations-file* :direction direction))
8919 (defun system-output-translations-pathname (&key (direction :input))
8920 (in-system-configuration-directory *output-translations-file* :direction direction))
8921 (defun user-output-translations-directory-pathname (&key (direction :input))
8922 (in-user-configuration-directory *output-translations-directory* :direction direction))
8923 (defun system-output-translations-directory-pathname (&key (direction :input))
8924 (in-system-configuration-directory *output-translations-directory* :direction direction))
8925 (defun environment-output-translations ()
8926 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
8928 (defgeneric process-output-translations (spec &key inherit collect))
8930 (defun inherit-output-translations (inherit &key collect)
8932 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
8934 (defun* (process-output-translations-directive) (directive &key inherit collect)
8935 (if (atom directive)
8937 ((:enable-user-cache)
8938 (process-output-translations-directive '(t :user-cache) :collect collect))
8940 (process-output-translations-directive '(t t) :collect collect))
8941 ((:inherit-configuration)
8942 (inherit-output-translations inherit :collect collect))
8943 ((:ignore-inherited-configuration :ignore-invalid-entries nil)
8945 (let ((src (first directive))
8946 (dst (second directive)))
8947 (if (eq src :include)
8949 (process-output-translations (pathname dst) :inherit nil :collect collect))
8951 (let ((trusrc (or (eql src t)
8952 (let ((loc (resolve-location src :ensure-directory t :wilden t)))
8953 (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
8955 ((location-function-p dst)
8958 (if (symbolp (second dst))
8959 (fdefinition (second dst))
8960 (eval (second dst))))))
8962 (funcall collect (list trusrc t)))
8964 (let* ((trudst (if dst
8965 (resolve-location dst :ensure-directory t :wilden t)
8967 (funcall collect (list trudst t))
8968 (funcall collect (list trusrc trudst)))))))))))
8970 (defmethod process-output-translations ((x symbol) &key
8971 (inherit *default-output-translations*)
8973 (process-output-translations (funcall x) :inherit inherit :collect collect))
8974 (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
8976 ((directory-pathname-p pathname)
8977 (process-output-translations (validate-output-translations-directory pathname)
8978 :inherit inherit :collect collect))
8979 ((probe-file* pathname :truename *resolve-symlinks*)
8980 (process-output-translations (validate-output-translations-file pathname)
8981 :inherit inherit :collect collect))
8983 (inherit-output-translations inherit :collect collect))))
8984 (defmethod process-output-translations ((string string) &key inherit collect)
8985 (process-output-translations (parse-output-translations-string string)
8986 :inherit inherit :collect collect))
8987 (defmethod process-output-translations ((x null) &key inherit collect)
8988 (declare (ignorable x))
8989 (inherit-output-translations inherit :collect collect))
8990 (defmethod process-output-translations ((form cons) &key inherit collect)
8991 (dolist (directive (cdr (validate-output-translations-form form)))
8992 (process-output-translations-directive directive :inherit inherit :collect collect)))
8994 (defun compute-output-translations (&optional parameter)
8995 "read the configuration, return it"
8997 (while-collecting (c)
8998 (inherit-output-translations
8999 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
9000 :test 'equal :from-end t))
9002 (defvar *output-translations-parameter* nil)
9004 (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
9005 "read the configuration, initialize the internal configuration variable,
9006 return the configuration"
9007 (setf *output-translations-parameter* parameter
9008 (output-translations) (compute-output-translations parameter)))
9010 (defun disable-output-translations ()
9011 "Initialize output translations in a way that maps every file to itself,
9012 effectively disabling the output translation facility."
9013 (initialize-output-translations
9014 '(:output-translations :disable-cache :ignore-inherited-configuration)))
9016 ;; checks an initial variable to see whether the state is initialized
9017 ;; or cleared. In the former case, return current configuration; in
9018 ;; the latter, initialize. ASDF will call this function at the start
9019 ;; of (asdf:find-system).
9020 (defun ensure-output-translations ()
9021 (if (output-translations-initialized-p)
9022 (output-translations)
9023 (initialize-output-translations)))
9025 (defun* (apply-output-translations) (path)
9029 ((or pathname string)
9030 (ensure-output-translations)
9031 (loop* :with p = (resolve-symlinks* path)
9032 :for (source destination) :in (car *output-translations*)
9033 :for root = (when (or (eq source t)
9034 (and (pathnamep source)
9035 (not (absolute-pathname-p source))))
9037 :for absolute-source = (cond
9038 ((eq source t) (wilden root))
9039 (root (merge-pathnames* source root))
9041 :when (or (eq source t) (pathname-match-p p absolute-source))
9042 :return (translate-pathname* p absolute-source destination root source)
9043 :finally (return p)))))
9045 ;; Hook into asdf/driver's output-translation mechanism
9047 (setf *output-translation-function* 'apply-output-translations)
9050 (defun translate-jar-pathname (source wildcard)
9051 (declare (ignore wildcard))
9052 (flet ((normalize-device (pathname)
9053 (if (find :windows *features*)
9055 (make-pathname :defaults pathname :device :unspecific))))
9057 (pathname (first (pathname-device source))))
9058 (target-root-directory-namestring
9059 (format nil "/___jar___file___root___/~@[~A/~]"
9060 (and (find :windows *features*)
9061 (pathname-device jar))))
9063 (relativize-pathname-directory source))
9065 (relativize-pathname-directory (ensure-directory-pathname jar)))
9066 (target-root-directory
9068 (pathname-directory-pathname
9069 (parse-namestring target-root-directory-namestring))))
9071 (merge-pathnames* relative-jar target-root-directory))
9073 (merge-pathnames* relative-source target-root)))
9074 (normalize-device (apply-output-translations target))))))
9076 ;;;; -------------------------------------------------------------------------
9077 ;;; Backward-compatible interfaces
9079 (asdf/package:define-package :asdf/backward-interface
9080 (:recycle :asdf/backward-interface :asdf)
9081 (:use :uiop/common-lisp :uiop :asdf/upgrade
9082 :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
9083 :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
9086 #:operation-error #:compile-error #:compile-failed #:compile-warned
9087 #:error-component #:error-operation #:traverse
9088 #:component-load-dependencies
9089 #:enable-asdf-binary-locations-compatibility
9091 #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
9092 #:component-property
9094 #:system-definition-pathname))
9095 (in-package :asdf/backward-interface)
9097 (with-upgradability ()
9098 (define-condition operation-error (error) ;; Bad, backward-compatible name
9099 ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
9100 ((component :reader error-component :initarg :component)
9101 (operation :reader error-operation :initarg :operation))
9102 (:report (lambda (c s)
9103 (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
9104 (type-of c) (error-operation c) (error-component c)))))
9105 (define-condition compile-error (operation-error) ())
9106 (define-condition compile-failed (compile-error) ())
9107 (define-condition compile-warned (compile-error) ())
9109 (defun component-load-dependencies (component)
9110 ;; Old deprecated name for the same thing. Please update your software.
9111 (component-sideway-dependencies component))
9113 (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
9114 (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
9116 (defgeneric operation-on-warnings (operation))
9117 (defgeneric operation-on-failure (operation))
9118 #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
9119 #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
9120 (defmethod operation-on-warnings ((o operation))
9121 (declare (ignorable o)) *compile-file-warnings-behaviour*)
9122 (defmethod operation-on-failure ((o operation))
9123 (declare (ignorable o)) *compile-file-failure-behaviour*)
9124 (defmethod (setf operation-on-warnings) (x (o operation))
9125 (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
9126 (defmethod (setf operation-on-failure) (x (o operation))
9127 (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
9129 (defun system-definition-pathname (x)
9130 ;; As of 2.014.8, we mean to make this function obsolete,
9131 ;; but that won't happen until all clients have been updated.
9132 ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
9133 "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
9134 It used to expose ASDF internals with subtle differences with respect to
9135 user expectations, that have been refactored away since.
9136 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
9137 for a mostly compatible replacement that we're supporting,
9138 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
9139 if that's whay you mean." ;;)
9140 (system-source-file x))
9142 (defgeneric* (traverse) (operation component &key &allow-other-keys)
9144 "Generate and return a plan for performing OPERATION on COMPONENT.
9146 The plan returned is a list of dotted-pairs. Each pair is the CONS
9147 of ASDF operation object and a COMPONENT object. The pairs will be
9148 processed in order by OPERATE."))
9149 (define-convenience-action-methods traverse (operation component &key))
9151 (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
9152 (plan-actions (apply 'make-plan plan-class o c keys))))
9155 ;;;; ASDF-Binary-Locations compatibility
9156 ;; This remains supported for legacy user, but not recommended for new users.
9157 (with-upgradability ()
9158 (defun enable-asdf-binary-locations-compatibility
9160 (centralize-lisp-binaries nil)
9161 (default-toplevel-directory
9162 (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
9163 (include-per-user-information nil)
9164 (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
9165 (source-to-target-mappings nil)
9166 (file-types `(,(compile-file-type)
9168 #+ecl (compile-file-type :type :object)
9169 #+mkcl (compile-file-type :fasl-p nil)
9170 #+clisp "lib" #+sbcl "cfasl"
9171 #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
9172 #+(or clisp ecl mkcl)
9173 (when (null map-all-source-files)
9174 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
9175 (let* ((patterns (if map-all-source-files (list *wild-file*)
9176 (loop :for type :in file-types
9177 :collect (make-pathname :type type :defaults *wild-file*))))
9178 (destination-directory
9179 (if centralize-lisp-binaries
9180 `(,default-toplevel-directory
9181 ,@(when include-per-user-information
9182 (cdr (pathname-directory (user-homedir-pathname))))
9183 :implementation ,*wild-inferiors*)
9184 `(:root ,*wild-inferiors* :implementation))))
9185 (initialize-output-translations
9186 `(:output-translations
9187 ,@source-to-target-mappings
9188 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
9189 #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
9190 ,@(loop :for pattern :in patterns
9191 :collect `((:root ,*wild-inferiors* ,pattern)
9192 (,@destination-directory ,pattern)))
9194 :ignore-inherited-configuration))))
9196 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
9197 (declare (ignorable operation-class system args))
9198 (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
9199 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
9200 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
9201 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
9202 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
9203 In case you insist on preserving your previous A-B-L configuration, but
9204 do not know how to achieve the same effect with A-O-T, you may use function
9205 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
9206 call that function where you would otherwise have loaded and configured A-B-L."))))
9209 ;;; run-shell-command
9210 ;; WARNING! The function below is not just deprecated but also dysfunctional.
9211 ;; Please use asdf/run-program:run-program instead.
9212 (with-upgradability ()
9213 (defun run-shell-command (control-string &rest args)
9214 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
9215 synchronously execute the result using a Bourne-compatible shell, with
9216 output to *VERBOSE-OUT*. Returns the shell's exit code.
9219 Deprecated function, for backward-compatibility only.
9220 Please use UIOP:RUN-PROGRAM instead."
9221 (let ((command (apply 'format nil control-string args)))
9222 (asdf-message "; $ ~A~%" command)
9225 (run-program command :force-shell t :ignore-error-status nil :output *verbose-out*)
9227 (subprocess-error (c)
9228 (let ((code (subprocess-error-code c)))
9233 (with-upgradability ()
9234 (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
9236 ;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
9237 (with-upgradability ()
9238 (defgeneric component-property (component property))
9239 (defgeneric (setf component-property) (new-value component property))
9241 (defmethod component-property ((c component) property)
9242 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
9244 (defmethod (setf component-property) (new-value (c component) property)
9245 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
9247 (setf (cdr a) new-value)
9248 (setf (slot-value c 'properties)
9249 (acons property new-value (slot-value c 'properties)))))
9251 ;;;; -----------------------------------------------------------------
9252 ;;;; Source Registry Configuration, by Francois-Rene Rideau
9253 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
9255 (asdf/package:define-package :asdf/source-registry
9256 (:recycle :asdf/source-registry :asdf)
9257 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
9259 #:*source-registry-parameter* #:*default-source-registries*
9260 #:invalid-source-registry
9261 #:source-registry-initialized-p
9262 #:initialize-source-registry #:clear-source-registry #:*source-registry*
9263 #:ensure-source-registry #:*source-registry-parameter*
9264 #:*default-source-registry-exclusions* #:*source-registry-exclusions*
9265 #:*wild-asd* #:directory-asd-files #:register-asd-directory
9266 #:collect-asds-in-directory #:collect-sub*directories-asd-files
9267 #:validate-source-registry-directive #:validate-source-registry-form
9268 #:validate-source-registry-file #:validate-source-registry-directory
9269 #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
9270 #:user-source-registry #:system-source-registry
9271 #:user-source-registry-directory #:system-source-registry-directory
9272 #:environment-source-registry #:process-source-registry
9273 #:compute-source-registry #:flatten-source-registry
9274 #:sysdef-source-registry-search))
9275 (in-package :asdf/source-registry)
9277 (with-upgradability ()
9278 (define-condition invalid-source-registry (invalid-configuration warning)
9279 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
9281 ;; Using ack 1.2 exclusions
9282 (defvar *default-source-registry-exclusions*
9284 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
9285 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
9286 "_sgbak" "autom4te.cache" "cover_db" "_build"
9287 "debian")) ;; debian often builds stuff under the debian directory... BAD.
9289 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
9291 (defvar *source-registry* nil
9292 "Either NIL (for uninitialized), or an equal hash-table, mapping
9293 system names to pathnames of .asd files")
9295 (defun source-registry-initialized-p ()
9296 (typep *source-registry* 'hash-table))
9298 (defun clear-source-registry ()
9299 "Undoes any initialization of the source registry."
9300 (setf *source-registry* nil)
9302 (register-clear-configuration-hook 'clear-source-registry)
9304 (defparameter *wild-asd*
9305 (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
9307 (defun directory-asd-files (directory)
9308 (directory-files directory *wild-asd*))
9310 (defun collect-asds-in-directory (directory collect)
9311 (map () collect (directory-asd-files directory)))
9313 (defun collect-sub*directories-asd-files
9314 (directory &key (exclude *default-source-registry-exclusions*) collect)
9315 (collect-sub*directories
9318 #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
9319 #'(lambda (dir) (collect-asds-in-directory dir collect))))
9321 (defun validate-source-registry-directive (directive)
9322 (or (member directive '(:default-registry))
9323 (and (consp directive)
9324 (let ((rest (rest directive)))
9325 (case (first directive)
9326 ((:include :directory :tree)
9327 (and (length=n-p rest 1)
9328 (location-designator-p (first rest))))
9329 ((:exclude :also-exclude)
9330 (every #'stringp rest))
9331 ((:default-registry)
9334 (defun validate-source-registry-form (form &key location)
9335 (validate-configuration-form
9336 form :source-registry 'validate-source-registry-directive
9337 :location location :invalid-form-reporter 'invalid-source-registry))
9339 (defun validate-source-registry-file (file)
9340 (validate-configuration-file
9341 file 'validate-source-registry-form :description "a source registry"))
9343 (defun validate-source-registry-directory (directory)
9344 (validate-configuration-directory
9345 directory :source-registry 'validate-source-registry-directive
9346 :invalid-form-reporter 'invalid-source-registry))
9348 (defun parse-source-registry-string (string &key location)
9350 ((or (null string) (equal string ""))
9351 '(:source-registry :inherit-configuration))
9352 ((not (stringp string))
9353 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
9354 ((find (char string 0) "\"(")
9355 (validate-source-registry-form (read-from-string string) :location location))
9359 :with directives = ()
9361 :with end = (length string)
9362 :with separator = (inter-directory-separator)
9363 :for pos = (position separator string :start start) :do
9364 (let ((s (subseq string start (or pos end))))
9366 (unless (absolute-pathname-p dir)
9367 (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
9370 ((equal "" s) ; empty element: inherit
9372 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
9375 (push ':inherit-configuration directives))
9376 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
9377 (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
9379 (push `(:directory ,(check s)) directives))))
9382 (setf start (1+ pos)))
9385 (push '(:ignore-inherited-configuration) directives))
9386 (return `(:source-registry ,@(nreverse directives))))))))))
9388 (defun register-asd-directory (directory &key recurse exclude collect)
9390 (collect-asds-in-directory directory collect)
9391 (collect-sub*directories-asd-files
9392 directory :exclude exclude :collect collect)))
9394 (defparameter *default-source-registries*
9395 '(environment-source-registry
9396 user-source-registry
9397 user-source-registry-directory
9398 system-source-registry
9399 system-source-registry-directory
9400 default-source-registry))
9402 (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
9403 (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
9405 (defun wrapping-source-registry ()
9407 #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
9408 #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
9409 :inherit-configuration
9410 #+cmu (:tree #p"modules:")
9411 #+scl (:tree #p"file://modules/")))
9412 (defun default-source-registry ()
9414 #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
9415 ,@(loop :for dir :in
9416 `(,@(when (os-unix-p)
9417 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
9418 (subpathname (user-homedir-pathname) ".local/share/"))
9419 ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
9420 '("/usr/local/share" "/usr/share"))))
9421 ,@(when (os-windows-p)
9422 (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
9423 :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
9424 :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
9425 :inherit-configuration))
9426 (defun user-source-registry (&key (direction :input))
9427 (in-user-configuration-directory *source-registry-file* :direction direction))
9428 (defun system-source-registry (&key (direction :input))
9429 (in-system-configuration-directory *source-registry-file* :direction direction))
9430 (defun user-source-registry-directory (&key (direction :input))
9431 (in-user-configuration-directory *source-registry-directory* :direction direction))
9432 (defun system-source-registry-directory (&key (direction :input))
9433 (in-system-configuration-directory *source-registry-directory* :direction direction))
9434 (defun environment-source-registry ()
9435 (getenv "CL_SOURCE_REGISTRY"))
9437 (defgeneric* (process-source-registry) (spec &key inherit register))
9439 (defun* (inherit-source-registry) (inherit &key register)
9441 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
9443 (defun* (process-source-registry-directive) (directive &key inherit register)
9444 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
9447 (destructuring-bind (pathname) rest
9448 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
9450 (destructuring-bind (pathname) rest
9452 (funcall register (resolve-location pathname :ensure-directory t)))))
9454 (destructuring-bind (pathname) rest
9456 (funcall register (resolve-location pathname :ensure-directory t)
9457 :recurse t :exclude *source-registry-exclusions*))))
9459 (setf *source-registry-exclusions* rest))
9461 (appendf *source-registry-exclusions* rest))
9462 ((:default-registry)
9463 (inherit-source-registry '(default-source-registry) :register register))
9464 ((:inherit-configuration)
9465 (inherit-source-registry inherit :register register))
9466 ((:ignore-inherited-configuration)
9470 (defmethod process-source-registry ((x symbol) &key inherit register)
9471 (process-source-registry (funcall x) :inherit inherit :register register))
9472 (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
9474 ((directory-pathname-p pathname)
9475 (let ((*here-directory* (resolve-symlinks* pathname)))
9476 (process-source-registry (validate-source-registry-directory pathname)
9477 :inherit inherit :register register)))
9478 ((probe-file* pathname :truename *resolve-symlinks*)
9479 (let ((*here-directory* (pathname-directory-pathname pathname)))
9480 (process-source-registry (validate-source-registry-file pathname)
9481 :inherit inherit :register register)))
9483 (inherit-source-registry inherit :register register))))
9484 (defmethod process-source-registry ((string string) &key inherit register)
9485 (process-source-registry (parse-source-registry-string string)
9486 :inherit inherit :register register))
9487 (defmethod process-source-registry ((x null) &key inherit register)
9488 (declare (ignorable x))
9489 (inherit-source-registry inherit :register register))
9490 (defmethod process-source-registry ((form cons) &key inherit register)
9491 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
9492 (dolist (directive (cdr (validate-source-registry-form form)))
9493 (process-source-registry-directive directive :inherit inherit :register register))))
9495 (defun flatten-source-registry (&optional parameter)
9497 (while-collecting (collect)
9498 (with-pathname-defaults () ;; be location-independent
9499 (inherit-source-registry
9500 `(wrapping-source-registry
9502 ,@*default-source-registries*)
9503 :register #'(lambda (directory &key recurse exclude)
9504 (collect (list directory :recurse recurse :exclude exclude))))))
9505 :test 'equal :from-end t))
9507 ;; Will read the configuration and initialize all internal variables.
9508 (defun compute-source-registry (&optional parameter (registry *source-registry*))
9509 (dolist (entry (flatten-source-registry parameter))
9510 (destructuring-bind (directory &key recurse exclude) entry
9511 (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
9512 (register-asd-directory
9513 directory :recurse recurse :exclude exclude :collect
9515 (let* ((name (pathname-name asd))
9516 (name (if (typep asd 'logical-pathname)
9517 ;; logical pathnames are upper-case,
9518 ;; at least in the CLHS and on SBCL,
9519 ;; yet (coerce-name :foo) is lower-case.
9520 ;; won't work well with (load-system "Foo")
9521 ;; instead of (load-system 'foo)
9522 (string-downcase name)
9525 ((gethash name registry) ; already shadowed by something else
9527 ((gethash name h) ; conflict at current level
9529 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
9530 found several entries for ~A - picking ~S over ~S~:>")
9531 directory recurse name (gethash name h) asd)))
9533 (setf (gethash name registry) asd)
9534 (setf (gethash name h) asd))))))
9538 (defvar *source-registry-parameter* nil)
9540 (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
9541 ;; Record the parameter used to configure the registry
9542 (setf *source-registry-parameter* parameter)
9543 ;; Clear the previous registry database:
9544 (setf *source-registry* (make-hash-table :test 'equal))
9546 (compute-source-registry parameter))
9548 ;; Checks an initial variable to see whether the state is initialized
9549 ;; or cleared. In the former case, return current configuration; in
9550 ;; the latter, initialize. ASDF will call this function at the start
9551 ;; of (asdf:find-system) to make sure the source registry is initialized.
9552 ;; However, it will do so *without* a parameter, at which point it
9553 ;; will be too late to provide a parameter to this function, though
9554 ;; you may override the configuration explicitly by calling
9555 ;; initialize-source-registry directly with your parameter.
9556 (defun ensure-source-registry (&optional parameter)
9557 (unless (source-registry-initialized-p)
9558 (initialize-source-registry parameter))
9561 (defun sysdef-source-registry-search (system)
9562 (ensure-source-registry)
9563 (values (gethash (primary-system-name system) *source-registry*))))
9566 ;;;; ---------------------------------------------------------------------------
9567 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
9569 (asdf/package:define-package :asdf/interface
9570 (:nicknames :asdf :asdf-utilities)
9571 (:recycle :asdf/interface :asdf)
9573 #:*asdf-revision* #:around #:asdf-method-combination
9574 #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
9575 #:split #:make-collector
9576 #:loaded-systems ; makes for annoying SLIME completion
9577 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
9578 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache
9579 :asdf/component :asdf/system :asdf/find-system :asdf/find-component
9580 :asdf/operation :asdf/action :asdf/lisp-action
9581 :asdf/output-translations :asdf/source-registry
9582 :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source
9583 :asdf/backward-internals :asdf/backward-interface)
9584 ;; TODO: automatically generate interface with reexport?
9586 #:defsystem #:find-system #:locate-system #:coerce-name
9587 #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
9588 #:system-definition-pathname #:with-system-definitions
9589 #:search-for-system-definition #:find-component #:component-find-path
9590 #:compile-system #:load-system #:load-systems
9591 #:require-system #:test-system #:clear-system
9592 #:operation #:make-operation #:find-operation
9593 #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
9594 #:build-system #:build-op
9595 #:load-op #:prepare-op #:compile-op
9596 #:prepare-source-op #:load-source-op #:test-op
9597 #:feature #:version #:version-satisfies #:upgrade-asdf
9598 #:implementation-identifier #:implementation-type #:hostname
9599 #:input-files #:output-files #:output-file #:perform
9600 #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
9602 ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
9603 #:component-load-dependencies #:run-shell-command ; deprecated, do not use
9604 #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
9606 #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
9607 #:lib-op #:dll-op #:binary-op #:program-op
9608 #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
9609 #:concatenate-source-op
9610 #:load-concatenated-source-op
9611 #:compile-concatenated-source-op
9612 #:load-compiled-concatenated-source-op
9613 #:monolithic-concatenate-source-op
9614 #:monolithic-load-concatenated-source-op
9615 #:monolithic-compile-concatenated-source-op
9616 #:monolithic-load-compiled-concatenated-source-op
9617 #:operation-monolithic-p
9618 #:required-components
9619 #:component-loaded-p
9621 #:component #:parent-component #:child-component #:system #:module
9622 #:file-component #:source-file #:c-source-file #:java-source-file
9623 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
9624 #:static-file #:doc-file #:html-file
9628 #:component-children ; component accessors
9629 #:component-children-by-name
9630 #:component-pathname
9631 #:component-relative-pathname
9636 #:component-encoding
9637 #:component-external-format
9639 #:component-depends-on ; backward-compatible name rather than action-depends-on
9640 #:module-components ; backward-compatibility
9641 #:operation-on-warnings #:operation-on-failure ; backward-compatibility
9642 #:component-property ; backward-compatibility
9643 #:traverse ; backward-compatibility
9645 #:system-description
9646 #:system-long-description
9651 #:system-source-file
9652 #:system-source-directory
9653 #:system-relative-pathname
9656 #:system-bug-tracker
9658 #:system-source-control
9661 #:*system-definition-search-functions* ; variables
9662 #:*central-registry*
9663 #:*compile-file-warnings-behaviour*
9664 #:*compile-file-failure-behaviour*
9665 #:*resolve-symlinks*
9666 #:*load-system-operation*
9667 #:*asdf-verbose* ;; unused. For backward-compatibility only.
9672 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
9673 #:compile-warned-warning #:compile-failed-warning
9674 #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility
9677 #:load-system-definition-error
9678 #:error-component #:error-operation
9679 #:system-definition-error
9681 #:missing-component-of-version
9682 #:missing-dependency
9683 #:missing-dependency-of-version
9684 #:circular-dependency ; errors
9685 #:duplicate-names #:non-toplevel-system #:non-system-system
9690 #:coerce-entry-to-directory
9691 #:remove-entry-from-registry
9693 #:*encoding-detection-hook*
9694 #:*encoding-external-format-hook*
9695 #:*default-encoding*
9696 #:*utf-8-external-format*
9698 #:clear-configuration
9699 #:*output-translations-parameter*
9700 #:initialize-output-translations
9701 #:disable-output-translations
9702 #:clear-output-translations
9703 #:ensure-output-translations
9704 #:apply-output-translations
9706 #:compile-file-pathname*
9707 #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
9708 #:enable-asdf-binary-locations-compatibility
9709 #:*default-source-registries*
9710 #:*source-registry-parameter*
9711 #:initialize-source-registry
9712 #:compute-source-registry
9713 #:clear-source-registry
9714 #:ensure-source-registry
9715 #:process-source-registry
9716 #:system-registered-p #:registered-systems #:already-loaded-systems
9720 #:user-output-translations-pathname
9721 #:system-output-translations-pathname
9722 #:user-output-translations-directory-pathname
9723 #:system-output-translations-directory-pathname
9724 #:user-source-registry
9725 #:system-source-registry
9726 #:user-source-registry-directory
9727 #:system-source-registry-directory))
9729 ;;;; ---------------------------------------------------------------------------
9730 ;;;; ASDF-USER, where the action happens.
9732 (asdf/package:define-package :asdf/user
9733 (:nicknames :asdf-user)
9734 (:use :asdf/common-lisp :asdf/package :asdf/interface))
9735 ;;;; -----------------------------------------------------------------------
9736 ;;;; ASDF Footer: last words and cleanup
9738 (asdf/package:define-package :asdf/footer
9739 (:recycle :asdf/footer :asdf)
9740 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
9741 :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action
9742 :asdf/operate :asdf/bundle :asdf/concatenate-source
9743 :asdf/output-translations :asdf/source-registry
9744 :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
9745 (in-package :asdf/footer)
9747 ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
9749 (with-upgradability ()
9750 #+(or abcl clisp clozure cmu ecl mkcl sbcl)
9751 (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
9752 (eval `(pushnew 'module-provide-asdf
9753 #+abcl sys::*module-provider-functions*
9755 #+clozure ccl:*module-provider-functions*
9756 #+(or cmu ecl) ext:*module-provider-functions*
9757 #+mkcl mk-ext:*module-provider-functions*
9758 #+sbcl sb-ext:*module-provider-functions*)))
9762 (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
9764 #+(or (and ecl win32) (and mkcl windows))
9765 (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
9766 (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
9768 (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
9769 (loop :for f :in #+ecl ext:*module-provider-functions*
9770 #+mkcl mk-ext::*module-provider-functions*
9772 (if (eq f 'module-provide-asdf) f
9774 (let ((l (multiple-value-list (funcall f name))))
9775 (and (first l) (register-pre-built-system (coerce-name name)))
9776 (values-list l))))))))
9779 (with-upgradability ()
9780 (defun herald-asdf (stream)
9781 (format stream " ASDF ~A" (asdf-version)))
9782 (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
9786 (with-upgradability ()
9788 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
9789 (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))
9791 (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*))
9795 (cleanup-upgraded-asdf))
9797 (when *load-verbose*
9798 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
projects / sbcl.git / blob