1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
2 ;;; This is ASDF 2.29: 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 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 (< existing-version-number
74 #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 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
84 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
85 ;; asdf/package will be frozen as of ASDF 3
86 ;; to forever export the same exact symbols.
87 ;; Any other symbol must be import-from'ed
88 ;; and reexported in a different package
89 ;; (alternatively the package may be dropped & replaced by one with a new name).
91 (defpackage :asdf/package
94 #:find-package* #:find-symbol* #:symbol-call
95 #:intern* #:unintern* #:export* #:make-symbol*
96 #:symbol-shadowing-p #:home-package-p #:rehome-symbol
97 #:symbol-package-name #:standard-common-lisp-symbol-p
98 #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
99 #:nuke-symbol-in-package #:nuke-symbol
100 #:ensure-package-unused #:delete-package*
101 #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
102 #:package-definition-form #:parse-define-package-form
103 #:ensure-package #:define-package))
105 (in-package :asdf/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 make-symbol* (name)
144 (string (make-symbol name))
145 (symbol (copy-symbol name))))
146 (defun unintern* (name package-designator &optional (error t))
148 (let ((package (find-package* package-designator error)))
150 (multiple-value-bind (symbol status) (find-symbol* name package error)
152 (status (unintern symbol package)
153 (return (values symbol status)))
154 (error (error "symbol ~A not present in package ~A"
155 (string symbol) (package-name package))))))
157 (defun symbol-shadowing-p (symbol package)
158 (and (member symbol (package-shadowing-symbols package)) t))
159 (defun home-package-p (symbol package)
160 (and package (let ((sp (symbol-package symbol)))
161 (and sp (let ((pp (find-package* package)))
162 (and pp (eq sp pp))))))))
165 (eval-when (:load-toplevel :compile-toplevel :execute)
166 (defun symbol-package-name (symbol)
167 (let ((package (symbol-package symbol)))
168 (and package (package-name package))))
169 (defun standard-common-lisp-symbol-p (symbol)
170 (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
171 (and (eq sym symbol) (eq status :external))))
172 (defun reify-package (package &optional package-context)
173 (if (eq package package-context) t
176 ((eql (find-package :cl)) :cl)
177 (package (package-name package)))))
178 (defun unreify-package (package &optional package-context)
181 ((eql t) package-context)
182 ((or symbol string) (find-package package))))
183 (defun reify-symbol (symbol &optional package-context)
185 ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
186 (symbol (vector (symbol-name symbol)
187 (reify-package (symbol-package symbol) package-context)))))
188 (defun unreify-symbol (symbol &optional package-context)
192 (let* ((symbol-name (svref symbol 0))
193 (package-foo (svref symbol 1))
194 (package (unreify-package package-foo package-context)))
195 (if package (intern* symbol-name package)
196 (make-symbol* symbol-name)))))))
198 (eval-when (:load-toplevel :compile-toplevel :execute)
199 (defvar *all-package-happiness* '())
200 (defvar *all-package-fishiness* (list t))
201 (defun record-fishy (info)
202 ;;(format t "~&FISHY: ~S~%" info)
203 (push info *all-package-fishiness*))
204 (defmacro when-package-fishiness (&body body)
205 `(when *all-package-fishiness* ,@body))
206 (defmacro note-package-fishiness (&rest info)
207 `(when-package-fishiness (record-fishy (list ,@info)))))
209 (eval-when (:load-toplevel :compile-toplevel :execute)
211 (defun get-setf-function-symbol (symbol)
212 #+clisp (let ((sym (get symbol 'system::setf-function)))
213 (if sym (values sym :setf-function)
214 (let ((sym (get symbol 'system::setf-expander)))
215 (if sym (values sym :setf-expander)
217 #+clozure (gethash symbol ccl::%setf-function-names%))
219 (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
220 #+clisp (assert (member kind '(:setf-function :setf-expander)))
221 #+clozure (assert (eq kind t))
224 ((null new-setf-symbol)
225 (remprop symbol 'system::setf-function)
226 (remprop symbol 'system::setf-expander))
227 ((eq kind :setf-function)
228 (setf (get symbol 'system::setf-function) new-setf-symbol))
229 ((eq kind :setf-expander)
230 (setf (get symbol 'system::setf-expander) new-setf-symbol))
231 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
232 kind symbol new-setf-symbol)))
235 (gethash symbol ccl::%setf-function-names%) new-setf-symbol
236 (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
238 (defun create-setf-function-symbol (symbol)
239 #+clisp (system::setf-symbol symbol)
240 #+clozure (ccl::construct-setf-function-name symbol))
241 (defun set-dummy-symbol (symbol reason other-symbol)
242 (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
243 (defun make-dummy-symbol (symbol)
244 (let ((dummy (copy-symbol symbol)))
245 (set-dummy-symbol dummy 'replacing symbol)
246 (set-dummy-symbol symbol 'replaced-by dummy)
248 (defun dummy-symbol (symbol)
249 (get symbol 'dummy-symbol))
250 (defun get-dummy-symbol (symbol)
251 (let ((existing (dummy-symbol symbol)))
252 (if existing (values (cdr existing) (car existing))
253 (make-dummy-symbol symbol))))
254 (defun nuke-symbol-in-package (symbol package-designator)
255 (let ((package (find-package* package-designator))
256 (name (symbol-name symbol)))
257 (multiple-value-bind (sym stat) (find-symbol name package)
258 (when (and (member stat '(:internal :external)) (eq symbol sym))
259 (if (symbol-shadowing-p symbol package)
260 (shadowing-import (get-dummy-symbol symbol) package)
261 (unintern symbol package))))))
262 (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
264 (multiple-value-bind (setf-symbol kind)
265 (get-setf-function-symbol symbol)
266 (when kind (nuke-symbol setf-symbol)))
267 (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
268 (defun rehome-symbol (symbol package-designator)
269 "Changes the home package of a symbol, also leaving it present in its old home if any"
270 (let* ((name (symbol-name symbol))
271 (package (find-package* package-designator))
272 (old-package (symbol-package symbol))
273 (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
274 (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
275 (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
276 (unless (eq package old-package)
277 (let ((overwritten-symbol-shadowing-p
278 (and overwritten-symbol-status
279 (symbol-shadowing-p overwritten-symbol package))))
280 (note-package-fishiness
282 (when old-package (package-name old-package)) old-status (and shadowing t)
283 (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
286 (shadowing-import shadowing old-package))
287 (unintern symbol old-package))
289 (overwritten-symbol-shadowing-p
290 (shadowing-import symbol package))
292 (when overwritten-symbol-status
293 (unintern overwritten-symbol package))
294 (import symbol package)))
296 (shadowing-import symbol old-package)
297 (import symbol old-package))
299 (multiple-value-bind (setf-symbol kind)
300 (get-setf-function-symbol symbol)
302 (let* ((setf-function (fdefinition setf-symbol))
303 (new-setf-symbol (create-setf-function-symbol symbol)))
304 (note-package-fishiness
306 name (package-name package)
307 (symbol-name setf-symbol) (symbol-package-name setf-symbol)
308 (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
309 (when (symbol-package setf-symbol)
310 (unintern setf-symbol (symbol-package setf-symbol)))
311 (setf (fdefinition new-setf-symbol) setf-function)
312 (set-setf-function-symbol new-setf-symbol symbol kind))))
314 (multiple-value-bind (overwritten-setf foundp)
315 (get-setf-function-symbol overwritten-symbol)
317 (unintern overwritten-setf)))
318 (when (eq old-status :external)
319 (export* symbol old-package))
320 (when (eq overwritten-symbol-status :external)
321 (export* symbol package))))
322 (values overwritten-symbol overwritten-symbol-status))))
323 (defun ensure-package-unused (package)
324 (loop :for p :in (package-used-by-list package) :do
325 (unuse-package package p)))
326 (defun delete-package* (package &key nuke)
327 (let ((p (find-package package)))
329 (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
330 (ensure-package-unused p)
331 (delete-package package))))
332 (defun package-names (package)
333 (cons (package-name package) (package-nicknames package)))
334 (defun packages-from-names (names)
335 (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
336 (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
338 (index (random most-positive-fixnum)))
339 (loop :for i :from index
340 :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
341 :thereis (and (not (find-package n)) n)))
342 (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
344 (apply 'fresh-package-name
345 :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
346 (record-fishy (list :rename-away (package-names p) new-name))
347 (rename-package p new-name))))
350 ;;; Communicable representation of symbol and package information
352 (eval-when (:load-toplevel :compile-toplevel :execute)
353 (defun package-definition-form (package-designator
354 &key (nicknamesp t) (usep t)
355 (shadowp t) (shadowing-import-p t)
356 (exportp t) (importp t) internp (error t))
357 (let* ((package (or (find-package* package-designator error)
358 (return-from package-definition-form nil)))
359 (name (package-name package))
360 (nicknames (package-nicknames package))
361 (use (mapcar #'package-name (package-use-list package)))
363 (shadowing-import (make-hash-table :test 'equal))
364 (import (make-hash-table :test 'equal))
368 (loop :for sym :being :the :symbols :in package
369 :for status = (nth-value 1 (find-symbol* sym package)) :do
372 ((:internal :external)
373 (let* ((name (symbol-name sym))
374 (external (eq status :external))
375 (home (symbol-package sym))
376 (home-name (package-name home))
377 (imported (not (eq home package)))
378 (shadowing (symbol-shadowing-p sym package)))
380 ((and shadowing imported)
381 (push name (gethash home-name shadowing-import)))
385 (push name (gethash home-name import))))
390 (t (push name intern)))))))
391 (labels ((sort-names (names)
392 (sort names #'string<))
394 (loop :for k :being :the :hash-keys :of table :collect k))
395 (when-relevant (key value)
396 (when value (list (cons key value))))
397 (import-options (key table)
398 (loop :for i :in (sort-names (table-keys table))
399 :collect `(,key ,i ,@(sort-names (gethash i table))))))
401 ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
402 (:use ,@(and usep (sort-names use)))
403 ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
404 ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
405 ,@(import-options :import-from (and importp import))
406 ,@(when-relevant :export (and exportp (sort-names export)))
407 ,@(when-relevant :intern (and internp (sort-names intern)))))))))
410 ;;; ensure-package, define-package
411 (eval-when (:load-toplevel :compile-toplevel :execute)
412 (defun ensure-shadowing-import (name to-package from-package shadowed imported)
413 (check-type name string)
414 (check-type to-package package)
415 (check-type from-package package)
416 (check-type shadowed hash-table)
417 (check-type imported hash-table)
418 (let ((import-me (find-symbol* name from-package)))
419 (multiple-value-bind (existing status) (find-symbol name to-package)
421 ((gethash name shadowed)
422 (unless (eq import-me existing)
423 (error "Conflicting shadowings for ~A" name)))
425 (setf (gethash name shadowed) t)
426 (setf (gethash name imported) t)
427 (unless (or (null status)
428 (and (member status '(:internal :external))
429 (eq existing import-me)
430 (symbol-shadowing-p existing to-package)))
431 (note-package-fishiness
432 :shadowing-import name
433 (package-name from-package)
434 (or (home-package-p import-me from-package) (symbol-package-name import-me))
435 (package-name to-package) status
436 (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
437 (shadowing-import import-me to-package))))))
438 (defun ensure-import (name to-package from-package shadowed imported)
439 (check-type name string)
440 (check-type to-package package)
441 (check-type from-package package)
442 (check-type shadowed hash-table)
443 (check-type imported hash-table)
444 (multiple-value-bind (import-me import-status) (find-symbol name from-package)
445 (when (null import-status)
446 (note-package-fishiness
447 :import-uninterned name (package-name from-package) (package-name to-package))
448 (setf import-me (intern name from-package)))
449 (multiple-value-bind (existing status) (find-symbol name to-package)
451 ((gethash name imported)
452 (unless (eq import-me existing)
453 (error "Can't import ~S from both ~S and ~S"
454 name (package-name (symbol-package existing)) (package-name from-package))))
455 ((gethash name shadowed)
456 (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
458 (setf (gethash name imported) t)
459 (unless (and status (eq import-me existing))
461 (note-package-fishiness
463 (package-name from-package)
464 (or (home-package-p import-me from-package) (symbol-package-name import-me))
465 (package-name to-package) status
466 (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
467 (unintern* existing to-package))
468 (import import-me to-package)))))))
469 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
470 (check-type name string)
471 (check-type symbol symbol)
472 (check-type to-package package)
473 (check-type from-package package)
474 (check-type mixp (member nil t)) ; no cl:boolean on Genera
475 (check-type shadowed hash-table)
476 (check-type imported hash-table)
477 (check-type inherited hash-table)
478 (multiple-value-bind (existing status) (find-symbol name to-package)
479 (let* ((sp (symbol-package symbol))
480 (in (gethash name inherited))
481 (xp (and status (symbol-package existing))))
483 (note-package-fishiness
484 :import-uninterned name
485 (package-name from-package) (package-name to-package) mixp)
486 (import symbol from-package)
487 (setf sp (package-name from-package)))
489 ((gethash name shadowed))
491 (unless (equal sp (first in))
493 (ensure-shadowing-import name to-package (second in) shadowed imported)
494 (error "Can't inherit ~S from ~S, it is inherited from ~S"
495 name (package-name sp) (package-name (first in))))))
496 ((gethash name imported)
497 (unless (eq symbol existing)
498 (error "Can't inherit ~S from ~S, it is imported from ~S"
499 name (package-name sp) (package-name xp))))
501 (setf (gethash name inherited) (list sp from-package))
502 (when (and status (not (eq sp xp)))
503 (let ((shadowing (symbol-shadowing-p existing to-package)))
504 (note-package-fishiness
506 (package-name from-package)
507 (or (home-package-p symbol from-package) (symbol-package-name symbol))
508 (package-name to-package)
509 (or (home-package-p existing to-package) (symbol-package-name existing)))
510 (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
511 (unintern* existing to-package)))))))))
512 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
513 (check-type name string)
514 (check-type symbol symbol)
515 (check-type to-package package)
516 (check-type from-package package)
517 (check-type shadowed hash-table)
518 (check-type imported hash-table)
519 (check-type inherited hash-table)
520 (unless (gethash name shadowed)
521 (multiple-value-bind (existing status) (find-symbol name to-package)
522 (let* ((sp (symbol-package symbol))
523 (im (gethash name imported))
524 (in (gethash name inherited)))
527 (and status (eq symbol existing))
528 (and in (eq sp (first in))))
529 (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
531 (remhash name inherited)
532 (ensure-shadowing-import name to-package (second in) shadowed imported))
534 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
535 name (package-name from-package)
536 (home-package-p symbol from-package) (symbol-package-name symbol)
537 (package-name to-package)
538 (home-package-p existing to-package) (symbol-package-name existing)))
540 (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
541 (defun recycle-symbol (name recycle exported)
542 (check-type name string)
543 (check-type recycle list)
544 (check-type exported hash-table)
545 (when (gethash name exported) ;; don't bother recycling private symbols
546 (let (recycled foundp)
547 (dolist (r recycle (values recycled foundp))
548 (multiple-value-bind (symbol status) (find-symbol name r)
549 (when (and status (home-package-p symbol r))
552 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
553 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
555 (setf recycled symbol foundp r)))))))))
556 (defun symbol-recycled-p (sym recycle)
557 (check-type sym symbol)
558 (check-type recycle list)
559 (member (symbol-package sym) recycle))
560 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
561 (check-type name string)
562 (check-type package package)
563 (check-type intern (member nil t)) ; no cl:boolean on Genera
564 (check-type shadowed hash-table)
565 (check-type imported hash-table)
566 (check-type inherited hash-table)
567 (unless (or (gethash name shadowed)
568 (gethash name imported)
569 (gethash name inherited))
570 (multiple-value-bind (existing status)
571 (find-symbol name package)
572 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
574 ((and status (eq existing recycled) (eq previous package)))
576 (rehome-symbol recycled package))
577 ((and status (eq package (symbol-package existing))))
580 (note-package-fishiness
582 (reify-package (symbol-package existing) package)
586 (intern* name package))))))))
587 (declaim (ftype function ensure-exported))
588 (defun ensure-exported-to-user (name symbol to-package &optional recycle)
589 (check-type name string)
590 (check-type symbol symbol)
591 (check-type to-package package)
592 (check-type recycle list)
593 (multiple-value-bind (existing status) (find-symbol name to-package)
594 (unless (and status (eq symbol existing))
597 (let ((shadowing (symbol-shadowing-p existing to-package))
598 (recycled (symbol-recycled-p existing recycle)))
599 (unless (and shadowing (not recycled))
600 (note-package-fishiness
601 :ensure-export name (symbol-package-name symbol)
602 (package-name to-package)
603 (or (home-package-p existing to-package) (symbol-package-name existing))
605 (if (or (eq status :inherited) shadowing)
606 (shadowing-import symbol to-package)
607 (unintern existing to-package))
609 (when (and accessible (eq status :external))
610 (ensure-exported name symbol to-package recycle))))))
611 (defun ensure-exported (name symbol from-package &optional recycle)
612 (dolist (to-package (package-used-by-list from-package))
613 (ensure-exported-to-user name symbol to-package recycle))
614 (import symbol from-package)
615 (export* name from-package))
616 (defun ensure-export (name from-package &optional recycle)
617 (multiple-value-bind (symbol status) (find-symbol* name from-package)
618 (unless (eq status :external)
619 (ensure-exported name symbol from-package recycle))))
620 (defun ensure-package (name &key
621 nicknames documentation use
622 shadow shadowing-import-from
623 import-from export intern
626 #+(or gcl2.6 genera) (declare (ignore documentation))
627 (let* ((package-name (string name))
628 (nicknames (mapcar #'string nicknames))
629 (names (cons package-name nicknames))
630 (previous (packages-from-names names))
631 (discarded (cdr previous))
633 (package (or (first previous) (make-package package-name :nicknames nicknames)))
634 (recycle (packages-from-names recycle))
635 (use (mapcar 'find-package* use))
636 (mix (mapcar 'find-package* mix))
637 (reexport (mapcar 'find-package* reexport))
638 (shadow (mapcar 'string shadow))
639 (export (mapcar 'string export))
640 (intern (mapcar 'string intern))
641 (unintern (mapcar 'string unintern))
642 (shadowed (make-hash-table :test 'equal)) ; string to bool
643 (imported (make-hash-table :test 'equal)) ; string to bool
644 (exported (make-hash-table :test 'equal)) ; string to bool
645 ;; string to list home package and use package:
646 (inherited (make-hash-table :test 'equal)))
647 (when-package-fishiness (record-fishy package-name))
649 (when documentation (setf (documentation package t) documentation))
650 (loop :for p :in (set-difference (package-use-list package) (append mix use))
651 :do (note-package-fishiness :over-use name (package-names p))
652 (unuse-package p package))
653 (loop :for p :in discarded
654 :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
656 :do (note-package-fishiness :nickname name (package-names p))
657 (cond (n (rename-package p (first n) (rest n)))
658 (t (rename-package-away p)
659 (push p to-delete))))
660 (rename-package package package-name nicknames)
661 (dolist (name unintern)
662 (multiple-value-bind (existing status) (find-symbol name package)
664 (unless (eq status :inherited)
665 (note-package-fishiness
666 :unintern (package-name package) name (symbol-package-name existing) status)
667 (unintern* name package nil)))))
668 (dolist (name export)
669 (setf (gethash name exported) t))
671 (do-external-symbols (sym p)
672 (setf (gethash (string sym) exported) t)))
673 (do-external-symbols (sym package)
674 (let ((name (symbol-name sym)))
675 (unless (gethash name exported)
676 (note-package-fishiness
677 :over-export (package-name package) name
678 (or (home-package-p sym package) (symbol-package-name sym)))
679 (unexport sym package))))
680 (dolist (name shadow)
681 (setf (gethash name shadowed) t)
682 (multiple-value-bind (existing status) (find-symbol name package)
683 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
684 (let ((shadowing (and status (symbol-shadowing-p existing package))))
686 ((eq previous package))
688 (rehome-symbol recycled package))
689 ((or (member status '(nil :inherited))
690 (home-package-p existing package)))
692 (let ((dummy (make-symbol name)))
693 (note-package-fishiness
694 :shadow-imported (package-name package) name
695 (symbol-package-name existing) status shadowing)
696 (shadowing-import dummy package)
697 (import dummy package)))))))
698 (shadow name package))
699 (loop :for (p . syms) :in shadowing-import-from
700 :for pp = (find-package* p) :do
701 (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
703 :for pp = (find-package* p) :do
704 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
705 (loop :for (p . syms) :in import-from
706 :for pp = (find-package p) :do
707 (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
708 (dolist (p (append use mix))
709 (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
710 (use-package p package))
711 (loop :for name :being :the :hash-keys :of exported :do
712 (ensure-symbol name package t recycle shadowed imported inherited exported)
713 (ensure-export name package recycle))
714 (dolist (name intern)
715 (ensure-symbol name package t recycle shadowed imported inherited exported))
716 (do-symbols (sym package)
717 (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
718 (map () 'delete-package* to-delete)
721 (eval-when (:load-toplevel :compile-toplevel :execute)
722 (defun parse-define-package-form (package clauses)
724 :with use-p = nil :with recycle-p = nil
725 :with documentation = nil
726 :for (kw . args) :in clauses
727 :when (eq kw :nicknames) :append args :into nicknames :else
728 :when (eq kw :documentation)
730 (documentation (error "define-package: can't define documentation twice"))
731 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
732 (t (setf documentation (car args)))) :else
733 :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
734 :when (eq kw :shadow) :append args :into shadow :else
735 :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
736 :when (eq kw :import-from) :collect args :into import-from :else
737 :when (eq kw :export) :append args :into export :else
738 :when (eq kw :intern) :append args :into intern :else
739 :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
740 :when (eq kw :mix) :append args :into mix :else
741 :when (eq kw :reexport) :append args :into reexport :else
742 :when (eq kw :unintern) :append args :into unintern :else
743 :do (error "unrecognized define-package keyword ~S" kw)
744 :finally (return `(,package
745 :nicknames ,nicknames :documentation ,documentation
746 :use ,(if use-p use '(:common-lisp))
747 :shadow ,shadow :shadowing-import-from ,shadowing-import-from
748 :import-from ,import-from :export ,export :intern ,intern
749 :recycle ,(if recycle-p recycle (cons package nicknames))
750 :mix ,mix :reexport ,reexport :unintern ,unintern)))))
752 (defmacro define-package (package &rest clauses)
754 `(apply 'ensure-package ',(parse-define-package-form package clauses))))
757 (eval-when (:compile-toplevel :load-toplevel :execute)
759 #+(or clisp ecl gcl) (defpackage ,package (:use))
760 (eval-when (:compile-toplevel :load-toplevel :execute)
763 ;;;; Final tricks to keep various implementations happy.
764 ;; We want most such tricks in common-lisp.lisp,
765 ;; but these need to be done before the define-package form there,
766 ;; that we nevertheless want to be the very first form.
767 (eval-when (:load-toplevel :compile-toplevel :execute)
768 #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
769 (setf excl::*autoload-package-name-alist*
770 (remove "asdf" excl::*autoload-package-name-alist*
771 :test 'equalp :key 'car))
773 ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
774 ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
776 ((or (< system::*gcl-major-version* 2)
777 (and (= system::*gcl-major-version* 2)
778 (< system::*gcl-minor-version* 6)))
779 (error "GCL 2.6 or later required to use ASDF"))
780 ((and (= system::*gcl-major-version* 2)
781 (= system::*gcl-minor-version* 6))
782 (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
783 (pushnew :gcl2.6 *features*))
785 (pushnew :gcl2.7 *features*))))
786 ;;;; -------------------------------------------------------------------------
787 ;;;; Handle compatibility with multiple implementations.
788 ;;; This file is for papering over the deficiencies and peculiarities
789 ;;; of various Common Lisp implementations.
790 ;;; For implementation-specific access to the system, see os.lisp instead.
791 ;;; A few functions are defined here, but actually exported from utility;
792 ;;; from this package only common-lisp symbols are exported.
794 (asdf/package:define-package :asdf/common-lisp
795 (:nicknames :asdf/cl)
796 (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
797 (:reexport :common-lisp)
798 (:recycle :asdf/common-lisp :asdf)
799 #+allegro (:intern #:*acl-warn-save*)
800 #+cormanlisp (:shadow #:user-homedir-pathname)
803 #:logical-pathname #:translate-logical-pathname
804 #:make-broadcast-stream #:file-namestring)
805 #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
806 #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
807 #+genera (:shadowing-import-from :scl #:boolean)
808 #+genera (:export #:boolean #:ensure-directories-exist)
809 #+mcl (:shadow #:user-homedir-pathname))
810 (in-package :asdf/common-lisp)
812 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
813 (error "ASDF is not supported on your implementation. Please help us port it.")
815 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
818 ;;;; Early meta-level tweaks
820 #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
821 clozure lispworks (and sbcl sb-unicode) scl)
822 (eval-when (:load-toplevel :compile-toplevel :execute)
823 (pushnew :asdf-unicode *features*))
826 (eval-when (:load-toplevel :compile-toplevel :execute)
827 (defparameter *acl-warn-save*
828 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
829 excl:*warn-on-nested-reader-conditionals*))
830 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
831 (setf excl:*warn-on-nested-reader-conditionals* nil))
832 (setf *print-readably* nil))
835 (eval-when (:load-toplevel :compile-toplevel :execute)
836 (deftype logical-pathname () nil)
837 (defun make-broadcast-stream () *error-output*)
838 (defun translate-logical-pathname (x) x)
839 (defun user-homedir-pathname (&optional host)
840 (declare (ignore host))
841 (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
842 (defun file-namestring (p)
843 (setf p (pathname p))
844 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
847 (eval-when (:load-toplevel :compile-toplevel :execute)
848 (setf *load-verbose* nil)
849 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
850 (unless (use-ecl-byte-compiler-p) (require :cmp)))
852 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
853 (eval-when (:load-toplevel :compile-toplevel :execute)
854 (unless (member :ansi-cl *features*)
855 (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
856 (setf compiler::*compiler-default-type* (pathname "")
857 compiler::*lsp-ext* ""))
860 (eval-when (:compile-toplevel :load-toplevel :execute)
861 (shadow 'type-of :asdf/common-lisp)
862 (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
865 (eval-when (:compile-toplevel :load-toplevel :execute)
866 (export 'type-of :asdf/common-lisp)
867 (export 'system:*load-pathname* :asdf/common-lisp))
869 #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
870 (eval-when (:load-toplevel :compile-toplevel :execute)
872 (deftype logical-pathname () nil)
873 (defun type-of (x) (class-name (class-of x)))
874 (defun wild-pathname-p (path) (declare (ignore path)) nil)
875 (defun translate-logical-pathname (x) x)
876 (defvar *compile-file-pathname* nil)
877 (defun pathname-match-p (in-pathname wild-pathname)
878 (declare (ignore in-wildname wild-wildname)) nil)
879 (defun translate-pathname (source from-wildname to-wildname &key)
880 (declare (ignore from-wildname to-wildname)) source)
881 (defun %print-unreadable-object (object stream type identity thunk)
882 (format stream "#<~@[~S ~]" (when type (type-of object)))
884 (format stream "~@[ ~X~]>" (when identity (system:address object))))
885 (defmacro with-standard-io-syntax (&body body)
887 (defmacro with-compilation-unit (options &body body)
888 (declare (ignore options)) `(progn ,@body))
889 (defmacro print-unreadable-object ((object stream &key type identity) &body body)
890 `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
891 (defun ensure-directories-exist (path)
892 (lisp:system (format nil "mkdir -p ~S"
893 (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
896 (eval-when (:load-toplevel :compile-toplevel :execute)
897 (unless (fboundp 'ensure-directories-exist)
898 (defun ensure-directories-exist (path)
899 (fs:create-directories-recursively (pathname path)))))
901 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
903 "(eval-when (:load-toplevel :compile-toplevel :execute)
904 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
905 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
906 ;; Note: ASDF may expect user-homedir-pathname to provide
907 ;; the pathname of the current user's home directory, whereas
908 ;; MCL by default provides the directory from which MCL was started.
909 ;; See http://code.google.com/p/mcl/wiki/Portability
910 (defun user-homedir-pathname ()
911 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
912 (defun probe-posix (posix-namestring)
913 \"If a file exists for the posix namestring, return the pathname\"
914 (ccl::with-cstrs ((cpath posix-namestring))
915 (ccl::rlet ((is-dir :boolean)
917 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
918 (ccl::%path-from-fsref fsref is-dir))))))"))
921 (eval-when (:load-toplevel :compile-toplevel :execute)
923 (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
927 (eval-when (:load-toplevel :compile-toplevel :execute)
928 (defmacro loop* (&rest rest)
929 #-genera `(loop ,@rest)
930 #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
933 ;;;; compatfmt: avoid fancy format directives when unsupported
934 (eval-when (:load-toplevel :compile-toplevel :execute)
935 (defun remove-substrings (substrings string)
936 (let ((length (length string)) (stream nil))
937 (labels ((emit (start end)
938 (when (and (zerop start) (= end length))
939 (return-from remove-substrings string))
941 (unless stream (setf stream (make-string-output-stream)))
942 (write-string string stream :start start :end end)))
943 (recurse (substrings start end)
946 ((null substrings) (emit start end))
947 (t (let* ((sub (first substrings))
948 (found (search sub string :start2 start :end2 end))
949 (more (rest substrings)))
952 (recurse more start found)
953 (recurse substrings (+ found (length sub)) end))
955 (recurse more start end))))))))
956 (recurse substrings 0 length))
957 (if stream (get-output-stream-string stream) "")))
959 (defmacro compatfmt (format)
961 (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
962 #-(or gcl genera) format))
965 ;;;; -------------------------------------------------------------------------
966 ;;;; General Purpose Utilities for ASDF
968 (asdf/package:define-package :asdf/utility
969 (:recycle :asdf/utility :asdf)
970 (:use :asdf/common-lisp :asdf/package)
971 ;; import and reexport a few things defined in :asdf/common-lisp
972 (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
973 #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
974 (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
975 #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
977 ;; magic helper to define debugging functions:
978 #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
979 #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
980 #:if-let ;; basic flow control
981 #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
982 #:emptyp ;; sequences
983 #:strcat #:first-char #:last-char #:split-string ;; strings
984 #:string-prefix-p #:string-enclosed-p #:string-suffix-p
985 #:find-class* ;; CLOS
986 #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
987 #:earlier-stamp #:stamps-earliest #:earliest-stamp
988 #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
989 #:list-to-hash-set ;; hash-table
990 #:ensure-function #:access-at #:access-at-count ;; functions
991 #:call-function #:call-functions #:register-hook-function
992 #:match-condition-p #:match-any-condition-p ;; conditions
993 #:call-with-muffled-conditions #:with-muffled-conditions
994 #:load-string #:load-stream
995 #:lexicographic< #:lexicographic<=
996 #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
997 (in-package :asdf/utility)
999 ;;;; Defining functions in a way compatible with hot-upgrade:
1000 ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
1001 ;; thus replacing the function without warning or error
1002 ;; even if the signature and/or generic-ness of the function has changed.
1003 ;; For a generic function, this invalidates any previous DEFMETHOD.
1004 (eval-when (:load-toplevel :compile-toplevel :execute)
1005 (defun undefine-function (function-spec)
1007 ((symbolp function-spec)
1009 (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
1010 (when (typep f 'clos:standard-generic-function)
1011 (loop :for m :in (clos:generic-function-methods f)
1012 :do (remove-method f m))))
1013 (fmakunbound function-spec))
1014 ((and (consp function-spec) (eq (car function-spec) 'setf)
1015 (consp (cdr function-spec)) (null (cddr function-spec)))
1016 #-gcl2.6 (fmakunbound function-spec))
1017 (t (error "bad function spec ~S" function-spec))))
1018 (defun undefine-functions (function-spec-list)
1019 (map () 'undefine-function function-spec-list))
1022 `(defmacro ,def* (name formals &rest rest)
1023 (destructuring-bind (name &key (supersede t))
1024 (if (or (atom name) (eq (car name) 'setf))
1025 (list name :supersede nil)
1027 (declare (ignorable supersede))
1029 ;; undefining the previous function is the portable way
1030 ;; of overriding any incompatible previous gf, except on CLISP.
1031 ;; We usually try to do it only for the functions that need it,
1032 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
1033 ;; (which causes issues in clisp)
1034 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
1035 `((undefine-function ',name)))
1036 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
1037 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
1038 `((declaim (notinline ,name))))
1039 (,',def ,name ,formals ,@rest))))))
1040 (defdef defgeneric* defgeneric)
1041 (defdef defun* defun))
1042 (defmacro with-upgradability ((&optional) &body body)
1043 `(eval-when (:compile-toplevel :load-toplevel :execute)
1044 ,@(loop :for form :in body :collect
1046 (destructuring-bind (car . cdr) form
1048 ((defun) `(defun* ,@cdr))
1050 (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
1051 `(defgeneric* ,@cdr)))
1055 ;;; Magic debugging help. See contrib/debug.lisp
1056 (with-upgradability ()
1057 (defvar *asdf-debug-utility*
1059 (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
1060 (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
1061 "form that evaluates to the pathname to your favorite debugging utilities")
1063 (defmacro asdf-debug (&rest keys)
1064 `(eval-when (:compile-toplevel :load-toplevel :execute)
1065 (load-asdf-debug-utility ,@keys)))
1067 (defun load-asdf-debug-utility (&key package utility-file)
1068 (let* ((*package* (if package (find-package package) *package*))
1069 (keyword (read-from-string
1070 (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
1071 (unless (member keyword *features*)
1072 (let* ((utility-file (or utility-file *asdf-debug-utility*))
1073 (file (ignore-errors (probe-file (eval utility-file)))))
1074 (if file (load file)
1075 (error "Failed to locate debug utility file: ~S" utility-file)))))))
1079 (with-upgradability ()
1080 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
1081 ;; bindings can be (var form) or ((var1 form1) ...)
1082 (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
1085 (variables (mapcar #'car binding-list)))
1087 (if (and ,@variables)
1091 ;;; List manipulation
1092 (with-upgradability ()
1093 (defmacro while-collecting ((&rest collectors) &body body)
1094 "COLLECTORS should be a list of names for collections. A collector
1095 defines a function that, when applied to an argument inside BODY, will
1096 add its argument to the corresponding collection. Returns multiple values,
1097 a list for each collection, in order.
1099 \(while-collecting \(foo bar\)
1100 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
1102 \(bar \(second x\)\)\)\)
1103 Returns two values: \(A B C\) and \(1 2 3\)."
1104 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
1105 (initial-values (mapcar (constantly nil) collectors)))
1106 `(let ,(mapcar #'list vars initial-values)
1107 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
1109 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
1111 (define-modify-macro appendf (&rest args)
1112 append "Append onto list") ;; only to be used on short lists.
1114 (defun length=n-p (x n) ;is it that (= (length x) n) ?
1115 (check-type n (integer 0 *))
1117 :for l = x :then (cdr l)
1118 :for i :downfrom n :do
1120 ((zerop i) (return (null l)))
1121 ((not (consp l)) (return nil))))))
1123 ;;; remove a key from a plist, i.e. for keyword argument cleanup
1124 (with-upgradability ()
1125 (defun remove-plist-key (key plist)
1126 "Remove a single key from a plist"
1127 (loop* :for (k v) :on plist :by #'cddr
1129 :append (list k v)))
1131 (defun remove-plist-keys (keys plist)
1132 "Remove a list of keys from a plist"
1133 (loop* :for (k v) :on plist :by #'cddr
1134 :unless (member k keys)
1135 :append (list k v))))
1139 (with-upgradability ()
1141 "Predicate that is true for an empty sequence"
1142 (or (null x) (and (vectorp x) (zerop (length x))))))
1146 (with-upgradability ()
1147 (defun strcat (&rest strings)
1148 (apply 'concatenate 'string strings))
1150 (defun first-char (s)
1151 (and (stringp s) (plusp (length s)) (char s 0)))
1153 (defun last-char (s)
1154 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
1156 (defun split-string (string &key max (separator '(#\Space #\Tab)))
1157 "Split STRING into a list of components separated by
1158 any of the characters in the sequence SEPARATOR.
1159 If MAX is specified, then no more than max(1,MAX) components will be returned,
1160 starting the separation from the end, e.g. when called with arguments
1161 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1163 (let ((list nil) (words 0) (end (length string)))
1164 (flet ((separatorp (char) (find char separator))
1165 (done () (return (cons (subseq string 0 end) list))))
1167 :for start = (if (and max (>= words (1- max)))
1169 (position-if #'separatorp string :end end :from-end t)) :do
1172 (push (subseq string (1+ start) end) list)
1174 (setf end start))))))
1176 (defun string-prefix-p (prefix string)
1177 "Does STRING begin with PREFIX?"
1178 (let* ((x (string prefix))
1182 (and (<= lx ly) (string= x y :end2 lx))))
1184 (defun string-suffix-p (string suffix)
1185 "Does STRING end with SUFFIX?"
1186 (let* ((x (string string))
1190 (and (<= ly lx) (string= x y :start1 (- lx ly)))))
1192 (defun string-enclosed-p (prefix string suffix)
1193 "Does STRING begin with PREFIX and end with SUFFIX?"
1194 (and (string-prefix-p prefix string)
1195 (string-suffix-p string suffix))))
1199 (with-upgradability ()
1200 (defun find-class* (x &optional (errorp t) environment)
1202 ((or standard-class built-in-class) x)
1203 #+gcl2.6 (keyword nil)
1204 (symbol (find-class x errorp environment)))))
1207 ;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
1208 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
1209 (deftype stamp () '(or real boolean)))
1210 (with-upgradability ()
1219 (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
1220 (defun stamp*< (&rest list) (stamps< list))
1221 (defun stamp<= (x y) (not (stamp< y x)))
1222 (defun earlier-stamp (x y) (if (stamp< x y) x y))
1223 (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
1224 (defun earliest-stamp (&rest list) (stamps-earliest list))
1225 (defun later-stamp (x y) (if (stamp< x y) y x))
1226 (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
1227 (defun latest-stamp (&rest list) (stamps-latest list))
1228 (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
1232 (with-upgradability ()
1233 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
1234 (dolist (x list h) (setf (gethash x h) t))))
1237 ;;; Function designators
1238 (with-upgradability ()
1239 (defun ensure-function (fun &key (package :cl))
1240 "Coerce the object FUN into a function.
1242 If FUN is a FUNCTION, return it.
1243 If the FUN is a non-sequence literal constant, return constantly that,
1244 i.e. for a boolean keyword character number or pathname.
1245 Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1246 If FUN is a CONS, return the function that applies its CAR
1247 to the appended list of the rest of its CDR and the arguments.
1248 If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1249 and EVAL that in a (FUNCTION ...) context."
1252 ((or boolean keyword character number pathname) (constantly fun))
1253 ((or function symbol) fun)
1254 (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
1255 (string (eval `(function ,(with-standard-io-syntax
1256 (let ((*package* (find-package package)))
1257 (read-from-string fun))))))))
1259 (defun access-at (object at)
1260 "Given an OBJECT and an AT specifier, list of successive accessors,
1261 call each accessor on the result of the previous calls.
1262 An accessor may be an integer, meaning a call to ELT,
1263 a keyword, meaning a call to GETF,
1264 NIL, meaning identity,
1265 a function or other symbol, meaning itself,
1266 or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1267 As a degenerate case, the AT specifier may be an atom of a single such accessor
1269 (flet ((access (object accessor)
1271 (function (funcall accessor object))
1272 (integer (elt object accessor))
1273 (keyword (getf object accessor))
1275 (symbol (funcall accessor object))
1276 (cons (funcall (ensure-function accessor) object)))))
1278 (dolist (accessor at object)
1279 (setf object (access object accessor)))
1280 (access object at))))
1282 (defun access-at-count (at)
1283 "From an AT specification, extract a COUNT of maximum number
1284 of sub-objects to read as per ACCESS-AT"
1288 ((and (consp at) (integerp (first at)))
1291 (defun call-function (function-spec &rest arguments)
1292 (apply (ensure-function function-spec) arguments))
1294 (defun call-functions (function-specs)
1295 (map () 'call-function function-specs))
1297 (defun register-hook-function (variable hook &optional call-now-p)
1298 (pushnew hook (symbol-value variable))
1299 (when call-now-p (call-function hook))))
1302 ;;; Version handling
1303 (with-upgradability ()
1304 (defun unparse-version (version-list)
1305 (format nil "~{~D~^.~}" version-list))
1307 (defun parse-version (version-string &optional on-error)
1308 "Parse a VERSION-STRING as a series of natural integers separated by dots.
1309 Return a (non-null) list of integers if the string is valid;
1310 otherwise return NIL.
1312 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1313 with format arguments explaining why the version is invalid.
1314 ON-ERROR is also called if the version is not canonical
1315 in that it doesn't print back to itself, but the list is returned anyway."
1317 (unless (stringp version-string)
1318 (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
1320 (unless (loop :for prev = nil :then c :for c :across version-string
1321 :always (or (digit-char-p c)
1322 (and (eql c #\.) prev (not (eql prev #\.))))
1323 :finally (return (and c (digit-char-p c))))
1324 (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
1325 'parse-version version-string)
1327 (let* ((version-list
1328 (mapcar #'parse-integer (split-string version-string :separator ".")))
1329 (normalized-version (unparse-version version-list)))
1330 (unless (equal version-string normalized-version)
1331 (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
1334 (defun lexicographic< (< x y)
1335 (cond ((null y) nil)
1337 ((funcall < (car x) (car y)) t)
1338 ((funcall < (car y) (car x)) nil)
1339 (t (lexicographic< < (cdr x) (cdr y)))))
1341 (defun lexicographic<= (< x y)
1342 (not (lexicographic< < y x)))
1344 (defun version< (version1 version2)
1345 (let ((v1 (parse-version version1 nil))
1346 (v2 (parse-version version2 nil)))
1347 (lexicographic< '< v1 v2)))
1349 (defun version<= (version1 version2)
1350 (not (version< version2 version1)))
1352 (defun version-compatible-p (provided-version required-version)
1353 "Is the provided version a compatible substitution for the required-version?
1354 If major versions differ, it's not compatible.
1355 If they are equal, then any later version is compatible,
1356 with later being determined by a lexicographical comparison of minor numbers."
1357 (let ((x (parse-version provided-version nil))
1358 (y (parse-version required-version nil)))
1359 (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
1362 ;;; Condition control
1364 (with-upgradability ()
1365 (defvar *uninteresting-conditions* nil
1366 "Uninteresting conditions, as per MATCH-CONDITION-P")
1368 (defparameter +simple-condition-format-control-slot+
1369 #+abcl 'system::format-control
1370 #+allegro 'excl::format-control
1371 #+clisp 'system::$format-control
1372 #+clozure 'ccl::format-control
1373 #+(or cmu scl) 'conditions::format-control
1374 #+ecl 'si::format-control
1375 #+(or gcl lispworks) 'conditions::format-string
1376 #+sbcl 'sb-kernel:format-control
1377 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
1378 "Name of the slot for FORMAT-CONTROL in simple-condition")
1380 (defun match-condition-p (x condition)
1381 "Compare received CONDITION to some pattern X:
1382 a symbol naming a condition class,
1383 a simple vector of length 2, arguments to find-symbol* with result as above,
1384 or a string describing the format-control of a simple-condition."
1386 (symbol (typep condition x))
1387 ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
1388 (function (funcall x condition))
1389 (string (and (typep condition 'simple-condition)
1390 ;; On SBCL, it's always set and the check triggers a warning
1391 #+(or allegro clozure cmu lispworks scl)
1392 (slot-boundp condition +simple-condition-format-control-slot+)
1393 (ignore-errors (equal (simple-condition-format-control condition) x))))))
1395 (defun match-any-condition-p (condition conditions)
1396 "match CONDITION against any of the patterns of CONDITIONS supplied"
1397 (loop :for x :in conditions :thereis (match-condition-p x condition)))
1399 (defun call-with-muffled-conditions (thunk conditions)
1400 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
1401 (muffle-warning c)))))
1404 (defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
1405 `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions)))
1408 ;;;; ---------------------------------------------------------------------------
1409 ;;;; Access to the Operating System
1411 (asdf/package:define-package :asdf/os
1412 (:recycle :asdf/os :asdf)
1413 (:use :asdf/common-lisp :asdf/package :asdf/utility)
1415 #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
1416 #:getenv #:getenvp ;; environment variables
1417 #:implementation-identifier ;; implementation identifier
1418 #:implementation-type #:*implementation-type*
1419 #:operating-system #:architecture #:lisp-version-string
1420 #:hostname #:getcwd #:chdir
1421 ;; Windows shortcut support
1422 #:read-null-terminated-string #:read-little-endian
1423 #:parse-file-location-info #:parse-windows-shortcut))
1424 (in-package :asdf/os)
1427 (with-upgradability ()
1428 (defun featurep (x &optional (*features* *features*))
1430 ((atom x) (and (member x *features*) t))
1431 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
1432 ((eq :or (car x)) (some #'featurep (cdr x)))
1433 ((eq :and (car x)) (every #'featurep (cdr x)))
1434 (t (error "Malformed feature specification ~S" x))))
1437 (or #+abcl (featurep :unix)
1438 #+(and (not abcl) (or unix cygwin darwin)) t))
1440 (defun os-windows-p ()
1441 (or #+abcl (featurep :windows)
1442 #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
1444 (defun os-genera-p ()
1448 (flet ((yes (yes) (pushnew yes *features*))
1449 (no (no) (setf *features* (remove no *features*))))
1451 ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
1452 ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
1453 ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
1454 (t (error "Congratulations for trying XCVB on an operating system~%~
1455 that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
1459 ;;;; Environment variables: getting them, and parsing them.
1461 (with-upgradability ()
1463 (declare (ignorable x))
1464 #+(or abcl clisp ecl xcl) (ext:getenv x)
1465 #+allegro (sys:getenv x)
1466 #+clozure (ccl:getenv x)
1467 #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
1469 (let* ((buffer (ct:malloc 1))
1470 (cname (ct:lisp-string-to-c-string x))
1471 (needed-size (win:getenvironmentvariable cname buffer 0))
1472 (buffer1 (ct:malloc (1+ needed-size))))
1473 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
1475 (ct:c-string-to-lisp-string buffer1))
1478 #+gcl (system:getenv x)
1480 #+lispworks (lispworks:environment-variable x)
1481 #+mcl (ccl:with-cstrs ((name x))
1482 (let ((value (_getenv name)))
1483 (unless (ccl:%null-ptr-p value)
1484 (ccl:%get-cstring value))))
1485 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
1486 #+sbcl (sb-ext:posix-getenv x)
1487 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
1488 (error "~S is not supported on your implementation" 'getenv))
1491 "Predicate that is true if the named variable is present in the libc environment,
1492 then returning the non-empty string value of the variable"
1493 (let ((g (getenv x))) (and (not (emptyp g)) g))))
1496 ;;;; implementation-identifier
1498 ;; produce a string to identify current implementation.
1499 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
1500 ;; We're back to runtime checking, for the sake of e.g. ABCL.
1502 (with-upgradability ()
1503 (defun first-feature (feature-sets)
1504 (dolist (x feature-sets)
1505 (multiple-value-bind (short long feature-expr)
1507 (values (first x) (second x) (cons :or (rest x)))
1509 (when (featurep feature-expr)
1510 (return (values short long))))))
1512 (defun implementation-type ()
1514 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
1515 (:cmu :cmucl :cmu) :ecl :gcl
1516 (:lwpe :lispworks-personal-edition) (:lw :lispworks)
1517 :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
1519 (defvar *implementation-type* (implementation-type))
1521 (defun operating-system ()
1523 '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
1524 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
1525 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
1526 (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
1529 (defun architecture ()
1531 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
1532 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
1533 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
1534 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
1535 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
1536 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
1537 ;; we may have to segregate the code still by architecture.
1538 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
1541 (defun ccl-fasl-version ()
1542 ;; the fasl version is target-dependent from CCL 1.8 on.
1543 (or (let ((s 'ccl::target-fasl-version))
1544 (and (fboundp s) (funcall s)))
1545 (and (boundp 'ccl::fasl-version)
1546 (symbol-value 'ccl::fasl-version))
1547 (error "Can't determine fasl version.")))
1549 (defun lisp-version-string ()
1550 (let ((s (lisp-implementation-version)))
1551 (car ; as opposed to OR, this idiom prevents some unreachable code warning
1554 (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
1555 excl::*common-lisp-version-number*
1556 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
1557 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
1558 ;; Note if not using International ACL
1559 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
1560 (excl:ics-target-case (:-ics "8"))
1561 (and (member :smp *features*) "S"))
1562 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
1564 (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
1566 (format nil "~d.~d-f~d" ; shorten for windows
1567 ccl::*openmcl-major-version*
1568 ccl::*openmcl-minor-version*
1569 (logand (ccl-fasl-version) #xFF))
1570 #+cmu (substitute #\- #\/ s)
1571 #+scl (format nil "~A~A" s
1572 ;; ANSI upper case vs lower case.
1573 (ecase ext:*case-mode* (:upper "") (:lower "l")))
1574 #+ecl (format nil "~A~@[-~A~]" s
1575 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
1576 (subseq vcs-id 0 (min (length vcs-id) 8))))
1577 #+gcl (subseq s (1+ (position #\space s)))
1579 (multiple-value-bind (major minor) (sct:get-system-version "System")
1580 (format nil "~D.~D" major minor))
1581 #+mcl (subseq s 8) ; strip the leading "Version "
1584 (defun implementation-identifier ()
1586 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
1587 (format nil "~(~a~@{~@[-~a~]~}~)"
1588 (or (implementation-type) (lisp-implementation-type))
1589 (or (lisp-version-string) (lisp-implementation-version))
1590 (or (operating-system) (software-type))
1591 (or (architecture) (machine-type))))))
1594 ;;;; Other system information
1596 (with-upgradability ()
1598 ;; Note: untested on RMCL
1599 #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
1600 #+cormanlisp "localhost" ;; is there a better way? Does it matter?
1601 #+allegro (symbol-call :excl.osi :gethostname)
1602 #+clisp (first (split-string (machine-instance) :separator " "))
1603 #+gcl (system:gethostname)))
1606 ;;; Current directory
1607 (with-upgradability ()
1610 (defun parse-unix-namestring* (unix-namestring)
1611 (multiple-value-bind (host device directory name type version)
1612 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
1613 (make-pathname :host (or host lisp::*unix-host*) :device device
1614 :directory directory :name name :type type :version version)))
1617 "Get the current working directory as per POSIX getcwd(3), as a pathname object"
1618 (or #+abcl (parse-namestring
1619 (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
1620 #+allegro (excl::current-directory)
1621 #+clisp (ext:default-directory)
1622 #+clozure (ccl:current-directory)
1623 #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
1624 (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
1625 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
1627 #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
1628 (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
1629 #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
1630 #+lispworks (system:current-directory)
1631 #+mkcl (mk-ext:getcwd)
1632 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
1633 #+xcl (extensions:current-directory)
1634 (error "getcwd not supported on your implementation")))
1637 "Change current directory, as per POSIX chdir(2), to a given pathname object"
1638 (if-let (x (pathname x))
1639 (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
1640 #+allegro (excl:chdir x)
1642 #+clozure (setf (ccl:current-directory) x)
1643 #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
1644 #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
1645 (error "Could not set current directory to ~A" x))
1647 #+genera (setf *default-pathname-defaults* x)
1648 #+lispworks (hcl:change-directory x)
1649 #+mkcl (mk-ext:chdir x)
1650 #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
1651 (error "chdir not supported on your implementation")))))
1654 ;;;; -----------------------------------------------------------------
1655 ;;;; Windows shortcut support. Based on:
1657 ;;;; Jesse Hager: The Windows Shortcut File Format.
1658 ;;;; http://www.wotsit.org/list.asp?fc=13
1660 (with-upgradability ()
1661 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1663 (defparameter *link-initial-dword* 76)
1664 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1666 (defun read-null-terminated-string (s)
1667 (with-output-to-string (out)
1668 (loop :for code = (read-byte s)
1670 :do (write-char (code-char code) out))))
1672 (defun read-little-endian (s &optional (bytes 4))
1673 (loop :for i :from 0 :below bytes
1674 :sum (ash (read-byte s) (* 8 i))))
1676 (defun parse-file-location-info (s)
1677 (let ((start (file-position s))
1678 (total-length (read-little-endian s))
1679 (end-of-header (read-little-endian s))
1680 (fli-flags (read-little-endian s))
1681 (local-volume-offset (read-little-endian s))
1682 (local-offset (read-little-endian s))
1683 (network-volume-offset (read-little-endian s))
1684 (remaining-offset (read-little-endian s)))
1685 (declare (ignore total-length end-of-header local-volume-offset))
1686 (unless (zerop fli-flags)
1688 ((logbitp 0 fli-flags)
1689 (file-position s (+ start local-offset)))
1690 ((logbitp 1 fli-flags)
1691 (file-position s (+ start
1692 network-volume-offset
1694 (strcat (read-null-terminated-string s)
1696 (file-position s (+ start remaining-offset))
1697 (read-null-terminated-string s))))))
1699 (defun parse-windows-shortcut (pathname)
1700 (with-open-file (s pathname :element-type '(unsigned-byte 8))
1702 (when (and (= (read-little-endian s) *link-initial-dword*)
1703 (let ((header (make-array (length *link-guid*))))
1704 (read-sequence header s)
1705 (equalp header *link-guid*)))
1706 (let ((flags (read-little-endian s)))
1707 (file-position s 76) ;skip rest of header
1708 (when (logbitp 0 flags)
1709 ;; skip shell item id list
1710 (let ((length (read-little-endian s 2)))
1711 (file-position s (+ length (file-position s)))))
1714 (parse-file-location-info s))
1716 (when (logbitp 2 flags)
1717 ;; skip description string
1718 (let ((length (read-little-endian s 2)))
1719 (file-position s (+ length (file-position s)))))
1720 (when (logbitp 3 flags)
1721 ;; finally, our pathname
1722 (let* ((length (read-little-endian s 2))
1723 (buffer (make-array length)))
1724 (read-sequence buffer s)
1725 (map 'string #'code-char buffer)))))))
1727 (declare (ignore c))
1731 ;;;; -------------------------------------------------------------------------
1732 ;;;; Portability layer around Common Lisp pathnames
1733 ;; This layer allows for portable manipulation of pathname objects themselves,
1734 ;; which all is necessary prior to any access the filesystem or environment.
1736 (asdf/package:define-package :asdf/pathname
1737 (:recycle :asdf/pathname :asdf)
1738 (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
1740 ;; Making and merging pathnames, portably
1741 #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
1742 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
1743 #:make-pathname-component-logical #:make-pathname-logical
1745 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
1747 #:pathname-equal #:logical-pathname-p #:physical-pathname-p
1748 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
1750 #:pathname-directory-pathname #:pathname-parent-directory-pathname
1751 #:directory-pathname-p #:ensure-directory-pathname
1752 ;; Parsing filenames
1753 #:component-name-to-pathname-components
1754 #:split-name-type #:parse-unix-namestring #:unix-namestring
1755 #:split-unix-namestring-directory-components
1756 ;; Absolute and relative pathnames
1757 #:subpathname #:subpathname*
1758 #:ensure-absolute-pathname
1759 #:pathname-root #:pathname-host-pathname
1761 ;; Checking constraints
1762 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
1763 ;; Wildcard pathnames
1764 #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
1765 ;; Translate a pathname
1766 #:relativize-directory-component #:relativize-pathname-directory
1767 #:directory-separator-for-host #:directorize-pathname-host-device
1768 #:translate-pathname*
1769 #:*output-translation-function*))
1770 (in-package :asdf/pathname)
1772 ;;; Normalizing pathnames across implementations
1774 (with-upgradability ()
1775 (defun normalize-pathname-directory-component (directory)
1776 "Given a pathname directory component, return an equivalent form that is a list"
1777 #+gcl2.6 (setf directory (substitute :back :parent directory))
1779 #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
1780 ((stringp directory) `(:absolute ,directory))
1782 ((and (consp directory) (eq :root (first directory)))
1783 `(:absolute ,@(rest directory)))
1784 ((or (null directory)
1785 (and (consp directory) (member (first directory) '(:absolute :relative))))
1789 `(:relative ,@directory))
1791 (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
1793 (defun denormalize-pathname-directory-component (directory-component)
1794 #-gcl2.6 directory-component
1796 (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
1797 directory-component)))
1799 ((and (consp d) (eq :relative (first d))) (rest d))
1800 ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
1803 (defun merge-pathname-directory-components (specified defaults)
1804 ;; Helper for merge-pathnames* that handles directory components.
1805 (let ((directory (normalize-pathname-directory-component specified)))
1806 (ecase (first directory)
1808 (:absolute specified)
1810 (let ((defdir (normalize-pathname-directory-component defaults))
1811 (reldir (cdr directory)))
1815 ((not (eq :back (first reldir)))
1816 (append defdir reldir))
1818 (loop :with defabs = (first defdir)
1819 :with defrev = (reverse (rest defdir))
1820 :while (and (eq :back (car reldir))
1821 (or (and (eq :absolute defabs) (null defrev))
1822 (stringp (car defrev))))
1823 :do (pop reldir) (pop defrev)
1824 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
1826 ;; Giving :unspecific as :type argument to make-pathname is not portable.
1827 ;; See CLHS make-pathname and 19.2.2.2.3.
1828 ;; This will be :unspecific if supported, or NIL if not.
1829 (defparameter *unspecific-pathname-type*
1830 #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
1831 #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
1833 (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
1834 host (device () #+allegro devicep) name type version defaults
1835 #+scl &allow-other-keys)
1836 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
1837 tries hard to make a pathname that will actually behave as documented,
1838 despite the peculiarities of each implementation"
1839 (declare (ignorable host device directory name type version defaults))
1840 (apply 'make-pathname
1842 #+allegro (when (and devicep (null device)) `(:device :unspecific))
1845 `(:directory ,(denormalize-pathname-directory-component directory)))
1848 (defun make-pathname-component-logical (x)
1849 "Make a pathname component suitable for use in a logical-pathname"
1851 ((eql :unspecific) nil)
1852 #+clisp (string (string-upcase x))
1853 #+clisp (cons (mapcar 'make-pathname-component-logical x))
1856 (defun make-pathname-logical (pathname host)
1857 "Take a PATHNAME's directory, name, type and version components,
1858 and make a new pathname with corresponding components and specified logical HOST"
1861 :directory (make-pathname-component-logical (pathname-directory pathname))
1862 :name (make-pathname-component-logical (pathname-name pathname))
1863 :type (make-pathname-component-logical (pathname-type pathname))
1864 :version (make-pathname-component-logical (pathname-version pathname))))
1866 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
1867 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
1868 if the SPECIFIED pathname does not have an absolute directory,
1869 then the HOST and DEVICE both come from the DEFAULTS, whereas
1870 if the SPECIFIED pathname does have an absolute directory,
1871 then the HOST and DEVICE both come from the SPECIFIED.
1872 This is what users want on a modern Unix or Windows operating system,
1873 unlike the MERGE-PATHNAME behavior.
1874 Also, if either argument is NIL, then the other argument is returned unmodified;
1875 this is unlike MERGE-PATHNAME which always merges with a pathname,
1876 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
1877 (when (null specified) (return-from merge-pathnames* defaults))
1878 (when (null defaults) (return-from merge-pathnames* specified))
1880 (ext:resolve-pathname specified defaults)
1882 (let* ((specified (pathname specified))
1883 (defaults (pathname defaults))
1884 (directory (normalize-pathname-directory-component (pathname-directory specified)))
1885 (name (or (pathname-name specified) (pathname-name defaults)))
1886 (type (or (pathname-type specified) (pathname-type defaults)))
1887 (version (or (pathname-version specified) (pathname-version defaults))))
1888 (labels ((unspecific-handler (p)
1889 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
1890 (multiple-value-bind (host device directory unspecific-handler)
1891 (ecase (first directory)
1893 (values (pathname-host specified)
1894 (pathname-device specified)
1896 (unspecific-handler specified)))
1898 (values (pathname-host defaults)
1899 (pathname-device defaults)
1900 (merge-pathname-directory-components directory (pathname-directory defaults))
1901 (unspecific-handler defaults))))
1902 (make-pathname* :host host :device device :directory directory
1903 :name (funcall unspecific-handler name)
1904 :type (funcall unspecific-handler type)
1905 :version (funcall unspecific-handler version))))))
1907 (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
1908 "A pathname that is as neutral as possible for use as defaults
1909 when merging, making or parsing pathnames"
1910 ;; 19.2.2.2.1 says a NIL host can mean a default host;
1911 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
1912 ;; strings and lists of strings or :unspecific
1913 ;; But CMUCL decides to die on NIL.
1914 #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
1915 :host (or #+cmu lisp::*unix-host*)
1916 #+scl ,@'(:scheme nil :scheme-specific-part nil
1917 :username nil :password nil :parameters nil :query nil :fragment nil)
1918 ;; the default shouldn't matter, but we really want something physical
1919 :defaults defaults))
1921 (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
1923 (defmacro with-pathname-defaults ((&optional defaults) &body body)
1924 `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
1927 ;;; Some pathname predicates
1928 (with-upgradability ()
1929 (defun pathname-equal (p1 p2)
1930 (when (stringp p1) (setf p1 (pathname p1)))
1931 (when (stringp p2) (setf p2 (pathname p2)))
1932 (flet ((normalize-component (x)
1933 (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
1935 (macrolet ((=? (&rest accessors)
1937 (reduce 'list (cons 'normalize-component accessors)
1938 :initial-value x :from-end t)))
1939 `(equal ,(frob 'p1) ,(frob 'p2)))))
1940 (or (and (null p1) (null p2))
1941 (and (pathnamep p1) (pathnamep p2)
1942 (and (=? pathname-host)
1943 (=? pathname-device)
1944 (=? normalize-pathname-directory-component pathname-directory)
1947 (=? pathname-version)))))))
1949 (defun logical-pathname-p (x)
1950 (typep x 'logical-pathname))
1952 (defun physical-pathname-p (x)
1953 (and (pathnamep x) (not (logical-pathname-p x))))
1955 (defun absolute-pathname-p (pathspec)
1956 "If PATHSPEC is a pathname or namestring object that parses as a pathname
1957 possessing an :ABSOLUTE directory component, return the (parsed) pathname.
1958 Otherwise return NIL"
1960 (typep pathspec '(or null pathname string))
1961 (let ((pathname (pathname pathspec)))
1962 (and (eq :absolute (car (normalize-pathname-directory-component
1963 (pathname-directory pathname))))
1966 (defun relative-pathname-p (pathspec)
1967 "If PATHSPEC is a pathname or namestring object that parses as a pathname
1968 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
1969 Otherwise return NIL"
1971 (typep pathspec '(or null pathname string))
1972 (let* ((pathname (pathname pathspec))
1973 (directory (normalize-pathname-directory-component
1974 (pathname-directory pathname))))
1975 (when (or (null directory) (eq :relative (car directory)))
1978 (defun hidden-pathname-p (pathname)
1979 "Return a boolean that is true if the pathname is hidden as per Unix style,
1980 i.e. its name starts with a dot."
1981 (and pathname (equal (first-char (pathname-name pathname)) #\.)))
1983 (defun file-pathname-p (pathname)
1984 "Does PATHNAME represent a file, i.e. has a non-null NAME component?
1986 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
1988 Note that this does _not_ check to see that PATHNAME points to an
1989 actually-existing file.
1991 Returns the (parsed) PATHNAME when true"
1993 (let* ((pathname (pathname pathname))
1994 (name (pathname-name pathname)))
1995 (when (not (member name '(nil :unspecific "") :test 'equal))
1999 ;;; Directory pathnames
2000 (with-upgradability ()
2001 (defun pathname-directory-pathname (pathname)
2002 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2003 and NIL NAME, TYPE and VERSION components"
2005 (make-pathname :name nil :type nil :version nil :defaults pathname)))
2007 (defun pathname-parent-directory-pathname (pathname)
2008 "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2009 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2010 Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2012 (make-pathname* :name nil :type nil :version nil
2013 :directory (merge-pathname-directory-components
2014 '(:relative :back) (pathname-directory pathname))
2015 :defaults pathname)))
2017 (defun directory-pathname-p (pathname)
2018 "Does PATHNAME represent a directory?
2020 A directory-pathname is a pathname _without_ a filename. The three
2021 ways that the filename components can be missing are for it to be NIL,
2022 :UNSPECIFIC or the empty string.
2024 Note that this does _not_ check to see that PATHNAME points to an
2025 actually-existing directory."
2027 (let ((pathname (pathname pathname)))
2028 (flet ((check-one (x)
2029 (member x '(nil :unspecific "") :test 'equal)))
2030 (and (not (wild-pathname-p pathname))
2031 (check-one (pathname-name pathname))
2032 (check-one (pathname-type pathname))
2035 (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
2036 "Converts the non-wild pathname designator PATHSPEC to directory form."
2039 (ensure-directory-pathname (pathname pathspec)))
2040 ((not (pathnamep pathspec))
2041 (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
2042 ((wild-pathname-p pathspec)
2043 (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
2044 ((directory-pathname-p pathspec)
2047 (make-pathname* :directory (append (or (normalize-pathname-directory-component
2048 (pathname-directory pathspec))
2050 (list (file-namestring pathspec)))
2051 :name nil :type nil :version nil :defaults pathspec)))))
2054 ;;; Parsing filenames
2055 (with-upgradability ()
2056 (defun split-unix-namestring-directory-components
2057 (unix-namestring &key ensure-directory dot-dot)
2058 "Splits the path string UNIX-NAMESTRING, returning four values:
2059 A flag that is either :absolute or :relative, indicating
2060 how the rest of the values are to be interpreted.
2061 A directory path --- a list of strings and keywords, suitable for
2062 use with MAKE-PATHNAME when prepended with the flag value.
2063 Directory components with an empty name or the name . are removed.
2064 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2065 A last-component, either a file-namestring including type extension,
2066 or NIL in the case of a directory pathname.
2067 A flag that is true iff the unix-style-pathname was just
2068 a file-namestring without / path specification.
2069 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2070 the third return value will be NIL, and final component of the namestring
2071 will be treated as part of the directory path.
2073 An empty string is thus read as meaning a pathname object with all fields nil.
2075 Note that : characters will NOT be interpreted as host specification.
2076 Absolute pathnames are only appropriate on Unix-style systems.
2078 The intention of this function is to support structured component names,
2079 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2080 (check-type unix-namestring string)
2081 (check-type dot-dot (member nil :back :up))
2082 (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
2083 (plusp (length unix-namestring)))
2084 (values :relative () unix-namestring t)
2085 (let* ((components (split-string unix-namestring :separator "/"))
2086 (last-comp (car (last components))))
2087 (multiple-value-bind (relative components)
2088 (if (equal (first components) "")
2089 (if (equal (first-char unix-namestring) #\/)
2090 (values :absolute (cdr components))
2091 (values :relative nil))
2092 (values :relative components))
2093 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
2095 (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
2097 ((equal last-comp "")
2098 (values relative components nil nil)) ; "" already removed from components
2100 (values relative components nil nil))
2102 (values relative (butlast components) last-comp nil)))))))
2104 (defun split-name-type (filename)
2105 "Split a filename into two values NAME and TYPE that are returned.
2106 We assume filename has no directory component.
2107 The last . if any separates name and type from from type,
2108 except that if there is only one . and it is in first position,
2109 the whole filename is the NAME with an empty type.
2110 NAME is always a string.
2111 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2112 (check-type filename string)
2113 (assert (plusp (length filename)))
2114 (destructuring-bind (name &optional (type *unspecific-pathname-type*))
2115 (split-string filename :max 2 :separator ".")
2117 (values filename *unspecific-pathname-type*)
2118 (values name type))))
2120 (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
2122 "Coerce NAME into a PATHNAME using standard Unix syntax.
2124 Unix syntax is used whether or not the underlying system is Unix;
2125 on such non-Unix systems it is only usable but for relative pathnames;
2126 but especially to manipulate relative pathnames portably, it is of crucial
2127 to possess a portable pathname syntax independent of the underlying OS.
2128 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2130 When given a PATHNAME object, just return it untouched.
2131 When given NIL, just return NIL.
2132 When given a non-null SYMBOL, first downcase its name and treat it as a string.
2133 When given a STRING, portably decompose it into a pathname as below.
2135 #\\/ separates directory components.
2137 The last #\\/-separated substring is interpreted as follows:
2138 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2139 the string is made the last directory component, and NAME and TYPE are NIL.
2140 if the string is empty, it's the empty pathname with all slots NIL.
2141 2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
2142 are separated by SPLIT-NAME-TYPE.
2143 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2145 Directory components with an empty name the name . are removed.
2146 Any directory named .. is read as DOT-DOT,
2147 which must be one of :BACK or :UP and defaults to :BACK.
2149 HOST, DEVICE and VERSION components are taken from DEFAULTS,
2150 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
2151 No host or device can be specified in the string itself,
2152 which makes it unsuitable for absolute pathnames outside Unix.
2154 For relative pathnames, these components (and hence the defaults) won't matter
2155 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2156 which is an important reason to always use MERGE-PATHNAMES*.
2158 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2159 with those keys, removing TYPE DEFAULTS and DOT-DOT.
2160 When you're manipulating pathnames that are supposed to make sense portably
2161 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2162 to throw an error if the pathname is absolute"
2164 (check-type type (or null string (eql :directory)))
2165 (when ensure-directory
2166 (setf type :directory))
2168 ((or null pathname) (return name))
2170 (setf name (string-downcase name)))
2172 (multiple-value-bind (relative path filename file-only)
2173 (split-unix-namestring-directory-components
2174 name :dot-dot dot-dot :ensure-directory (eq type :directory))
2175 (multiple-value-bind (name type)
2177 ((or (eq type :directory) (null filename))
2180 (values filename type))
2182 (split-name-type filename)))
2183 (apply 'ensure-pathname
2185 :directory (unless file-only (cons relative path))
2186 :name name :type type
2187 :defaults (or defaults *nil-pathname*))
2188 (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
2190 (defun unix-namestring (pathname)
2191 "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2192 If the PATHNAME is NIL or a STRING, return it unchanged.
2194 This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2195 This is a portable solution for representing relative pathnames,
2196 But unless you are running on a Unix system, it is not a general solution
2197 to representing native pathnames.
2199 An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2200 or if it is a PATHNAME but some of its components are not recognized."
2202 ((or null string) pathname)
2204 (with-output-to-string (s)
2205 (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
2206 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
2207 (name (pathname-name pathname))
2208 (type (pathname-type pathname))
2209 (type (and (not (eq type :unspecific)) type)))
2212 ((eq dir '(:relative)) (princ "./" s))
2214 (destructuring-bind (relabs &rest dirs) dir
2215 (or (member relabs '(:relative :absolute)) (err))
2216 (when (eq relabs :absolute) (princ #\/ s))
2217 (loop :for x :in dirs :do
2219 ((member x '(:back :up)) (princ "../" s))
2220 ((equal x "") (err))
2221 ;;((member x '("." "..") :test 'equal) (err))
2222 ((stringp x) (format s "~A/" x))
2227 (or (and (stringp name) (or (null type) (stringp type))) (err))
2228 (format s "~A~@[.~A~]" name type))
2230 (or (null type) (err)))))))))))
2232 ;;; Absolute and relative pathnames
2233 (with-upgradability ()
2234 (defun subpathname (pathname subpath &key type)
2235 "This function takes a PATHNAME and a SUBPATH and a TYPE.
2236 If SUBPATH is already a PATHNAME object (not namestring),
2237 and is an absolute pathname at that, it is returned unchanged;
2238 otherwise, SUBPATH is turned into a relative pathname with given TYPE
2239 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2240 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2241 (or (and (pathnamep subpath) (absolute-pathname-p subpath))
2242 (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
2243 (pathname-directory-pathname pathname))))
2245 (defun subpathname* (pathname subpath &key type)
2246 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2248 (subpathname (ensure-directory-pathname pathname) subpath :type type)))
2250 (defun pathname-root (pathname)
2251 (make-pathname* :directory '(:absolute)
2252 :name nil :type nil :version nil
2253 :defaults pathname ;; host device, and on scl, *some*
2254 ;; scheme-specific parts: port username password, not others:
2255 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2257 (defun pathname-host-pathname (pathname)
2258 (make-pathname* :directory nil
2259 :name nil :type nil :version nil :device nil
2260 :defaults pathname ;; host device, and on scl, *some*
2261 ;; scheme-specific parts: port username password, not others:
2262 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2264 (defun subpathp (maybe-subpath base-pathname)
2265 (and (pathnamep maybe-subpath) (pathnamep base-pathname)
2266 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
2267 (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
2268 (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
2269 (with-pathname-defaults ()
2270 (let ((enough (enough-namestring maybe-subpath base-pathname)))
2271 (and (relative-pathname-p enough) (pathname enough))))))
2273 (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
2275 ((absolute-pathname-p path))
2276 ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
2277 ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
2278 ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
2279 (or (if (absolute-pathname-p default-pathname)
2280 (absolute-pathname-p (merge-pathnames* path default-pathname))
2281 (call-function on-error "Default pathname ~S is not an absolute pathname"
2283 (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
2284 path default-pathname))))
2285 (t (call-function on-error
2286 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
2290 ;;; Wildcard pathnames
2291 (with-upgradability ()
2292 (defparameter *wild* (or #+cormanlisp "*" :wild))
2293 (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
2294 (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
2295 (defparameter *wild-file*
2296 (make-pathname :directory nil :name *wild* :type *wild*
2297 :version (or #-(or allegro abcl xcl) *wild*)))
2298 (defparameter *wild-directory*
2299 (make-pathname* :directory `(:relative ,*wild-directory-component*)
2300 :name nil :type nil :version nil))
2301 (defparameter *wild-inferiors*
2302 (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
2303 :name nil :type nil :version nil))
2304 (defparameter *wild-path*
2305 (merge-pathnames* *wild-file* *wild-inferiors*))
2307 (defun wilden (path)
2308 (merge-pathnames* *wild-path* path)))
2311 ;;; Translate a pathname
2312 (with-upgradability ()
2313 (defun relativize-directory-component (directory-component)
2314 (let ((directory (normalize-pathname-directory-component directory-component)))
2316 ((stringp directory)
2317 (list :relative directory))
2318 ((eq (car directory) :absolute)
2319 (cons :relative (cdr directory)))
2323 (defun relativize-pathname-directory (pathspec)
2324 (let ((p (pathname pathspec)))
2326 :directory (relativize-directory-component (pathname-directory p))
2329 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
2330 (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
2331 (last-char (namestring foo))))
2334 (defun directorize-pathname-host-device (pathname)
2336 (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
2337 (return-from directorize-pathname-host-device pathname))
2338 (let* ((root (pathname-root pathname))
2339 (wild-root (wilden root))
2340 (absolute-pathname (merge-pathnames* pathname root))
2341 (separator (directory-separator-for-host root))
2342 (root-namestring (namestring root))
2345 #'(lambda (x) (or (eql x #\:)
2348 (multiple-value-bind (relative path filename)
2349 (split-unix-namestring-directory-components root-string :ensure-directory t)
2350 (declare (ignore relative filename))
2352 (make-pathname* :defaults root :directory `(:absolute ,@path))))
2353 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
2356 (defun directorize-pathname-host-device (pathname)
2357 (let ((scheme (ext:pathname-scheme pathname))
2358 (host (pathname-host pathname))
2359 (port (ext:pathname-port pathname))
2360 (directory (pathname-directory pathname)))
2361 (flet ((specificp (x) (and x (not (eq x :unspecific)))))
2362 (if (or (specificp port)
2363 (and (specificp host) (plusp (length host)))
2366 (when (specificp port)
2367 (setf prefix (format nil ":~D" port)))
2368 (when (and (specificp host) (plusp (length host)))
2369 (setf prefix (strcat host prefix)))
2370 (setf prefix (strcat ":" prefix))
2371 (when (specificp scheme)
2372 (setf prefix (strcat scheme prefix)))
2373 (assert (and directory (eq (first directory) :absolute)))
2374 (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
2375 :defaults pathname)))
2378 (defun* (translate-pathname*) (path absolute-source destination &optional root source)
2379 (declare (ignore source))
2381 ((functionp destination)
2382 (funcall destination path absolute-source))
2385 ((not (pathnamep destination))
2386 (error "Invalid destination"))
2387 ((not (absolute-pathname-p destination))
2388 (translate-pathname path absolute-source (merge-pathnames* destination root)))
2390 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
2392 (translate-pathname path absolute-source destination))))
2394 (defvar *output-translation-function* 'identity)) ; Hook for output translations
2397 ;;;; -------------------------------------------------------------------------
2398 ;;;; Portability layer around Common Lisp filesystem access
2400 (asdf/package:define-package :asdf/filesystem
2401 (:recycle :asdf/pathname :asdf)
2402 (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname)
2404 ;; Native namestrings
2405 #:native-namestring #:parse-native-namestring
2406 ;; Probing the filesystem
2407 #:truename* #:safe-file-write-date #:probe-file*
2408 #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
2409 #:collect-sub*directories
2410 ;; Resolving symlinks somewhat
2411 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
2413 #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
2414 ;; Environment pathnames
2415 #:inter-directory-separator #:split-native-pathnames-string
2416 #:getenv-pathname #:getenv-pathnames
2417 #:getenv-absolute-directory #:getenv-absolute-directories
2418 #:lisp-implementation-directory #:lisp-implementation-pathname-p
2419 ;; Simple filesystem operations
2420 #:ensure-all-directories-exist
2421 #:rename-file-overwriting-target
2422 #:delete-file-if-exists))
2423 (in-package :asdf/filesystem)
2425 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
2426 (with-upgradability ()
2427 (defun native-namestring (x)
2428 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
2430 (let ((p (pathname x)))
2431 #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
2432 #+(or cmu scl) (ext:unix-namestring p nil)
2433 #+sbcl (sb-ext:native-namestring p)
2434 #-(or clozure cmu sbcl scl)
2435 (if (os-unix-p) (unix-namestring p)
2438 (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
2439 "From a native namestring suitable for use by the operating system, return
2440 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
2441 (check-type string (or string null))
2444 (with-pathname-defaults ()
2445 #+clozure (ccl:native-to-pathname string)
2446 #+sbcl (sb-ext:parse-native-namestring string)
2449 (parse-unix-namestring string :ensure-directory ensure-directory)
2450 (parse-namestring string)))))
2452 (if ensure-directory
2453 (and pathname (ensure-directory-pathname pathname))
2455 (apply 'ensure-pathname pathname constraints))))
2458 ;;; Probing the filesystem
2459 (with-upgradability ()
2460 (defun truename* (p)
2461 ;; avoids both logical-pathname merging and physical resolution issues
2462 (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
2464 (defun safe-file-write-date (pathname)
2465 ;; If FILE-WRITE-DATE returns NIL, it's possible that
2466 ;; the user or some other agent has deleted an input file.
2467 ;; Also, generated files will not exist at the time planning is done
2468 ;; and calls compute-action-stamp which calls safe-file-write-date.
2469 ;; So it is very possible that we can't get a valid file-write-date,
2470 ;; and we can survive and we will continue the planning
2471 ;; as if the file were very old.
2472 ;; (or should we treat the case in a different, special way?)
2474 (handler-case (file-write-date (translate-logical-pathname pathname))
2475 (file-error () nil))))
2477 (defun probe-file* (p &key truename)
2478 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
2479 probes the filesystem for a file or directory with given pathname.
2480 If it exists, return its truename is ENSURE-PATHNAME is true,
2481 or the original (parsed) pathname if it is false (the default)."
2482 (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
2485 (string (probe-file* (parse-namestring p) :truename truename))
2490 (probe-file p :follow-symlinks truename)
2491 #-(or allegro clisp gcl2.6)
2494 (and (not (wild-pathname-p p))
2496 (let ((pp (translate-logical-pathname p)))
2497 #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
2498 #+(and lispworks unix) (system:get-file-stat pp)
2499 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
2500 #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
2503 #.(flet ((probe (probe)
2504 `(let ((foundtrue ,probe))
2506 (truename foundtrue)
2509 (probe '(or (probe-file p)
2510 (and (directory-pathname-p p)
2512 (ensure-directory-pathname
2513 (truename* (subpathname
2514 (ensure-directory-pathname p) ".")))))))
2516 (let* ((fs (find-symbol* '#:file-stat :posix nil))
2517 (pp (find-symbol* '#:probe-pathname :ext nil))
2519 `(ignore-errors (,pp p))
2521 (truename* (ignore-errors (ensure-directory-pathname p)))))))
2525 (and (ignore-errors (,fs p)) p))
2527 (file-error () nil))))))
2529 (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
2530 (apply 'directory pathname-spec
2531 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
2532 #+clozure '(:follow-links nil)
2533 #+clisp '(:circle t :if-does-not-exist :ignore)
2534 #+(or cmu scl) '(:follow-links nil :truenamep nil)
2535 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
2536 '(:resolve-symlinks nil))))))
2538 (defun filter-logical-directory-results (directory entries merger)
2539 (if (logical-pathname-p directory)
2540 ;; Try hard to not resolve logical-pathname into physical pathnames;
2541 ;; otherwise logical-pathname users/lovers will be disappointed.
2542 ;; If directory* could use some implementation-dependent magic,
2543 ;; we will have logical pathnames already; otherwise,
2544 ;; we only keep pathnames for which specifying the name and
2545 ;; translating the LPN commute.
2546 (loop :for f :in entries
2547 :for p = (or (and (logical-pathname-p f) f)
2548 (let* ((u (ignore-errors (funcall merger f))))
2549 ;; The first u avoids a cumbersome (truename u) error.
2550 ;; At this point f should already be a truename,
2551 ;; but isn't quite in CLISP, for it doesn't have :version :newest
2552 (and u (equal (truename* u) (truename* f)) u)))
2556 (defun directory-files (directory &optional (pattern *wild-file*))
2557 (let ((dir (pathname directory)))
2558 (when (logical-pathname-p dir)
2559 ;; Because of the filtering we do below,
2560 ;; logical pathnames have restrictions on wild patterns.
2561 ;; Not that the results are very portable when you use these patterns on physical pathnames.
2562 (when (wild-pathname-p dir)
2563 (error "Invalid wild pattern in logical directory ~S" directory))
2564 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
2565 (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
2566 (setf pattern (make-pathname-logical pattern (pathname-host dir))))
2567 (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
2568 (filter-logical-directory-results
2571 (make-pathname :defaults dir
2572 :name (make-pathname-component-logical (pathname-name f))
2573 :type (make-pathname-component-logical (pathname-type f))
2574 :version (make-pathname-component-logical (pathname-version f))))))))
2576 (defun subdirectories (directory)
2577 (let* ((directory (ensure-directory-pathname directory))
2578 #-(or abcl cormanlisp genera xcl)
2579 (wild (merge-pathnames*
2580 #-(or abcl allegro cmu lispworks sbcl scl xcl)
2582 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
2585 #-(or abcl cormanlisp genera xcl)
2587 (directory* wild . #.(or #+clozure '(:directories t :files nil)
2588 #+mcl '(:directories t))))
2589 #+(or abcl xcl) (system:list-directory directory)
2590 #+cormanlisp (cl::directory-subdirs directory)
2591 #+genera (fs:directory-list directory))
2592 #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
2593 (dirs (loop :for x :in dirs
2594 :for d = #+(or abcl xcl) (extensions:probe-directory x)
2595 #+allegro (excl:probe-directory x)
2596 #+(or cmu sbcl scl) (directory-pathname-p x)
2597 #+genera (getf (cdr x) :directory)
2598 #+lispworks (lw:file-directory-p x)
2599 :when d :collect #+(or abcl allegro xcl) d
2600 #+genera (ensure-directory-pathname (first x))
2601 #+(or cmu lispworks sbcl scl) x)))
2602 (filter-logical-directory-results
2604 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
2605 '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
2607 (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
2608 (and (consp dir) (consp (cdr dir))
2610 :defaults directory :name nil :type nil :version nil
2611 :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
2613 (defun collect-sub*directories (directory collectp recursep collector)
2614 (when (funcall collectp directory)
2615 (funcall collector directory))
2616 (dolist (subdir (subdirectories directory))
2617 (when (funcall recursep subdir)
2618 (collect-sub*directories subdir collectp recursep collector)))))
2620 ;;; Resolving symlinks somewhat
2621 (with-upgradability ()
2622 (defun truenamize (pathname)
2623 "Resolve as much of a pathname as possible"
2625 (when (typep pathname '(or null logical-pathname)) (return pathname))
2627 (unless (absolute-pathname-p p)
2628 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
2630 (when (logical-pathname-p p) (return p))
2631 (let ((found (probe-file* p :truename t)))
2632 (when found (return found)))
2633 (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
2634 (up-components (reverse (rest directory)))
2635 (down-components ()))
2636 (assert (eq :absolute (first directory)))
2637 (loop :while up-components :do
2638 (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
2639 :name nil :type nil :version nil :defaults p)))
2640 (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
2642 (ensure-directory-pathname parent)))
2643 (push (pop up-components) down-components))
2644 :finally (return p))))))
2646 (defun resolve-symlinks (path)
2647 #-allegro (truenamize path)
2649 (if (physical-pathname-p path)
2650 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
2653 (defvar *resolve-symlinks* t
2654 "Determine whether or not ASDF resolves symlinks when defining systems.
2657 (defun resolve-symlinks* (path)
2658 (if *resolve-symlinks*
2659 (and path (resolve-symlinks path))
2663 ;;; Check pathname constraints
2664 (with-upgradability ()
2665 (defun ensure-pathname
2668 defaults type dot-dot
2670 want-logical want-physical ensure-physical
2671 want-relative want-absolute ensure-absolute ensure-subpath
2672 want-non-wild want-wild wilden
2673 want-file want-directory ensure-directory
2674 want-existing ensure-directories-exist
2675 truename resolve-symlinks truenamize
2676 &aux (p pathname)) ;; mutable working copy, preserve original
2677 "Coerces its argument into a PATHNAME,
2678 optionally doing some transformations and checking specified constraints.
2680 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
2682 If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
2683 reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
2684 then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
2685 and the all the checks and transformations are run.
2687 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
2688 The boolean T is an alias for ERROR.
2689 ERROR means that an error will be raised if the constraint is not satisfied.
2690 CERROR means that an continuable error will be raised if the constraint is not satisfied.
2691 IGNORE means just return NIL instead of the pathname.
2693 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
2694 that will be called with the the following arguments:
2695 a generic format string for ensure pathname, the pathname,
2696 the keyword argument corresponding to the failed check or transformation,
2697 a format string for the reason ENSURE-PATHNAME failed,
2698 and a list with arguments to that format string.
2699 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
2700 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
2702 The transformations and constraint checks are done in this order,
2703 which is also the order in the lambda-list:
2705 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
2706 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
2707 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
2708 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
2709 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
2710 WANT-RELATIVE checks that pathname has a relative directory component
2711 WANT-ABSOLUTE checks that pathname does have an absolute directory component
2712 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
2713 that the result absolute is an absolute pathname indeed.
2714 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
2715 WANT-FILE checks that pathname has a non-nil FILE component
2716 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
2717 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
2718 any file and type components as being actually a last directory component.
2719 WANT-NON-WILD checks that pathname is not a wild pathname
2720 WANT-WILD checks that pathname is a wild pathname
2721 WILDEN merges the pathname with **/*.*.* if it is not wild
2722 WANT-EXISTING checks that a file (or directory) exists with that pathname.
2723 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
2724 TRUENAME replaces the pathname by its truename, or errors if not possible.
2725 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
2726 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
2728 (flet ((report-error (keyword description &rest arguments)
2729 (call-function (or on-error 'error)
2730 "Invalid pathname ~S: ~*~?"
2731 pathname keyword description arguments)))
2732 (macrolet ((err (constraint &rest arguments)
2733 `(report-error ',(intern* constraint :keyword) ,@arguments))
2734 (check (constraint condition &rest arguments)
2736 (unless ,condition (err ,constraint ,@arguments))))
2737 (transform (transform condition expr)
2739 (,@(if condition `(when ,condition) '(progn))
2742 ((or null pathname))
2744 (setf p (parse-unix-namestring
2745 p :defaults defaults :type type :dot-dot dot-dot
2746 :ensure-directory ensure-directory :want-relative want-relative))))
2747 (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
2748 (unless (pathnamep p) (return nil))
2749 (check want-logical (logical-pathname-p p) "Expected a logical pathname")
2750 (check want-physical (physical-pathname-p p) "Expected a physical pathname")
2751 (transform ensure-physical () (translate-logical-pathname p))
2752 (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
2753 (check want-relative (relative-pathname-p p) "Expected a relative pathname")
2754 (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
2755 (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
2756 (check ensure-absolute (absolute-pathname-p p)
2757 "Could not make into an absolute pathname even after merging with ~S" defaults)
2758 (check ensure-subpath (absolute-pathname-p defaults)
2759 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
2760 (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
2761 (check want-file (file-pathname-p p) "Expected a file pathname")
2762 (check want-directory (directory-pathname-p p) "Expected a directory pathname")
2763 (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
2764 (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
2765 (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
2766 (transform wilden (not (wild-pathname-p p)) (wilden p))
2768 (let ((existing (probe-file* p :truename truename)))
2772 (err want-existing "Expected an existing pathname"))))
2773 (when ensure-directories-exist (ensure-directories-exist p))
2775 (let ((truename (truename* p)))
2778 (err truename "Can't get a truename for pathname"))))
2779 (transform resolve-symlinks () (resolve-symlinks p))
2780 (transform truenamize () (truenamize p))
2784 ;;; Pathname defaults
2785 (with-upgradability ()
2786 (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
2787 (or (absolute-pathname-p defaults)
2788 (merge-pathnames* defaults (getcwd))))
2790 (defun call-with-current-directory (dir thunk)
2792 (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
2793 (*default-pathname-defaults* dir)
2801 (defmacro with-current-directory ((&optional dir) &body body)
2802 "Call BODY while the POSIX current working directory is set to DIR"
2803 `(call-with-current-directory ,dir #'(lambda () ,@body))))
2806 ;;; Environment pathnames
2807 (with-upgradability ()
2808 (defun inter-directory-separator ()
2809 (if (os-unix-p) #\: #\;))
2811 (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
2812 (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
2813 :collect (apply 'parse-native-namestring namestring constraints)))
2815 (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
2816 (apply 'parse-native-namestring (getenvp x)
2817 :on-error (or on-error
2818 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
2820 (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
2821 (apply 'split-native-pathnames-string (getenvp x)
2822 :on-error (or on-error
2823 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
2825 (defun getenv-absolute-directory (x)
2826 (getenv-pathname x :want-absolute t :ensure-directory t))
2827 (defun getenv-absolute-directories (x)
2828 (getenv-pathnames x :want-absolute t :ensure-directory t))
2830 (defun lisp-implementation-directory (&key truename)
2831 (declare (ignorable truename))
2832 #+(or clozure ecl gcl mkcl sbcl)
2836 #+(or ecl mkcl) #p"SYS:"
2837 #+gcl system::*system-directory*
2838 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
2840 (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
2841 (if (and dir truename)
2845 (defun lisp-implementation-pathname-p (pathname)
2846 ;; Other builtin systems are those under the implementation directory
2848 (if-let (impdir (lisp-implementation-directory))
2849 (or (subpathp pathname impdir)
2850 (when *resolve-symlinks*
2851 (if-let (truename (truename* pathname))
2852 (if-let (trueimpdir (truename* impdir))
2853 (subpathp truename trueimpdir)))))))
2857 ;;; Simple filesystem operations
2858 (with-upgradability ()
2859 (defun ensure-all-directories-exist (pathnames)
2860 (dolist (pathname pathnames)
2861 (ensure-directories-exist (translate-logical-pathname pathname))))
2863 (defun rename-file-overwriting-target (source target)
2864 #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
2865 (posix:copy-file source target :method :rename)
2867 (rename-file source target
2868 #+clozure :if-exists #+clozure :rename-and-delete))
2870 (defun delete-file-if-exists (x)
2871 (when x (handler-case (delete-file x) (file-error () nil)))))
2874 ;;;; ---------------------------------------------------------------------------
2875 ;;;; Utilities related to streams
2877 (asdf/package:define-package :asdf/stream
2878 (:recycle :asdf/stream)
2879 (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem)
2881 #:*default-stream-element-type* #:*stderr* #:setup-stderr
2882 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
2883 #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
2884 #:*default-encoding* #:*utf-8-external-format*
2885 #:with-safe-io-syntax #:call-with-safe-io-syntax
2886 #:with-output #:output-string #:with-input
2887 #:with-input-file #:call-with-input-file
2888 #:finish-outputs #:format! #:safe-format!
2889 #:copy-stream-to-stream #:concatenate-files
2890 #:copy-stream-to-stream-line-by-line
2891 #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
2892 #:slurp-stream-forms #:slurp-stream-form
2893 #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
2894 #:eval-input #:eval-thunk #:standard-eval-thunk
2896 #:*temporary-directory* #:temporary-directory #:default-temporary-directory
2897 #:setup-temporary-directory
2898 #:call-with-temporary-file #:with-temporary-file
2899 #:add-pathname-suffix #:tmpize-pathname
2900 #:call-with-staging-pathname #:with-staging-pathname))
2901 (in-package :asdf/stream)
2903 (with-upgradability ()
2904 (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
2905 "default element-type for open (depends on the current CL implementation)")
2907 (defvar *stderr* *error-output*
2908 "the original error output stream at startup")
2910 (defun setup-stderr ()
2912 #+allegro excl::*stderr*
2913 #+clozure ccl::*stderr*
2914 #-(or allegro clozure) *error-output*))
2918 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
2919 (with-upgradability ()
2920 (defvar *default-encoding* :default
2921 "Default encoding for source files.
2922 The default value :default preserves the legacy behavior.
2923 A future default might be :utf-8 or :autodetect
2924 reading emacs-style -*- coding: utf-8 -*- specifications,
2925 and falling back to utf-8 or latin1 if nothing is specified.")
2927 (defparameter *utf-8-external-format*
2928 #+(and asdf-unicode (not clisp)) :utf-8
2929 #+(and asdf-unicode clisp) charset:utf-8
2930 #-asdf-unicode :default
2931 "Default :external-format argument to pass to CL:OPEN and also
2932 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
2933 On modern implementations, this will decode UTF-8 code points as CL characters.
2934 On legacy implementations, it may fall back on some 8-bit encoding,
2935 with non-ASCII code points being read as several CL characters;
2936 hopefully, if done consistently, that won't affect program behavior too much.")
2938 (defun always-default-encoding (pathname)
2939 (declare (ignore pathname))
2942 (defvar *encoding-detection-hook* #'always-default-encoding
2943 "Hook for an extension to define a function to automatically detect a file's encoding")
2945 (defun detect-encoding (pathname)
2946 (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
2947 (funcall *encoding-detection-hook* pathname)
2948 *default-encoding*))
2950 (defun default-encoding-external-format (encoding)
2952 (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
2953 (:utf-8 *utf-8-external-format*)
2955 (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
2958 (defvar *encoding-external-format-hook*
2959 #'default-encoding-external-format
2960 "Hook for an extension to define a mapping between non-default encodings
2961 and implementation-defined external-format's")
2963 (defun encoding-external-format (encoding)
2964 (funcall *encoding-external-format-hook* encoding)))
2968 (with-upgradability ()
2969 (defvar *standard-readtable* (copy-readtable nil))
2971 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
2972 "Establish safe CL reader options around the evaluation of BODY"
2973 `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
2975 (defun call-with-safe-io-syntax (thunk &key (package :cl))
2976 (with-standard-io-syntax
2977 (let ((*package* (find-package package))
2978 (*read-default-float-format* 'double-float)
2979 (*print-readably* nil)
2984 ;;; Output to a stream or string, FORMAT-style
2985 (with-upgradability ()
2986 (defun call-with-output (output function)
2987 "Calls FUNCTION with an actual stream argument,
2988 behaving like FORMAT with respect to how stream designators are interpreted:
2989 If OUTPUT is a stream, use it as the stream.
2990 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
2991 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
2992 If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
2993 Otherwise, signal an error."
2996 (with-output-to-string (stream) (funcall function stream)))
2998 (funcall function *standard-output*))
3000 (funcall function output))
3002 (assert (fill-pointer output))
3003 (with-output-to-string (stream output) (funcall function stream)))))
3005 (defmacro with-output ((output-var &optional (value output-var)) &body body)
3006 "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
3007 as per FORMAT, and evaluate BODY within the scope of this binding."
3008 `(call-with-output ,value #'(lambda (,output-var) ,@body)))
3010 (defun output-string (string &optional output)
3011 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
3013 (with-output (output) (princ string output))
3018 (with-upgradability ()
3019 (defun call-with-input (input function)
3020 "Calls FUNCTION with an actual stream argument, interpreting
3021 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
3022 If INPUT is a STREAM, use it as the stream.
3023 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
3024 If INPUT is T, use *TERMINAL-IO* as the stream.
3025 As an extension, if INPUT is a string, use it as a string-input-stream.
3026 Otherwise, signal an error."
3028 (null (funcall function *standard-input*))
3029 ((eql t) (funcall function *terminal-io*))
3030 (stream (funcall function input))
3031 (string (with-input-from-string (stream input) (funcall function stream)))))
3033 (defmacro with-input ((input-var &optional (value input-var)) &body body)
3034 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
3035 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
3036 `(call-with-input ,value #'(lambda (,input-var) ,@body)))
3038 (defun call-with-input-file (pathname thunk
3040 (element-type *default-stream-element-type*)
3041 (external-format *utf-8-external-format*)
3042 (if-does-not-exist :error))
3043 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
3044 Other keys are accepted but discarded."
3045 #+gcl2.6 (declare (ignore external-format))
3046 (with-open-file (s pathname :direction :input
3047 :element-type element-type
3048 #-gcl2.6 :external-format #-gcl2.6 external-format
3049 :if-does-not-exist if-does-not-exist)
3052 (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
3053 (declare (ignore element-type external-format))
3054 `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
3057 ;;; Ensure output buffers are flushed
3058 (with-upgradability ()
3059 (defun finish-outputs (&rest streams)
3060 "Finish output on the main output streams as well as any specified one.
3061 Useful for portably flushing I/O before user input or program exit."
3062 ;; CCL notably buffers its stream output by default.
3063 (dolist (s (append streams
3064 (list *stderr* *error-output* *standard-output* *trace-output*
3065 *debug-io* *terminal-io* *debug-io* *query-io*)))
3066 (ignore-errors (finish-output s)))
3069 (defun format! (stream format &rest args)
3070 "Just like format, but call finish-outputs before and after the output."
3071 (finish-outputs stream)
3072 (apply 'format stream format args)
3073 (finish-output stream))
3075 (defun safe-format! (stream format &rest args)
3076 (with-safe-io-syntax ()
3077 (ignore-errors (apply 'format! stream format args))
3078 (finish-outputs stream)))) ; just in case format failed
3081 ;;; Simple Whole-Stream processing
3082 (with-upgradability ()
3083 (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
3084 "Copy the contents of the INPUT stream into the OUTPUT stream.
3085 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
3086 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
3087 (with-open-stream (input input)
3089 (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
3091 (when prefix (princ prefix output))
3093 (unless eof (terpri output))
3094 (finish-output output)
3095 (when eof (return)))
3097 :with buffer-size = (or buffer-size 8192)
3098 :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
3099 :for end = (read-sequence buffer input)
3101 :do (write-sequence buffer output :end end)
3102 (when (< end buffer-size) (return))))))
3104 (defun concatenate-files (inputs output)
3105 (with-open-file (o output :element-type '(unsigned-byte 8)
3106 :direction :output :if-exists :rename-and-delete)
3107 (dolist (input inputs)
3108 (with-open-file (i input :element-type '(unsigned-byte 8)
3109 :direction :input :if-does-not-exist :error)
3110 (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
3112 (defun slurp-stream-string (input &key (element-type 'character))
3113 "Read the contents of the INPUT stream as a string"
3114 (with-open-stream (input input)
3115 (with-output-to-string (output)
3116 (copy-stream-to-stream input output :element-type element-type))))
3118 (defun slurp-stream-lines (input &key count)
3119 "Read the contents of the INPUT stream as a list of lines, return those lines.
3121 Read no more than COUNT lines."
3122 (check-type count (or null integer))
3123 (with-open-stream (input input)
3124 (loop :for n :from 0
3125 :for l = (and (or (not count) (< n count))
3126 (read-line input nil nil))
3127 :while l :collect l)))
3129 (defun slurp-stream-line (input &key (at 0))
3130 "Read the contents of the INPUT stream as a list of lines,
3131 then return the ACCESS-AT of that list of lines using the AT specifier.
3132 PATH defaults to 0, i.e. return the first line.
3133 PATH is typically an integer, or a list of an integer and a function.
3134 If PATH is NIL, it will return all the lines in the file.
3136 The stream will not be read beyond the Nth lines,
3137 where N is the index specified by path
3138 if path is either an integer or a list that starts with an integer."
3139 (access-at (slurp-stream-lines input :count (access-at-count at)) at))
3141 (defun slurp-stream-forms (input &key count)
3142 "Read the contents of the INPUT stream as a list of forms,
3143 and return those forms.
3145 If COUNT is null, read to the end of the stream;
3146 if COUNT is an integer, stop after COUNT forms were read.
3148 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3149 (check-type count (or null integer))
3150 (loop :with eof = '#:eof
3152 :for form = (if (and count (>= n count))
3154 (read-preserving-whitespace input nil eof))
3155 :until (eq form eof) :collect form))
3157 (defun slurp-stream-form (input &key (at 0))
3158 "Read the contents of the INPUT stream as a list of forms,
3159 then return the ACCESS-AT of these forms following the AT.
3160 AT defaults to 0, i.e. return the first form.
3161 AT is typically a list of integers.
3162 If AT is NIL, it will return all the forms in the file.
3164 The stream will not be read beyond the Nth form,
3165 where N is the index specified by path,
3166 if path is either an integer or a list that starts with an integer.
3168 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3169 (access-at (slurp-stream-forms input :count (access-at-count at)) at))
3171 (defun read-file-string (file &rest keys)
3172 "Open FILE with option KEYS, read its contents as a string"
3173 (apply 'call-with-input-file file 'slurp-stream-string keys))
3175 (defun read-file-lines (file &rest keys)
3176 "Open FILE with option KEYS, read its contents as a list of lines
3177 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3178 (apply 'call-with-input-file file 'slurp-stream-lines keys))
3180 (defun read-file-forms (file &rest keys &key count &allow-other-keys)
3181 "Open input FILE with option KEYS (except COUNT),
3182 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
3183 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3184 (apply 'call-with-input-file file
3185 #'(lambda (input) (slurp-stream-forms input :count count))
3186 (remove-plist-key :count keys)))
3188 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
3189 "Open input FILE with option KEYS (except AT),
3190 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
3191 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
3192 (apply 'call-with-input-file file
3193 #'(lambda (input) (slurp-stream-form input :at at))
3194 (remove-plist-key :at keys)))
3196 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
3197 "Reads the specified form from the top of a file using a safe standardized syntax.
3198 Extracts the form using READ-FILE-FORM,
3199 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
3200 (with-safe-io-syntax (:package package)
3201 (apply 'read-file-form pathname (remove-plist-key :package keys))))
3203 (defun eval-input (input)
3204 "Portably read and evaluate forms from INPUT, return the last values."
3206 (loop :with results :with eof ='#:eof
3207 :for form = (read input nil eof)
3208 :until (eq form eof)
3209 :do (setf results (multiple-value-list (eval form)))
3210 :finally (return (apply 'values results)))))
3212 (defun eval-thunk (thunk)
3213 "Evaluate a THUNK of code:
3214 If a function, FUNCALL it without arguments.
3215 If a constant literal and not a sequence, return it.
3216 If a cons or a symbol, EVAL it.
3217 If a string, repeatedly read and evaluate from it, returning the last values."
3219 ((or boolean keyword number character pathname) thunk)
3220 ((or cons symbol) (eval thunk))
3221 (function (funcall thunk))
3222 (string (eval-input thunk))))
3224 (defun standard-eval-thunk (thunk &key (package :cl))
3225 "Like EVAL-THUNK, but in a more standardized evaluation context."
3226 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
3228 (with-safe-io-syntax (:package package)
3229 (let ((*read-eval* t))
3230 (eval-thunk thunk))))))
3233 ;;; Using temporary files
3234 (with-upgradability ()
3235 (defun default-temporary-directory ()
3238 (or (getenv-pathname "TMPDIR" :ensure-directory t)
3239 (parse-native-namestring "/tmp/")))
3240 (when (os-windows-p)
3241 (getenv-pathname "TEMP" :ensure-directory t))
3242 (subpathname (user-homedir-pathname) "tmp/")))
3244 (defvar *temporary-directory* nil)
3246 (defun temporary-directory ()
3247 (or *temporary-directory* (default-temporary-directory)))
3249 (defun setup-temporary-directory ()
3250 (setf *temporary-directory* (default-temporary-directory))
3251 ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
3252 #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
3254 (defun call-with-temporary-file
3256 prefix keep (direction :io)
3257 (element-type *default-stream-element-type*)
3258 (external-format :default))
3259 #+gcl2.6 (declare (ignorable external-format))
3260 (check-type direction (member :output :io))
3262 :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
3263 :for counter :from (random (ash 1 32))
3264 :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
3265 ;; TODO: on Unix, do something about umask
3266 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
3267 ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
3268 (with-open-file (stream pathname
3269 :direction direction
3270 :element-type element-type
3271 #-gcl2.6 :external-format #-gcl2.6 external-format
3272 :if-exists nil :if-does-not-exist :create)
3276 (funcall thunk stream pathname)
3278 (funcall thunk stream pathname)
3279 (ignore-errors (delete-file pathname)))))))))
3281 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
3282 (pathname (gensym "PATHNAME") pathnamep)
3283 prefix keep direction element-type external-format)
3285 "Evaluate BODY where the symbols specified by keyword arguments
3286 STREAM and PATHNAME are bound corresponding to a newly created temporary file
3287 ready for I/O. Unless KEEP is specified, delete the file afterwards."
3288 (check-type stream symbol)
3289 (check-type pathname symbol)
3290 `(flet ((think (,stream ,pathname)
3291 ,@(unless pathnamep `((declare (ignore ,pathname))))
3292 ,@(unless streamp `((when ,stream (close ,stream))))
3294 #-gcl (declare (dynamic-extent #'think))
3295 (call-with-temporary-file
3297 ,@(when direction `(:direction ,direction))
3298 ,@(when prefix `(:prefix ,prefix))
3299 ,@(when keep `(:keep ,keep))
3300 ,@(when element-type `(:element-type ,element-type))
3301 ,@(when external-format `(:external-format external-format)))))
3303 ;; Temporary pathnames in simple cases where no contention is assumed
3304 (defun add-pathname-suffix (pathname suffix)
3305 (make-pathname :name (strcat (pathname-name pathname) suffix)
3306 :defaults pathname))
3308 (defun tmpize-pathname (x)
3309 (add-pathname-suffix x "-ASDF-TMP"))
3311 (defun call-with-staging-pathname (pathname fun)
3312 "Calls fun with a staging pathname, and atomically
3313 renames the staging pathname to the pathname in the end.
3314 Note: this protects only against failure of the program,
3315 not against concurrent attempts.
3316 For the latter case, we ought pick random suffix and atomically open it."
3317 (let* ((pathname (pathname pathname))
3318 (staging (tmpize-pathname pathname)))
3320 (multiple-value-prog1
3321 (funcall fun staging)
3322 (rename-file-overwriting-target staging pathname))
3323 (delete-file-if-exists staging))))
3325 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
3326 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
3328 ;;;; -------------------------------------------------------------------------
3329 ;;;; Starting, Stopping, Dumping a Lisp image
3331 (asdf/package:define-package :asdf/image
3332 (:recycle :asdf/image :xcvb-driver)
3333 (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
3335 #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
3336 #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
3337 #:*lisp-interaction*
3338 #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
3339 #:call-with-fatal-condition-handler #:with-fatal-condition-handler
3340 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
3341 #:*image-postlude* #:*image-dump-hook*
3342 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
3343 #:shell-boolean-exit
3344 #:register-image-restore-hook #:register-image-dump-hook
3345 #:call-image-restore-hook #:call-image-dump-hook
3346 #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
3348 (in-package :asdf/image)
3350 (with-upgradability ()
3351 (defvar *lisp-interaction* t
3352 "Is this an interactive Lisp environment, or is it batch processing?")
3354 (defvar *command-line-arguments* nil
3355 "Command-line arguments")
3357 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
3358 "Is this a dumped image? As a standalone executable?")
3360 (defvar *image-restore-hook* nil
3361 "Functions to call (in reverse order) when the image is restored")
3363 (defvar *image-prelude* nil
3364 "a form to evaluate, or string containing forms to read and evaluate
3365 when the image is restarted, but before the entry point is called.")
3367 (defvar *image-entry-point* nil
3368 "a function with which to restart the dumped image when execution is restored from it.")
3370 (defvar *image-postlude* nil
3371 "a form to evaluate, or string containing forms to read and evaluate
3372 before the image dump hooks are called and before the image is dumped.")
3374 (defvar *image-dump-hook* nil
3375 "Functions to call (in order) when before an image is dumped")
3377 (defvar *fatal-conditions* '(error)
3378 "conditions that cause the Lisp image to enter the debugger if interactive,
3379 or to die if not interactive"))
3382 ;;; Exiting properly or im-
3383 (with-upgradability ()
3384 (defun quit (&optional (code 0) (finish-output t))
3385 "Quits from the Lisp world, with the given exit status if provided.
3386 This is designed to abstract away the implementation specific quit forms."
3387 (when finish-output ;; essential, for ClozureCL, and for standard compliance.
3389 #+(or abcl xcl) (ext:quit :status code)
3390 #+allegro (excl:exit code :quiet t)
3391 #+clisp (ext:quit code)
3392 #+clozure (ccl:quit code)
3393 #+cormanlisp (win32:exitprocess code)
3394 #+(or cmu scl) (unix:unix-exit code)
3395 #+ecl (si:quit code)
3396 #+gcl (lisp:quit code)
3397 #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
3398 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
3399 #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
3400 #+mkcl (mk-ext:quit :exit-code code)
3401 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
3402 (quit (find-symbol* :quit :sb-ext nil)))
3404 (exit `(,exit :code code :abort (not finish-output)))
3405 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
3406 #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
3407 (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
3409 (defun die (code format &rest arguments)
3410 "Die in error with some error message"
3411 (with-safe-io-syntax ()
3413 (fresh-line *stderr*)
3414 (apply #'format *stderr* format arguments)
3415 (format! *stderr* "~&")))
3418 (defun raw-print-backtrace (&key (stream *debug-io*) count)
3419 "Print a backtrace, directly accessing the implementation"
3420 (declare (ignorable stream count))
3422 (let ((*debug-io* stream)) (top-level::backtrace-command count))
3424 (let ((*terminal-io* stream)
3425 (*standard-output* stream)
3426 (tpl:*zoom-print-circle* *print-circle*)
3427 (tpl:*zoom-print-level* *print-level*)
3428 (tpl:*zoom-print-length* *print-length*))
3429 (tpl:do-command "zoom"
3430 :from-read-eval-print-loop nil
3434 (system::print-backtrace :out stream :limit count)
3436 (let ((*debug-io* stream))
3437 (ccl:print-call-history :count count :start-frame-number 1)
3438 (finish-output stream))
3440 (let ((debug:*debug-print-level* *print-level*)
3441 (debug:*debug-print-length* *print-length*))
3442 (debug:backtrace most-positive-fixnum stream))
3446 (let ((dbg::*debugger-stack*
3447 (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
3449 (dbg:*debug-print-level* *print-level*)
3450 (dbg:*debug-print-length* *print-length*))
3451 (dbg:bug-backtrace nil))
3454 #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
3457 (defun print-backtrace (&rest keys &key stream count)
3458 (declare (ignore stream count))
3459 (with-safe-io-syntax (:package :cl)
3460 (let ((*print-readably* nil)
3462 (*print-miser-width* 75)
3463 (*print-length* nil)
3466 (ignore-errors (apply 'raw-print-backtrace keys)))))
3468 (defun print-condition-backtrace (condition &key (stream *stderr*) count)
3469 ;; We print the condition *after* the backtrace,
3470 ;; for the sake of who sees the backtrace at a terminal.
3471 ;; It is up to the caller to print the condition *before*, with some context.
3472 (print-backtrace :stream stream :count count)
3474 (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
3477 (defun fatal-condition-p (condition)
3478 (match-any-condition-p condition *fatal-conditions*))
3480 (defun handle-fatal-condition (condition)
3481 "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
3484 (invoke-debugger condition))
3486 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
3487 (print-condition-backtrace condition :stream *stderr*)
3488 (die 99 "~A" condition))))
3490 (defun call-with-fatal-condition-handler (thunk)
3491 (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
3494 (defmacro with-fatal-condition-handler ((&optional) &body body)
3495 `(call-with-fatal-condition-handler #'(lambda () ,@body)))
3497 (defun shell-boolean-exit (x)
3498 "Quit with a return code that is 0 iff argument X is true"
3502 ;;; Using image hooks
3503 (with-upgradability ()
3504 (defun register-image-restore-hook (hook &optional (call-now-p t))
3505 (register-hook-function '*image-restore-hook* hook call-now-p))
3507 (defun register-image-dump-hook (hook &optional (call-now-p nil))
3508 (register-hook-function '*image-dump-hook* hook call-now-p))
3510 (defun call-image-restore-hook ()
3511 (call-functions (reverse *image-restore-hook*)))
3513 (defun call-image-dump-hook ()
3514 (call-functions *image-dump-hook*)))
3517 ;;; Proper command-line arguments
3518 (with-upgradability ()
3519 (defun raw-command-line-arguments ()
3520 "Find what the actual command line for this process was."
3521 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
3522 #+allegro (sys:command-line-arguments) ; default: :application t
3523 #+clisp (coerce (ext:argv) 'list)
3524 #+clozure (ccl::command-line-arguments)
3525 #+(or cmu scl) extensions:*command-line-strings*
3526 #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
3527 #+gcl si:*command-args*
3529 #+lispworks sys:*line-arguments-list*
3530 #+sbcl sb-ext:*posix-argv*
3532 #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
3533 (error "raw-command-line-arguments not implemented yet"))
3535 (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
3536 "Extract user arguments from command-line invocation of current process.
3537 Assume the calling conventions of a generated script that uses --
3538 if we are not called from a directly executable image."
3541 (let* (#-(or sbcl allegro)
3543 (if (eq *image-dumped-p* :executable)
3545 (member "--" arguments :test 'string-equal))))
3548 (defun setup-command-line-arguments ()
3549 (setf *command-line-arguments* (command-line-arguments)))
3551 (defun restore-image (&key
3552 ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
3553 ((:restore-hook *image-restore-hook*) *image-restore-hook*)
3554 ((:prelude *image-prelude*) *image-prelude*)
3555 ((:entry-point *image-entry-point*) *image-entry-point*))
3556 (with-fatal-condition-handler ()
3557 (call-image-restore-hook)
3558 (standard-eval-thunk *image-prelude*)
3559 (let ((results (multiple-value-list
3560 (if *image-entry-point*
3561 (call-function *image-entry-point*)
3563 (if *lisp-interaction*
3564 (apply 'values results)
3565 (shell-boolean-exit (first results)))))))
3568 ;;; Dumping an image
3570 (with-upgradability ()
3572 (defun dump-image (filename &key output-name executable
3573 ((:postlude *image-postlude*) *image-postlude*)
3574 ((:dump-hook *image-dump-hook*) *image-dump-hook*))
3575 (declare (ignorable filename output-name executable))
3576 (setf *image-dumped-p* (if executable :executable t))
3577 (standard-eval-thunk *image-postlude*)
3578 (call-image-dump-hook)
3579 #-(or clisp clozure cmu lispworks sbcl scl)
3581 (error "Dumping an executable is not supported on this implementation! Aborting."))
3584 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
3585 (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
3587 (apply #'ext:saveinitmem filename
3589 :start-package *package*
3590 :keep-global-handlers nil
3591 :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
3594 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
3595 :norc t :script nil :init-function #'restore-image)))
3597 (ccl:save-application filename :prepend-kernel t
3598 :toplevel-function (when executable #'restore-image))
3602 (setf ext:*batch-mode* nil)
3603 (setf ext::*gc-run-time* 0)
3604 (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
3605 (when executable '(:init-function restore-image :process-command-line nil))))
3608 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
3609 (si::save-system filename))
3612 (lispworks:deliver 'restore-image filename 0 :interface nil)
3613 (hcl:save-image filename :environment nil))
3616 ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
3617 (setf sb-ext::*gc-run-time* 0)
3618 (apply 'sb-ext:save-lisp-and-die filename
3619 :executable t ;--- always include the runtime that goes with the core
3620 (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
3621 #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
3622 (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
3623 filename (nth-value 1 (implementation-type))))
3627 (defun create-image (destination object-files
3628 &key kind output-name prologue-code epilogue-code
3629 (prelude () preludep) (entry-point () entry-point-p) build-args)
3630 ;; Is it meaningful to run these in the current environment?
3631 ;; only if we also track the object files that constitute the "current" image,
3632 ;; and otherwise simulate dump-image, including quitting at the end.
3633 ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
3634 (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
3636 kind (pathname destination)
3637 :lisp-files object-files
3638 :init-name (c::compute-init-name (or output-name destination) :kind kind)
3639 :prologue-code prologue-code
3643 ,@(when (eq kind :program)
3644 `((setf *image-dumped-p* :executable)
3645 (restore-image ;; default behavior would be (si::top-level)
3646 ,@(when preludep `(:prelude ',prelude))
3647 ,@(when entry-point-p `(:entry-point ',entry-point))))))
3651 ;;; Some universal image restore hooks
3652 (with-upgradability ()
3653 (map () 'register-image-restore-hook
3654 '(setup-temporary-directory setup-stderr setup-command-line-arguments
3656 ;;;; -------------------------------------------------------------------------
3657 ;;;; run-program initially from xcvb-driver.
3659 (asdf/package:define-package :asdf/run-program
3660 (:recycle :asdf/run-program :xcvb-driver)
3661 (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream)
3663 ;;; Escaping the command invocation madness
3664 #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
3665 #:escape-windows-token #:escape-windows-command
3666 #:escape-token #:escape-command
3669 #:slurp-input-stream
3672 #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
3674 (in-package :asdf/run-program)
3676 ;;;; ----- Escaping strings for the shell -----
3678 (with-upgradability ()
3679 (defun requires-escaping-p (token &key good-chars bad-chars)
3680 "Does this token require escaping, given the specification of
3681 either good chars that don't need escaping or bad chars that do need escaping,
3682 as either a recognizing function or a sequence of characters."
3685 ((and good-chars bad-chars)
3686 (error "only one of good-chars and bad-chars can be provided"))
3687 ((functionp good-chars)
3688 (complement good-chars))
3689 ((functionp bad-chars)
3691 ((and good-chars (typep good-chars 'sequence))
3692 #'(lambda (c) (not (find c good-chars))))
3693 ((and bad-chars (typep bad-chars 'sequence))
3694 #'(lambda (c) (find c bad-chars)))
3695 (t (error "requires-escaping-p: no good-char criterion")))
3698 (defun escape-token (token &key stream quote good-chars bad-chars escaper)
3699 "Call the ESCAPER function on TOKEN string if it needs escaping as per
3700 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
3701 using STREAM as output (or returning result as a string if NIL)"
3702 (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
3703 (with-output (stream)
3704 (apply escaper token stream (when quote `(:quote ,quote))))
3705 (output-string token stream)))
3707 (defun escape-windows-token-within-double-quotes (x &optional s)
3708 "Escape a string token X within double-quotes
3709 for use within a MS Windows command-line, outputing to S."
3710 (labels ((issue (c) (princ c s))
3711 (issue-backslash (n) (loop :repeat n :do (issue #\\))))
3713 :initially (issue #\") :finally (issue #\")
3714 :with l = (length x) :with i = 0
3715 :for i+1 = (1+ i) :while (< i l) :do
3717 ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
3719 (let* ((j (and (< i+1 l) (position-if-not
3720 #'(lambda (c) (eql c #\\)) x :start i+1)))
3724 (issue-backslash (* 2 n)) (setf i l))
3725 ((and (< j l) (eql (char x j) #\"))
3726 (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
3728 (issue-backslash n) (setf i j)))))
3730 (issue (char x i)) (setf i i+1))))))
3732 (defun escape-windows-token (token &optional s)
3733 "Escape a string TOKEN within double-quotes if needed
3734 for use within a MS Windows command-line, outputing to S."
3735 (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
3736 :escaper 'escape-windows-token-within-double-quotes))
3738 (defun escape-sh-token-within-double-quotes (x s &key (quote t))
3739 "Escape a string TOKEN within double-quotes
3740 for use within a POSIX Bourne shell, outputing to S;
3741 omit the outer double-quotes if key argument :QUOTE is NIL"
3742 (when quote (princ #\" s))
3743 (loop :for c :across x :do
3744 (when (find c "$`\\\"") (princ #\\ s))
3746 (when quote (princ #\" s)))
3748 (defun easy-sh-character-p (x)
3749 (or (alphanumericp x) (find x "+-_.,%@:/")))
3751 (defun escape-sh-token (token &optional s)
3752 "Escape a string TOKEN within double-quotes if needed
3753 for use within a POSIX Bourne shell, outputing to S."
3754 (escape-token token :stream s :quote #\" :good-chars
3755 #'easy-sh-character-p
3756 :escaper 'escape-sh-token-within-double-quotes))
3758 (defun escape-shell-token (token &optional s)
3760 ((os-unix-p) (escape-sh-token token s))
3761 ((os-windows-p) (escape-windows-token token s))))
3763 (defun escape-command (command &optional s
3764 (escaper 'escape-shell-token))
3765 "Given a COMMAND as a list of tokens, return a string of the
3766 spaced, escaped tokens, using ESCAPER to escape."
3768 (string (output-string command s))
3769 (list (with-output (s)
3770 (loop :for first = t :then nil :for token :in command :do
3771 (unless first (princ #\space s))
3772 (funcall escaper token s))))))
3774 (defun escape-windows-command (command &optional s)
3775 "Escape a list of command-line arguments into a string suitable for parsing
3776 by CommandLineToArgv in MS Windows"
3777 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
3778 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
3779 (escape-command command s 'escape-windows-token))
3781 (defun escape-sh-command (command &optional s)
3782 "Escape a list of command-line arguments into a string suitable for parsing
3783 by /bin/sh in POSIX"
3784 (escape-command command s 'escape-sh-token))
3786 (defun escape-shell-command (command &optional stream)
3787 "Escape a command for the current operating system's shell"
3788 (escape-command command stream 'escape-shell-token)))
3791 ;;;; Slurping a stream, typically the output of another program
3792 (with-upgradability ()
3793 (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
3795 #-(or gcl2.6 genera)
3796 (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
3797 (funcall function input-stream))
3799 (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
3800 (apply (first list) (cons input-stream (rest list))))
3802 #-(or gcl2.6 genera)
3803 (defmethod slurp-input-stream ((output-stream stream) input-stream
3804 &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
3805 (copy-stream-to-stream
3806 input-stream output-stream
3807 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
3809 (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
3810 (declare (ignorable x))
3811 (slurp-stream-string stream))
3813 (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
3814 (declare (ignorable x))
3815 (slurp-stream-string stream))
3817 (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
3818 (declare (ignorable x))
3819 (slurp-stream-lines stream :count count))
3821 (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
3822 (declare (ignorable x))
3823 (slurp-stream-line stream :at at))
3825 (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
3826 (declare (ignorable x))
3827 (slurp-stream-forms stream :count count))
3829 (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
3830 (declare (ignorable x))
3831 (slurp-stream-form stream :at at))
3833 (defmethod slurp-input-stream (x stream
3834 &key linewise prefix (element-type 'character) buffer-size
3836 (declare (ignorable stream linewise prefix element-type buffer-size))
3838 #+(or gcl2.6 genera)
3839 ((functionp x) (funcall x stream))
3840 #+(or gcl2.6 genera)
3841 ((output-stream-p x)
3842 (copy-stream-to-stream
3843 input-stream output-stream
3844 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
3846 (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
3849 ;;;; ----- Running an external program -----
3850 ;;; Simple variant of run-program with no input, and capturing output
3851 ;;; On some implementations, may output to a temporary file...
3852 (with-upgradability ()
3853 (define-condition subprocess-error (error)
3854 ((code :initform nil :initarg :code :reader subprocess-error-code)
3855 (command :initform nil :initarg :command :reader subprocess-error-command)
3856 (process :initform nil :initarg :process :reader subprocess-error-process))
3857 (:report (lambda (condition stream)
3858 (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
3859 (subprocess-error-process condition)
3860 (subprocess-error-command condition)
3861 (subprocess-error-code condition)))))
3863 (defun run-program (command
3864 &key output ignore-error-status force-shell
3865 (element-type *default-stream-element-type*)
3866 (external-format :default)
3868 "Run program specified by COMMAND,
3869 either a list of strings specifying a program and list of arguments,
3870 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
3871 have its output processed by the OUTPUT processor function
3872 as per SLURP-INPUT-STREAM,
3873 or merely output to the inherited standard output if it's NIL.
3874 Always call a shell (rather than directly execute the command)
3875 if FORCE-SHELL is specified.
3876 Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
3878 Return the exit status code of the process that was called.
3879 Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
3880 (declare (ignorable ignore-error-status element-type external-format))
3881 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
3882 (error "RUN-PROGRAM not implemented for this Lisp")
3883 (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
3884 (run-program (command &key pipe interactive)
3885 "runs the specified command (a list of program and arguments).
3886 If using a pipe, returns two values: process and stream
3887 If not using a pipe, returns one values: the process result;
3888 also, inherits the output stream."
3889 ;; NB: these implementations have unix vs windows set at compile-time.
3890 (assert (not (and pipe interactive)))
3891 (let* ((wait (not pipe))
3892 #-(and clisp os-windows)
3895 #+os-unix (string `("/bin/sh" "-c" ,command))
3896 #+os-unix (list command)
3899 ;; NB: We do NOT add cmd /c here. You might want to.
3901 ;; On ClozureCL for Windows, we assume you are using
3902 ;; r15398 or later in 1.9 or later,
3903 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
3904 #+clozure (cons "cmd" (strcat "/c " command))
3905 ;; NB: On other Windows implementations, this is utterly bogus
3906 ;; except in the most trivial cases where no quoting is needed.
3907 ;; Use at your own risk.
3908 #-(or allegro clozure) (list "cmd" "/c" command))
3911 #+(or allegro clozure) (escape-windows-command command)
3912 #-(or allegro clozure) command)))
3913 #+(and clozure os-windows) (command (list command))
3915 (multiple-value-list
3917 (excl:run-shell-command
3918 #+os-unix (coerce (cons (first command) command) 'vector)
3919 #+os-windows command
3920 :input interactive :output (or (and pipe :stream) interactive) :wait wait
3921 #+os-windows :show-window #+os-windows (and pipe :hide))
3923 (flet ((run (f &rest args)
3924 (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
3925 ,(if pipe :stream :terminal)))))
3927 #+os-windows (run 'ext:run-shell-command command)
3928 (list (run 'ext:run-program (car command)
3929 :arguments (cdr command)))))
3931 (system:run-shell-command
3932 (cons "/usr/bin/env" command) ; lispworks wants a full path.
3933 :input interactive :output (or (and pipe :stream) interactive)
3934 :wait wait :save-exit-status (and pipe t))
3935 #+(or clozure cmu ecl sbcl scl)
3936 (#+(or cmu ecl scl) ext:run-program
3937 #+clozure ccl:run-program
3938 #+sbcl sb-ext:run-program
3939 (car command) (cdr command)
3940 :input interactive :wait wait
3941 :output (if pipe :stream t)
3943 #+(or clozure cmu ecl sbcl scl) '(:error t)
3944 ;; note: :external-format requires a recent SBCL
3945 #+sbcl '(:search t :external-format external-format)))))
3947 #+(or allegro lispworks) (if pipe (third process*) (first process*))
3948 #+ecl (third process*)
3949 #-(or allegro lispworks ecl) (first process*))
3952 #+(or allegro lispworks ecl) (first process*)
3953 #+clisp (first process*)
3954 #+clozure (ccl::external-process-output process)
3955 #+(or cmu scl) (ext:process-output process)
3956 #+sbcl (sb-ext:process-output process))))
3957 (values process stream)))
3958 #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
3959 (process-result (process pipe)
3960 (declare (ignorable pipe))
3962 #+(and clozure os-unix) (ccl::external-process-wait process)
3963 #+(or cmu scl) (ext:process-wait process)
3964 #+(and ecl os-unix) (ext:external-process-wait process)
3965 #+sbcl (sb-ext:process-wait process)
3966 ;; 2- extract result
3967 #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
3969 #+clozure (nth-value 1 (ccl:external-process-status process))
3970 #+(or cmu scl) (ext:process-exit-code process)
3971 #+ecl (nth-value 1 (ext:external-process-status process))
3972 #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
3973 #+sbcl (sb-ext:process-exit-code process))
3974 (check-result (exit-code process)
3977 (typecase exit-code (integer exit-code) (null 0) (t -1)))
3978 (unless (or ignore-error-status
3979 (equal exit-code 0))
3980 (error 'subprocess-error :command command :code exit-code :process process))
3983 #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
3984 (let* ((interactive (eq output :interactive))
3985 (pipe (and output (not interactive))))
3986 (multiple-value-bind (process stream)
3987 (run-program command :pipe pipe :interactive interactive)
3988 (if (and output (not interactive))
3990 (slurp-input-stream output stream)
3991 (when stream (close stream))
3992 (check-result (process-result process pipe) process))
3995 #+(or allegro lispworks) ; when not capturing, returns the exit code!
3997 #-(or allegro lispworks) (process-result process pipe)
3999 (system-command (command)
4001 (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
4002 (list (escape-shell-command
4003 (if (os-unix-p) (cons "exec" command) command)))))
4004 (redirected-system-command (command out)
4005 (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
4006 (system-command command) (native-namestring out)))
4007 (system (command &key interactive)
4008 (declare (ignorable interactive))
4009 #+(or abcl xcl) (ext:run-shell-command command)
4011 (excl:run-shell-command command :input interactive :output interactive :wait t)
4012 #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
4013 (process-result (run-program command :pipe nil :interactive interactive) nil)
4014 #+ecl (ext:system command)
4015 #+cormanlisp (win32:system command)
4016 #+gcl (lisp:system command)
4017 #+(and lispworks os-windows)
4018 (system:call-system-showing-output
4019 command :show-cmd interactive :prefix "" :output-stream nil)
4020 #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
4022 (mkcl:run-program #+windows command #+windows ()
4023 #-windows "/bin/sh" (list "-c" command)
4024 :input nil :output nil)))
4025 (call-system (command-string &key interactive)
4026 (check-result (system command-string :interactive interactive) nil))
4028 (let ((interactive (eq output :interactive)))
4029 (if (and output (not interactive))
4030 (with-temporary-file (:pathname tmp :direction :output)
4031 (call-system (redirected-system-command command tmp))
4032 (with-open-file (stream tmp
4034 :if-does-not-exist :error
4035 :element-type element-type
4036 #-gcl2.6 :external-format #-gcl2.6 external-format)
4037 (slurp-input-stream output stream)))
4038 (call-system (system-command command) :interactive interactive)))))
4039 (if (and (not force-shell)
4040 #+(or clisp ecl) ignore-error-status
4041 #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
4045 ;;;; -------------------------------------------------------------------------
4046 ;;;; Support to build (compile and load) Lisp files
4048 (asdf/package:define-package :asdf/lisp-build
4049 (:recycle :asdf/interface :asdf :asdf/lisp-build)
4050 (:use :asdf/common-lisp :asdf/package :asdf/utility
4051 :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
4054 #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
4055 #:*output-translation-function*
4056 #:*optimization-settings* #:*previous-optimization-settings*
4057 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
4058 #:compile-warned-warning #:compile-failed-warning
4059 #:check-lisp-compile-results #:check-lisp-compile-warnings
4060 #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
4061 ;; Functions & Macros
4062 #:get-optimization-settings #:proclaim-optimization-settings
4063 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
4064 #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
4065 #:reify-simple-sexp #:unreify-simple-sexp
4066 #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
4067 #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
4068 #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
4069 #:current-lisp-file-pathname #:load-pathname
4070 #:lispize-pathname #:compile-file-type #:call-around-hook
4071 #:compile-file* #:compile-file-pathname*
4072 #:load* #:load-from-string #:combine-fasls)
4073 (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
4074 (in-package :asdf/lisp-build)
4076 (with-upgradability ()
4077 (defvar *compile-file-warnings-behaviour*
4078 (or #+clisp :ignore :warn)
4079 "How should ASDF react if it encounters a warning when compiling a file?
4080 Valid values are :error, :warn, and :ignore.")
4082 (defvar *compile-file-failure-behaviour*
4083 (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
4084 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
4085 when compiling a file, which includes any non-style-warning warning.
4086 Valid values are :error, :warn, and :ignore.
4087 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
4090 ;;; Optimization settings
4091 (with-upgradability ()
4092 (defvar *optimization-settings* nil)
4093 (defvar *previous-optimization-settings* nil)
4094 (defun get-optimization-settings ()
4095 "Get current compiler optimization settings, ready to PROCLAIM again"
4096 (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
4097 #-(or clisp clozure cmu ecl sbcl scl)
4098 (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
4099 #.`(loop :for x :in settings
4100 ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
4101 #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
4102 #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
4103 :for y = (or #+clisp (gethash x system::*optimize*)
4104 #+(or clozure ecl) (symbol-value v)
4105 #+(or cmu scl) (funcall f c::*default-cookie*)
4106 #+sbcl (cdr (assoc x sb-c::*policy*)))
4107 :when y :collect (list x y))))
4108 (defun proclaim-optimization-settings ()
4109 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
4110 (proclaim `(optimize ,@*optimization-settings*))
4111 (let ((settings (get-optimization-settings)))
4112 (unless (equal *previous-optimization-settings* settings)
4113 (setf *previous-optimization-settings* settings)))))
4116 ;;; Condition control
4117 (with-upgradability ()
4120 (defun sb-grovel-unknown-constant-condition-p (c)
4121 (and (typep c 'sb-int:simple-style-warning)
4123 "Couldn't grovel for "
4124 (simple-condition-format-control c)
4125 " (unknown to the C compiler).")))
4126 (deftype sb-grovel-unknown-constant-condition ()
4127 '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
4129 (defvar *uninteresting-compiler-conditions*
4131 ;;#+clozure '(ccl:compiler-warning)
4132 #+cmu '("Deleting unreachable code.")
4133 #+lispworks '("~S being redefined in ~A (previously in ~A)."
4134 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
4136 '(sb-c::simple-compiler-note
4137 "&OPTIONAL and &KEY found in the same lambda list: ~S"
4138 sb-int:package-at-variance
4139 sb-kernel:uninteresting-redefinition
4140 sb-kernel:undefined-alien-style-warning
4141 ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
4142 #+sb-eval sb-kernel:lexical-environment-too-complex
4143 sb-grovel-unknown-constant-condition ; defined above.
4144 ;; BEWARE: the below four are controversial to include here.
4145 sb-kernel:redefinition-with-defun
4146 sb-kernel:redefinition-with-defgeneric
4147 sb-kernel:redefinition-with-defmethod
4148 sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
4149 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
4150 "Conditions that may be skipped while compiling")
4152 (defvar *uninteresting-loader-conditions*
4154 '("Overwriting already existing readtable ~S." ;; from named-readtables
4155 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
4156 #+clisp '(clos::simple-gf-replacing-method-warning))
4157 "Additional conditions that may be skipped while loading"))
4159 ;;;; ----- Filtering conditions while building -----
4160 (with-upgradability ()
4161 (defun call-with-muffled-compiler-conditions (thunk)
4162 (call-with-muffled-conditions
4163 thunk *uninteresting-compiler-conditions*))
4164 (defmacro with-muffled-compiler-conditions ((&optional) &body body)
4165 "Run BODY where uninteresting compiler conditions are muffled"
4166 `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
4167 (defun call-with-muffled-loader-conditions (thunk)
4168 (call-with-muffled-conditions
4169 thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
4170 (defmacro with-muffled-loader-conditions ((&optional) &body body)
4171 "Run BODY where uninteresting compiler and additional loader conditions are muffled"
4172 `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
4175 ;;;; Handle warnings and failures
4176 (with-upgradability ()
4177 (define-condition compile-condition (condition)
4179 :initform nil :reader compile-condition-context-format :initarg :context-format)
4181 :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
4183 :initform nil :reader compile-condition-description :initarg :description))
4184 (:report (lambda (c s)
4185 (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
4186 (or (compile-condition-description c) (type-of c))
4187 (compile-condition-context-format c)
4188 (compile-condition-context-arguments c)))))
4189 (define-condition compile-file-error (compile-condition error) ())
4190 (define-condition compile-warned-warning (compile-condition warning) ())
4191 (define-condition compile-warned-error (compile-condition error) ())
4192 (define-condition compile-failed-warning (compile-condition warning) ())
4193 (define-condition compile-failed-error (compile-condition error) ())
4195 (defun check-lisp-compile-warnings (warnings-p failure-p
4196 &optional context-format context-arguments)
4198 (case *compile-file-failure-behaviour*
4199 (:warn (warn 'compile-failed-warning
4200 :description "Lisp compilation failed"
4201 :context-format context-format
4202 :context-arguments context-arguments))
4203 (:error (error 'compile-failed-error
4204 :description "Lisp compilation failed"
4205 :context-format context-format
4206 :context-arguments context-arguments))
4209 (case *compile-file-warnings-behaviour*
4210 (:warn (warn 'compile-warned-warning
4211 :description "Lisp compilation had style-warnings"
4212 :context-format context-format
4213 :context-arguments context-arguments))
4214 (:error (error 'compile-warned-error
4215 :description "Lisp compilation had style-warnings"
4216 :context-format context-format
4217 :context-arguments context-arguments))
4220 (defun check-lisp-compile-results (output warnings-p failure-p
4221 &optional context-format context-arguments)
4223 (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
4224 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
4227 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
4229 ;;; To support an implementation, three functions must be implemented:
4230 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
4231 ;;; See their respective docstrings.
4232 (with-upgradability ()
4233 (defun reify-simple-sexp (sexp)
4235 (symbol (reify-symbol sexp))
4236 ((or number character simple-string pathname) sexp)
4237 (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
4238 (defun unreify-simple-sexp (sexp)
4240 ((or symbol number character simple-string pathname) sexp)
4241 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
4242 ((simple-vector 2) (unreify-symbol sexp))))
4246 (defun reify-source-note (source-note)
4248 (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
4249 (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
4250 (declare (ignorable source))
4251 (list :filename filename :start-pos start-pos :end-pos end-pos
4252 #|:source (reify-source-note source)|#))))
4253 (defun unreify-source-note (source-note)
4255 (destructuring-bind (&key filename start-pos end-pos source) source-note
4256 (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
4257 :source (unreify-source-note source)))))
4258 (defun reify-function-name (function-name)
4260 (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%))
4263 (defun unreify-function-name (function-name)
4264 (let ((name (unreify-simple-sexp function-name)))
4265 (if (and (consp name) (eq (first name) 'setf))
4266 (let ((setfed (second name)))
4267 (gethash setfed ccl::%setf-function-names%))
4269 (defun reify-deferred-warning (deferred-warning)
4270 (with-accessors ((warning-type ccl::compiler-warning-warning-type)
4271 (args ccl::compiler-warning-args)
4272 (source-note ccl:compiler-warning-source-note)
4273 (function-name ccl:compiler-warning-function-name)) deferred-warning
4274 (list :warning-type warning-type :function-name (reify-function-name function-name)
4275 :source-note (reify-source-note source-note)
4276 :args (destructuring-bind (fun . formals) args
4277 (cons (reify-function-name fun) (reify-simple-sexp formals))))))
4278 (defun unreify-deferred-warning (reified-deferred-warning)
4279 (destructuring-bind (&key warning-type function-name source-note args)
4280 reified-deferred-warning
4281 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
4282 'ccl::compiler-warning)
4283 :function-name (unreify-function-name function-name)
4284 :source-note (unreify-source-note source-note)
4285 :warning-type warning-type
4286 :args (destructuring-bind (fun . formals) args
4287 (cons (unreify-function-name fun) (unreify-simple-sexp formals)))))))
4289 (defun reify-undefined-warning (warning)
4290 ;; Extracting undefined-warnings from the compilation-unit
4291 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4293 (c::undefined-warning-kind warning)
4294 (c::undefined-warning-name warning)
4295 (c::undefined-warning-count warning)
4298 ;; the lexenv slot can be ignored for reporting purposes
4299 `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
4300 :source ,(c::compiler-error-context-source frob)
4301 :original-source ,(c::compiler-error-context-original-source frob)
4302 :context ,(c::compiler-error-context-context frob)
4303 :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
4304 :file-position ,(c::compiler-error-context-file-position frob) ; an integer
4305 :original-source-path ,(c::compiler-error-context-original-source-path frob)))
4306 (c::undefined-warning-warnings warning))))
4309 (defun reify-undefined-warning (warning)
4310 ;; Extracting undefined-warnings from the compilation-unit
4311 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
4313 (sb-c::undefined-warning-kind warning)
4314 (sb-c::undefined-warning-name warning)
4315 (sb-c::undefined-warning-count warning)
4318 ;; the lexenv slot can be ignored for reporting purposes
4319 `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
4320 :source ,(sb-c::compiler-error-context-source frob)
4321 :original-source ,(sb-c::compiler-error-context-original-source frob)
4322 :context ,(sb-c::compiler-error-context-context frob)
4323 :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
4324 :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
4325 :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
4326 (sb-c::undefined-warning-warnings warning))))
4328 (defun reify-deferred-warnings ()
4329 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
4330 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
4331 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
4334 (list :functions-defined excl::.functions-defined.
4335 :functions-called excl::.functions-called.))
4337 (mapcar 'reify-deferred-warning
4338 (if-let (dw ccl::*outstanding-deferred-warnings*)
4339 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
4340 (ccl::deferred-warnings.warnings mdw))))
4342 (when lisp::*in-compilation-unit*
4343 ;; Try to send nothing through the pipe if nothing needs to be accumulated
4344 `(,@(when c::*undefined-warnings*
4345 `((c::*undefined-warnings*
4346 ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
4347 ,@(loop :for what :in '(c::*compiler-error-count*
4348 c::*compiler-warning-count*
4349 c::*compiler-note-count*)
4350 :for value = (symbol-value what)
4352 :collect `(,what . ,value))))
4354 (when sb-c::*in-compilation-unit*
4355 ;; Try to send nothing through the pipe if nothing needs to be accumulated
4356 `(,@(when sb-c::*undefined-warnings*
4357 `((sb-c::*undefined-warnings*
4358 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
4359 ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
4360 sb-c::*compiler-error-count*
4361 sb-c::*compiler-warning-count*
4362 sb-c::*compiler-style-warning-count*
4363 sb-c::*compiler-note-count*)
4364 :for value = (symbol-value what)
4366 :collect `(,what . ,value)))))
4368 (defun unreify-deferred-warnings (reified-deferred-warnings)
4369 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
4370 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
4371 Handle any warning that has been resolved already,
4372 such as an undefined function that has been defined since.
4373 One of three functions required for deferred-warnings support in ASDF."
4374 (declare (ignorable reified-deferred-warnings))
4376 (destructuring-bind (&key functions-defined functions-called)
4377 (unreify-simple-sexp reified-deferred-warnings)
4378 (setf excl::.functions-defined.
4379 (append functions-defined excl::.functions-defined.)
4380 excl::.functions-called.
4381 (append functions-called excl::.functions-called.)))
4383 (let ((dw (or ccl::*outstanding-deferred-warnings*
4384 (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
4385 (appendf (ccl::deferred-warnings.warnings dw)
4386 (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
4388 (dolist (item reified-deferred-warnings)
4389 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
4390 ;; For *undefined-warnings*, the adjustment is a list of initargs.
4391 ;; For everything else, it's an integer.
4392 (destructuring-bind (symbol . adjustment) item
4394 ((c::*undefined-warnings*)
4395 (setf c::*undefined-warnings*
4398 (destructuring-bind (kind name count . rest) stuff
4399 (unless (case kind (:function (fboundp name)))
4401 (c::make-undefined-warning
4406 (mapcar #'(lambda (x)
4407 (apply #'c::make-compiler-error-context x))
4410 c::*undefined-warnings*)))
4412 (set symbol (+ (symbol-value symbol) adjustment))))))
4414 (dolist (item reified-deferred-warnings)
4415 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
4416 ;; For *undefined-warnings*, the adjustment is a list of initargs.
4417 ;; For everything else, it's an integer.
4418 (destructuring-bind (symbol . adjustment) item
4420 ((sb-c::*undefined-warnings*)
4421 (setf sb-c::*undefined-warnings*
4424 (destructuring-bind (kind name count . rest) stuff
4425 (unless (case kind (:function (fboundp name)))
4427 (sb-c::make-undefined-warning
4432 (mapcar #'(lambda (x)
4433 (apply #'sb-c::make-compiler-error-context x))
4436 sb-c::*undefined-warnings*)))
4438 (set symbol (+ (symbol-value symbol) adjustment)))))))
4440 (defun reset-deferred-warnings ()
4441 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
4442 One of three functions required for deferred-warnings support in ASDF."
4444 (setf excl::.functions-defined. nil
4445 excl::.functions-called. nil)
4447 (if-let (dw ccl::*outstanding-deferred-warnings*)
4448 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
4449 (setf (ccl::deferred-warnings.warnings mdw) nil)))
4451 (when lisp::*in-compilation-unit*
4452 (setf c::*undefined-warnings* nil
4453 c::*compiler-error-count* 0
4454 c::*compiler-warning-count* 0
4455 c::*compiler-note-count* 0))
4457 (when sb-c::*in-compilation-unit*
4458 (setf sb-c::*undefined-warnings* nil
4459 sb-c::*aborted-compilation-unit-count* 0
4460 sb-c::*compiler-error-count* 0
4461 sb-c::*compiler-warning-count* 0
4462 sb-c::*compiler-style-warning-count* 0
4463 sb-c::*compiler-note-count* 0)))
4465 (defun save-deferred-warnings (warnings-file)
4466 "Save forward reference conditions so they may be issued at a latter time,
4467 possibly in a different process."
4468 (with-open-file (s warnings-file :direction :output :if-exists :supersede
4469 :element-type *default-stream-element-type*
4470 :external-format *utf-8-external-format*)
4471 (with-safe-io-syntax ()
4472 (write (reify-deferred-warnings) :stream s :pretty t :readably t)
4475 (defun warnings-file-type (&optional implementation-type)
4476 (case (or implementation-type *implementation-type*)
4477 ((:acl :allegro) "allegro-warnings")
4478 ;;((:clisp) "clisp-warnings")
4479 ((:cmu :cmucl) "cmucl-warnings")
4480 ((:sbcl) "sbcl-warnings")
4481 ((:clozure :ccl) "ccl-warnings")
4482 ((:scl) "scl-warnings")))
4484 (defvar *warnings-file-type* (warnings-file-type)
4485 "Type for warnings files")
4487 (defun warnings-file-p (file &optional implementation-type)
4488 (if-let (type (if implementation-type
4489 (warnings-file-type implementation-type)
4490 *warnings-file-type*))
4491 (equal (pathname-type file) type)))
4493 (defun check-deferred-warnings (files &optional context-format context-arguments)
4494 (let ((file-errors nil)
4498 ((warning #'(lambda (c)
4500 (unless (typep c 'style-warning)
4501 (setf failure-p t)))))
4502 (with-compilation-unit (:override t)
4503 (reset-deferred-warnings)
4504 (dolist (file files)
4505 (unreify-deferred-warnings
4506 (handler-case (safe-read-file-form file)
4508 (delete-file-if-exists file)
4509 (push c file-errors)
4511 (dolist (error file-errors) (error error))
4512 (check-lisp-compile-warnings
4513 (or failure-p warnings-p) failure-p context-format context-arguments)))
4516 Mini-guide to adding support for deferred warnings on an implementation.
4518 First, look at what such a warning looks like:
4522 (and (eval '(lambda () (some-undefined-function))) nil)
4525 Then you can grep for the condition type in your compiler sources
4526 and see how to catch those that have been deferred,
4527 and/or read, clear and restore the deferred list.
4530 (macroexpand-1 '(with-compilation-unit () foo))
4533 (defun call-with-saved-deferred-warnings (thunk warnings-file)
4535 (with-compilation-unit (:override t)
4537 (let (#+sbcl (sb-c::*undefined-warnings* nil))
4538 (multiple-value-prog1
4540 (save-deferred-warnings warnings-file)))
4541 (reset-deferred-warnings)))
4544 (defmacro with-saved-deferred-warnings ((warnings-file) &body body)
4545 "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
4546 and saves those warnings to the given file for latter use,
4547 possibly in a different process. Otherwise just run the BODY."
4548 `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
4552 (with-upgradability ()
4553 (defun current-lisp-file-pathname ()
4554 (or *compile-file-pathname* *load-pathname*))
4556 (defun load-pathname ()
4559 (defun lispize-pathname (input-file)
4560 (make-pathname :type "lisp" :defaults input-file))
4562 (defun compile-file-type (&rest keys)
4563 "pathname TYPE for lisp FASt Loading files"
4564 (declare (ignorable keys))
4565 #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
4566 #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
4568 (defun call-around-hook (hook function)
4569 (call-function (or hook 'funcall) function))
4571 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
4573 (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
4574 ,@(unless output-file '(:output-file))) keys)))
4575 (if (absolute-pathname-p output-file)
4576 ;; what cfp should be doing, w/ mp* instead of mp
4577 (let* ((type (pathname-type (apply 'compile-file-type keys)))
4578 (defaults (make-pathname
4579 :type type :defaults (merge-pathnames* input-file))))
4580 (merge-pathnames* output-file defaults))
4581 (funcall *output-translation-function*
4582 (apply 'compile-file-pathname input-file keys)))))
4584 (defun* (compile-file*) (input-file &rest keys
4585 &key compile-check output-file warnings-file
4586 #+clisp lib-file #+(or ecl mkcl) object-file
4588 "This function provides a portable wrapper around COMPILE-FILE.
4589 It ensures that the OUTPUT-FILE value is only returned and
4590 the file only actually created if the compilation was successful,
4591 even though your implementation may not do that, and including
4592 an optional call to an user-provided consistency check function COMPILE-CHECK;
4593 it will call this function if not NIL at the end of the compilation
4594 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
4595 where TMP-FILE is the name of a temporary output-file.
4596 It also checks two flags (with legacy british spelling from ASDF1),
4597 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
4598 with appropriate implementation-dependent defaults,
4599 and if a failure (respectively warnings) are reported by COMPILE-FILE
4600 with consider it an error unless the respective behaviour flag
4601 is one of :SUCCESS :WARN :IGNORE.
4602 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
4603 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
4604 On implementations that erroneously do not recognize standard keyword arguments,
4605 it will filter them appropriately."
4606 #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file)))
4607 (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
4608 'compile-file* output-file object-file)
4609 (rotatef output-file object-file))
4610 (let* ((keywords (remove-plist-keys
4611 `(:output-file :compile-check :warnings-file
4612 #+clisp :lib-file #+(or ecl mkcl) :object-file
4613 #+gcl2.6 ,@'(:external-format :print :verbose)) keys))
4616 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
4619 (unless (use-ecl-byte-compiler-p)
4621 (compile-file-pathname output-file :type :object))))
4625 (compile-file-pathname output-file :fasl-p nil)))
4626 (tmp-file (tmpize-pathname output-file))
4628 (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
4629 (multiple-value-bind (output-truename warnings-p failure-p)
4630 (with-saved-deferred-warnings (warnings-file)
4631 (with-muffled-compiler-conditions ()
4632 (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
4633 #+ecl (apply 'compile-file input-file :output-file
4635 (list* object-file :system-p t keywords)
4636 (list* tmp-file keywords)))
4637 #+mkcl (apply 'compile-file input-file
4638 :output-file object-file :fasl-p nil keywords))))
4640 ((and output-truename
4641 (flet ((check-flag (flag behaviour)
4642 (or (not flag) (member behaviour '(:success :warn :ignore)))))
4643 (and (check-flag failure-p *compile-file-failure-behaviour*)
4644 (check-flag warnings-p *compile-file-warnings-behaviour*)))
4647 (when (and #+ecl object-file)
4648 (setf output-truename
4649 (compiler::build-fasl
4650 tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files
4651 (list object-file))))
4652 (or (not compile-check)
4653 (apply compile-check input-file :output-file tmp-file keywords))))
4654 (delete-file-if-exists output-file)
4655 (when output-truename
4656 #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
4657 (rename-file-overwriting-target output-truename output-file)
4658 (setf output-truename (truename output-file)))
4659 #+clisp (delete-file-if-exists tmp-lib))
4660 (t ;; error or failed check
4661 (delete-file-if-exists output-truename)
4662 (setf output-truename nil)))
4663 (values output-truename warnings-p failure-p))))
4665 (defun load* (x &rest keys &key &allow-other-keys)
4667 ((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
4669 #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys)))
4670 ;; GCL 2.6, Genera can't load from a string-input-stream
4671 ;; ClozureCL 1.6 can only load from file input stream
4672 ;; Allegro 5, I don't remember but it must have been broken when I tested.
4673 #+(or allegro clozure gcl2.6 genera)
4674 (stream ;; make do this way
4675 (let ((*package* *package*)
4676 (*readtable* *readtable*)
4677 (*load-pathname* nil)
4678 (*load-truename* nil))
4681 (defun load-from-string (string)
4682 "Portably read and evaluate forms from a STRING."
4683 (with-input-from-string (s string) (load* s))))
4685 ;;; Links FASLs together
4686 (with-upgradability ()
4687 (defun combine-fasls (inputs output)
4688 #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
4689 (error "~A does not support ~S~%inputs ~S~%output ~S"
4690 (implementation-type) 'combine-fasls inputs output)
4691 #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
4692 #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
4697 (loop :for i :in inputs
4699 :for f = (add-pathname-suffix
4700 output (format nil "-FASL~D" n))
4701 :do #-lispworks-personal-edition (lispworks:copy-file i f)
4702 #+lispworks-personal-edition (concatenate-files (list i) f)
4704 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
4705 (eval `(scm:defsystem :fasls-to-concatenate
4706 (:default-pathname ,(pathname-directory-pathname output))
4708 ,(loop :for f :in (reverse fasls)
4709 :collect `(,(namestring f) :load-only t))))
4710 (scm:concatenate-system output :fasls-to-concatenate))
4711 (loop :for f :in fasls :do (ignore-errors (delete-file f)))
4712 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
4714 ;;;; ---------------------------------------------------------------------------
4715 ;;;; Generic support for configuration files
4717 (asdf/package:define-package :asdf/configuration
4718 (:recycle :asdf/configuration :asdf)
4719 (:use :asdf/common-lisp :asdf/utility
4720 :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
4723 #:user-configuration-directories #:system-configuration-directories
4724 #:in-first-directory
4725 #:in-user-configuration-directory #:in-system-configuration-directory
4726 #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
4727 #:configuration-inheritance-directive-p
4728 #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
4729 #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
4730 #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
4731 #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
4732 (in-package :asdf/configuration)
4734 (with-upgradability ()
4735 (define-condition invalid-configuration ()
4736 ((form :reader condition-form :initarg :form)
4737 (location :reader condition-location :initarg :location)
4738 (format :reader condition-format :initarg :format)
4739 (arguments :reader condition-arguments :initarg :arguments :initform nil))
4740 (:report (lambda (c s)
4741 (format s (compatfmt "~@<~? (will be skipped)~@:>")
4742 (condition-format c)
4743 (list* (condition-form c) (condition-location c)
4744 (condition-arguments c))))))
4746 (defun get-folder-path (folder)
4747 (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
4748 #+(and lispworks mswindows) (sys:get-folder-path folder)
4749 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
4751 (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
4752 (:appdata (getenv-absolute-directory "APPDATA"))
4753 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
4754 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
4756 (defun user-configuration-directories ()
4758 `(,@(when (os-unix-p)
4760 (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
4761 (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
4762 :collect (subpathname* dir "common-lisp/"))))
4763 ,@(when (os-windows-p)
4764 `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
4765 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
4766 ,(subpathname (user-homedir-pathname) ".config/common-lisp/"))))
4767 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
4768 :from-end t :test 'equal)))
4770 (defun system-configuration-directories ()
4772 ((os-unix-p) '(#p"/etc/common-lisp/"))
4774 (if-let (it (subpathname* (get-folder-path :common-appdata) "common-lisp/config/"))
4777 (defun in-first-directory (dirs x &key (direction :input))
4778 (loop :with fun = (ecase direction
4779 ((nil :input :probe) 'probe-file*)
4780 ((:output :io) 'identity))
4782 :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
4784 (defun in-user-configuration-directory (x &key (direction :input))
4785 (in-first-directory (user-configuration-directories) x :direction direction))
4786 (defun in-system-configuration-directory (x &key (direction :input))
4787 (in-first-directory (system-configuration-directories) x :direction direction))
4789 (defun configuration-inheritance-directive-p (x)
4790 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
4792 (and (length=n-p x 1) (member (car x) kw)))))
4794 (defun report-invalid-form (reporter &rest args)
4797 (apply 'error 'invalid-configuration args))
4799 (apply reporter args))
4801 (apply 'error reporter args))
4803 (apply 'apply (append reporter args)))))
4805 (defvar *ignored-configuration-form* nil)
4807 (defun validate-configuration-form (form tag directive-validator
4808 &key location invalid-form-reporter)
4809 (unless (and (consp form) (eq (car form) tag))
4810 (setf *ignored-configuration-form* t)
4811 (report-invalid-form invalid-form-reporter :form form :location location)
4812 (return-from validate-configuration-form nil))
4813 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
4814 :for directive :in (cdr form)
4816 ((configuration-inheritance-directive-p directive)
4818 ((eq directive :ignore-invalid-entries)
4819 (setf ignore-invalid-p t) t)
4820 ((funcall directive-validator directive)
4825 (setf *ignored-configuration-form* t)
4826 (report-invalid-form invalid-form-reporter :form directive :location location)
4828 :do (push directive x)
4830 (unless (= inherit 1)
4831 (report-invalid-form invalid-form-reporter
4832 :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
4833 :inherit-configuration :ignore-inherited-configuration)))
4834 (return (nreverse x))))
4836 (defun validate-configuration-file (file validator &key description)
4837 (let ((forms (read-file-forms file)))
4838 (unless (length=n-p forms 1)
4839 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
4841 (funcall validator (car forms) :location file)))
4843 (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
4844 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
4845 be applied to the results to yield a configuration form. Current
4846 values of TAG include :source-registry and :output-translations."
4847 (let ((files (sort (ignore-errors
4850 (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
4851 #'string< :key #'namestring)))
4853 ,@(loop :for file :in files :append
4854 (loop :with ignore-invalid-p = nil
4855 :for form :in (read-file-forms file)
4856 :when (eq form :ignore-invalid-entries)
4857 :do (setf ignore-invalid-p t)
4859 :when (funcall validator form)
4862 :when ignore-invalid-p
4863 :do (setf *ignored-configuration-form* t)
4865 :do (report-invalid-form invalid-form-reporter :form form :location file)))
4866 :inherit-configuration)))
4868 (defun resolve-relative-location (x &key ensure-directory wilden)
4872 (string (parse-unix-namestring
4873 x :ensure-directory ensure-directory))
4876 (resolve-relative-location
4877 (car x) :ensure-directory ensure-directory :wilden wilden)
4878 (let* ((car (resolve-relative-location
4879 (car x) :ensure-directory t :wilden nil)))
4881 (resolve-relative-location
4882 (cdr x) :ensure-directory ensure-directory :wilden wilden)
4884 ((eql :*/) *wild-directory*)
4885 ((eql :**/) *wild-inferiors*)
4886 ((eql :*.*.*) *wild-file*)
4887 ((eql :implementation)
4888 (parse-unix-namestring
4889 (implementation-identifier) :ensure-directory t))
4890 ((eql :implementation-type)
4891 (parse-unix-namestring
4892 (string-downcase (implementation-type)) :ensure-directory t))
4894 (parse-unix-namestring (hostname) :ensure-directory t)))
4895 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
4898 (defvar *here-directory* nil
4899 "This special variable is bound to the currect directory during calls to
4900 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
4903 (defvar *user-cache* nil
4904 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
4906 (defun compute-user-cache ()
4908 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
4910 (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
4911 (when (os-windows-p)
4912 (try (or (get-folder-path :local-appdata)
4913 (get-folder-path :appdata))
4914 "common-lisp" "cache" :implementation))
4915 '(:home ".cache" "common-lisp" :implementation)))))
4916 (register-image-restore-hook 'compute-user-cache)
4918 (defun resolve-absolute-location (x &key ensure-directory wilden)
4923 (let ((p #-mcl (parse-namestring x)
4924 #+mcl (probe-posix x)))
4925 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
4926 (if ensure-directory (ensure-directory-pathname p) p)))
4928 (return-from resolve-absolute-location
4930 (resolve-absolute-location
4931 (car x) :ensure-directory ensure-directory :wilden wilden)
4933 (resolve-relative-location
4934 (cdr x) :ensure-directory ensure-directory :wilden wilden)
4935 (resolve-absolute-location
4936 (car x) :ensure-directory t :wilden nil)))))
4938 ;; special magic! we return a relative pathname,
4939 ;; but what it means to the output-translations is
4940 ;; "relative to the root of the source pathname's host and device".
4941 (return-from resolve-absolute-location
4942 (let ((p (make-pathname* :directory '(:relative))))
4943 (if wilden (wilden p) p))))
4944 ((eql :home) (user-homedir-pathname))
4945 ((eql :here) (resolve-absolute-location
4946 *here-directory* :ensure-directory t :wilden nil))
4947 ((eql :user-cache) (resolve-absolute-location
4948 *user-cache* :ensure-directory t :wilden nil)))
4949 :wilden (and wilden (not (pathnamep x)))
4950 :resolve-symlinks *resolve-symlinks*
4953 ;; Try to override declaration in previous versions of ASDF.
4954 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
4955 (:ensure-directory boolean)) t) resolve-location))
4957 (defun* (resolve-location) (x &key ensure-directory wilden directory)
4958 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
4959 (loop* :with dirp = (or directory ensure-directory)
4960 :with (first . rest) = (if (atom x) (list x) x)
4961 :with path = (resolve-absolute-location
4962 first :ensure-directory (and (or dirp rest) t)
4963 :wilden (and wilden (null rest)))
4964 :for (element . morep) :on rest
4965 :for dir = (and (or morep dirp) t)
4966 :for wild = (and wilden (not morep))
4967 :for sub = (merge-pathnames*
4968 (resolve-relative-location
4969 element :ensure-directory dir :wilden wild)
4971 :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
4972 :finally (return path)))
4974 (defun location-designator-p (x)
4975 (flet ((absolute-component-p (c)
4976 (typep c '(or string pathname
4977 (member :root :home :here :user-cache))))
4978 (relative-component-p (c)
4979 (typep c '(or string pathname
4980 (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
4981 (or (typep x 'boolean)
4982 (absolute-component-p x)
4983 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
4985 (defun location-function-p (x)
4988 (eq (car x) :function)
4989 (or (symbolp (cadr x))
4990 (and (consp (cadr x))
4991 (eq (caadr x) 'lambda)
4992 (length=n-p (cadadr x) 2)))))
4994 (defvar *clear-configuration-hook* '())
4996 (defun register-clear-configuration-hook (hook-function &optional call-now-p)
4997 (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
4999 (defun clear-configuration ()
5000 (call-functions *clear-configuration-hook*))
5002 (register-image-dump-hook 'clear-configuration)
5004 ;; If a previous version of ASDF failed to read some configuration, try again.
5005 (defun upgrade-configuration ()
5006 (when *ignored-configuration-form*
5007 (clear-configuration)
5008 (setf *ignored-configuration-form* nil))))
5011 ;;;; -------------------------------------------------------------------------
5012 ;;; Hacks for backward-compatibility of the driver
5014 (asdf/package:define-package :asdf/backward-driver
5015 (:recycle :asdf/backward-driver :asdf)
5016 (:use :asdf/common-lisp :asdf/package :asdf/utility
5017 :asdf/pathname :asdf/stream :asdf/os :asdf/image
5018 :asdf/run-program :asdf/lisp-build
5019 :asdf/configuration)
5021 #:coerce-pathname #:component-name-to-pathname-components
5022 #+(or ecl mkcl) #:compile-file-keeping-object
5024 (in-package :asdf/backward-driver)
5026 ;;;; Backward compatibility with various pathname functions.
5028 (with-upgradability ()
5029 (defun coerce-pathname (name &key type defaults)
5030 ;; For backward-compatibility only, for people using internals
5031 ;; Reported users in quicklisp: hu.dwim.asdf, asdf-utils, xcvb
5032 ;; Will be removed after 2014-01-16.
5033 ;;(warn "Please don't use ASDF::COERCE-PATHNAME. Use ASDF/PATHNAME:PARSE-UNIX-NAMESTRING.")
5034 (parse-unix-namestring name :type type :defaults defaults))
5036 (defun component-name-to-pathname-components (unix-style-namestring
5037 &key force-directory force-relative)
5038 ;; Will be removed after 2014-01-16.
5039 ;; (warn "Please don't use ASDF::COMPONENT-NAME-TO-PATHNAME-COMPONENTS, use SPLIT-UNIX-NAMESTRING-DIRECTORY-COMPONENTS")
5040 (multiple-value-bind (relabs path filename file-only)
5041 (split-unix-namestring-directory-components
5042 unix-style-namestring :ensure-directory force-directory)
5043 (declare (ignore file-only))
5044 (when (and force-relative (not (eq relabs :relative)))
5045 (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>")
5046 unix-style-namestring))
5047 (values relabs path filename)))
5050 (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args)))
5051 ;;;; ---------------------------------------------------------------------------
5052 ;;;; Re-export all the functionality in asdf/driver
5054 (asdf/package:define-package :asdf/driver
5055 (:nicknames :asdf-driver :asdf-utils)
5056 (:use :asdf/common-lisp :asdf/package :asdf/utility
5057 :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
5058 :asdf/run-program :asdf/lisp-build
5059 :asdf/configuration :asdf/backward-driver)
5061 ;; NB: excluding asdf/common-lisp
5062 ;; which include all of CL with compatibility modifications on select platforms.
5063 :asdf/package :asdf/utility
5064 :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
5065 :asdf/run-program :asdf/lisp-build
5066 :asdf/configuration :asdf/backward-driver))
5067 ;;;; -------------------------------------------------------------------------
5068 ;;;; Handle upgrade as forward- and backward-compatibly as possible
5069 ;; See https://bugs.launchpad.net/asdf/+bug/485687
5071 (asdf/package:define-package :asdf/upgrade
5072 (:recycle :asdf/upgrade :asdf)
5073 (:use :asdf/common-lisp :asdf/driver)
5075 #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
5076 #:asdf-message #:*verbose-out*
5077 #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
5078 #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
5079 ;; There will be no symbol left behind!
5081 (:import-from :asdf/package #:intern* #:find-symbol*))
5082 (in-package :asdf/upgrade)
5084 ;;; Special magic to detect if this is an upgrade
5086 (with-upgradability ()
5087 (defun asdf-version ()
5088 "Exported interface to the version of ASDF currently installed. A string.
5089 You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
5090 (when (find-package :asdf)
5091 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
5092 (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
5093 (rev (and revsym (boundp revsym) (symbol-value revsym))))
5096 (cons (format nil "~{~D~^.~}" rev))
5098 (defvar *asdf-version* nil)
5099 (defvar *previous-asdf-versions* nil)
5100 (defvar *verbose-out* nil)
5101 (defun asdf-message (format-string &rest format-args)
5102 (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
5103 (defvar *post-upgrade-cleanup-hook* ())
5104 (defvar *post-upgrade-restart-hook* ())
5105 (defun upgrading-p ()
5106 (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
5107 (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
5108 `(with-upgradability ()
5109 (when (and ,upgrading-p ,@(when when `(,when)))
5110 (handler-bind ((style-warning #'muffle-warning))
5111 (eval '(progn ,@body))))))
5112 (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
5113 ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
5114 ;; can help you do these changes in synch (look at the source for documentation).
5115 ;; Relying on its automation, the version is now redundantly present on top of this file.
5116 ;; "3.4" would be the general branch for major version 3, minor version 4.
5117 ;; "3.4.5" would be an official release in the 3.4 branch.
5118 ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
5119 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
5120 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
5121 (asdf-version "2.29")
5122 (existing-version (asdf-version)))
5123 (setf *asdf-version* asdf-version)
5124 (when (and existing-version (not (equal asdf-version existing-version)))
5125 (push existing-version *previous-asdf-versions*)
5126 (when (or *load-verbose* *verbose-out*)
5127 (format *trace-output*
5128 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
5129 existing-version asdf-version)))))
5132 (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
5133 '(#:component-relative-pathname #:component-parent-pathname ;; component
5135 #:find-system #:system-source-file #:system-relative-pathname ;; system
5136 #:find-component ;; find-component
5137 #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
5138 #:component-depends-on #:component-self-dependencies #:operation-done-p
5140 #:operate ;; operate
5141 #:parse-component-form ;; defsystem
5142 #:apply-output-translations ;; output-translations
5143 #:process-output-translations-directive
5144 #:inherit-source-registry #:process-source-registry ;; source-registry
5145 #:process-source-registry-directive
5146 #:trivial-system-p ;; bundle
5147 ;; NB: it's too late to do anything about asdf-driver functions!
5150 '(#:*asdf-revision* #:around #:asdf-method-combination
5151 #:split #:make-collector #:do-dep #:do-one-dep
5152 #:resolve-relative-location-component #:resolve-absolute-location-component
5153 #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
5154 (declare (ignorable redefined-functions uninterned-symbols))
5155 (loop :for name :in (append #-(or ecl) redefined-functions)
5156 :for sym = (find-symbol* name :asdf nil) :do
5159 (loop :with asdf = (find-package :asdf)
5160 :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
5161 :for sym = (find-symbol* name :asdf nil)
5162 :for base-pkg = (and sym (symbol-package sym)) :do
5165 ((or (eq base-pkg asdf) (not base-pkg))
5166 (unintern* sym asdf)
5169 (unintern* sym base-pkg)
5170 (let ((new (intern* sym base-pkg)))
5171 (shadowing-import new asdf))))))))
5174 ;;; Self-upgrade functions
5176 (with-upgradability ()
5177 (defun asdf-upgrade-error ()
5178 ;; Important notice for whom it concerns. The crux of the matter is that
5179 ;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late.
5180 (error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~
5181 Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"))
5183 (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
5184 (let ((new-version (asdf-version)))
5185 (unless (equal old-version new-version)
5186 (push new-version *previous-asdf-versions*)
5189 ((version-compatible-p new-version old-version)
5190 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
5191 old-version new-version))
5192 ((version-compatible-p old-version new-version)
5193 (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
5194 old-version new-version))
5196 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
5197 old-version new-version)))
5198 (call-functions (reverse *post-upgrade-cleanup-hook*))
5201 (defun upgrade-asdf ()
5202 "Try to upgrade of ASDF. If a different version was used, return T.
5203 We need do that before we operate on anything that may possibly depend on ASDF."
5204 (let ((*load-print* nil)
5205 (*compile-print* nil))
5206 (handler-bind (((or style-warning warning) #'muffle-warning))
5207 (symbol-call :asdf :load-system :asdf :verbose nil))))
5209 (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
5211 ;;;; -------------------------------------------------------------------------
5214 (asdf/package:define-package :asdf/component
5215 (:recycle :asdf/component :asdf)
5216 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
5218 #:component #:component-find-path
5219 #:component-name #:component-pathname #:component-relative-pathname
5220 #:component-parent #:component-system #:component-parent-pathname
5221 #:child-component #:parent-component #:module
5223 #:source-file #:c-source-file #:java-source-file
5224 #:static-file #:doc-file #:html-file
5225 #:source-file-type ;; backward-compatibility
5226 #:component-in-order-to #:component-sibling-dependencies
5227 #:component-if-feature #:around-compile-hook
5228 #:component-description #:component-long-description
5229 #:component-version #:version-satisfies
5230 #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
5231 #:component-operation-times ;; For internal use only.
5232 ;; portable ASDF encoding and implementation-specific external-format
5233 #:component-external-format #:component-encoding
5234 #:component-children-by-name #:component-children #:compute-children-by-name
5235 #:component-build-operation
5236 #:module-default-component-class
5237 #:module-components ;; backward-compatibility. DO NOT USE.
5240 ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
5241 #:name #:version #:description #:long-description #:author #:maintainer #:licence
5242 #:components-by-name #:components
5243 #:children #:children-by-name #:default-component-class
5244 #:author #:maintainer #:licence #:source-file #:defsystem-depends-on
5245 #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
5246 #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
5247 #:%encoding #:properties #:component-properties #:parent))
5248 (in-package :asdf/component)
5250 (with-upgradability ()
5251 (defgeneric component-name (component)
5252 (:documentation "Name of the COMPONENT, unique relative to its parent"))
5253 (defgeneric component-system (component)
5254 (:documentation "Find the top-level system containing COMPONENT"))
5255 (defgeneric component-pathname (component)
5256 (:documentation "Extracts the pathname applicable for a particular component."))
5257 (defgeneric (component-relative-pathname) (component)
5258 (:documentation "Returns a pathname for the component argument intended to be
5259 interpreted relative to the pathname of that component's parent.
5260 Despite the function's name, the return value may be an absolute
5261 pathname, because an absolute pathname may be interpreted relative to
5262 another pathname in a degenerate way."))
5263 (defgeneric component-external-format (component))
5264 (defgeneric component-encoding (component))
5265 (defgeneric version-satisfies (component version))
5266 (defgeneric component-version (component))
5267 (defgeneric (setf component-version) (new-version component))
5268 (defgeneric component-parent (component))
5269 (defmethod component-parent ((component null)) (declare (ignorable component)) nil)
5271 ;; Backward compatible way of computing the FILE-TYPE of a component.
5272 ;; TODO: find users, have them stop using that, remove it for ASDF4.
5273 (defgeneric (source-file-type) (component system)))
5275 (when-upgrading (:when (find-class 'component nil))
5276 (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
5277 (declare (ignorable c initargs)) (values)))
5279 (with-upgradability ()
5280 (defclass component ()
5281 ((name :accessor component-name :initarg :name :type string :documentation
5282 "Component name: designator for a string composed of portable pathname characters")
5283 ;; We might want to constrain version with
5284 ;; :type (and string (satisfies parse-version))
5285 ;; but we cannot until we fix all systems that don't use it correctly!
5286 (version :accessor component-version :initarg :version :initform nil)
5287 (description :accessor component-description :initarg :description :initform nil)
5288 (long-description :accessor component-long-description :initarg :long-description :initform nil)
5289 (sibling-dependencies :accessor component-sibling-dependencies :initform nil)
5290 (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
5291 ;; In the ASDF object model, dependencies exist between *actions*,
5292 ;; where an action is a pair of an operation and a component.
5293 ;; Dependencies are represented as alists of operations
5294 ;; to a list where each entry is a pair of an operation and a list of component specifiers.
5295 ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
5296 ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
5297 ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
5298 ;; and do-first things that modify the current image (such as loading a fasl).
5299 ;; These are now unified because we now correctly propagate timestamps between dependencies.
5300 ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
5301 ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
5302 ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
5303 ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
5304 ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
5305 ;; See our ASDF 2 paper for more complete explanations.
5306 (in-order-to :initform nil :initarg :in-order-to
5307 :accessor component-in-order-to)
5308 ;; methods defined using the "inline" style inside a defsystem form:
5309 ;; need to store them somewhere so we can delete them when the system
5311 (inline-methods :accessor component-inline-methods :initform nil) ;; OBSOLETE! DELETE THIS IF NO ONE USES.
5312 ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
5313 ;; There is no initform and no direct accessor for this specified pathname,
5314 ;; so we only access the information through appropriate methods, after it has been processed.
5315 ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
5316 (relative-pathname :initarg :pathname)
5317 ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
5318 ;; The slot is but a cache used by component-pathname.
5320 (operation-times :initform (make-hash-table)
5321 :accessor component-operation-times)
5322 (around-compile :initarg :around-compile)
5323 ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
5324 (properties :accessor component-properties :initarg :properties
5326 (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
5327 ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
5328 (parent :initarg :parent :initform nil :reader component-parent)
5330 :initarg :build-operation :initform nil :reader component-build-operation)))
5332 (defun component-find-path (component)
5333 (check-type component (or null component))
5335 (loop :for c = component :then (component-parent c)
5336 :while c :collect (component-name c))))
5338 (defmethod print-object ((c component) stream)
5339 (print-unreadable-object (c stream :type t :identity nil)
5340 (format stream "~{~S~^ ~}" (component-find-path c))))
5342 (defmethod component-system ((component component))
5343 (if-let (system (component-parent component))
5344 (component-system system)
5348 ;;;; Component hierarchy within a system
5349 ;; The tree typically but not necessarily follows the filesystem hierarchy.
5350 (with-upgradability ()
5351 (defclass child-component (component) ())
5353 (defclass file-component (child-component)
5354 ((type :accessor file-type :initarg :type))) ; no default
5355 (defclass source-file (file-component)
5356 ((type :initform nil))) ;; NB: many systems have come to rely on this default.
5357 (defclass c-source-file (source-file)
5358 ((type :initform "c")))
5359 (defclass java-source-file (source-file)
5360 ((type :initform "java")))
5361 (defclass static-file (source-file)
5362 ((type :initform nil)))
5363 (defclass doc-file (static-file) ())
5364 (defclass html-file (doc-file)
5365 ((type :initform "html")))
5367 (defclass parent-component (component)
5370 :initarg :components
5371 :reader module-components ; backward-compatibility
5372 :accessor component-children)
5374 :reader module-components-by-name ; backward-compatibility
5375 :accessor component-children-by-name)
5376 (default-component-class
5378 :initarg :default-component-class
5379 :accessor module-default-component-class))))
5381 (with-upgradability ()
5382 (defun compute-children-by-name (parent &key only-if-needed-p)
5383 (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
5384 (let ((hash (make-hash-table :test 'equal)))
5385 (setf (component-children-by-name parent) hash)
5386 (loop :for c :in (component-children parent)
5387 :for name = (component-name c)
5388 :for previous = (gethash name hash)
5389 :do (when previous (error 'duplicate-names :name name))
5390 (setf (gethash name hash) c))
5393 (when-upgrading (:when (find-class 'module nil))
5394 (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
5395 (declare (ignorable m initargs)) (values))
5396 (defmethod update-instance-for-redefined-class :after
5397 ((m module) added deleted plist &key)
5398 (declare (ignorable m added deleted plist))
5399 (when (and (member 'children added) (member 'components deleted))
5400 (setf (slot-value m 'children)
5401 ;; old ECLs provide an alist instead of a plist(!)
5402 (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist)))
5403 (getf plist 'components)))
5404 (compute-children-by-name m))))
5406 (with-upgradability ()
5407 (defclass module (child-component parent-component)
5408 (#+clisp (components)))) ;; backward compatibility during upgrade only
5411 ;;;; component pathnames
5412 (with-upgradability ()
5413 (defgeneric* (component-parent-pathname) (component))
5414 (defmethod component-parent-pathname (component)
5415 (component-pathname (component-parent component)))
5417 (defmethod component-pathname ((component component))
5418 (if (slot-boundp component 'absolute-pathname)
5419 (slot-value component 'absolute-pathname)
5422 (component-relative-pathname component)
5423 (pathname-directory-pathname (component-parent-pathname component)))))
5424 (unless (or (null pathname) (absolute-pathname-p pathname))
5425 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
5426 pathname (component-find-path component)))
5427 (setf (slot-value component 'absolute-pathname) pathname)
5430 (defmethod component-relative-pathname ((component component))
5431 ;; source-file-type is backward-compatibility with ASDF1;
5432 ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE.
5433 ;; TODO: track who uses it, and have them not use it anymore.
5434 (parse-unix-namestring
5435 (or (and (slot-boundp component 'relative-pathname)
5436 (slot-value component 'relative-pathname))
5437 (component-name component))
5439 :type (source-file-type component (component-system component))
5440 :defaults (component-parent-pathname component)))
5442 (defmethod source-file-type ((component parent-component) system)
5443 (declare (ignorable component system))
5446 (defmethod source-file-type ((component file-component) system)
5447 (declare (ignorable system))
5448 (file-type component)))
5452 (with-upgradability ()
5453 (defmethod component-encoding ((c component))
5454 (or (loop :for x = c :then (component-parent x)
5455 :while x :thereis (%component-encoding x))
5456 (detect-encoding (component-pathname c))))
5458 (defmethod component-external-format ((c component))
5459 (encoding-external-format (component-encoding c))))
5462 ;;;; around-compile-hook
5463 (with-upgradability ()
5464 (defgeneric around-compile-hook (component))
5465 (defmethod around-compile-hook ((c component))
5467 ((slot-boundp c 'around-compile)
5468 (slot-value c 'around-compile))
5469 ((component-parent c)
5470 (around-compile-hook (component-parent c))))))
5473 ;;;; version-satisfies
5474 (with-upgradability ()
5475 (defmethod version-satisfies ((c component) version)
5476 (unless (and version (slot-boundp c 'version))
5478 (warn "Requested version ~S but component ~S has no version" version c))
5479 (return-from version-satisfies t))
5480 (version-satisfies (component-version c) version))
5482 (defmethod version-satisfies ((cver string) version)
5483 (version-compatible-p cver version)))
5486 ;;; all sub-components (of a given type)
5487 (with-upgradability ()
5488 (defun sub-components (component &key (type t))
5489 (while-collecting (c)
5490 (labels ((recurse (x)
5491 (when (if-let (it (component-if-feature x)) (featurep it) t)
5492 (when (typep x type)
5494 (when (typep x 'parent-component)
5495 (map () #'recurse (component-children x))))))
5496 (recurse component)))))
5498 ;;;; -------------------------------------------------------------------------
5501 (asdf/package:define-package :asdf/system
5502 (:recycle :asdf :asdf/system)
5503 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component)
5505 #:system #:proto-system
5506 #:system-source-file #:system-source-directory #:system-relative-pathname
5508 #:system-description #:system-long-description
5509 #:system-author #:system-maintainer #:system-licence #:system-license
5510 #:system-defsystem-depends-on
5511 #:component-build-pathname #:build-pathname
5512 #:component-entry-point #:entry-point
5513 #:homepage #:system-homepage
5514 #:bug-tracker #:system-bug-tracker
5515 #:mailto #:system-mailto
5516 #:long-name #:system-long-name
5517 #:source-control #:system-source-control
5518 #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
5519 (in-package :asdf/system)
5521 (with-upgradability ()
5522 (defgeneric* (find-system) (system &optional error-p))
5523 (defgeneric* (system-source-file) (system)
5524 (:documentation "Return the source file in which system is defined."))
5525 (defgeneric component-build-pathname (component))
5527 (defgeneric component-entry-point (component))
5528 (defmethod component-entry-point ((c component))
5529 (declare (ignorable c))
5533 ;;;; The system class
5535 (with-upgradability ()
5536 (defclass proto-system () ; slots to keep when resetting a system
5537 ;; To preserve identity for all objects, we'd need keep the components slots
5538 ;; but also to modify parse-component-form to reset the recycled objects.
5539 ((name) (source-file) #|(children) (children-by-names)|#))
5541 (defclass system (module proto-system)
5542 ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
5543 (;; {,long-}description is now inherited from component, but we add the legacy accessors
5544 (description :accessor system-description)
5545 (long-description :accessor system-long-description)
5546 (author :accessor system-author :initarg :author :initform nil)
5547 (maintainer :accessor system-maintainer :initarg :maintainer :initform nil)
5548 (licence :accessor system-licence :initarg :licence
5549 :accessor system-license :initarg :license :initform nil)
5550 (homepage :accessor system-homepage :initarg :homepage :initform nil)
5551 (bug-tracker :accessor system-bug-tracker :initarg :bug-tracker :initform nil)
5552 (mailto :accessor system-mailto :initarg :mailto :initform nil)
5553 (long-name :accessor system-long-name :initarg :long-name :initform nil)
5554 ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
5555 ;; I'm introducing the slot before the conventions are set for maximum compatibility.
5556 (source-control :accessor system-source-control :initarg :source-control :initform nil)
5557 (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
5559 :initform nil :initarg :build-pathname :accessor component-build-pathname)
5561 :initform nil :initarg :entry-point :accessor component-entry-point)
5562 (source-file :initform nil :initarg :source-file :accessor system-source-file)
5563 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
5565 (defun reset-system (system &rest keys &key &allow-other-keys)
5566 (change-class (change-class system 'proto-system) 'system)
5567 (apply 'reinitialize-instance system keys)))
5572 (with-upgradability ()
5573 (defmethod system-source-file ((system-name string))
5574 (system-source-file (find-system system-name)))
5575 (defmethod system-source-file ((system-name symbol))
5576 (system-source-file (find-system system-name)))
5578 (defun system-source-directory (system-designator)
5579 "Return a pathname object corresponding to the directory
5580 in which the system specification (.asd file) is located."
5581 (pathname-directory-pathname (system-source-file system-designator)))
5583 (defun (system-relative-pathname) (system name &key type)
5584 (subpathname (system-source-directory system) name :type type))
5586 (defmethod component-pathname ((system system))
5587 (let ((pathname (or (call-next-method) (system-source-directory system))))
5588 (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
5589 (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
5590 (setf (slot-value system 'relative-pathname) pathname))
5593 (defmethod component-relative-pathname ((system system))
5594 (parse-unix-namestring
5595 (and (slot-boundp system 'relative-pathname)
5596 (slot-value system 'relative-pathname))
5600 :defaults (system-source-directory system)))
5602 (defmethod component-parent-pathname ((system system))
5603 (system-source-directory system))
5605 (defmethod component-build-pathname ((c component))
5606 (declare (ignorable c))
5609 ;;;; -------------------------------------------------------------------------
5612 (asdf/package:define-package :asdf/cache
5613 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
5614 (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp
5615 #:consult-asdf-cache #:do-asdf-cache
5616 #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*))
5617 (in-package :asdf/cache)
5619 ;;; This stamp cache is useful for:
5620 ;; * consistency of stamps used within a single run
5621 ;; * fewer accesses to the filesystem
5622 ;; * the ability to test with fake timestamps, without touching files
5624 (with-upgradability ()
5625 (defvar *asdf-cache* nil)
5627 (defun set-asdf-cache-entry (key value-list)
5630 (setf (gethash key *asdf-cache*) value-list)
5633 (defun consult-asdf-cache (key thunk)
5635 (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
5637 (apply 'values results)
5638 (set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
5641 (defmacro do-asdf-cache (key &body body)
5642 `(consult-asdf-cache ,key #'(lambda () ,@body)))
5644 (defun call-with-asdf-cache (thunk &key override)
5645 (if (and *asdf-cache* (not override))
5647 (let ((*asdf-cache* (make-hash-table :test 'equal)))
5650 (defmacro with-asdf-cache ((&key override) &body body)
5651 `(call-with-asdf-cache #'(lambda () ,@body) :override ,override))
5653 (defun compute-file-stamp (file)
5654 (safe-file-write-date file))
5656 (defun register-file-stamp (file &optional (stamp (compute-file-stamp file)))
5657 (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp)))
5659 (defun get-file-stamp (file)
5660 (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file))))
5663 ;;;; -------------------------------------------------------------------------
5664 ;;;; Finding systems
5666 (asdf/package:define-package :asdf/find-system
5667 (:recycle :asdf/find-system :asdf)
5668 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
5669 :asdf/component :asdf/system :asdf/cache)
5671 #:remove-entry-from-registry #:coerce-entry-to-directory
5672 #:coerce-name #:primary-system-name
5673 #:find-system #:locate-system #:load-asd #:with-system-definitions
5674 #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
5675 #:system-definition-error #:missing-component #:missing-requires #:missing-parent
5676 #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error
5677 #:load-system-definition-error #:error-name #:error-pathname #:error-condition
5678 #:*system-definition-search-functions* #:search-for-system-definition
5679 #:*central-registry* #:probe-asd #:sysdef-central-registry-search
5680 #:find-system-if-being-defined #:*systems-being-defined*
5681 #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
5682 #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems*
5683 #:clear-defined-systems #:*defined-systems*
5684 ;; defined in source-registry, but specially mentioned here:
5685 #:initialize-source-registry #:sysdef-source-registry-search))
5686 (in-package :asdf/find-system)
5688 (with-upgradability ()
5689 (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference
5691 (define-condition system-definition-error (error) ()
5692 ;; [this use of :report should be redundant, but unfortunately it's not.
5693 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
5694 ;; over print-object; this is always conditions::%print-condition for
5695 ;; condition objects, which in turn does inheritance of :report options at
5696 ;; run-time. fortunately, inheritance means we only need this kludge here in
5697 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
5698 #+cmu (:report print-object))
5700 (define-condition missing-component (system-definition-error)
5701 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
5702 (parent :initform nil :reader missing-parent :initarg :parent)))
5704 (define-condition formatted-system-definition-error (system-definition-error)
5705 ((format-control :initarg :format-control :reader format-control)
5706 (format-arguments :initarg :format-arguments :reader format-arguments))
5707 (:report (lambda (c s)
5708 (apply 'format s (format-control c) (format-arguments c)))))
5710 (define-condition load-system-definition-error (system-definition-error)
5711 ((name :initarg :name :reader error-name)
5712 (pathname :initarg :pathname :reader error-pathname)
5713 (condition :initarg :condition :reader error-condition))
5714 (:report (lambda (c s)
5715 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
5716 (error-name c) (error-pathname c) (error-condition c)))))
5718 (defun sysdef-error (format &rest arguments)
5719 (error 'formatted-system-definition-error :format-control
5720 format :format-arguments arguments))
5722 (defun coerce-name (name)
5724 (component (component-name name))
5725 (symbol (string-downcase (symbol-name name)))
5727 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
5729 (defun primary-system-name (name)
5730 ;; When a system name has slashes, the file with defsystem is named by
5731 ;; the first of the slash-separated components.
5732 (first (split-string (coerce-name name) :separator "/")))
5734 (defvar *defined-systems* (make-hash-table :test 'equal)
5735 "This is a hash table whose keys are strings, being the
5736 names of the systems, and whose values are pairs, the first
5737 element of which is a universal-time indicating when the
5738 system definition was last updated, and the second element
5739 of which is a system object.")
5741 (defun system-registered-p (name)
5742 (gethash (coerce-name name) *defined-systems*))
5744 (defun registered-systems ()
5745 (loop :for registered :being :the :hash-values :of *defined-systems*
5746 :collect (coerce-name (cdr registered))))
5748 (defun register-system (system)
5749 (check-type system system)
5750 (let ((name (component-name system)))
5751 (check-type name string)
5752 (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
5753 (unless (eq system (cdr (gethash name *defined-systems*)))
5754 (setf (gethash name *defined-systems*)
5755 (cons (if-let (file (ignore-errors (system-source-file system)))
5756 (get-file-stamp file))
5759 (defun clear-defined-systems ()
5760 ;; Invalidate all systems but ASDF itself, if registered.
5761 (let ((asdf (cdr (system-registered-p :asdf))))
5762 (setf *defined-systems* (make-hash-table :test 'equal))
5764 (setf (component-version asdf) *asdf-version*)
5765 (register-system asdf)))
5768 (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
5770 (defun clear-system (name)
5771 "Clear the entry for a system in the database of systems previously loaded.
5772 Note that this does NOT in any way cause the code of the system to be unloaded."
5773 ;; There is no "unload" operation in Common Lisp, and
5774 ;; a general such operation cannot be portably written,
5775 ;; considering how much CL relies on side-effects to global data structures.
5776 (remhash (coerce-name name) *defined-systems*))
5778 (defun map-systems (fn)
5779 "Apply FN to each defined system.
5781 FN should be a function of one argument. It will be
5782 called with an object of type asdf:system."
5783 (loop :for registered :being :the :hash-values :of *defined-systems*
5784 :do (funcall fn (cdr registered)))))
5786 ;;; for the sake of keeping things reasonably neat, we adopt a
5787 ;;; convention that functions in this list are prefixed SYSDEF-
5788 (with-upgradability ()
5789 (defvar *system-definition-search-functions* '())
5791 (defun cleanup-system-definition-search-functions ()
5792 (setf *system-definition-search-functions*
5794 ;; Remove known-incompatible sysdef functions from old versions of asdf.
5795 (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf)))
5796 *system-definition-search-functions*)
5797 ;; Tuck our defaults at the end of the list if they were absent.
5798 ;; This is imperfect, in case they were removed on purpose,
5799 ;; but then it will be the responsibility of whoever does that
5800 ;; to upgrade asdf before he does such a thing rather than after.
5801 (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
5802 '(sysdef-central-registry-search
5803 sysdef-source-registry-search
5804 sysdef-find-preloaded-systems)))))
5805 (cleanup-system-definition-search-functions)
5807 (defun search-for-system-definition (system)
5808 (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
5809 (cons 'find-system-if-being-defined
5810 *system-definition-search-functions*)))
5812 (defvar *central-registry* nil
5813 "A list of 'system directory designators' ASDF uses to find systems.
5815 A 'system directory designator' is a pathname or an expression
5816 which evaluates to a pathname. For example:
5818 (setf asdf:*central-registry*
5819 (list '*default-pathname-defaults*
5820 #p\"/home/me/cl/systems/\"
5821 #p\"/usr/share/common-lisp/systems/\"))
5823 This is for backward compatibility.
5824 Going forward, we recommend new users should be using the source-registry.
5827 (defun probe-asd (name defaults &key truename)
5829 (when (directory-pathname-p defaults)
5830 (if-let (file (probe-file*
5831 (ensure-absolute-pathname
5832 (parse-unix-namestring name :type "asd")
5833 #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil))
5835 :truename truename))
5837 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
5838 (when (os-windows-p)
5841 :defaults defaults :case :local
5842 :name (strcat name ".asd")
5844 (when (probe-file* shortcut)
5845 (let ((target (parse-windows-shortcut shortcut)))
5847 (return (pathname target))))))))))
5849 (defun sysdef-central-registry-search (system)
5850 (let ((name (primary-system-name system))
5855 (dolist (dir *central-registry*)
5856 (let ((defaults (eval dir))
5859 (cond ((directory-pathname-p defaults)
5860 (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
5865 (let* ((*print-circle* nil)
5868 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>")
5869 system dir defaults)))
5871 (remove-entry-from-registry ()
5872 :report "Remove entry from *central-registry* and continue"
5873 (push dir to-remove))
5874 (coerce-entry-to-directory ()
5875 :test (lambda (c) (declare (ignore c))
5876 (and (not (directory-pathname-p defaults))
5877 (directory-pathname-p
5879 (ensure-directory-pathname defaults)))))
5881 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
5883 (push (cons dir directorized) to-replace))))))))
5885 (dolist (dir to-remove)
5886 (setf *central-registry* (remove dir *central-registry*)))
5887 (dolist (pair to-replace)
5888 (let* ((current (car pair))
5890 (position (position current *central-registry*)))
5891 (setf *central-registry*
5892 (append (subseq *central-registry* 0 position)
5894 (subseq *central-registry* (1+ position))))))))))
5896 (defmethod find-system ((name null) &optional (error-p t))
5897 (declare (ignorable name))
5899 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
5901 (defmethod find-system (name &optional (error-p t))
5902 (find-system (coerce-name name) error-p))
5904 (defvar *systems-being-defined* nil
5905 "A hash-table of systems currently being defined keyed by name, or NIL")
5907 (defun find-system-if-being-defined (name)
5908 (when *systems-being-defined*
5909 (gethash (coerce-name name) *systems-being-defined*)))
5911 (defun call-with-system-definitions (thunk)
5912 (if *systems-being-defined*
5913 (call-with-asdf-cache thunk)
5914 (let ((*systems-being-defined* (make-hash-table :test 'equal)))
5915 (call-with-asdf-cache thunk))))
5917 (defmacro with-system-definitions ((&optional) &body body)
5918 `(call-with-system-definitions #'(lambda () ,@body)))
5920 (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))))
5921 ;; Tries to load system definition with canonical NAME from PATHNAME.
5922 (with-system-definitions ()
5923 (with-standard-io-syntax
5924 (let ((*package* (find-package :asdf-user))
5925 (*print-readably* nil)
5926 (*default-pathname-defaults*
5927 ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
5928 (pathname-directory-pathname (translate-logical-pathname pathname))))
5930 ((error #'(lambda (condition)
5931 (error 'load-system-definition-error
5932 :name name :pathname pathname
5933 :condition condition))))
5934 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
5936 (with-muffled-loader-conditions ()
5937 (load* pathname :external-format external-format)))))))
5939 (defun locate-system (name)
5940 "Given a system NAME designator, try to locate where to load the system from.
5941 Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
5942 FOUNDP is true when a system was found,
5943 either a new unregistered one or a previously registered one.
5944 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
5945 PATHNAME when not null is a path from where to load the system,
5946 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
5947 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
5948 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
5949 (let* ((name (coerce-name name))
5950 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
5951 (previous (cdr in-memory))
5952 (previous (and (typep previous 'system) previous))
5953 (previous-time (car in-memory))
5954 (found (search-for-system-definition name))
5955 (found-system (and (typep found 'system) found))
5956 (pathname (or (and (typep found '(or pathname string)) (pathname found))
5957 (and found-system (system-source-file found-system))
5958 (and previous (system-source-file previous))))
5959 (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
5960 (foundp (and (or found-system pathname previous) t)))
5961 (check-type found (or null pathname system))
5962 (values foundp found-system pathname previous previous-time)))
5964 (defmethod find-system ((name string) &optional (error-p t))
5965 (with-system-definitions ()
5968 (multiple-value-bind (foundp found-system pathname previous previous-time)
5969 (locate-system name)
5970 (assert (eq foundp (and (or found-system pathname previous) t)))
5971 (let ((previous-pathname (and previous (system-source-file previous)))
5972 (system (or previous found-system)))
5973 (when (and found-system (not previous))
5974 (register-system found-system))
5975 (when (and system pathname)
5976 (setf (system-source-file system) pathname))
5978 (let ((stamp (get-file-stamp pathname)))
5981 (or (pathname-equal pathname previous-pathname)
5982 (and pathname previous-pathname
5984 (translate-logical-pathname pathname)
5985 (translate-logical-pathname previous-pathname))))
5986 (stamp<= stamp previous-time))))))
5987 ;; only load when it's a pathname that is different or has newer content
5988 (load-asd pathname :name name)))
5989 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
5994 (setf (car in-memory) (get-file-stamp pathname)))
5997 (error 'missing-component :requires name))))))
5998 (reinitialize-source-registry-and-retry ()
6000 (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
6001 (initialize-source-registry))))))
6003 (defvar *preloaded-systems* (make-hash-table :test 'equal))
6005 (defun sysdef-find-preloaded-systems (requested)
6006 (let ((name (coerce-name requested)))
6007 (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
6009 (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys)))))
6011 (defun register-preloaded-system (system-name &rest keys)
6012 (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
6014 (register-preloaded-system "asdf" :version *asdf-version*)
6015 (register-preloaded-system "asdf-driver" :version *asdf-version*))
6017 ;;;; -------------------------------------------------------------------------
6018 ;;;; Finding components
6020 (asdf/package:define-package :asdf/find-component
6021 (:recycle :asdf/find-component :asdf)
6022 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6023 :asdf/component :asdf/system :asdf/find-system)
6026 #:resolve-dependency-name #:resolve-dependency-spec
6027 #:resolve-dependency-combination
6029 #:missing-component #:missing-component-of-version #:retry
6030 #:missing-dependency #:missing-dependency-of-version
6031 #:missing-requires #:missing-parent
6032 #:missing-required-by #:missing-version))
6033 (in-package :asdf/find-component)
6035 ;;;; Missing component conditions
6037 (with-upgradability ()
6038 (define-condition missing-component-of-version (missing-component)
6039 ((version :initform nil :reader missing-version :initarg :version)))
6041 (define-condition missing-dependency (missing-component)
6042 ((required-by :initarg :required-by :reader missing-required-by)))
6044 (defmethod print-object ((c missing-dependency) s)
6045 (format s (compatfmt "~@<~A, required by ~A~@:>")
6046 (call-next-method c nil) (missing-required-by c)))
6048 (define-condition missing-dependency-of-version (missing-dependency
6049 missing-component-of-version)
6052 (defmethod print-object ((c missing-component) s)
6053 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
6054 (missing-requires c)
6055 (when (missing-parent c)
6056 (coerce-name (missing-parent c)))))
6058 (defmethod print-object ((c missing-component-of-version) s)
6059 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
6060 (missing-requires c)
6062 (when (missing-parent c)
6063 (coerce-name (missing-parent c))))))
6066 ;;;; Finding components
6068 (with-upgradability ()
6069 (defgeneric* (find-component) (base path)
6070 (:documentation "Find a component by resolving the PATH starting from BASE parent"))
6071 (defgeneric resolve-dependency-combination (component combinator arguments))
6073 (defmethod find-component ((base string) path)
6074 (let ((s (find-system base nil)))
6075 (and s (find-component s path))))
6077 (defmethod find-component ((base symbol) path)
6079 (base (find-component (coerce-name base) path))
6080 (path (find-component path nil))
6083 (defmethod find-component ((base cons) path)
6084 (find-component (car base) (cons (cdr base) path)))
6086 (defmethod find-component ((parent parent-component) (name string))
6087 (compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!!
6088 (values (gethash name (component-children-by-name parent))))
6090 (defmethod find-component (base (name symbol))
6092 (find-component base (coerce-name name))
6095 (defmethod find-component ((c component) (name cons))
6096 (find-component (find-component c (car name)) (cdr name)))
6098 (defmethod find-component (base (actual component))
6099 (declare (ignorable base))
6102 (defun resolve-dependency-name (component name &optional version)
6106 (let ((comp (find-component (component-parent component) name)))
6108 (error 'missing-dependency
6109 :required-by component
6112 (unless (version-satisfies comp version)
6113 (error 'missing-dependency-of-version
6114 :required-by component
6120 (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
6124 (and (typep c 'missing-dependency)
6125 (eq (missing-required-by c) component)
6126 (equal (missing-requires c) name))))))))
6128 (defun resolve-dependency-spec (component dep-spec)
6129 (let ((component (find-component () component)))
6131 (resolve-dependency-name component dep-spec)
6132 (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
6134 (defmethod resolve-dependency-combination (component combinator arguments)
6135 (error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
6136 (cons combinator arguments) component))
6138 (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
6139 (declare (ignorable combinator))
6140 (when (featurep (first arguments))
6141 (resolve-dependency-spec component (second arguments))))
6143 (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
6144 (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
6145 (resolve-dependency-name component (first arguments) (second arguments))))
6147 ;;;; -------------------------------------------------------------------------
6150 (asdf/package:define-package :asdf/operation
6151 (:recycle :asdf/operation :asdf)
6152 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
6155 #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
6156 #:build-op ;; THE generic operation
6160 (in-package :asdf/operation)
6162 ;;; Operation Classes
6164 (when-upgrading (:when (find-class 'operation nil))
6165 (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
6166 (declare (ignorable o slot-names initargs)) (values)))
6168 (with-upgradability ()
6169 (defclass operation ()
6170 ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced)
6171 :initform nil :initarg :original-initargs :accessor operation-original-initargs)))
6173 (defmethod initialize-instance :after ((o operation) &rest initargs
6174 &key force force-not system verbose &allow-other-keys)
6175 (declare (ignorable force force-not system verbose))
6176 (unless (slot-boundp o 'original-initargs)
6177 (setf (operation-original-initargs o) initargs)))
6179 (defmethod print-object ((o operation) stream)
6180 (print-unreadable-object (o stream :type t :identity nil)
6182 (format stream "~{~S~^ ~}" (operation-original-initargs o))))))
6184 ;;; make-operation, find-operation
6186 (with-upgradability ()
6187 (defparameter *operations* (make-hash-table :test 'equal))
6188 (defun make-operation (operation-class &rest initargs)
6189 (let ((key (cons operation-class initargs)))
6190 (multiple-value-bind (operation foundp) (gethash key *operations*)
6191 (if foundp operation
6192 (setf (gethash key *operations*)
6193 (apply 'make-instance operation-class initargs))))))
6195 (defgeneric find-operation (context spec)
6196 (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
6197 (defmethod find-operation (context (spec operation))
6198 (declare (ignorable context))
6200 (defmethod find-operation (context (spec symbol))
6201 (apply 'make-operation spec (operation-original-initargs context)))
6202 (defmethod operation-original-initargs ((context symbol))
6203 (declare (ignorable context))
6206 (defclass build-op (operation) ()))
6209 ;;;; -------------------------------------------------------------------------
6212 (asdf/package:define-package :asdf/action
6213 (:nicknames :asdf-action)
6214 (:recycle :asdf/action :asdf)
6215 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6216 :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation)
6218 #:action #:define-convenience-action-methods
6219 #:explain #:action-description
6220 #:downward-operation #:upward-operation #:sibling-operation
6221 #:component-depends-on #:component-self-dependencies
6222 #:input-files #:output-files #:output-file #:operation-done-p
6223 #:action-status #:action-stamp #:action-done-p
6224 #:component-operation-time #:mark-operation-done #:compute-action-stamp
6225 #:perform #:perform-with-restarts #:retry #:accept #:feature
6226 #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
6227 #:action-path #:find-action #:stamp #:done-p))
6228 (in-package :asdf/action)
6230 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
6231 (deftype action () '(cons operation component))) ;; a step to be performed while building
6233 (with-upgradability ()
6234 (defgeneric traverse-actions (actions &key &allow-other-keys))
6235 (defgeneric traverse-sub-actions (operation component &key &allow-other-keys))
6236 (defgeneric required-components (component &key &allow-other-keys)))
6238 ;;;; Reified representation for storage or debugging. Note: dropping original-initargs
6239 (with-upgradability ()
6240 (defun action-path (action)
6241 (destructuring-bind (o . c) action (cons (type-of o) (component-find-path c))))
6242 (defun find-action (path)
6243 (destructuring-bind (o . c) path (cons (make-operation o) (find-component () c)))))
6246 ;;;; Convenience methods
6247 (with-upgradability ()
6248 (defmacro define-convenience-action-methods
6249 (function (operation component &optional keyp)
6250 &key if-no-operation if-no-component operation-initargs)
6251 (let* ((rest (gensym "REST"))
6252 (found (gensym "FOUND"))
6253 (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
6254 (flet ((next-method (o c)
6256 `(apply ',function ,o ,c ,rest)
6257 `(,function ,o ,c))))
6259 (defmethod ,function ((,operation symbol) ,component ,@more-args)
6262 (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
6263 `(apply 'make-operation ,operation :original-initargs ,rest ,rest)
6264 `(make-operation ,operation))
6265 `(or (find-component () ,component) ,if-no-component))
6267 (defmethod ,function ((,operation operation) ,component ,@more-args)
6268 (if (typep ,component 'component)
6269 (error "No defined method for ~S on ~/asdf-action:format-action/"
6270 ',function (cons ,operation ,component))
6271 (let ((,found (find-component () ,component)))
6273 ,(next-method operation found)
6274 ,if-no-component)))))))))
6277 ;;;; self-description
6278 (with-upgradability ()
6279 (defgeneric action-description (operation component)
6280 (:documentation "returns a phrase that describes performing this operation
6281 on this component, e.g. \"loading /a/b/c\".
6282 You can put together sentences using this phrase."))
6283 (defmethod action-description (operation component)
6284 (format nil (compatfmt "~@<~A on ~A~@:>")
6285 (type-of operation) component))
6286 (defgeneric* (explain) (operation component))
6287 (defmethod explain ((o operation) (c component))
6288 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))
6289 (define-convenience-action-methods explain (operation component))
6291 (defun format-action (stream action &optional colon-p at-sign-p)
6292 (assert (null colon-p)) (assert (null at-sign-p))
6293 (destructuring-bind (operation . component) action
6294 (princ (action-description operation component) stream))))
6298 (with-upgradability ()
6299 (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
6301 "Returns a list of dependencies needed by the component to perform
6302 the operation. A dependency has one of the following forms:
6304 (<operation> <component>*), where <operation> is a class
6305 designator and each <component> is a component
6306 designator, which means that the component depends on
6307 <operation> having been performed on each <component>; or
6309 (FEATURE <feature>), which means that the component depends
6310 on <feature>'s presence in *FEATURES*.
6312 Methods specialized on subclasses of existing component types
6313 should usually append the results of CALL-NEXT-METHOD to the
6315 (defgeneric component-self-dependencies (operation component))
6316 (define-convenience-action-methods component-depends-on (operation component))
6317 (define-convenience-action-methods component-self-dependencies (operation component))
6319 (defmethod component-depends-on ((o operation) (c component))
6320 (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
6322 (defmethod component-self-dependencies ((o operation) (c component))
6323 ;; NB: result in the same format as component-depends-on
6324 (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
6325 :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
6326 :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
6327 :collect (list o-spec c))))
6329 ;;;; upward-operation, downward-operation
6330 ;; These together handle actions that propagate along the component hierarchy.
6331 ;; Downward operations like load-op or compile-op propagate down the hierarchy:
6332 ;; operation on a parent depends-on operation on its children.
6333 ;; By default, an operation propagates itself, but it may propagate another one instead.
6334 (with-upgradability ()
6335 (defclass downward-operation (operation)
6336 ((downward-operation
6337 :initform nil :initarg :downward-operation :reader downward-operation)))
6338 (defmethod component-depends-on ((o downward-operation) (c parent-component))
6339 `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
6340 ;; Upward operations like prepare-op propagate up the component hierarchy:
6341 ;; operation on a child depends-on operation on its parent.
6342 ;; By default, an operation propagates itself, but it may propagate another one instead.
6343 (defclass upward-operation (operation)
6345 :initform nil :initarg :downward-operation :reader upward-operation)))
6346 ;; For backward-compatibility reasons, a system inherits from module and is a child-component
6347 ;; so we must guard against this case. ASDF4: remove that.
6348 (defmethod component-depends-on ((o upward-operation) (c child-component))
6349 `(,@(if-let (p (component-parent c))
6350 `((,(or (upward-operation o) o) ,p))) ,@(call-next-method)))
6351 ;; Sibling operations propagate to siblings in the component hierarchy:
6352 ;; operation on a child depends-on operation on its parent.
6353 ;; By default, an operation propagates itself, but it may propagate another one instead.
6354 (defclass sibling-operation (operation)
6356 :initform nil :initarg :sibling-operation :reader sibling-operation)))
6357 (defmethod component-depends-on ((o sibling-operation) (c component))
6358 `((,(or (sibling-operation o) o)
6359 ,@(loop :for dep :in (component-sibling-dependencies c)
6360 :collect (resolve-dependency-spec c dep)))
6361 ,@(call-next-method))))
6364 ;;;; Inputs, Outputs, and invisible dependencies
6365 (with-upgradability ()
6366 (defgeneric* (output-files) (operation component))
6367 (defgeneric* (input-files) (operation component))
6368 (defgeneric* (operation-done-p) (operation component)
6369 (:documentation "Returns a boolean, which is NIL if the action is forced to be performed again"))
6370 (define-convenience-action-methods output-files (operation component))
6371 (define-convenience-action-methods input-files (operation component))
6372 (define-convenience-action-methods operation-done-p (operation component))
6374 (defmethod operation-done-p ((o operation) (c component))
6375 (declare (ignorable o c))
6378 (defmethod output-files :around (operation component)
6379 "Translate output files, unless asked not to. Memoize the result."
6380 operation component ;; hush genera, not convinced by declare ignorable(!)
6381 (do-asdf-cache `(output-files ,operation ,component)
6383 (multiple-value-bind (pathnames fixedp) (call-next-method)
6384 ;; 1- Make sure we have absolute pathnames
6385 (let* ((directory (pathname-directory-pathname
6386 (component-pathname (find-component () component))))
6389 :for pathname :in pathnames
6390 :collect (ensure-absolute-pathname pathname directory))))
6391 ;; 2- Translate those pathnames as required
6394 (mapcar *output-translation-function* absolute-pathnames))))
6396 (defmethod output-files ((o operation) (c component))
6397 (declare (ignorable o c))
6399 (defun output-file (operation component)
6400 "The unique output file of performing OPERATION on COMPONENT"
6401 (let ((files (output-files operation component)))
6402 (assert (length=n-p files 1))
6405 (defmethod input-files :around (operation component)
6406 "memoize input files."
6407 (do-asdf-cache `(input-files ,operation ,component)
6408 (call-next-method)))
6410 (defmethod input-files ((o operation) (c parent-component))
6411 (declare (ignorable o c))
6414 (defmethod input-files ((o operation) (c component))
6415 (or (loop* :for (dep-o) :in (component-self-dependencies o c)
6416 :append (or (output-files dep-o c) (input-files dep-o c)))
6417 ;; no non-trivial previous operations needed?
6418 ;; I guess we work with the original source file, then
6419 (if-let ((pathname (component-pathname c)))
6420 (and (file-pathname-p pathname) (list pathname))))))
6423 ;;;; Done performing
6424 (with-upgradability ()
6425 (defgeneric component-operation-time (operation component)) ;; ASDF4: hide it behind plan-action-stamp
6426 (define-convenience-action-methods component-operation-time (operation component))
6428 (defgeneric mark-operation-done (operation component)) ;; ASDF4: hide it behind (setf plan-action-stamp)
6429 (defgeneric compute-action-stamp (plan operation component &key just-done)
6430 (:documentation "Has this action been successfully done already,
6431 and at what known timestamp has it been done at or will it be done at?
6432 Takes two keywords JUST-DONE and PLAN:
6433 JUST-DONE is a boolean that is true if the action was just successfully performed,
6434 at which point we want compute the actual stamp and warn if files are missing;
6435 otherwise we are making plans, anticipating the effects of the action.
6436 PLAN is a plan object modelling future effects of actions,
6437 or NIL to denote what actually happened.
6439 * a STAMP saying when it was done or will be done,
6440 or T if the action has involves files that need to be recomputed.
6441 * a boolean DONE-P that indicates whether the action has actually been done,
6442 and both its output-files and its in-image side-effects are up to date."))
6444 (defclass action-status ()
6446 :initarg :stamp :reader action-stamp
6447 :documentation "STAMP associated with the ACTION if it has been completed already
6448 in some previous image, or T if it needs to be done.")
6450 :initarg :done-p :reader action-done-p
6451 :documentation "a boolean, true iff the action was already done (before any planned action)."))
6452 (:documentation "Status of an action"))
6454 (defmethod print-object ((status action-status) stream)
6455 (print-unreadable-object (status stream :type t)
6456 (with-slots (stamp done-p) status
6457 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p))))
6459 (defmethod component-operation-time ((o operation) (c component))
6460 (gethash (type-of o) (component-operation-times c)))
6462 (defmethod mark-operation-done ((o operation) (c component))
6463 (setf (gethash (type-of o) (component-operation-times c))
6464 (compute-action-stamp nil o c :just-done t))))
6468 (with-upgradability ()
6469 (defgeneric* (perform-with-restarts) (operation component))
6470 (defgeneric* (perform) (operation component))
6471 (define-convenience-action-methods perform (operation component))
6473 (defmethod perform :before ((o operation) (c component))
6474 (ensure-all-directories-exist (output-files o c)))
6475 (defmethod perform :after ((o operation) (c component))
6476 (mark-operation-done o c))
6477 (defmethod perform ((o operation) (c parent-component))
6478 (declare (ignorable o c))
6480 (defmethod perform ((o operation) (c source-file))
6482 (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
6483 (class-of o) (class-of c)))
6485 (defmethod perform-with-restarts (operation component)
6486 ;; TOO verbose, especially as the default. Add your own :before method
6487 ;; to perform-with-restart or perform if you want that:
6488 #|(explain operation component)|#
6489 (perform operation component))
6490 (defmethod perform-with-restarts :around (operation component)
6493 (return (call-next-method))
6497 (format s (compatfmt "~@<Retry ~A.~@:>")
6498 (action-description operation component))))
6502 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
6503 (action-description operation component)))
6504 (mark-operation-done operation component)
6507 ;;; Generic build operation
6508 (with-upgradability ()
6509 (defmethod component-depends-on ((o build-op) (c component))
6510 `((,(or (component-build-operation c) 'load-op) ,c))))
6512 ;;;; -------------------------------------------------------------------------
6513 ;;;; Actions to build Common Lisp software
6515 (asdf/package:define-package :asdf/lisp-action
6516 (:recycle :asdf/lisp-action :asdf)
6517 (:intern #:proclamations #:flags)
6518 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6519 :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
6522 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
6523 #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
6524 #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
6525 #:call-with-around-compile-hook
6526 #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
6527 (in-package :asdf/lisp-action)
6530 ;;;; Component classes
6531 (with-upgradability ()
6532 (defclass cl-source-file (source-file)
6533 ((type :initform "lisp")))
6534 (defclass cl-source-file.cl (cl-source-file)
6535 ((type :initform "cl")))
6536 (defclass cl-source-file.lsp (cl-source-file)
6537 ((type :initform "lsp"))))
6540 ;;;; Operation classes
6541 (with-upgradability ()
6542 (defclass basic-load-op (operation) ())
6543 (defclass basic-compile-op (operation)
6544 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
6545 (flags :initarg :flags :accessor compile-op-flags
6548 ;;; Our default operations: loading into the current lisp image
6549 (with-upgradability ()
6550 (defclass load-op (basic-load-op downward-operation sibling-operation) ())
6551 (defclass prepare-op (upward-operation sibling-operation)
6552 ((sibling-operation :initform 'load-op :allocation :class)))
6553 (defclass compile-op (basic-compile-op downward-operation)
6554 ((downward-operation :initform 'load-op :allocation :class)))
6556 (defclass load-source-op (basic-load-op downward-operation) ())
6557 (defclass prepare-source-op (upward-operation sibling-operation)
6558 ((sibling-operation :initform 'load-source-op :allocation :class)))
6560 (defclass test-op (operation) ()))
6563 ;;;; prepare-op, compile-op and load-op
6566 (with-upgradability ()
6567 (defmethod action-description ((o prepare-op) (c component))
6568 (declare (ignorable o))
6569 (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
6570 (defmethod perform ((o prepare-op) (c component))
6571 (declare (ignorable o c))
6573 (defmethod input-files ((o prepare-op) (c component))
6574 (declare (ignorable o c))
6576 (defmethod input-files ((o prepare-op) (s system))
6577 (declare (ignorable o))
6578 (if-let (it (system-source-file s)) (list it))))
6581 (with-upgradability ()
6582 (defmethod action-description ((o compile-op) (c component))
6583 (declare (ignorable o))
6584 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
6585 (defmethod action-description ((o compile-op) (c parent-component))
6586 (declare (ignorable o))
6587 (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
6588 (defgeneric call-with-around-compile-hook (component thunk))
6589 (defmethod call-with-around-compile-hook ((c component) function)
6590 (call-around-hook (around-compile-hook c) function))
6591 (defun perform-lisp-compilation (o c)
6592 (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
6593 ;; we consult input-files, the first of which should be the one to compile-file
6594 (input-file (first (input-files o c)))
6595 ;; on some implementations, there are more than one output-file,
6596 ;; but the first one should always be the primary fasl that gets loaded.
6597 (outputs (output-files o c)))
6598 (multiple-value-bind (output warnings-p failure-p)
6603 #+(or ecl mkcl) object-file
6604 warnings-file) outputs
6605 (call-with-around-compile-hook
6606 c #'(lambda (&rest flags)
6607 (with-muffled-compiler-conditions ()
6608 (apply 'compile-file* input-file
6609 :output-file output-file
6610 :external-format (component-external-format c)
6611 :warnings-file warnings-file
6613 #+clisp (list :lib-file lib-file)
6614 #+(or ecl mkcl) (list :object-file object-file)
6615 flags (compile-op-flags o)))))))
6616 (check-lisp-compile-results output warnings-p failure-p
6617 "~/asdf-action::format-action/" (list (cons o c))))))
6619 (defun report-file-p (f)
6620 (equal (pathname-type f) "build-report"))
6621 (defun perform-lisp-warnings-check (o c)
6622 (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
6623 (actual-warnings-files (loop :for w :in expected-warnings-files
6624 :when (get-file-stamp w)
6626 :else :do (warn "Missing warnings file ~S while ~A"
6627 w (action-description o c)))))
6628 (check-deferred-warnings actual-warnings-files)
6629 (let* ((output (output-files o c))
6630 (report (find-if #'report-file-p output)))
6632 (with-open-file (s report :direction :output :if-exists :supersede)
6633 (format s ":success~%"))))))
6634 (defmethod perform ((o compile-op) (c cl-source-file))
6635 (perform-lisp-compilation o c))
6636 (defmethod output-files ((o compile-op) (c cl-source-file))
6637 (declare (ignorable o))
6638 (let* ((i (first (input-files o c)))
6639 (f (compile-file-pathname
6640 i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
6641 `(,f ;; the fasl is the primary output, in first position
6643 ,@`(,(make-pathname :type "lib" :defaults f))
6645 ,@(unless (use-ecl-byte-compiler-p)
6646 `(,(compile-file-pathname i :type :object)))
6648 ,(compile-file-pathname i :fasl-p nil) ;; object file
6649 ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
6650 `(,(make-pathname :type *warnings-file-type* :defaults f))))))
6651 (defmethod component-depends-on ((o compile-op) (c component))
6652 (declare (ignorable o))
6653 `((prepare-op ,c) ,@(call-next-method)))
6654 (defmethod perform ((o compile-op) (c static-file))
6655 (declare (ignorable o c))
6657 (defmethod output-files ((o compile-op) (c static-file))
6658 (declare (ignorable o c))
6660 (defmethod perform ((o compile-op) (c system))
6661 (when (and *warnings-file-type* (not (builtin-system-p c)))
6662 (perform-lisp-warnings-check o c)))
6663 (defmethod input-files ((o compile-op) (c system))
6664 (when (and *warnings-file-type* (not (builtin-system-p c)))
6665 ;; The most correct way to do it would be to use:
6666 ;; (traverse-sub-actions o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
6667 ;; but it's expensive and we don't care too much about file order or ASDF extensions.
6668 (loop :for sub :in (sub-components c :type 'cl-source-file)
6669 :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))
6670 (defmethod output-files ((o compile-op) (c system))
6671 (when (and *warnings-file-type* (not (builtin-system-p c)))
6672 (if-let ((pathname (component-pathname c)))
6673 (list (subpathname pathname (component-name c) :type "build-report"))))))
6676 (with-upgradability ()
6677 (defmethod action-description ((o load-op) (c cl-source-file))
6678 (declare (ignorable o))
6679 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
6680 (defmethod action-description ((o load-op) (c parent-component))
6681 (declare (ignorable o))
6682 (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
6683 (defmethod action-description ((o load-op) component)
6684 (declare (ignorable o))
6685 (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
6687 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
6690 (return (call-next-method))
6693 (format s "Recompile ~a and try loading it again"
6694 (component-name c)))
6695 (perform (find-operation o 'compile-op) c)))))
6696 (defun perform-lisp-load-fasl (o c)
6697 (if-let (fasl (first (input-files o c)))
6698 (with-muffled-loader-conditions () (load* fasl))))
6699 (defmethod perform ((o load-op) (c cl-source-file))
6700 (perform-lisp-load-fasl o c))
6701 (defmethod perform ((o load-op) (c static-file))
6702 (declare (ignorable o c))
6704 (defmethod component-depends-on ((o load-op) (c component))
6705 (declare (ignorable o))
6706 ;; NB: even though compile-op depends-on on prepare-op,
6707 ;; it is not needed-in-image-p, whereas prepare-op is,
6708 ;; so better not omit prepare-op and think it will happen.
6709 `((prepare-op ,c) (compile-op ,c) ,@(call-next-method))))
6712 ;;;; prepare-source-op, load-source-op
6714 ;;; prepare-source-op
6715 (with-upgradability ()
6716 (defmethod action-description ((o prepare-source-op) (c component))
6717 (declare (ignorable o))
6718 (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
6719 (defmethod input-files ((o prepare-source-op) (c component))
6720 (declare (ignorable o c))
6722 (defmethod input-files ((o prepare-source-op) (s system))
6723 (declare (ignorable o))
6724 (if-let (it (system-source-file s)) (list it)))
6725 (defmethod perform ((o prepare-source-op) (c component))
6726 (declare (ignorable o c))
6730 (with-upgradability ()
6731 (defmethod action-description ((o load-source-op) c)
6732 (declare (ignorable o))
6733 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
6734 (defmethod action-description ((o load-source-op) (c parent-component))
6735 (declare (ignorable o))
6736 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
6737 (defmethod component-depends-on ((o load-source-op) (c component))
6738 (declare (ignorable o))
6739 `((prepare-source-op ,c) ,@(call-next-method)))
6740 (defun perform-lisp-load-source (o c)
6741 (call-with-around-compile-hook
6743 (with-muffled-loader-conditions ()
6744 (load* (first (input-files o c))
6745 :external-format (component-external-format c))))))
6747 (defmethod perform ((o load-source-op) (c cl-source-file))
6748 (perform-lisp-load-source o c))
6749 (defmethod perform ((o load-source-op) (c static-file))
6750 (declare (ignorable o c))
6752 (defmethod output-files ((o load-source-op) (c component))
6753 (declare (ignorable o c))
6758 (with-upgradability ()
6759 (defmethod perform ((o test-op) (c component))
6760 (declare (ignorable o c))
6762 (defmethod operation-done-p ((o test-op) (c system))
6763 "Testing a system is _never_ done."
6764 (declare (ignorable o c))
6766 (defmethod component-depends-on ((o test-op) (c system))
6767 (declare (ignorable o))
6768 `((load-op ,c) ,@(call-next-method))))
6770 ;;;; -------------------------------------------------------------------------
6773 (asdf/package:define-package :asdf/plan
6774 (:recycle :asdf/plan :asdf)
6775 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
6776 :asdf/component :asdf/operation :asdf/system
6777 :asdf/cache :asdf/find-system :asdf/find-component
6778 :asdf/operation :asdf/action :asdf/lisp-action)
6780 #:component-operation-time #:mark-operation-done
6781 #:plan-traversal #:sequential-plan #:*default-plan-class*
6782 #:planned-action-status #:plan-action-status #:action-already-done-p
6783 #:circular-dependency #:circular-dependency-actions
6784 #:node-for #:needed-in-image-p
6785 #:action-index #:action-planned-p #:action-valid-p
6786 #:plan-record-dependency #:visiting-action-p
6787 #:normalize-forced-systems #:action-forced-p #:action-forced-not-p
6788 #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
6789 #:visit-dependencies #:compute-action-stamp #:traverse-action
6790 #:circular-dependency #:circular-dependency-actions
6791 #:call-while-visiting-action #:while-visiting-action
6792 #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
6793 #:planned-p #:index #:forced #:forced-not #:total-action-count
6794 #:planned-action-count #:planned-output-action-count #:visited-actions
6795 #:visiting-action-set #:visiting-action-list #:plan-actions-r
6796 #:required-components #:filtered-sequential-plan
6798 #:plan-action-filter #:plan-component-type #:plan-keep-operation #:plan-keep-component
6799 #:traverse-actions #:traverse-sub-actions))
6800 (in-package :asdf/plan)
6802 ;;;; Generic plan traversal class
6803 (with-upgradability ()
6804 (defclass plan-traversal ()
6805 ((system :initform nil :initarg :system :accessor plan-system)
6806 (forced :initform nil :initarg :force :accessor plan-forced)
6807 (forced-not :initform nil :initarg :force-not :accessor plan-forced-not)
6808 (total-action-count :initform 0 :accessor plan-total-action-count)
6809 (planned-action-count :initform 0 :accessor plan-planned-action-count)
6810 (planned-output-action-count :initform 0 :accessor plan-planned-output-action-count)
6811 (visited-actions :initform (make-hash-table :test 'equal) :accessor plan-visited-actions)
6812 (visiting-action-set :initform (make-hash-table :test 'equal) :accessor plan-visiting-action-set)
6813 (visiting-action-list :initform () :accessor plan-visiting-action-list))))
6816 ;;;; Planned action status
6817 (with-upgradability ()
6818 (defgeneric plan-action-status (plan operation component)
6819 (:documentation "Returns the ACTION-STATUS associated to
6820 the action of OPERATION on COMPONENT in the PLAN"))
6822 (defgeneric (setf plan-action-status) (new-status plan operation component)
6823 (:documentation "Sets the ACTION-STATUS associated to
6824 the action of OPERATION on COMPONENT in the PLAN"))
6826 (defclass planned-action-status (action-status)
6828 :initarg :planned-p :reader action-planned-p
6829 :documentation "a boolean, true iff the action was included in the plan.")
6831 :initarg :index :reader action-index
6832 :documentation "an integer, counting all traversed actions in traversal order."))
6833 (:documentation "Status of an action in a plan"))
6835 (defmethod print-object ((status planned-action-status) stream)
6836 (print-unreadable-object (status stream :type t :identity nil)
6837 (with-slots (stamp done-p planned-p index) status
6838 (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index))))
6840 (defmethod action-planned-p (action-status)
6841 (declare (ignorable action-status)) ; default method for non planned-action-status objects
6844 ;; TODO: eliminate NODE-FOR, use CONS.
6845 ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION.
6846 ;; However, see also component-operation-time and mark-operation-done
6847 (defun node-for (o c) (cons (type-of o) c))
6849 (defun action-already-done-p (plan operation component)
6850 (action-done-p (plan-action-status plan operation component)))
6852 (defmethod plan-action-status ((plan null) (o operation) (c component))
6853 (declare (ignorable plan))
6854 (multiple-value-bind (stamp done-p) (component-operation-time o c)
6855 (make-instance 'action-status :stamp stamp :done-p done-p)))
6857 (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component))
6858 (declare (ignorable plan))
6859 (let ((to (type-of o))
6860 (times (component-operation-times c)))
6861 (if (action-done-p new-status)
6863 (setf (gethash to times) (action-stamp new-status))))
6868 (with-upgradability ()
6869 (defgeneric action-forced-p (plan operation component))
6870 (defgeneric action-forced-not-p (plan operation component))
6872 (defun normalize-forced-systems (x system)
6874 ((member nil :all) x)
6875 (cons (list-to-hash-set (mapcar #'coerce-name x)))
6876 ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
6878 (defun action-override-p (plan operation component override-accessor)
6879 (declare (ignorable operation))
6880 (let* ((override (funcall override-accessor plan)))
6882 (if (typep override 'hash-table)
6883 (gethash (coerce-name (component-system (find-component () component))) override)
6886 (defmethod action-forced-p (plan operation component)
6888 ;; Did the user ask us to re-perform the action?
6889 (action-override-p plan operation component 'plan-forced)
6890 ;; You really can't force a builtin system and :all doesn't apply to it,
6891 ;; except it it's the specifically the system currently being built.
6892 (not (let ((system (component-system component)))
6893 (and (builtin-system-p system)
6894 (not (eq system (plan-system plan))))))))
6896 (defmethod action-forced-not-p (plan operation component)
6898 ;; Did the user ask us to not re-perform the action?
6899 (action-override-p plan operation component 'plan-forced-not)
6900 ;; Force takes precedence over force-not
6901 (not (action-forced-p plan operation component))))
6903 (defmethod action-forced-p ((plan null) operation component)
6904 (declare (ignorable plan operation component))
6907 (defmethod action-forced-not-p ((plan null) operation component)
6908 (declare (ignorable plan operation component))
6913 (with-upgradability ()
6914 (defgeneric action-valid-p (plan operation component)
6915 (:documentation "Is this action valid to include amongst dependencies?"))
6916 (defmethod action-valid-p (plan operation (c component))
6917 (declare (ignorable plan operation))
6918 (if-let (it (component-if-feature c)) (featurep it) t))
6919 (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil)
6920 (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil)
6921 (defmethod action-valid-p ((plan null) operation component)
6922 (declare (ignorable plan operation component))
6923 (and operation component t)))
6926 ;;;; Is the action needed in this image?
6927 (with-upgradability ()
6928 (defgeneric needed-in-image-p (operation component)
6929 (:documentation "Is the action of OPERATION on COMPONENT needed in the current image to be meaningful,
6930 or could it just as well have been done in another Lisp image?"))
6932 (defmethod needed-in-image-p ((o operation) (c component))
6933 ;; We presume that actions that modify the filesystem don't need be run
6934 ;; in the current image if they have already been done in another,
6935 ;; and can be run in another process (e.g. a fork),
6936 ;; whereas those that don't are meant to side-effect the current image and can't.
6937 (not (output-files o c))))
6940 ;;;; Visiting dependencies of an action and computing action stamps
6941 (with-upgradability ()
6942 (defun map-direct-dependencies (operation component fun)
6943 (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
6944 :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
6945 :do (loop :with dep-o = (find-operation operation dep-o-spec)
6946 :for dep-c-spec :in dep-c-specs
6947 :for dep-c = (resolve-dependency-spec component dep-c-spec)
6948 :do (funcall fun dep-o dep-c))))
6950 (defun reduce-direct-dependencies (operation component combinator seed)
6951 (map-direct-dependencies
6953 #'(lambda (dep-o dep-c)
6954 (setf seed (funcall combinator dep-o dep-c seed))))
6957 (defun direct-dependencies (operation component)
6958 (reduce-direct-dependencies operation component #'acons nil))
6960 (defun visit-dependencies (plan operation component dependency-stamper &aux stamp)
6961 (map-direct-dependencies
6963 #'(lambda (dep-o dep-c)
6964 (when (action-valid-p plan dep-o dep-c)
6965 (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c)))))
6968 (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
6969 ;; In a distant future, get-file-stamp and component-operation-time
6970 ;; shall also be parametrized by the plan, or by a second model object.
6971 (let* ((stamp-lookup #'(lambda (o c)
6972 (if-let (it (plan-action-status plan o c)) (action-stamp it) t)))
6973 (out-files (output-files o c))
6974 (in-files (input-files o c))
6975 ;; Three kinds of actions:
6976 (out-op (and out-files t)) ; those that create files on the filesystem
6977 ;(image-op (and in-files (null out-files))) ; those that load stuff into the image
6978 ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing
6979 ;; When was the thing last actually done? (Now, or ask.)
6980 (op-time (or just-done (component-operation-time o c)))
6981 ;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
6982 (dep-stamp (visit-dependencies plan o c stamp-lookup))
6983 ;; Time stamps from the files at hand, and whether any is missing
6984 (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
6985 (in-stamps (mapcar #'get-file-stamp in-files))
6987 (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
6989 (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
6990 (all-present (not (or missing-in missing-out)))
6991 ;; Has any input changed since we last generated the files?
6992 (earliest-out (stamps-earliest out-stamps))
6993 (latest-in (stamps-latest (cons dep-stamp in-stamps)))
6994 (up-to-date-p (stamp<= latest-in earliest-out))
6995 ;; If everything is up to date, the latest of inputs and outputs is our stamp
6996 (done-stamp (stamps-latest (cons latest-in out-stamps))))
6997 ;; Warn if some files are missing:
6998 ;; either our model is wrong or some other process is messing with our files.
6999 (when (and just-done (not all-present))
7000 (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
7001 ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
7002 (action-description o c)
7003 missing-in (length missing-in) (and missing-in missing-out)
7004 missing-out (length missing-out)))
7005 ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
7006 ;; Any race condition is intrinsic to the limited timestamp resolution.
7007 (if (or just-done ;; The done-stamp is valid: if we're just done, or
7008 ;; if all filesystem effects are up-to-date and there's no invalidating reason.
7009 (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
7010 (values done-stamp ;; return the hard-earned timestamp
7012 (or out-op ;; a file-creating op is done when all files are up to date
7013 ;; a image-effecting a placeholder op is done when it was actually run,
7014 (and op-time (eql op-time done-stamp))))) ;; with the matching stamp
7015 ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
7019 ;;;; Generic support for plan-traversal
7020 (with-upgradability ()
7021 (defgeneric plan-record-dependency (plan operation component))
7023 (defgeneric call-while-visiting-action (plan operation component function)
7024 (:documentation "Detect circular dependencies"))
7026 (defmethod initialize-instance :after ((plan plan-traversal)
7027 &key (force () fp) (force-not () fnp) system
7029 (with-slots (forced forced-not) plan
7030 (when fp (setf forced (normalize-forced-systems force system)))
7031 (when fnp (setf forced-not (normalize-forced-systems force-not system)))))
7033 (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component))
7034 (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status))
7036 (defmethod plan-action-status ((plan plan-traversal) (o operation) (c component))
7037 (or (and (action-forced-not-p plan o c) (plan-action-status nil o c))
7038 (values (gethash (node-for o c) (plan-visited-actions plan)))))
7040 (defmethod action-valid-p ((plan plan-traversal) (o operation) (s system))
7041 (and (not (action-forced-not-p plan o s)) (call-next-method)))
7043 (defmethod call-while-visiting-action ((plan plan-traversal) operation component fun)
7044 (with-accessors ((action-set plan-visiting-action-set)
7045 (action-list plan-visiting-action-list)) plan
7046 (let ((action (cons operation component)))
7047 (when (gethash action action-set)
7048 (error 'circular-dependency :actions
7049 (member action (reverse action-list) :test 'equal)))
7050 (setf (gethash action action-set) t)
7051 (push action action-list)
7055 (setf (gethash action action-set) nil))))))
7058 ;;;; Actual traversal: traverse-action
7059 (with-upgradability ()
7060 (define-condition circular-dependency (system-definition-error)
7061 ((actions :initarg :actions :reader circular-dependency-actions))
7062 (:report (lambda (c s)
7063 (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
7064 (circular-dependency-actions c)))))
7066 (defmacro while-visiting-action ((p o c) &body body)
7067 `(call-while-visiting-action ,p ,o ,c #'(lambda () ,@body)))
7069 (defgeneric traverse-action (plan operation component needed-in-image-p))
7071 (defmethod traverse-action (plan operation component needed-in-image-p)
7073 (unless (action-valid-p plan operation component) (return nil))
7074 (plan-record-dependency plan operation component)
7075 (let* ((aniip (needed-in-image-p operation component))
7076 (eniip (and aniip needed-in-image-p))
7077 (status (plan-action-status plan operation component)))
7078 (when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
7079 ;; Already visited with sufficient need-in-image level: just return the stamp.
7080 (return (action-stamp status)))
7081 (labels ((visit-action (niip)
7082 (visit-dependencies plan operation component
7083 #'(lambda (o c) (traverse-action plan o c niip)))
7084 (multiple-value-bind (stamp done-p)
7085 (compute-action-stamp plan operation component)
7086 (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
7088 ((and add-to-plan-p (not niip)) ;; if we need to do it,
7089 (visit-action t)) ;; then we need to do it in the image!
7091 (setf (plan-action-status plan operation component)
7093 'planned-action-status
7095 :done-p (and done-p (not add-to-plan-p))
7096 :planned-p add-to-plan-p
7097 :index (if status (action-index status) (incf (plan-total-action-count plan)))))
7099 (incf (plan-planned-action-count plan))
7101 (incf (plan-planned-output-action-count plan))))
7103 (while-visiting-action (plan operation component) ; maintain context, handle circularity.
7104 (visit-action eniip)))))))
7107 ;;;; Sequential plans (the default)
7108 (with-upgradability ()
7109 (defclass sequential-plan (plan-traversal)
7110 ((actions-r :initform nil :accessor plan-actions-r)))
7112 (defgeneric plan-actions (plan))
7113 (defmethod plan-actions ((plan sequential-plan))
7114 (reverse (plan-actions-r plan)))
7116 (defmethod plan-record-dependency ((plan sequential-plan)
7117 (operation operation) (component component))
7118 (declare (ignorable plan operation component))
7121 (defmethod (setf plan-action-status) :after
7122 (new-status (p sequential-plan) (o operation) (c component))
7123 (when (action-planned-p new-status)
7124 (push (cons o c) (plan-actions-r p)))))
7127 ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
7128 (with-upgradability ()
7129 (defgeneric* (traverse) (operation component &key &allow-other-keys)
7131 "Generate and return a plan for performing OPERATION on COMPONENT.
7133 The plan returned is a list of dotted-pairs. Each pair is the CONS
7134 of ASDF operation object and a COMPONENT object. The pairs will be
7135 processed in order by OPERATE."))
7136 (define-convenience-action-methods traverse (operation component &key))
7138 (defgeneric perform-plan (plan &key))
7139 (defgeneric plan-operates-on-p (plan component))
7141 (defparameter *default-plan-class* 'sequential-plan)
7143 (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
7144 (let ((plan (apply 'make-instance
7145 (or plan-class *default-plan-class*)
7146 :system (component-system c) (remove-plist-key :plan-class keys))))
7147 (traverse-action plan o c t)
7148 (plan-actions plan)))
7150 (defmethod perform-plan :around (plan &key)
7151 (declare (ignorable plan))
7152 (let ((*package* *package*)
7153 (*readtable* *readtable*))
7154 (with-compilation-unit () ;; backward-compatibility.
7155 (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
7157 (defmethod perform-plan ((steps list) &key)
7158 (loop* :for (op . component) :in steps :do
7159 (perform-with-restarts op component)))
7161 (defmethod plan-operates-on-p ((plan list) (component-path list))
7162 (find component-path (mapcar 'cdr plan)
7163 :test 'equal :key 'component-find-path)))
7166 ;;;; Incidental traversals
7167 (with-upgradability ()
7168 (defclass filtered-sequential-plan (sequential-plan)
7169 ((action-filter :initform t :initarg :action-filter :reader plan-action-filter)
7170 (component-type :initform t :initarg :component-type :reader plan-component-type)
7171 (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
7172 (keep-component :initform t :initarg :keep-component :reader plan-keep-component)))
7174 (defmethod initialize-instance :after ((plan filtered-sequential-plan)
7175 &key (force () fp) (force-not () fnp)
7177 (declare (ignore force force-not))
7178 (with-slots (forced forced-not action-filter system) plan
7179 (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system)))
7180 (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system)))
7181 (setf action-filter (ensure-function action-filter))))
7183 (defmethod action-valid-p ((plan filtered-sequential-plan) o c)
7184 (and (funcall (plan-action-filter plan) o c)
7185 (typep c (plan-component-type plan))
7186 (call-next-method)))
7188 (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
7189 (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
7190 (loop* :for (o . c) :in actions :do
7191 (traverse-action plan o c t))
7192 (plan-actions plan)))
7194 (define-convenience-action-methods traverse-sub-actions (o c &key))
7195 (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
7196 (apply 'traverse-actions (direct-dependencies operation component)
7197 :system (component-system component) keys))
7199 (defmethod plan-actions ((plan filtered-sequential-plan))
7200 (with-slots (keep-operation keep-component) plan
7201 (loop* :for (o . c) :in (call-next-method)
7202 :when (and (typep o keep-operation)
7203 (typep c keep-component))
7204 :collect (cons o c))))
7206 (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
7208 (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
7211 ;;;; -------------------------------------------------------------------------
7212 ;;;; Invoking Operations
7214 (asdf/package:define-package :asdf/operate
7215 (:recycle :asdf/operate :asdf)
7216 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7217 :asdf/component :asdf/system :asdf/operation :asdf/action
7218 :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
7221 #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
7223 #:load-system #:load-systems #:compile-system #:test-system #:require-system
7224 #:*load-system-operation* #:module-provide-asdf
7225 #:component-loaded-p #:already-loaded-systems
7226 #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
7227 (in-package :asdf/operate)
7229 (with-upgradability ()
7230 (defgeneric* (operate) (operation component &key &allow-other-keys))
7231 (define-convenience-action-methods
7232 operate (operation component &key)
7233 :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
7234 :if-no-component (error 'missing-component :requires component))
7236 (defvar *systems-being-operated* nil
7237 "A boolean indicating that some systems are being operated on")
7239 (defmethod operate :around (operation component
7241 (on-warnings *compile-file-warnings-behaviour*)
7242 (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
7243 (declare (ignorable operation component))
7244 ;; Setup proper bindings around any operate call.
7245 (with-system-definitions ()
7246 (let* ((*verbose-out* (and verbose *standard-output*))
7247 (*compile-file-warnings-behaviour* on-warnings)
7248 (*compile-file-failure-behaviour* on-failure))
7249 (call-next-method))))
7251 (defmethod operate ((operation operation) (component component)
7252 &rest args &key version &allow-other-keys)
7253 "Operate does three things:
7255 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
7256 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk).
7257 3. It then calls TRAVERSE with the operation and system as arguments
7259 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code.
7260 If a VERSION argument is supplied, then operate also ensures that the system found
7261 satisfies it using the VERSION-SATISFIES method.
7263 Note that dependencies may cause the operation to invoke other operations on the system
7264 or its components: the new operations will be created with the same initargs as the original one.
7266 The :FORCE or :FORCE-NOT argument to OPERATE can be:
7267 T to force the inside of the specified system to be rebuilt (resp. not),
7268 without recursively forcing the other systems we depend on.
7269 :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
7270 (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
7271 :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
7272 (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
7273 ;; but swank.asd relies on :force (!).
7274 (systems-being-operated *systems-being-operated*)
7275 (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
7276 (system (component-system component)))
7277 (setf (gethash (coerce-name system) *systems-being-operated*) system)
7278 (unless (version-satisfies component version)
7279 (error 'missing-component-of-version :requires component :version version))
7280 ;; Before we operate on any system, make sure ASDF is up-to-date,
7281 ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
7282 (unless systems-being-operated
7283 (let ((operation-name (reify-symbol (type-of operation)))
7284 (component-path (component-find-path component)))
7285 (when (upgrade-asdf)
7286 ;; If we were upgraded, restart OPERATE the hardest of ways, for
7287 ;; its function may have been redefined, its symbol uninterned, its package deleted.
7288 (return-from operate
7289 (apply (find-symbol* 'operate :asdf)
7290 (unreify-symbol operation-name)
7291 component-path args)))))
7292 (let ((plan (apply 'traverse operation system args)))
7294 (values operation plan))))
7296 (defun oos (operation component &rest args &key &allow-other-keys)
7297 (apply 'operate operation component args))
7299 (setf (documentation 'oos 'function)
7300 (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
7301 (documentation 'operate 'function))))
7304 ;;;; Common operations
7305 (with-upgradability ()
7306 (defvar *load-system-operation* 'load-op
7307 "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
7308 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
7309 or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.
7311 This may change in the future as we will implement component-based strategy
7312 for how to load or compile stuff")
7314 (defun build-system (system &rest keys)
7315 "Shorthand for `(operate 'asdf:build-op system)`."
7316 (apply 'operate 'build-op system keys)
7319 (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
7320 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
7321 (declare (ignore force force-not verbose version))
7322 (apply 'operate *load-system-operation* system keys)
7325 (defun load-systems (&rest systems)
7326 "Loading multiple systems at once."
7327 (map () 'load-system systems))
7329 (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
7330 "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
7331 (declare (ignore force force-not verbose version))
7332 (apply 'operate 'compile-op system args)
7335 (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
7336 "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
7337 (declare (ignore force force-not verbose version))
7338 (apply 'operate 'test-op system args)
7342 ;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
7343 ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
7344 (with-upgradability ()
7345 (defun component-loaded-p (c)
7346 (action-already-done-p nil (make-instance 'load-op) (find-component c ())))
7348 (defun already-loaded-systems ()
7349 (remove-if-not 'component-loaded-p (registered-systems)))
7351 (defun require-system (s &rest keys &key &allow-other-keys)
7352 (apply 'load-system s :force-not (already-loaded-systems) keys))
7354 (defun module-provide-asdf (name)
7356 ((style-warning #'muffle-warning)
7357 (missing-component (constantly nil))
7358 (error #'(lambda (e)
7359 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
7361 (let ((*verbose-out* (make-broadcast-stream))
7362 (system (find-system (string-downcase name) nil)))
7364 (require-system system :verbose nil)
7368 ;;;; Some upgrade magic
7369 (with-upgradability ()
7370 (defun restart-upgraded-asdf ()
7371 ;; If we're in the middle of something, restart it.
7372 (when *systems-being-defined*
7373 (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
7374 (clrhash *systems-being-defined*)
7375 (dolist (s l) (find-system s nil)))))
7377 (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*))
7380 ;;;; ---------------------------------------------------------------------------
7381 ;;;; asdf-output-translations
7383 (asdf/package:define-package :asdf/output-translations
7384 (:recycle :asdf/output-translations :asdf)
7385 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
7387 #:*output-translations* #:*output-translations-parameter*
7388 #:invalid-output-translation
7389 #:output-translations #:output-translations-initialized-p
7390 #:initialize-output-translations #:clear-output-translations
7391 #:disable-output-translations #:ensure-output-translations
7392 #:apply-output-translations
7393 #:validate-output-translations-directive #:validate-output-translations-form
7394 #:validate-output-translations-file #:validate-output-translations-directory
7395 #:parse-output-translations-string #:wrapping-output-translations
7396 #:user-output-translations-pathname #:system-output-translations-pathname
7397 #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
7398 #:environment-output-translations #:process-output-translations
7399 #:compute-output-translations
7400 #+abcl #:translate-jar-pathname
7402 (in-package :asdf/output-translations)
7404 (when-upgrading () (undefine-function '(setf output-translations)))
7406 (with-upgradability ()
7407 (define-condition invalid-output-translation (invalid-configuration warning)
7408 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
7410 (defvar *output-translations* ()
7411 "Either NIL (for uninitialized), or a list of one element,
7412 said element itself being a sorted list of mappings.
7413 Each mapping is a pair of a source pathname and destination pathname,
7414 and the order is by decreasing length of namestring of the source pathname.")
7416 (defun output-translations ()
7417 (car *output-translations*))
7419 (defun set-output-translations (new-value)
7420 (setf *output-translations*
7422 (stable-sort (copy-list new-value) #'>
7427 (let ((directory (pathname-directory (car x))))
7428 (if (listp directory) (length directory) 0))))))))
7430 (defsetf output-translations set-output-translations) ; works with gcl 2.6
7432 (defun output-translations-initialized-p ()
7433 (and *output-translations* t))
7435 (defun clear-output-translations ()
7436 "Undoes any initialization of the output translations."
7437 (setf *output-translations* '())
7439 (register-clear-configuration-hook 'clear-output-translations)
7441 (defun validate-output-translations-directive (directive)
7442 (or (member directive '(:enable-user-cache :disable-cache nil))
7443 (and (consp directive)
7444 (or (and (length=n-p directive 2)
7445 (or (and (eq (first directive) :include)
7446 (typep (second directive) '(or string pathname null)))
7447 (and (location-designator-p (first directive))
7448 (or (location-designator-p (second directive))
7449 (location-function-p (second directive))))))
7450 (and (length=n-p directive 1)
7451 (location-designator-p (first directive)))))))
7453 (defun validate-output-translations-form (form &key location)
7454 (validate-configuration-form
7456 :output-translations
7457 'validate-output-translations-directive
7458 :location location :invalid-form-reporter 'invalid-output-translation))
7460 (defun validate-output-translations-file (file)
7461 (validate-configuration-file
7462 file 'validate-output-translations-form :description "output translations"))
7464 (defun validate-output-translations-directory (directory)
7465 (validate-configuration-directory
7466 directory :output-translations 'validate-output-translations-directive
7467 :invalid-form-reporter 'invalid-output-translation))
7469 (defun parse-output-translations-string (string &key location)
7471 ((or (null string) (equal string ""))
7472 '(:output-translations :inherit-configuration))
7473 ((not (stringp string))
7474 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
7475 ((eql (char string 0) #\")
7476 (parse-output-translations-string (read-from-string string) :location location))
7477 ((eql (char string 0) #\()
7478 (validate-output-translations-form (read-from-string string) :location location))
7482 :with directives = ()
7484 :with end = (length string)
7486 :with separator = (inter-directory-separator)
7487 :for i = (or (position separator string :start start) end) :do
7488 (let ((s (subseq string start i)))
7491 (push (list source (if (equal "" s) nil s)) directives)
7495 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
7498 (push :inherit-configuration directives))
7504 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
7507 (push :ignore-inherited-configuration directives))
7508 (return `(:output-translations ,@(nreverse directives)))))))))
7510 (defparameter *default-output-translations*
7511 '(environment-output-translations
7512 user-output-translations-pathname
7513 user-output-translations-directory-pathname
7514 system-output-translations-pathname
7515 system-output-translations-directory-pathname))
7517 (defun wrapping-output-translations ()
7518 `(:output-translations
7519 ;; Some implementations have precompiled ASDF systems,
7520 ;; so we must disable translations for implementation paths.
7521 #+(or #|clozure|# ecl mkcl sbcl)
7522 ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
7523 (when h `(((,h ,*wild-path*) ()))))
7524 #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
7525 ;; All-import, here is where we want user stuff to be:
7526 :inherit-configuration
7527 ;; These are for convenience, and can be overridden by the user:
7528 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
7529 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
7530 ;; We enable the user cache by default, and here is the place we do:
7531 :enable-user-cache))
7533 (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
7534 (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
7536 (defun user-output-translations-pathname (&key (direction :input))
7537 (in-user-configuration-directory *output-translations-file* :direction direction))
7538 (defun system-output-translations-pathname (&key (direction :input))
7539 (in-system-configuration-directory *output-translations-file* :direction direction))
7540 (defun user-output-translations-directory-pathname (&key (direction :input))
7541 (in-user-configuration-directory *output-translations-directory* :direction direction))
7542 (defun system-output-translations-directory-pathname (&key (direction :input))
7543 (in-system-configuration-directory *output-translations-directory* :direction direction))
7544 (defun environment-output-translations ()
7545 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
7547 (defgeneric process-output-translations (spec &key inherit collect))
7549 (defun inherit-output-translations (inherit &key collect)
7551 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
7553 (defun* (process-output-translations-directive) (directive &key inherit collect)
7554 (if (atom directive)
7556 ((:enable-user-cache)
7557 (process-output-translations-directive '(t :user-cache) :collect collect))
7559 (process-output-translations-directive '(t t) :collect collect))
7560 ((:inherit-configuration)
7561 (inherit-output-translations inherit :collect collect))
7562 ((:ignore-inherited-configuration :ignore-invalid-entries nil)
7564 (let ((src (first directive))
7565 (dst (second directive)))
7566 (if (eq src :include)
7568 (process-output-translations (pathname dst) :inherit nil :collect collect))
7570 (let ((trusrc (or (eql src t)
7571 (let ((loc (resolve-location src :ensure-directory t :wilden t)))
7572 (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
7574 ((location-function-p dst)
7577 (if (symbolp (second dst))
7578 (fdefinition (second dst))
7579 (eval (second dst))))))
7581 (funcall collect (list trusrc t)))
7583 (let* ((trudst (if dst
7584 (resolve-location dst :ensure-directory t :wilden t)
7586 (funcall collect (list trudst t))
7587 (funcall collect (list trusrc trudst)))))))))))
7589 (defmethod process-output-translations ((x symbol) &key
7590 (inherit *default-output-translations*)
7592 (process-output-translations (funcall x) :inherit inherit :collect collect))
7593 (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
7595 ((directory-pathname-p pathname)
7596 (process-output-translations (validate-output-translations-directory pathname)
7597 :inherit inherit :collect collect))
7598 ((probe-file* pathname :truename *resolve-symlinks*)
7599 (process-output-translations (validate-output-translations-file pathname)
7600 :inherit inherit :collect collect))
7602 (inherit-output-translations inherit :collect collect))))
7603 (defmethod process-output-translations ((string string) &key inherit collect)
7604 (process-output-translations (parse-output-translations-string string)
7605 :inherit inherit :collect collect))
7606 (defmethod process-output-translations ((x null) &key inherit collect)
7607 (declare (ignorable x))
7608 (inherit-output-translations inherit :collect collect))
7609 (defmethod process-output-translations ((form cons) &key inherit collect)
7610 (dolist (directive (cdr (validate-output-translations-form form)))
7611 (process-output-translations-directive directive :inherit inherit :collect collect)))
7613 (defun compute-output-translations (&optional parameter)
7614 "read the configuration, return it"
7616 (while-collecting (c)
7617 (inherit-output-translations
7618 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
7619 :test 'equal :from-end t))
7621 (defvar *output-translations-parameter* nil)
7623 (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
7624 "read the configuration, initialize the internal configuration variable,
7625 return the configuration"
7626 (setf *output-translations-parameter* parameter
7627 (output-translations) (compute-output-translations parameter)))
7629 (defun disable-output-translations ()
7630 "Initialize output translations in a way that maps every file to itself,
7631 effectively disabling the output translation facility."
7632 (initialize-output-translations
7633 '(:output-translations :disable-cache :ignore-inherited-configuration)))
7635 ;; checks an initial variable to see whether the state is initialized
7636 ;; or cleared. In the former case, return current configuration; in
7637 ;; the latter, initialize. ASDF will call this function at the start
7638 ;; of (asdf:find-system).
7639 (defun ensure-output-translations ()
7640 (if (output-translations-initialized-p)
7641 (output-translations)
7642 (initialize-output-translations)))
7644 (defun* (apply-output-translations) (path)
7645 #+cormanlisp (resolve-symlinks* path) #-cormanlisp
7649 ((or pathname string)
7650 (ensure-output-translations)
7651 (loop* :with p = (resolve-symlinks* path)
7652 :for (source destination) :in (car *output-translations*)
7653 :for root = (when (or (eq source t)
7654 (and (pathnamep source)
7655 (not (absolute-pathname-p source))))
7657 :for absolute-source = (cond
7658 ((eq source t) (wilden root))
7659 (root (merge-pathnames* source root))
7661 :when (or (eq source t) (pathname-match-p p absolute-source))
7662 :return (translate-pathname* p absolute-source destination root source)
7663 :finally (return p)))))
7665 ;; Hook into asdf/driver's output-translation mechanism
7666 (setf *output-translation-function* 'apply-output-translations)
7669 (defun translate-jar-pathname (source wildcard)
7670 (declare (ignore wildcard))
7671 (flet ((normalize-device (pathname)
7672 (if (find :windows *features*)
7674 (make-pathname :defaults pathname :device :unspecific))))
7676 (pathname (first (pathname-device source))))
7677 (target-root-directory-namestring
7678 (format nil "/___jar___file___root___/~@[~A/~]"
7679 (and (find :windows *features*)
7680 (pathname-device jar))))
7682 (relativize-pathname-directory source))
7684 (relativize-pathname-directory (ensure-directory-pathname jar)))
7685 (target-root-directory
7687 (pathname-directory-pathname
7688 (parse-namestring target-root-directory-namestring))))
7690 (merge-pathnames* relative-jar target-root-directory))
7692 (merge-pathnames* relative-source target-root)))
7693 (normalize-device (apply-output-translations target))))))
7695 ;;;; -----------------------------------------------------------------
7696 ;;;; Source Registry Configuration, by Francois-Rene Rideau
7697 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
7699 (asdf/package:define-package :asdf/source-registry
7700 (:recycle :asdf/source-registry :asdf)
7701 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
7703 #:*source-registry* #:*source-registry-parameter* #:*default-source-registries*
7704 #:invalid-source-registry
7705 #:source-registry #:source-registry-initialized-p
7706 #:initialize-source-registry #:clear-source-registry #:*source-registry*
7707 #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter*
7708 #:*default-source-registry-exclusions* #:*source-registry-exclusions*
7709 #:*wild-asd* #:directory-asd-files #:register-asd-directory
7710 #:collect-asds-in-directory #:collect-sub*directories-asd-files
7711 #:validate-source-registry-directive #:validate-source-registry-form
7712 #:validate-source-registry-file #:validate-source-registry-directory
7713 #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
7714 #:user-source-registry #:system-source-registry
7715 #:user-source-registry-directory #:system-source-registry-directory
7716 #:environment-source-registry #:process-source-registry
7717 #:compute-source-registry #:flatten-source-registry
7718 #:sysdef-source-registry-search))
7719 (in-package :asdf/source-registry)
7721 (with-upgradability ()
7722 (define-condition invalid-source-registry (invalid-configuration warning)
7723 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
7725 ;; Using ack 1.2 exclusions
7726 (defvar *default-source-registry-exclusions*
7728 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
7729 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
7730 "_sgbak" "autom4te.cache" "cover_db" "_build"
7731 "debian")) ;; debian often builds stuff under the debian directory... BAD.
7733 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
7735 (defvar *source-registry* nil
7736 "Either NIL (for uninitialized), or an equal hash-table, mapping
7737 system names to pathnames of .asd files")
7739 (defun source-registry-initialized-p ()
7740 (typep *source-registry* 'hash-table))
7742 (defun clear-source-registry ()
7743 "Undoes any initialization of the source registry."
7744 (setf *source-registry* nil)
7746 (register-clear-configuration-hook 'clear-source-registry)
7748 (defparameter *wild-asd*
7749 (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
7751 (defun directory-asd-files (directory)
7752 (directory-files directory *wild-asd*))
7754 (defun collect-asds-in-directory (directory collect)
7755 (map () collect (directory-asd-files directory)))
7757 (defun collect-sub*directories-asd-files
7758 (directory &key (exclude *default-source-registry-exclusions*) collect)
7759 (collect-sub*directories
7762 #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
7763 #'(lambda (dir) (collect-asds-in-directory dir collect))))
7765 (defun validate-source-registry-directive (directive)
7766 (or (member directive '(:default-registry))
7767 (and (consp directive)
7768 (let ((rest (rest directive)))
7769 (case (first directive)
7770 ((:include :directory :tree)
7771 (and (length=n-p rest 1)
7772 (location-designator-p (first rest))))
7773 ((:exclude :also-exclude)
7774 (every #'stringp rest))
7775 ((:default-registry)
7778 (defun validate-source-registry-form (form &key location)
7779 (validate-configuration-form
7780 form :source-registry 'validate-source-registry-directive
7781 :location location :invalid-form-reporter 'invalid-source-registry))
7783 (defun validate-source-registry-file (file)
7784 (validate-configuration-file
7785 file 'validate-source-registry-form :description "a source registry"))
7787 (defun validate-source-registry-directory (directory)
7788 (validate-configuration-directory
7789 directory :source-registry 'validate-source-registry-directive
7790 :invalid-form-reporter 'invalid-source-registry))
7792 (defun parse-source-registry-string (string &key location)
7794 ((or (null string) (equal string ""))
7795 '(:source-registry :inherit-configuration))
7796 ((not (stringp string))
7797 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
7798 ((find (char string 0) "\"(")
7799 (validate-source-registry-form (read-from-string string) :location location))
7803 :with directives = ()
7805 :with end = (length string)
7806 :with separator = (inter-directory-separator)
7807 :for pos = (position separator string :start start) :do
7808 (let ((s (subseq string start (or pos end))))
7810 (unless (absolute-pathname-p dir)
7811 (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
7814 ((equal "" s) ; empty element: inherit
7816 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
7819 (push ':inherit-configuration directives))
7820 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
7821 (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
7823 (push `(:directory ,(check s)) directives))))
7826 (setf start (1+ pos)))
7829 (push '(:ignore-inherited-configuration) directives))
7830 (return `(:source-registry ,@(nreverse directives))))))))))
7832 (defun register-asd-directory (directory &key recurse exclude collect)
7834 (collect-asds-in-directory directory collect)
7835 (collect-sub*directories-asd-files
7836 directory :exclude exclude :collect collect)))
7838 (defparameter *default-source-registries*
7839 '(environment-source-registry
7840 user-source-registry
7841 user-source-registry-directory
7842 system-source-registry
7843 system-source-registry-directory
7844 default-source-registry))
7846 (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
7847 (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
7849 (defun wrapping-source-registry ()
7851 #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
7852 #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
7853 :inherit-configuration
7854 #+cmu (:tree #p"modules:")
7855 #+scl (:tree #p"file://modules/")))
7856 (defun default-source-registry ()
7858 #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
7859 ,@(loop :for dir :in
7860 `(,@(when (os-unix-p)
7861 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
7862 (subpathname (user-homedir-pathname) ".local/share/"))
7863 ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
7864 '("/usr/local/share" "/usr/share"))))
7865 ,@(when (os-windows-p)
7866 (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
7867 :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
7868 :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
7869 :inherit-configuration))
7870 (defun user-source-registry (&key (direction :input))
7871 (in-user-configuration-directory *source-registry-file* :direction direction))
7872 (defun system-source-registry (&key (direction :input))
7873 (in-system-configuration-directory *source-registry-file* :direction direction))
7874 (defun user-source-registry-directory (&key (direction :input))
7875 (in-user-configuration-directory *source-registry-directory* :direction direction))
7876 (defun system-source-registry-directory (&key (direction :input))
7877 (in-system-configuration-directory *source-registry-directory* :direction direction))
7878 (defun environment-source-registry ()
7879 (getenv "CL_SOURCE_REGISTRY"))
7881 (defgeneric* (process-source-registry) (spec &key inherit register))
7883 (defun* (inherit-source-registry) (inherit &key register)
7885 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
7887 (defun* (process-source-registry-directive) (directive &key inherit register)
7888 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
7891 (destructuring-bind (pathname) rest
7892 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
7894 (destructuring-bind (pathname) rest
7896 (funcall register (resolve-location pathname :ensure-directory t)))))
7898 (destructuring-bind (pathname) rest
7900 (funcall register (resolve-location pathname :ensure-directory t)
7901 :recurse t :exclude *source-registry-exclusions*))))
7903 (setf *source-registry-exclusions* rest))
7905 (appendf *source-registry-exclusions* rest))
7906 ((:default-registry)
7907 (inherit-source-registry '(default-source-registry) :register register))
7908 ((:inherit-configuration)
7909 (inherit-source-registry inherit :register register))
7910 ((:ignore-inherited-configuration)
7914 (defmethod process-source-registry ((x symbol) &key inherit register)
7915 (process-source-registry (funcall x) :inherit inherit :register register))
7916 (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
7918 ((directory-pathname-p pathname)
7919 (let ((*here-directory* (resolve-symlinks* pathname)))
7920 (process-source-registry (validate-source-registry-directory pathname)
7921 :inherit inherit :register register)))
7922 ((probe-file* pathname :truename *resolve-symlinks*)
7923 (let ((*here-directory* (pathname-directory-pathname pathname)))
7924 (process-source-registry (validate-source-registry-file pathname)
7925 :inherit inherit :register register)))
7927 (inherit-source-registry inherit :register register))))
7928 (defmethod process-source-registry ((string string) &key inherit register)
7929 (process-source-registry (parse-source-registry-string string)
7930 :inherit inherit :register register))
7931 (defmethod process-source-registry ((x null) &key inherit register)
7932 (declare (ignorable x))
7933 (inherit-source-registry inherit :register register))
7934 (defmethod process-source-registry ((form cons) &key inherit register)
7935 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
7936 (dolist (directive (cdr (validate-source-registry-form form)))
7937 (process-source-registry-directive directive :inherit inherit :register register))))
7939 (defun flatten-source-registry (&optional parameter)
7941 (while-collecting (collect)
7942 (with-pathname-defaults () ;; be location-independent
7943 (inherit-source-registry
7944 `(wrapping-source-registry
7946 ,@*default-source-registries*)
7947 :register #'(lambda (directory &key recurse exclude)
7948 (collect (list directory :recurse recurse :exclude exclude))))))
7949 :test 'equal :from-end t))
7951 ;; Will read the configuration and initialize all internal variables.
7952 (defun compute-source-registry (&optional parameter (registry *source-registry*))
7953 (dolist (entry (flatten-source-registry parameter))
7954 (destructuring-bind (directory &key recurse exclude) entry
7955 (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
7956 (register-asd-directory
7957 directory :recurse recurse :exclude exclude :collect
7959 (let* ((name (pathname-name asd))
7960 (name (if (typep asd 'logical-pathname)
7961 ;; logical pathnames are upper-case,
7962 ;; at least in the CLHS and on SBCL,
7963 ;; yet (coerce-name :foo) is lower-case.
7964 ;; won't work well with (load-system "Foo")
7965 ;; instead of (load-system 'foo)
7966 (string-downcase name)
7969 ((gethash name registry) ; already shadowed by something else
7971 ((gethash name h) ; conflict at current level
7973 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
7974 found several entries for ~A - picking ~S over ~S~:>")
7975 directory recurse name (gethash name h) asd)))
7977 (setf (gethash name registry) asd)
7978 (setf (gethash name h) asd))))))
7982 (defvar *source-registry-parameter* nil)
7984 (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
7985 ;; Record the parameter used to configure the registry
7986 (setf *source-registry-parameter* parameter)
7987 ;; Clear the previous registry database:
7988 (setf *source-registry* (make-hash-table :test 'equal))
7990 (compute-source-registry parameter))
7992 ;; Checks an initial variable to see whether the state is initialized
7993 ;; or cleared. In the former case, return current configuration; in
7994 ;; the latter, initialize. ASDF will call this function at the start
7995 ;; of (asdf:find-system) to make sure the source registry is initialized.
7996 ;; However, it will do so *without* a parameter, at which point it
7997 ;; will be too late to provide a parameter to this function, though
7998 ;; you may override the configuration explicitly by calling
7999 ;; initialize-source-registry directly with your parameter.
8000 (defun ensure-source-registry (&optional parameter)
8001 (unless (source-registry-initialized-p)
8002 (initialize-source-registry parameter))
8005 (defun sysdef-source-registry-search (system)
8006 (ensure-source-registry)
8007 (values (gethash (primary-system-name system) *source-registry*))))
8010 ;;;; -------------------------------------------------------------------------
8011 ;;; Internal hacks for backward-compatibility
8013 (asdf/package:define-package :asdf/backward-internals
8014 (:recycle :asdf/backward-internals :asdf)
8015 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8016 :asdf/system :asdf/component :asdf/operation
8017 :asdf/find-system :asdf/action :asdf/lisp-action)
8018 (:export ;; for internal use
8019 #:load-sysdef #:make-temporary-package
8020 #:%refresh-component-inline-methods
8021 #:%resolve-if-component-dep-fails
8022 #:make-sub-operation
8023 #:load-sysdef #:make-temporary-package))
8024 (in-package :asdf/backward-internals)
8026 ;;;; Backward compatibility with "inline methods"
8027 (with-upgradability ()
8028 (defparameter +asdf-methods+
8029 '(perform-with-restarts perform explain output-files operation-done-p))
8031 (defun %remove-component-inline-methods (component)
8032 (dolist (name +asdf-methods+)
8034 ;; this is inefficient as most of the stored
8035 ;; methods will not be for this particular gf
8036 ;; But this is hardly performance-critical
8038 (remove-method (symbol-function name) m))
8039 (component-inline-methods component)))
8040 (component-inline-methods component) nil)
8042 (defun %define-component-inline-methods (ret rest)
8043 (dolist (name +asdf-methods+)
8044 (let ((keyword (intern (symbol-name name) :keyword)))
8045 (loop :for data = rest :then (cddr data)
8046 :for key = (first data)
8047 :for value = (second data)
8049 :when (eq key keyword) :do
8050 (destructuring-bind (op qual? &rest rest) value
8051 (multiple-value-bind (qual args-and-body)
8053 (values (list qual?) rest)
8054 (values nil (cons qual? rest)))
8055 (destructuring-bind ((o c) &body body) args-and-body
8057 (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret)))
8059 (component-inline-methods ret)))))))))
8061 (defun %refresh-component-inline-methods (component rest)
8062 ;; clear methods, then add the new ones
8063 (%remove-component-inline-methods component)
8064 (%define-component-inline-methods component rest)))
8066 ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
8067 ;; and the companion asdf:feature pseudo-dependency.
8068 ;; This won't recurse into dependencies to accumulate feature conditions.
8069 ;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL
8070 ;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles.
8071 (with-upgradability ()
8072 (defun %resolve-if-component-dep-fails (if-component-dep-fails component)
8073 (asdf-message "The system definition for ~S uses deprecated ~
8074 ASDF option :IF-COMPONENT-DEP-DAILS. ~
8075 Starting with ASDF 3, please use :IF-FEATURE instead"
8076 (coerce-name (component-system component)))
8077 ;; This only supports the pattern of use of the "feature" seen in the wild
8078 (check-type component parent-component)
8079 (check-type if-component-dep-fails (member :fail :ignore :try-next))
8080 (unless (eq if-component-dep-fails :fail)
8081 (loop :with o = (make-operation 'compile-op)
8082 :for c :in (component-children component) :do
8083 (loop* :for (feature? feature) :in (component-depends-on o c)
8084 :when (eq feature? 'feature) :do
8085 (setf (component-if-feature c) feature))))))
8087 (when-upgrading (:when (fboundp 'make-sub-operation))
8088 (defun make-sub-operation (c o dep-c dep-o)
8089 (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
8093 (with-upgradability ()
8094 (defun load-sysdef (name pathname)
8095 (load-asd pathname :name name))
8097 (defun make-temporary-package ()
8098 ;; For loading a .asd file, we dont't make a temporary package anymore,
8099 ;; but use ASDF-USER. I'd like to have this function do this,
8100 ;; but since whoever uses it is likely to delete-package the result afterwards,
8101 ;; this would be a bad idea, so preserve the old behavior.
8102 (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf))))
8105 ;;;; -------------------------------------------------------------------------
8108 (asdf/package:define-package :asdf/defsystem
8109 (:recycle :asdf/defsystem :asdf)
8110 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8111 :asdf/component :asdf/system :asdf/cache
8112 :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate
8113 :asdf/backward-internals)
8115 #:defsystem #:register-system-definition
8116 #:class-for-type #:*default-component-class*
8117 #:determine-system-directory #:parse-component-form
8118 #:duplicate-names #:sysdef-error-component #:check-component-input))
8119 (in-package :asdf/defsystem)
8122 (with-upgradability ()
8123 (defun determine-system-directory (pathname)
8124 ;; The defsystem macro calls this function to determine
8125 ;; the pathname of a system as follows:
8126 ;; 1. if the pathname argument is an pathname object (NOT a namestring),
8127 ;; that is already an absolute pathname, return it.
8128 ;; 2. otherwise, the directory containing the LOAD-PATHNAME
8129 ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
8130 ;; if it is indeed available and an absolute pathname, then
8131 ;; the PATHNAME argument is normalized to a relative pathname
8132 ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
8133 ;; and merged into that DIRECTORY as per SUBPATHNAME.
8134 ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded,
8135 ;; and may be from within the EVAL-WHEN of a file compilation.
8136 ;; If no absolute pathname was found, we return NIL.
8137 (check-type pathname (or null string pathname))
8138 (pathname-directory-pathname
8140 (ensure-absolute-pathname
8141 (parse-unix-namestring pathname :type :directory)
8142 #'(lambda () (ensure-absolute-pathname
8143 (load-pathname) 'get-pathname-defaults nil))
8148 (with-upgradability ()
8149 (defvar *default-component-class* 'cl-source-file)
8151 (defun class-for-type (parent type)
8152 (or (loop :for symbol :in (list
8154 (find-symbol* type *package* nil)
8155 (find-symbol* type :asdf/interface nil))
8156 :for class = (and symbol (find-class* symbol nil))
8158 (#-cormanlisp subtypep #+cormanlisp cl::subclassp
8159 class (find-class* 'component)))
8161 (and (eq type :file)
8163 (or (loop :for p = parent :then (component-parent p) :while p
8164 :thereis (module-default-component-class p))
8165 *default-component-class*) nil))
8166 (sysdef-error "don't recognize component type ~A" type))))
8170 (with-upgradability ()
8171 (define-condition duplicate-names (system-definition-error)
8172 ((name :initarg :name :reader duplicate-names-name))
8173 (:report (lambda (c s)
8174 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
8175 (duplicate-names-name c)))))
8177 (defun sysdef-error-component (msg type name value)
8178 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
8181 (defun check-component-input (type name weakly-depends-on
8182 depends-on components)
8183 "A partial test of the values of a component."
8184 (unless (listp depends-on)
8185 (sysdef-error-component ":depends-on must be a list."
8186 type name depends-on))
8187 (unless (listp weakly-depends-on)
8188 (sysdef-error-component ":weakly-depends-on must be a list."
8189 type name weakly-depends-on))
8190 (unless (listp components)
8191 (sysdef-error-component ":components must be NIL or a list of components."
8192 type name components)))
8194 (defun normalize-version (form pathname)
8196 ((or string null) form)
8198 (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string."
8200 (format nil "~D" form)) ;; 1.0 is "1.0"
8204 (destructuring-bind (subpath &key (at 0)) (rest form)
8205 (safe-read-file-form (subpathname pathname subpath) :at at))))))))
8208 ;;; Main parsing function
8209 (with-upgradability ()
8210 (defun* (parse-component-form) (parent options &key previous-serial-component)
8212 (type name &rest rest &key
8213 (builtin-system-p () bspp)
8214 ;; the following list of keywords is reproduced below in the
8215 ;; remove-plist-keys form. important to keep them in sync
8216 components pathname perform explain output-files operation-done-p
8217 weakly-depends-on depends-on serial
8218 do-first if-component-dep-fails (version nil versionp)
8220 &allow-other-keys) options
8221 (declare (ignorable perform explain output-files operation-done-p builtin-system-p))
8222 (check-component-input type name weakly-depends-on depends-on components)
8224 (find-component parent name)
8225 (not ;; ignore the same object when rereading the defsystem
8226 (typep (find-component parent name)
8227 (class-for-type parent type))))
8228 (error 'duplicate-names :name name))
8229 (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
8230 (let* ((args `(:name ,(coerce-name name)
8232 ,@(when parent `(:parent ,parent))
8233 ,@(remove-plist-keys
8234 '(:components :pathname :if-component-dep-fails :version
8235 :perform :explain :output-files :operation-done-p
8236 :weakly-depends-on :depends-on :serial)
8238 (component (find-component parent name)))
8239 (when weakly-depends-on
8240 ;; ASDF4: deprecate this feature and remove it.
8242 (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
8243 (when previous-serial-component
8244 (push previous-serial-component depends-on))
8245 (if component ; preserve identity
8246 (apply 'reinitialize-instance component args)
8247 (setf component (apply 'make-instance (class-for-type parent type) args)))
8248 (component-pathname component) ; eagerly compute the absolute pathname
8249 (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
8250 (when (and (typep component 'system) (not bspp))
8251 (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir)))
8252 (setf version (normalize-version version sysdir)))
8253 (when (and versionp version (not (parse-version version nil)))
8254 (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
8255 version name parent))
8256 ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
8257 ;; A better fix is required.
8258 (setf (slot-value component 'version) version)
8259 (when (typep component 'parent-component)
8260 (setf (component-children component)
8262 :with previous-component = nil
8263 :for c-form :in components
8264 :for c = (parse-component-form component c-form
8265 :previous-serial-component previous-component)
8266 :for name = (component-name c)
8268 :when serial :do (setf previous-component name)))
8269 (compute-children-by-name component))
8270 ;; Used by POIU. ASDF4: rename to component-depends-on?
8271 (setf (component-sibling-dependencies component) depends-on)
8272 (%refresh-component-inline-methods component rest)
8273 (when if-component-dep-fails
8274 (%resolve-if-component-dep-fails if-component-dep-fails component))
8277 (defun register-system-definition
8278 (name &rest options &key pathname (class 'system) (source-file () sfp)
8279 defsystem-depends-on &allow-other-keys)
8280 ;; The system must be registered before we parse the body,
8281 ;; otherwise we recur when trying to find an existing system
8282 ;; of the same name to reuse options (e.g. pathname) from.
8283 ;; To avoid infinite recursion in cases where you defsystem a system
8284 ;; that is registered to a different location to find-system,
8285 ;; we also need to remember it in a special variable *systems-being-defined*.
8286 (with-system-definitions ()
8287 (let* ((name (coerce-name name))
8288 (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))
8289 (registered (system-registered-p name))
8290 (registered! (if registered
8291 (rplaca registered (get-file-stamp source-file))
8293 (make-instance 'system :name name :source-file source-file))))
8294 (system (reset-system (cdr registered!)
8295 :name name :source-file source-file))
8296 (component-options (remove-plist-key :class options))
8297 (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
8298 (resolve-dependency-spec nil spec))))
8299 (apply 'load-systems defsystem-dependencies)
8300 ;; We change-class AFTER we loaded the defsystem-depends-on
8301 ;; since the class might be defined as part of those.
8302 (let ((class (class-for-type nil class)))
8303 (unless (eq (type-of system) class)
8304 (change-class system class)))
8305 (parse-component-form
8308 :pathname (determine-system-directory pathname)
8309 component-options)))))
8311 (defmacro defsystem (name &body options)
8312 `(apply 'register-system-definition ',name ',options)))
8313 ;;;; -------------------------------------------------------------------------
8316 (asdf/package:define-package :asdf/bundle
8317 (:recycle :asdf/bundle :asdf)
8318 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8319 :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
8320 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
8322 #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
8323 #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
8324 #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files
8325 #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
8327 #:compiled-file #:precompiled-system #:prebuilt-system
8328 #:operation-monolithic-p
8329 #:user-system-p #:user-system #:trivial-system-p
8331 #:register-pre-built-system
8332 #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
8333 (in-package :asdf/bundle)
8335 (with-upgradability ()
8336 (defclass bundle-op (operation)
8337 ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
8338 (name-suffix :initarg :name-suffix :initform nil)
8339 (bundle-type :initform :no-output-file :reader bundle-type)
8340 #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
8341 #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
8342 #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
8344 (defclass fasl-op (bundle-op)
8345 ;; create a single fasl for the entire library
8346 ((bundle-type :initform :fasl)))
8348 (defclass load-fasl-op (basic-load-op)
8349 ;; load a single fasl for the entire library
8352 (defclass lib-op (bundle-op)
8353 ;; On ECL: compile the system and produce linkable .a library for it.
8354 ;; On others: just compile the system.
8355 ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
8357 (defclass dll-op (bundle-op)
8358 ;; Link together all the dynamic library used by this system into a single one.
8359 ((bundle-type :initform :dll)))
8361 (defclass binary-op (bundle-op)
8362 ;; On ECL: produce lib and fasl for the system.
8363 ;; On "normal" Lisps: produce just the fasl.
8366 (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
8368 (defclass monolithic-bundle-op (monolithic-op bundle-op)
8369 ((prologue-code :accessor monolithic-op-prologue-code)
8370 (epilogue-code :accessor monolithic-op-epilogue-code)))
8372 (defclass monolithic-binary-op (binary-op monolithic-bundle-op)
8373 ;; On ECL: produce lib and fasl for combined system and dependencies.
8374 ;; On "normal" Lisps: produce an image file from system and dependencies.
8377 (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
8378 ;; Create a single fasl for the system and its dependencies.
8381 (defclass monolithic-lib-op (monolithic-bundle-op lib-op)
8382 ;; ECL: Create a single linkable library for the system and its dependencies.
8383 ((bundle-type :initform :lib)))
8385 (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
8386 ((bundle-type :initform :dll)))
8388 (defclass program-op (monolithic-bundle-op)
8389 ;; All: create an executable file from the system and its dependencies
8390 ((bundle-type :initform :program)))
8392 (defun bundle-pathname-type (bundle-type)
8393 (etypecase bundle-type
8394 ((eql :no-output-file) nil) ;; should we error out instead?
8395 ((or null string) bundle-type)
8396 ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
8398 ((member :binary :dll :lib :static-library :program :object :program)
8399 (compile-file-type :type bundle-type))
8400 ((eql :binary) "image")
8401 ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
8402 ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
8403 ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
8405 (defun bundle-output-files (o c)
8406 (let ((bundle-type (bundle-type o)))
8407 (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
8408 (let ((name (or (component-build-pathname c)
8409 (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
8410 (type (bundle-pathname-type bundle-type)))
8411 (values (list (subpathname (component-pathname c) name :type type))
8412 (eq (type-of o) (component-build-operation c)))))))
8414 (defmethod output-files ((o bundle-op) (c system))
8415 (bundle-output-files o c))
8419 (defmethod perform ((o program-op) (c system))
8420 (let ((output-file (output-file o c)))
8421 (setf *image-entry-point* (ensure-function (component-entry-point c)))
8422 (dump-image output-file :executable t)))
8424 (defmethod perform ((o monolithic-binary-op) (c system))
8425 (let ((output-file (output-file o c)))
8426 (dump-image output-file))))
8428 (defclass compiled-file (file-component)
8429 ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
8431 (defclass precompiled-system (system)
8432 ((build-pathname :initarg :fasl)))
8434 (defclass prebuilt-system (system)
8435 ((build-pathname :initarg :static-library :initarg :lib
8436 :accessor prebuilt-system-static-library))))
8442 ;;; This operation takes all components from one or more systems and
8443 ;;; creates a single output file, which may be
8444 ;;; a FASL, a statically linked library, a shared library, etc.
8445 ;;; The different targets are defined by specialization.
8447 (with-upgradability ()
8448 (defun operation-monolithic-p (op)
8449 (typep op 'monolithic-op))
8451 (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
8452 &key (name-suffix nil name-suffix-p)
8454 (declare (ignorable initargs name-suffix))
8455 (unless name-suffix-p
8456 (setf (slot-value instance 'name-suffix)
8457 (unless (typep instance 'program-op)
8458 (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
8459 (when (typep instance 'monolithic-bundle-op)
8460 (destructuring-bind (&rest original-initargs
8461 &key lisp-files prologue-code epilogue-code
8463 (operation-original-initargs instance)
8464 (setf (operation-original-initargs instance)
8465 (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
8466 (monolithic-op-prologue-code instance) prologue-code
8467 (monolithic-op-epilogue-code instance) epilogue-code)
8468 #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
8469 #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
8470 (setf (bundle-op-build-args instance)
8471 (remove-plist-keys '(:type :monolithic :name-suffix)
8472 (operation-original-initargs instance))))
8474 (defmethod bundle-op-build-args :around ((o lib-op))
8475 (declare (ignorable o))
8476 (let ((args (call-next-method)))
8477 (remf args :ld-flags)
8480 (defun bundlable-file-p (pathname)
8481 (let ((type (pathname-type pathname)))
8482 (declare (ignorable type))
8483 (or #+ecl (or (equal type (compile-file-type :type :object))
8484 (equal type (compile-file-type :type :static-library)))
8485 #+mkcl (equal type (compile-file-type :fasl-p nil))
8486 #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
8488 (defgeneric* (trivial-system-p) (component))
8490 (defun user-system-p (s)
8491 (and (typep s 'system)
8492 (not (builtin-system-p s))
8493 (not (trivial-system-p s)))))
8495 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
8496 (deftype user-system () '(and system (satisfies user-system-p))))
8499 ;;; First we handle monolithic bundles.
8500 ;;; These are standalone systems which contain everything,
8501 ;;; including other ASDF systems required by the current one.
8502 ;;; A PROGRAM is always monolithic.
8504 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
8506 (with-upgradability ()
8507 (defmethod component-depends-on ((o monolithic-lib-op) (c system))
8508 (declare (ignorable o))
8509 `((lib-op ,@(required-components c :other-systems t :component-type 'system
8510 :goal-operation 'load-op
8511 :keep-operation 'compile-op))))
8513 (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
8514 (declare (ignorable o))
8515 `((fasl-op ,@(required-components c :other-systems t :component-type 'system
8516 :goal-operation 'load-fasl-op
8517 :keep-operation 'fasl-op))))
8519 (defmethod component-depends-on ((o program-op) (c system))
8520 (declare (ignorable o))
8521 #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
8522 #-(or ecl mkcl) `((load-op ,c)))
8524 (defmethod component-depends-on ((o binary-op) (c system))
8525 (declare (ignorable o))
8529 (defmethod component-depends-on ((o monolithic-binary-op) (c system))
8530 `((,(find-operation o 'monolithic-fasl-op) ,c)
8531 (,(find-operation o 'monolithic-lib-op) ,c)))
8533 (defmethod component-depends-on ((o lib-op) (c system))
8534 (declare (ignorable o))
8535 `((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
8536 :goal-operation 'load-op
8537 :keep-operation 'compile-op))))
8539 (defmethod component-depends-on ((o fasl-op) (c system))
8540 (declare (ignorable o))
8541 #+ecl `((lib-op ,c))
8543 (component-depends-on (find-operation o 'lib-op) c))
8545 (defmethod component-depends-on ((o dll-op) c)
8546 (component-depends-on (find-operation o 'lib-op) c))
8548 (defmethod component-depends-on ((o bundle-op) c)
8549 (declare (ignorable o c))
8552 (defmethod component-depends-on :around ((o bundle-op) (c component))
8553 (declare (ignorable o c))
8554 (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
8556 (call-next-method)))
8558 (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
8559 (while-collecting (collect)
8560 (map-direct-dependencies
8561 o c #'(lambda (sub-o sub-c)
8562 (loop :for f :in (funcall key sub-o sub-c)
8563 :when (funcall test f) :do (collect f))))))
8565 (defmethod input-files ((o bundle-op) (c system))
8566 (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
8568 (defun select-bundle-operation (type &optional monolithic)
8571 (if monolithic 'monolithic-binary-op 'binary-op))
8572 ((:dll :shared-library)
8573 (if monolithic 'monolithic-dll-op 'dll-op))
8574 ((:lib :static-library)
8575 (if monolithic 'monolithic-lib-op 'lib-op))
8577 (if monolithic 'monolithic-fasl-op 'fasl-op))
8581 (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
8582 (move-here nil move-here-p)
8584 (let* ((operation-name (select-bundle-operation type monolithic))
8585 (move-here-path (if (and move-here
8586 (typep move-here '(or pathname string)))
8587 (pathname move-here)
8588 (system-relative-pathname system "asdf-output/")))
8589 (operation (apply #'operate operation-name
8591 (remove-plist-keys '(:monolithic :type :move-here) args)))
8592 (system (find-system system))
8593 (files (and system (output-files operation system))))
8594 (if (or move-here (and (null move-here-p)
8595 (member operation-name '(:program :binary))))
8596 (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
8598 :for new-f = (make-pathname :name (pathname-name f)
8599 :type (pathname-type f)
8600 :defaults dest-path)
8601 :do (rename-file-overwriting-target f new-f)
8608 ;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
8610 (with-upgradability ()
8611 (defmethod component-depends-on ((o load-fasl-op) (c system))
8612 (declare (ignorable o))
8613 `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
8614 :collect (resolve-dependency-spec c dep)))
8615 (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
8616 ,@(call-next-method)))
8618 (defmethod input-files ((o load-fasl-op) (c system))
8619 (when (user-system-p c)
8620 (output-files (find-operation o 'fasl-op) c)))
8622 (defmethod perform ((o load-fasl-op) c)
8623 (declare (ignorable o c))
8626 (defmethod perform ((o load-fasl-op) (c system))
8627 (perform-lisp-load-fasl o c))
8629 (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
8630 (mark-operation-done (find-operation o 'load-op) c)))
8633 ;;; PRECOMPILED FILES
8635 ;;; This component can be used to distribute ASDF systems in precompiled form.
8636 ;;; Only useful when the dependencies have also been precompiled.
8638 (with-upgradability ()
8639 (defmethod trivial-system-p ((s system))
8640 (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
8642 (defmethod output-files (o (c compiled-file))
8643 (declare (ignorable o c))
8645 (defmethod input-files (o (c compiled-file))
8646 (declare (ignorable o))
8647 (component-pathname c))
8648 (defmethod perform ((o load-op) (c compiled-file))
8649 (perform-lisp-load-fasl o c))
8650 (defmethod perform ((o load-source-op) (c compiled-file))
8651 (perform (find-operation o 'load-op) c))
8652 (defmethod perform ((o load-fasl-op) (c compiled-file))
8653 (perform (find-operation o 'load-op) c))
8654 (defmethod perform (o (c compiled-file))
8655 (declare (ignorable o c))
8659 ;;; Pre-built systems
8661 (with-upgradability ()
8662 (defmethod trivial-system-p ((s prebuilt-system))
8663 (declare (ignorable s))
8666 (defmethod perform ((o lib-op) (c prebuilt-system))
8667 (declare (ignorable o c))
8670 (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
8671 (declare (ignorable o c))
8674 (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
8675 (declare (ignorable o))
8680 ;;; PREBUILT SYSTEM CREATOR
8682 (with-upgradability ()
8683 (defmethod output-files ((o binary-op) (s system))
8684 (list (make-pathname :name (component-name s) :type "asd"
8685 :defaults (component-pathname s))))
8687 (defmethod perform ((o binary-op) (s system))
8688 (let* ((dependencies (component-depends-on o s))
8689 (fasl (first (apply #'output-files (first dependencies))))
8690 (library (first (apply #'output-files (second dependencies))))
8691 (asd (first (output-files o s)))
8692 (name (pathname-name asd))
8693 (name-keyword (intern (string name) (find-package :keyword))))
8694 (with-open-file (s asd :direction :output :if-exists :supersede
8695 :if-does-not-exist :create)
8696 (format s ";;; Prebuilt ASDF definition for system ~A" name)
8697 (format s ";;; Built for ~A ~A on a ~A/~A ~A"
8698 (lisp-implementation-type)
8699 (lisp-implementation-version)
8703 (let ((*package* (find-package :keyword)))
8704 (pprint `(defsystem ,name-keyword
8705 :class prebuilt-system
8706 :components ((:compiled-file ,(pathname-name fasl)))
8707 :lib ,(and library (file-namestring library)))
8711 (defmethod perform ((o fasl-op) (c system))
8712 (let* ((input-files (input-files o c))
8713 (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=))
8714 (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
8715 (output-files (output-files o c))
8716 (output-file (first output-files)))
8717 (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
8719 (assert output-files)
8720 (when non-fasl-files
8721 (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
8722 (implementation-type) non-fasl-files))
8723 (when (and (typep o 'monolithic-bundle-op)
8724 (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
8725 (error "prologue-code and epilogue-code are not supported on ~A"
8726 (implementation-type)))
8727 (with-staging-pathname (output-file)
8728 (combine-fasls fasl-files output-file)))))
8730 (defmethod input-files ((o load-op) (s precompiled-system))
8731 (declare (ignorable o))
8732 (bundle-output-files (find-operation o 'fasl-op) s))
8734 (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
8735 (declare (ignorable o))
8736 `((load-op ,s) ,@(call-next-method))))
8739 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
8740 (asdf:load-system :precompiled-asdf-utils)
8744 (with-upgradability ()
8745 (defmethod perform ((o bundle-op) (c system))
8746 (let* ((object-files (input-files o c))
8747 (output (output-files o c))
8748 (bundle (first output))
8749 (kind (bundle-type o)))
8751 bundle (append object-files (bundle-op-lisp-files o))
8753 :entry-point (component-entry-point c)
8755 (when (typep o 'monolithic-bundle-op)
8756 (monolithic-op-prologue-code o))
8758 (when (typep o 'monolithic-bundle-op)
8759 (monolithic-op-epilogue-code o))
8760 :build-args (bundle-op-build-args o)))))
8763 (with-upgradability ()
8764 (defmethod perform ((o lib-op) (s system))
8765 (apply #'compiler::build-static-library (first output)
8766 :lisp-object-files (input-files o s) (bundle-op-build-args o)))
8768 (defmethod perform ((o fasl-op) (s system))
8769 (apply #'compiler::build-bundle (second output)
8770 :lisp-object-files (input-files o s) (bundle-op-build-args o)))
8772 (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
8773 (declare (ignore force verbose version))
8774 (apply #'operate 'binary-op system args)))
8777 (with-upgradability ()
8778 (defun register-pre-built-system (name)
8779 (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
8781 ;;;; -------------------------------------------------------------------------
8782 ;;;; Concatenate-source
8784 (asdf/package:define-package :asdf/concatenate-source
8785 (:recycle :asdf/concatenate-source :asdf)
8786 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8787 :asdf/component :asdf/operation
8788 :asdf/system :asdf/find-system :asdf/defsystem
8789 :asdf/action :asdf/lisp-action :asdf/bundle)
8791 #:concatenate-source-op
8792 #:load-concatenated-source-op
8793 #:compile-concatenated-source-op
8794 #:load-compiled-concatenated-source-op
8795 #:monolithic-concatenate-source-op
8796 #:monolithic-load-concatenated-source-op
8797 #:monolithic-compile-concatenated-source-op
8798 #:monolithic-load-compiled-concatenated-source-op
8799 #:component-concatenated-source-file
8800 #:concatenated-source-file))
8801 (in-package :asdf/concatenate-source)
8804 ;;; Concatenate sources
8806 (with-upgradability ()
8807 (defclass concatenate-source-op (bundle-op)
8808 ((bundle-type :initform "lisp")))
8809 (defclass load-concatenated-source-op (basic-load-op operation)
8810 ((bundle-type :initform :no-output-file)))
8811 (defclass compile-concatenated-source-op (basic-compile-op bundle-op)
8812 ((bundle-type :initform :fasl)))
8813 (defclass load-compiled-concatenated-source-op (basic-load-op operation)
8814 ((bundle-type :initform :no-output-file)))
8816 (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
8817 (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
8818 (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
8819 (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
8821 (defmethod input-files ((operation concatenate-source-op) (s system))
8822 (loop :with encoding = (or (component-encoding s) *default-encoding*)
8823 :with other-encodings = '()
8824 :with around-compile = (around-compile-hook s)
8825 :with other-around-compile = '()
8826 :for c :in (required-components
8827 s :goal-operation 'compile-op
8828 :keep-operation 'compile-op
8829 :other-systems (operation-monolithic-p operation))
8831 (when (typep c 'cl-source-file)
8832 (let ((e (component-encoding c)))
8833 (unless (equal e encoding)
8834 (pushnew e other-encodings :test 'equal)))
8835 (let ((a (around-compile-hook c)))
8836 (unless (equal a around-compile)
8837 (pushnew a other-around-compile :test 'equal)))
8838 (input-files (make-operation 'compile-op) c)) :into inputs
8840 (when other-encodings
8841 (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
8842 operation encoding other-encodings))
8843 (when other-around-compile
8844 (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
8845 operation around-compile other-around-compile))
8848 (defmethod input-files ((o load-concatenated-source-op) (s system))
8849 (direct-dependency-files o s))
8850 (defmethod input-files ((o compile-concatenated-source-op) (s system))
8851 (direct-dependency-files o s))
8852 (defmethod output-files ((o compile-concatenated-source-op) (s system))
8853 (let ((input (first (input-files o s))))
8854 (list (compile-file-pathname input))))
8855 (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
8856 (direct-dependency-files o s))
8858 (defmethod perform ((o concatenate-source-op) (s system))
8859 (let ((inputs (input-files o s))
8860 (output (output-file o s)))
8861 (concatenate-files inputs output)))
8862 (defmethod perform ((o load-concatenated-source-op) (s system))
8863 (perform-lisp-load-source o s))
8864 (defmethod perform ((o compile-concatenated-source-op) (s system))
8865 (perform-lisp-compilation o s))
8866 (defmethod perform ((o load-compiled-concatenated-source-op) (s system))
8867 (perform-lisp-load-fasl o s))
8869 (defmethod component-depends-on ((o concatenate-source-op) (s system))
8870 (declare (ignorable o s)) nil)
8871 (defmethod component-depends-on ((o load-concatenated-source-op) (s system))
8872 (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
8873 (defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
8874 (declare (ignorable o s)) `((concatenate-source-op ,s)))
8875 (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
8876 (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
8878 (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
8879 (declare (ignorable o s)) nil)
8880 (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
8881 (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
8882 (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
8883 (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
8884 (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
8885 (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))))
8887 ;;;; -------------------------------------------------------------------------
8888 ;;; Backward-compatible interfaces
8890 (asdf/package:define-package :asdf/backward-interface
8891 (:recycle :asdf/backward-interface :asdf)
8892 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
8893 :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
8894 :asdf/lisp-build :asdf/operate :asdf/output-translations)
8897 #:operation-error #:compile-error #:compile-failed #:compile-warned
8898 #:error-component #:error-operation
8899 #:component-load-dependencies
8900 #:enable-asdf-binary-locations-compatibility
8902 #:operation-on-failure
8903 #:operation-on-warnings
8904 #:component-property
8906 #:system-definition-pathname))
8907 (in-package :asdf/backward-interface)
8909 (with-upgradability ()
8910 (define-condition operation-error (error) ;; Bad, backward-compatible name
8911 ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
8912 ((component :reader error-component :initarg :component)
8913 (operation :reader error-operation :initarg :operation))
8914 (:report (lambda (c s)
8915 (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
8916 (type-of c) (error-operation c) (error-component c)))))
8917 (define-condition compile-error (operation-error) ())
8918 (define-condition compile-failed (compile-error) ())
8919 (define-condition compile-warned (compile-error) ())
8921 (defun component-load-dependencies (component)
8922 ;; Old deprecated name for the same thing. Please update your software.
8923 (component-sibling-dependencies component))
8925 (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
8926 (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
8928 (defgeneric operation-on-warnings (operation))
8929 (defgeneric operation-on-failure (operation))
8930 #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
8931 #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
8932 (defmethod operation-on-warnings ((o operation))
8933 (declare (ignorable o)) *compile-file-warnings-behaviour*)
8934 (defmethod operation-on-failure ((o operation))
8935 (declare (ignorable o)) *compile-file-failure-behaviour*)
8936 (defmethod (setf operation-on-warnings) (x (o operation))
8937 (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
8938 (defmethod (setf operation-on-failure) (x (o operation))
8939 (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
8941 (defun system-definition-pathname (x)
8942 ;; As of 2.014.8, we mean to make this function obsolete,
8943 ;; but that won't happen until all clients have been updated.
8944 ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
8945 "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
8946 It used to expose ASDF internals with subtle differences with respect to
8947 user expectations, that have been refactored away since.
8948 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
8949 for a mostly compatible replacement that we're supporting,
8950 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
8951 if that's whay you mean." ;;)
8952 (system-source-file x)))
8955 ;;;; ASDF-Binary-Locations compatibility
8956 ;; This remains supported for legacy user, but not recommended for new users.
8957 (with-upgradability ()
8958 (defun enable-asdf-binary-locations-compatibility
8960 (centralize-lisp-binaries nil)
8961 (default-toplevel-directory
8962 (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
8963 (include-per-user-information nil)
8964 (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
8965 (source-to-target-mappings nil)
8966 (file-types `(,(compile-file-type)
8968 #+ecl (compile-file-type :type :object)
8969 #+mkcl (compile-file-type :fasl-p nil)
8970 #+clisp "lib" #+sbcl "cfasl"
8971 #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
8972 #+(or clisp ecl mkcl)
8973 (when (null map-all-source-files)
8974 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
8975 (let* ((patterns (if map-all-source-files (list *wild-file*)
8976 (loop :for type :in file-types
8977 :collect (make-pathname :type type :defaults *wild-file*))))
8978 (destination-directory
8979 (if centralize-lisp-binaries
8980 `(,default-toplevel-directory
8981 ,@(when include-per-user-information
8982 (cdr (pathname-directory (user-homedir-pathname))))
8983 :implementation ,*wild-inferiors*)
8984 `(:root ,*wild-inferiors* :implementation))))
8985 (initialize-output-translations
8986 `(:output-translations
8987 ,@source-to-target-mappings
8988 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
8989 #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
8990 ,@(loop :for pattern :in patterns
8991 :collect `((:root ,*wild-inferiors* ,pattern)
8992 (,@destination-directory ,pattern)))
8994 :ignore-inherited-configuration))))
8996 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
8997 (declare (ignorable operation-class system args))
8998 (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
8999 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
9000 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
9001 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
9002 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
9003 In case you insist on preserving your previous A-B-L configuration, but
9004 do not know how to achieve the same effect with A-O-T, you may use function
9005 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
9006 call that function where you would otherwise have loaded and configured A-B-L."))))
9009 ;;; run-shell-command
9010 ;; WARNING! The function below is not just deprecated but also dysfunctional.
9011 ;; Please use asdf/run-program:run-program instead.
9012 (with-upgradability ()
9013 (defun run-shell-command (control-string &rest args)
9014 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
9015 synchronously execute the result using a Bourne-compatible shell, with
9016 output to *VERBOSE-OUT*. Returns the shell's exit code.
9019 Deprecated function, for backward-compatibility only.
9020 Please use ASDF-DRIVER:RUN-PROGRAM instead."
9021 (let ((command (apply 'format nil control-string args)))
9022 (asdf-message "; $ ~A~%" command)
9023 (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
9025 (with-upgradability ()
9026 (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
9028 ;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
9029 (with-upgradability ()
9030 (defgeneric component-property (component property))
9031 (defgeneric (setf component-property) (new-value component property))
9033 (defmethod component-property ((c component) property)
9034 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
9036 (defmethod (setf component-property) (new-value (c component) property)
9037 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
9039 (setf (cdr a) new-value)
9040 (setf (slot-value c 'properties)
9041 (acons property new-value (slot-value c 'properties)))))
9043 ;;;; ---------------------------------------------------------------------------
9044 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
9046 (asdf/package:define-package :asdf/interface
9047 (:nicknames :asdf :asdf-utilities)
9048 (:recycle :asdf/interface :asdf)
9050 #:*asdf-revision* #:around #:asdf-method-combination
9051 #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
9052 #:split #:make-collector
9053 #:loaded-systems ; makes for annoying SLIME completion
9054 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
9055 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache
9056 :asdf/component :asdf/system :asdf/find-system :asdf/find-component
9057 :asdf/operation :asdf/action :asdf/lisp-action
9058 :asdf/output-translations :asdf/source-registry
9059 :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source
9060 :asdf/backward-internals :asdf/backward-interface)
9061 ;; TODO: automatically generate interface with reexport?
9063 #:defsystem #:find-system #:locate-system #:coerce-name
9064 #:oos #:operate #:traverse #:perform-plan
9065 #:system-definition-pathname #:with-system-definitions
9066 #:search-for-system-definition #:find-component #:component-find-path
9067 #:compile-system #:load-system #:load-systems
9068 #:require-system #:test-system #:clear-system
9069 #:operation #:upward-operation #:downward-operation #:make-operation
9070 #:build-system #:build-op
9071 #:load-op #:prepare-op #:compile-op
9072 #:prepare-source-op #:load-source-op #:test-op
9073 #:feature #:version #:version-satisfies #:upgrade-asdf
9074 #:implementation-identifier #:implementation-type #:hostname
9075 #:input-files #:output-files #:output-file #:perform
9076 #:operation-done-p #:explain #:action-description #:component-sibling-dependencies
9078 ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
9079 #:component-load-dependencies #:run-shell-command ; deprecated, do not use
9080 #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
9082 #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
9083 #:concatenate-source-op
9084 #:load-concatenated-source-op
9085 #:compile-concatenated-source-op
9086 #:load-compiled-concatenated-source-op
9087 #:monolithic-concatenate-source-op
9088 #:monolithic-load-concatenated-source-op
9089 #:monolithic-compile-concatenated-source-op
9090 #:monolithic-load-compiled-concatenated-source-op
9091 #:operation-monolithic-p
9092 #:required-components
9094 #:component #:parent-component #:child-component #:system #:module
9095 #:file-component #:source-file #:c-source-file #:java-source-file
9096 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
9097 #:static-file #:doc-file #:html-file :text-file
9100 #:component-children ; component accessors
9101 #:component-children-by-name
9102 #:component-pathname
9103 #:component-relative-pathname
9108 #:component-encoding
9109 #:component-external-format
9111 #:component-depends-on ; backward-compatible name rather than action-depends-on
9112 #:module-components ; backward-compatibility
9113 #:operation-on-warnings #:operation-on-failure ; backward-compatibility
9114 #:component-property ; backward-compatibility
9116 #:system-description
9117 #:system-long-description
9122 #:system-source-file
9123 #:system-source-directory
9124 #:system-relative-pathname
9126 #:system-bug-tracker
9127 #:system-developers-email
9129 #:system-source-control
9132 #:*system-definition-search-functions* ; variables
9133 #:*central-registry*
9134 #:*compile-file-warnings-behaviour*
9135 #:*compile-file-failure-behaviour*
9136 #:*resolve-symlinks*
9137 #:*load-system-operation*
9138 #:*asdf-verbose* ;; unused. For backward-compatibility only.
9143 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
9144 #:compile-warned-warning #:compile-failed-warning
9145 #:operation-error #:compile-failed #:compile-warned #:compile-error ;; backward compatibility
9148 #:load-system-definition-error
9149 #:error-component #:error-operation
9150 #:system-definition-error
9152 #:missing-component-of-version
9153 #:missing-dependency
9154 #:missing-dependency-of-version
9155 #:circular-dependency ; errors
9161 #:coerce-entry-to-directory
9162 #:remove-entry-from-registry
9164 #:*encoding-detection-hook*
9165 #:*encoding-external-format-hook*
9166 #:*default-encoding*
9167 #:*utf-8-external-format*
9169 #:clear-configuration
9170 #:*output-translations-parameter*
9171 #:initialize-output-translations
9172 #:disable-output-translations
9173 #:clear-output-translations
9174 #:ensure-output-translations
9175 #:apply-output-translations
9177 #:compile-file-pathname*
9178 #:*warnings-file-type*
9179 #:enable-asdf-binary-locations-compatibility
9180 #:*default-source-registries*
9181 #:*source-registry-parameter*
9182 #:initialize-source-registry
9183 #:compute-source-registry
9184 #:clear-source-registry
9185 #:ensure-source-registry
9186 #:process-source-registry
9187 #:system-registered-p #:registered-systems #:already-loaded-systems
9190 #:user-output-translations-pathname
9191 #:system-output-translations-pathname
9192 #:user-output-translations-directory-pathname
9193 #:system-output-translations-directory-pathname
9194 #:user-source-registry
9195 #:system-source-registry
9196 #:user-source-registry-directory
9197 #:system-source-registry-directory))
9199 ;;;; ---------------------------------------------------------------------------
9200 ;;;; ASDF-USER, where the action happens.
9202 (asdf/package:define-package :asdf/user
9203 (:nicknames :asdf-user)
9204 (:use :asdf/common-lisp :asdf/package :asdf/interface))
9205 ;;;; -----------------------------------------------------------------------
9206 ;;;; ASDF Footer: last words and cleanup
9208 (asdf/package:define-package :asdf/footer
9209 (:recycle :asdf/footer :asdf)
9210 (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
9211 :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action
9212 :asdf/operate :asdf/bundle :asdf/concatenate-source
9213 :asdf/output-translations :asdf/source-registry
9214 :asdf/backward-internals :asdf/defsystem :asdf/backward-interface))
9215 (in-package :asdf/footer)
9217 ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
9219 (with-upgradability ()
9220 #+(or abcl clisp clozure cmu ecl mkcl sbcl)
9221 (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil)))
9222 (eval `(pushnew 'module-provide-asdf
9223 #+abcl sys::*module-provider-functions*
9225 #+clozure ccl:*module-provider-functions*
9226 #+(or cmu ecl) ext:*module-provider-functions*
9227 #+mkcl mk-ext:*module-provider-functions*
9228 #+sbcl sb-ext:*module-provider-functions*)))
9232 (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
9234 #+(or (and ecl win32) (and mkcl windows))
9235 (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
9236 (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
9238 (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
9239 (loop :for f :in #+ecl ext:*module-provider-functions*
9240 #+mkcl mk-ext::*module-provider-functions*
9241 :unless (eq f 'module-provide-asdf)
9242 :collect #'(lambda (name)
9243 (let ((l (multiple-value-list (funcall f name))))
9244 (and (first l) (register-pre-built-system (coerce-name name)))
9245 (values-list l)))))))
9249 (with-upgradability ()
9251 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
9252 (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*))
9254 (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*))
9258 (cleanup-upgraded-asdf))
9260 (when *load-verbose*
9261 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
9264 ;;; Local Variables:
projects / sbcl.git / blob