1 ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*-
2 ;;; This is ASDF 3.3.6: 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-2019 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.
49 (eval-when (:compile-toplevel :load-toplevel :execute)
50 (multiple-value-bind (system-major system-minor)
51 (sct:get-system-version)
52 (multiple-value-bind (is-major is-minor)
53 (sct:get-system-version "Intel-Support")
54 (unless (or (> system-major 452)
57 (and (= is-major 3) (> is-minor 86)))))
58 (error "ASDF requires either System 453 or later or Intel Support 3.87 or later")))))
59 ;;;; ---------------------------------------------------------------------------
60 ;;;; ASDF package upgrade, including implementation-dependent magic.
62 ;; See https://bugs.launchpad.net/asdf/+bug/485687
65 ;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE,
66 ;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER.
67 ;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES.
69 ;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard
70 ;; *leaves it unspecified what happens when a package is redefined incompatibly*.
71 ;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens,
72 ;; throwing a wrench in upgrading code with ASDF itself, while continuing to
73 ;; export old symbols it now shouldn't as it also exports new ones,
74 ;; causing problems with code that relies on the new/current exports.
75 ;; CLISP and CCL also exports both sets of symbols, though without any WARNING.
76 ;; ABCL 1.6.1 will plainly ignore the new definition.
77 ;; Other implementations may do whatever they want and change their behavior at any time.
78 ;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.***
80 ;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined
81 ;; in an upgrade-friendly way: the new definition is authoritative, and
82 ;; the package will define and export exactly those symbols in the new definition,
83 ;; no more and no fewer, whereas it is well-defined what happens to previous symbols.
84 ;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE
85 ;; to define UIOP/PACKAGE itself, only DEFPACKAGE.
86 ;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable,
87 ;; now and forever. It is frozen for the aeons to come, like the CL package itself,
88 ;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013.
89 ;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally.
91 ;; If you ever must define new symbols in this file, you can and must
92 ;; export them from a different package, possibly defined in the same file,
93 ;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE,
94 ;; that might use :import-from to import the symbols from UIOP/PACKAGE,
95 ;; if you must somehow define them in UIOP/PACKAGE.
97 (defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above.
100 #:find-package* #:find-symbol* #:symbol-call
101 #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
102 #:symbol-shadowing-p #:home-package-p
103 #:symbol-package-name #:standard-common-lisp-symbol-p
104 #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
105 #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
106 #:ensure-package-unused #:delete-package*
107 #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
108 #:package-definition-form #:parse-define-package-form
109 #:ensure-package #:define-package
112 (in-package :uiop/package)
114 ;;; package local nicknames feature.
115 ;;; This can't be deferred until common-lisp.lisp, where most such features are set.
116 ;;; ABCL and CCL already define this feature appropriately.
117 ;;; Seems to be unconditionally present for SBCL, ACL, and CLASP
118 ;;; Don't know about ECL, or others
119 (eval-when (:load-toplevel :compile-toplevel :execute)
120 ;; ABCL pushes :package-local-nicknames without UIOP interfering,
121 ;; and Lispworks will do so
123 (pushnew :package-local-nicknames *features*)
125 (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl)))
126 (when (and fname (fboundp fname))
127 (pushnew :package-local-nicknames *features*))))
129 ;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation.
130 ;; If you somehow need to modify the API in any way,
131 ;; you will need to create another, differently named, and just as immutable package.
132 #+package-local-nicknames
133 (defpackage :uiop/package-local-nicknames
138 #+(or clasp abcl ecl) #:ext
141 #-(or allegro sbcl clasp abcl ccl lispworks ecl)
142 (error "Don't know from which package this lisp supplies the local-package-nicknames API.")
143 #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname)
145 #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames))
147 ;;;; General purpose package utilities
149 (eval-when (:load-toplevel :compile-toplevel :execute)
150 (deftype package-designator () '(and (or package character string symbol) (satisfies find-package)))
151 (define-condition no-such-package-error (type-error)
153 (:default-initargs :expected-type 'package-designator)
154 (:report (lambda (c s)
155 (format s "No package named ~a" (string (type-error-datum c))))))
157 (defmethod package-designator ((c no-such-package-error))
158 (type-error-datum c))
160 (defun find-package* (package-designator &optional (errorp t))
161 "Like CL:FIND-PACKAGE, but by default raises a UIOP:NO-SUCH-PACKAGE-ERROR if the
162 package is not found."
163 (let ((package (find-package package-designator)))
166 (errorp (error 'no-such-package-error :datum package-designator))
169 (defun find-symbol* (name package-designator &optional (error t))
170 "Find a symbol in a package of given string'ified NAME;
171 unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
172 by letting you supply a symbol or keyword for the name;
173 also works well when the package is not present.
174 If optional ERROR argument is NIL, return NIL instead of an error
175 when the symbol is not found."
177 (let ((package (find-package* package-designator error)))
178 (when package ;; package error handled by find-package* already
179 (multiple-value-bind (symbol status) (find-symbol (string name) package)
181 (status (return (values symbol status)))
182 (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
184 (defun symbol-call (package name &rest args)
185 "Call a function associated with symbol of given name in given package,
186 with given ARGS. Useful when the call is read before the package is loaded,
187 or when loading the package is optional."
188 (apply (find-symbol* name package) args))
189 (defun intern* (name package-designator &optional (error t))
190 (intern (string name) (find-package* package-designator error)))
191 (defun export* (name package-designator)
192 (let* ((package (find-package* package-designator))
193 (symbol (intern* name package)))
194 (export (or symbol (list symbol)) package)))
195 (defun import* (symbol package-designator)
196 (import (or symbol (list symbol)) (find-package* package-designator)))
197 (defun shadowing-import* (symbol package-designator)
198 (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
199 (defun shadow* (name package-designator)
200 (shadow (list (string name)) (find-package* package-designator)))
201 (defun make-symbol* (name)
203 (string (make-symbol name))
204 (symbol (copy-symbol name))))
205 (defun unintern* (name package-designator &optional (error t))
207 (let ((package (find-package* package-designator error)))
209 (multiple-value-bind (symbol status) (find-symbol* name package error)
211 (status (unintern symbol package)
212 (return (values symbol status)))
213 (error (error "symbol ~A not present in package ~A"
214 (string symbol) (package-name package))))))
216 (defun symbol-shadowing-p (symbol package)
217 (and (member symbol (package-shadowing-symbols package)) t))
218 (defun home-package-p (symbol package)
219 (and package (let ((sp (symbol-package symbol)))
220 (and sp (let ((pp (find-package* package)))
221 (and pp (eq sp pp))))))))
224 (eval-when (:load-toplevel :compile-toplevel :execute)
225 (defun symbol-package-name (symbol)
226 (let ((package (symbol-package symbol)))
227 (and package (package-name package))))
228 (defun standard-common-lisp-symbol-p (symbol)
229 (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
230 (and (eq sym symbol) (eq status :external))))
231 (defun reify-package (package &optional package-context)
232 (if (eq package package-context) t
235 ((eql (find-package :cl)) :cl)
236 (package (package-name package)))))
237 (defun unreify-package (package &optional package-context)
240 ((eql t) package-context)
241 ((or symbol string) (find-package package))))
242 (defun reify-symbol (symbol &optional package-context)
244 ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
245 (symbol (vector (symbol-name symbol)
246 (reify-package (symbol-package symbol) package-context)))))
247 (defun unreify-symbol (symbol &optional package-context)
251 (let* ((symbol-name (svref symbol 0))
252 (package-foo (svref symbol 1))
253 (package (unreify-package package-foo package-context)))
254 (if package (intern* symbol-name package)
255 (make-symbol* symbol-name)))))))
257 (eval-when (:load-toplevel :compile-toplevel :execute)
258 (defvar *all-package-happiness* '())
259 (defvar *all-package-fishiness* (list t))
260 (defun record-fishy (info)
261 ;;(format t "~&FISHY: ~S~%" info)
262 (push info *all-package-fishiness*))
263 (defmacro when-package-fishiness (&body body)
264 `(when *all-package-fishiness* ,@body))
265 (defmacro note-package-fishiness (&rest info)
266 `(when-package-fishiness (record-fishy (list ,@info)))))
268 (eval-when (:load-toplevel :compile-toplevel :execute)
270 (defun get-setf-function-symbol (symbol)
271 #+clisp (let ((sym (get symbol 'system::setf-function)))
272 (if sym (values sym :setf-function)
273 (let ((sym (get symbol 'system::setf-expander)))
274 (if sym (values sym :setf-expander)
276 #+clozure (gethash symbol ccl::%setf-function-names%))
278 (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
279 #+clisp (assert (member kind '(:setf-function :setf-expander)))
280 #+clozure (assert (eq kind t))
283 ((null new-setf-symbol)
284 (remprop symbol 'system::setf-function)
285 (remprop symbol 'system::setf-expander))
286 ((eq kind :setf-function)
287 (setf (get symbol 'system::setf-function) new-setf-symbol))
288 ((eq kind :setf-expander)
289 (setf (get symbol 'system::setf-expander) new-setf-symbol))
290 (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
291 kind symbol new-setf-symbol)))
294 (gethash symbol ccl::%setf-function-names%) new-setf-symbol
295 (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
297 (defun create-setf-function-symbol (symbol)
298 #+clisp (system::setf-symbol symbol)
299 #+clozure (ccl::construct-setf-function-name symbol))
300 (defun set-dummy-symbol (symbol reason other-symbol)
301 (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
302 (defun make-dummy-symbol (symbol)
303 (let ((dummy (copy-symbol symbol)))
304 (set-dummy-symbol dummy 'replacing symbol)
305 (set-dummy-symbol symbol 'replaced-by dummy)
307 (defun dummy-symbol (symbol)
308 (get symbol 'dummy-symbol))
309 (defun get-dummy-symbol (symbol)
310 (let ((existing (dummy-symbol symbol)))
311 (if existing (values (cdr existing) (car existing))
312 (make-dummy-symbol symbol))))
313 (defun nuke-symbol-in-package (symbol package-designator)
314 (let ((package (find-package* package-designator))
315 (name (symbol-name symbol)))
316 (multiple-value-bind (sym stat) (find-symbol name package)
317 (when (and (member stat '(:internal :external)) (eq symbol sym))
318 (if (symbol-shadowing-p symbol package)
319 (shadowing-import* (get-dummy-symbol symbol) package)
320 (unintern* symbol package))))))
321 (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
323 (multiple-value-bind (setf-symbol kind)
324 (get-setf-function-symbol symbol)
325 (when kind (nuke-symbol setf-symbol)))
326 (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
327 (defun rehome-symbol (symbol package-designator)
328 "Changes the home package of a symbol, also leaving it present in its old home if any"
329 (let* ((name (symbol-name symbol))
330 (package (find-package* package-designator))
331 (old-package (symbol-package symbol))
332 (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
333 (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
334 (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
335 (unless (eq package old-package)
336 (let ((overwritten-symbol-shadowing-p
337 (and overwritten-symbol-status
338 (symbol-shadowing-p overwritten-symbol package))))
339 (note-package-fishiness
341 (when old-package (package-name old-package)) old-status (and shadowing t)
342 (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
345 (shadowing-import* shadowing old-package))
346 (unintern* symbol old-package))
348 (overwritten-symbol-shadowing-p
349 (shadowing-import* symbol package))
351 (when overwritten-symbol-status
352 (unintern* overwritten-symbol package))
353 (import* symbol package)))
355 (shadowing-import* symbol old-package)
356 (import* symbol old-package))
358 (multiple-value-bind (setf-symbol kind)
359 (get-setf-function-symbol symbol)
361 (let* ((setf-function (fdefinition setf-symbol))
362 (new-setf-symbol (create-setf-function-symbol symbol)))
363 (note-package-fishiness
365 name (package-name package)
366 (symbol-name setf-symbol) (symbol-package-name setf-symbol)
367 (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
368 (when (symbol-package setf-symbol)
369 (unintern* setf-symbol (symbol-package setf-symbol)))
370 (setf (fdefinition new-setf-symbol) setf-function)
371 (set-setf-function-symbol new-setf-symbol symbol kind))))
373 (multiple-value-bind (overwritten-setf foundp)
374 (get-setf-function-symbol overwritten-symbol)
376 (unintern overwritten-setf)))
377 (when (eq old-status :external)
378 (export* symbol old-package))
379 (when (eq overwritten-symbol-status :external)
380 (export* symbol package))))
381 (values overwritten-symbol overwritten-symbol-status))))
382 (defun ensure-package-unused (package)
383 (loop :for p :in (package-used-by-list package) :do
384 (unuse-package package p)))
385 (defun delete-package* (package &key nuke)
386 (let ((p (find-package package)))
388 (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
389 (ensure-package-unused p)
390 (delete-package package))))
391 (defun package-names (package)
392 (cons (package-name package) (package-nicknames package)))
393 (defun packages-from-names (names)
394 (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
395 (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
397 (index (random most-positive-fixnum)))
398 (loop :for i :from index
399 :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
400 :thereis (and (not (find-package n)) n)))
401 (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
403 (apply 'fresh-package-name
404 :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
405 (record-fishy (list :rename-away (package-names p) new-name))
406 (rename-package p new-name))))
409 ;;; Communicable representation of symbol and package information
411 (eval-when (:load-toplevel :compile-toplevel :execute)
412 (defun package-definition-form (package-designator
413 &key (nicknamesp t) (usep t)
414 (shadowp t) (shadowing-import-p t)
415 (exportp t) (importp t) internp (error t))
416 (let* ((package (or (find-package* package-designator error)
417 (return-from package-definition-form nil)))
418 (name (package-name package))
419 (nicknames (package-nicknames package))
420 (use (mapcar #'package-name (package-use-list package)))
422 (shadowing-import (make-hash-table :test 'equal))
423 (import (make-hash-table :test 'equal))
427 (loop :for sym :being :the :symbols :in package
428 :for status = (nth-value 1 (find-symbol* sym package)) :do
431 ((:internal :external)
432 (let* ((name (symbol-name sym))
433 (external (eq status :external))
434 (home (symbol-package sym))
435 (home-name (package-name home))
436 (imported (not (eq home package)))
437 (shadowing (symbol-shadowing-p sym package)))
439 ((and shadowing imported)
440 (push name (gethash home-name shadowing-import)))
444 (push name (gethash home-name import))))
449 (t (push name intern)))))))
450 (labels ((sort-names (names)
451 (sort (copy-list names) #'string<))
453 (loop :for k :being :the :hash-keys :of table :collect k))
454 (when-relevant (key value)
455 (when value (list (cons key value))))
456 (import-options (key table)
457 (loop :for i :in (sort-names (table-keys table))
458 :collect `(,key ,i ,@(sort-names (gethash i table))))))
460 ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
461 (:use ,@(and usep (sort-names use)))
462 ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
463 ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
464 ,@(import-options :import-from (and importp import))
465 ,@(when-relevant :export (and exportp (sort-names export)))
466 ,@(when-relevant :intern (and internp (sort-names intern)))))))))
469 ;;; ensure-package, define-package
470 (eval-when (:load-toplevel :compile-toplevel :execute)
471 ;; We already have UIOP:SIMPLE-STYLE-WARNING, but it comes from a later
473 (define-condition define-package-style-warning
474 #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
476 (defun ensure-shadowing-import (name to-package from-package shadowed imported)
477 (check-type name string)
478 (check-type to-package package)
479 (check-type from-package package)
480 (check-type shadowed hash-table)
481 (check-type imported hash-table)
482 (let ((import-me (find-symbol* name from-package)))
483 (multiple-value-bind (existing status) (find-symbol name to-package)
485 ((gethash name shadowed)
486 (unless (eq import-me existing)
487 (error "Conflicting shadowings for ~A" name)))
489 (setf (gethash name shadowed) t)
490 (setf (gethash name imported) t)
491 (unless (or (null status)
492 (and (member status '(:internal :external))
493 (eq existing import-me)
494 (symbol-shadowing-p existing to-package)))
495 (note-package-fishiness
496 :shadowing-import name
497 (package-name from-package)
498 (or (home-package-p import-me from-package) (symbol-package-name import-me))
499 (package-name to-package) status
500 (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
501 (shadowing-import* import-me to-package))))))
502 (defun ensure-imported (import-me into-package &optional from-package)
503 (check-type import-me symbol)
504 (check-type into-package package)
505 (check-type from-package (or null package))
506 (let ((name (symbol-name import-me)))
507 (multiple-value-bind (existing status) (find-symbol name into-package)
510 (import* import-me into-package))
511 ((eq import-me existing))
513 (let ((shadowing-p (symbol-shadowing-p existing into-package)))
514 (note-package-fishiness
515 :ensure-imported name
516 (and from-package (package-name from-package))
517 (or (home-package-p import-me from-package) (symbol-package-name import-me))
518 (package-name into-package)
520 (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
523 ((or shadowing-p (eq status :inherited))
524 (shadowing-import* import-me into-package))
526 (unintern* existing into-package)
527 (import* import-me into-package))))))))
529 (defun ensure-import (name to-package from-package shadowed imported)
530 (check-type name string)
531 (check-type to-package package)
532 (check-type from-package package)
533 (check-type shadowed hash-table)
534 (check-type imported hash-table)
535 (multiple-value-bind (import-me import-status) (find-symbol name from-package)
536 (when (null import-status)
537 (note-package-fishiness
538 :import-uninterned name (package-name from-package) (package-name to-package))
539 (setf import-me (intern* name from-package)))
540 (multiple-value-bind (existing status) (find-symbol name to-package)
542 ((and imported (gethash name imported))
543 (unless (and status (eq import-me existing))
544 (error "Can't import ~S from both ~S and ~S"
545 name (package-name (symbol-package existing)) (package-name from-package))))
546 ((gethash name shadowed)
547 (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
549 (setf (gethash name imported) t))))
550 (ensure-imported import-me to-package from-package)))
551 (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
552 (check-type name string)
553 (check-type symbol symbol)
554 (check-type to-package package)
555 (check-type from-package package)
556 (check-type mixp (member nil t)) ; no cl:boolean on Genera
557 (check-type shadowed hash-table)
558 (check-type imported hash-table)
559 (check-type inherited hash-table)
560 (multiple-value-bind (existing status) (find-symbol name to-package)
561 (let* ((sp (symbol-package symbol))
562 (in (gethash name inherited))
563 (xp (and status (symbol-package existing))))
565 (note-package-fishiness
566 :import-uninterned name
567 (package-name from-package) (package-name to-package) mixp)
568 (import* symbol from-package)
569 (setf sp (package-name from-package)))
571 ((gethash name shadowed))
573 (unless (equal sp (first in))
575 (ensure-shadowing-import name to-package (second in) shadowed imported)
576 (error "Can't inherit ~S from ~S, it is inherited from ~S"
577 name (package-name sp) (package-name (first in))))))
578 ((gethash name imported)
579 (unless (eq symbol existing)
580 (error "Can't inherit ~S from ~S, it is imported from ~S"
581 name (package-name sp) (package-name xp))))
583 (setf (gethash name inherited) (list sp from-package))
584 (when (and status (not (eq sp xp)))
585 (let ((shadowing (symbol-shadowing-p existing to-package)))
586 (note-package-fishiness
588 (package-name from-package)
589 (or (home-package-p symbol from-package) (symbol-package-name symbol))
590 (package-name to-package)
591 (or (home-package-p existing to-package) (symbol-package-name existing)))
592 (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
593 (unintern* existing to-package)))))))))
594 (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
595 (check-type name string)
596 (check-type symbol symbol)
597 (check-type to-package package)
598 (check-type from-package package)
599 (check-type shadowed hash-table)
600 (check-type imported hash-table)
601 (check-type inherited hash-table)
602 (unless (gethash name shadowed)
603 (multiple-value-bind (existing status) (find-symbol name to-package)
604 (let* ((sp (symbol-package symbol))
605 (im (gethash name imported))
606 (in (gethash name inherited)))
609 (and status (eq symbol existing))
610 (and in (eq sp (first in))))
611 (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
613 (remhash name inherited)
614 (ensure-shadowing-import name to-package (second in) shadowed imported))
616 (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
617 name (package-name from-package)
618 (home-package-p symbol from-package) (symbol-package-name symbol)
619 (package-name to-package)
620 (home-package-p existing to-package) (symbol-package-name existing)))
622 (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
624 (defun recycle-symbol (name recycle exported)
625 ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE
626 ;; packages, and a hash-table of names (strings) of symbols scheduled to be
627 ;; EXPORTED from the package being defined. It returns two values, the
628 ;; symbol found (if any, or else NIL), and a boolean flag indicating whether
629 ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the
630 ;; re-homing of the symbol, etc.
631 (check-type name string)
632 (check-type recycle list)
633 (check-type exported hash-table)
634 (when (gethash name exported) ;; don't bother recycling private symbols
635 (let (recycled foundp)
636 (dolist (r recycle (values recycled foundp))
637 (multiple-value-bind (symbol status) (find-symbol name r)
638 (when (and status (home-package-p symbol r))
641 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
642 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
644 (setf recycled symbol foundp r)))))))))
645 (defun symbol-recycled-p (sym recycle)
646 (check-type sym symbol)
647 (check-type recycle list)
648 (and (member (symbol-package sym) recycle) t))
649 (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
650 (check-type name string)
651 (check-type package package)
652 (check-type intern (member nil t)) ; no cl:boolean on Genera
653 (check-type shadowed hash-table)
654 (check-type imported hash-table)
655 (check-type inherited hash-table)
656 (unless (or (gethash name shadowed)
657 (gethash name imported)
658 (gethash name inherited))
659 (multiple-value-bind (existing status)
660 (find-symbol name package)
661 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
663 ((and status (eq existing recycled) (eq previous package)))
665 (rehome-symbol recycled package))
666 ((and status (eq package (symbol-package existing))))
669 (note-package-fishiness
671 (reify-package (symbol-package existing) package)
675 (intern* name package))))))))
676 (declaim (ftype (function (t t t &optional t) t) ensure-exported))
677 (defun ensure-exported-to-user (name symbol to-package &optional recycle)
678 (check-type name string)
679 (check-type symbol symbol)
680 (check-type to-package package)
681 (check-type recycle list)
682 (assert (equal name (symbol-name symbol)))
683 (multiple-value-bind (existing status) (find-symbol name to-package)
684 (unless (and status (eq symbol existing))
687 (let ((shadowing (symbol-shadowing-p existing to-package))
688 (recycled (symbol-recycled-p existing recycle)))
689 (unless (and shadowing (not recycled))
690 (note-package-fishiness
691 :ensure-export name (symbol-package-name symbol)
692 (package-name to-package)
693 (or (home-package-p existing to-package) (symbol-package-name existing))
695 (if (or (eq status :inherited) shadowing)
696 (shadowing-import* symbol to-package)
697 (unintern existing to-package))
699 (when (and accessible (eq status :external))
700 (ensure-exported name symbol to-package recycle))))))
701 (defun ensure-exported (name symbol from-package &optional recycle)
702 (dolist (to-package (package-used-by-list from-package))
703 (ensure-exported-to-user name symbol to-package recycle))
704 (unless (eq from-package (symbol-package symbol))
705 (ensure-imported symbol from-package))
706 (export* name from-package))
707 (defun ensure-export (name from-package &optional recycle)
708 (multiple-value-bind (symbol status) (find-symbol* name from-package)
709 (unless (eq status :external)
710 (ensure-exported name symbol from-package recycle))))
712 #+package-local-nicknames
713 (defun install-package-local-nicknames (destination-package new-nicknames)
714 ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.)
715 (dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package))
716 (uiop/package-local-nicknames:remove-package-local-nickname
717 (string (car pair-to-remove)) destination-package))
718 ;; Then, install all desired nicknames.
719 (loop :for (nickname package) :in new-nicknames
720 :do (uiop/package-local-nicknames:add-package-local-nickname
722 (find-package package)
723 destination-package)))
725 (defun ensure-package (name &key
726 nicknames documentation use
727 shadow shadowing-import-from
728 import-from export intern
730 unintern local-nicknames)
731 #+genera (declare (ignore documentation))
732 (let* ((package-name (string name))
733 (nicknames (mapcar #'string nicknames))
734 (names (cons package-name nicknames))
735 (previous (packages-from-names names))
736 (discarded (cdr previous))
738 (package (or (first previous) (make-package package-name :nicknames nicknames)))
739 (recycle (packages-from-names recycle))
740 (use (mapcar 'find-package* use))
741 (mix (mapcar 'find-package* mix))
742 (reexport (mapcar 'find-package* reexport))
743 (shadow (mapcar 'string shadow))
744 (export (mapcar 'string export))
745 (intern (mapcar 'string intern))
746 (unintern (mapcar 'string unintern))
747 (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames))
748 (shadowed (make-hash-table :test 'equal)) ; string to bool
749 (imported (make-hash-table :test 'equal)) ; string to bool
750 (exported (make-hash-table :test 'equal)) ; string to bool
751 ;; string to list home package and use package:
752 (inherited (make-hash-table :test 'equal)))
753 #-package-local-nicknames
754 (declare (ignore local-nicknames)) ; if not supported
755 (when-package-fishiness (record-fishy package-name))
756 ;; if supported, put package documentation
758 (when documentation (setf (documentation package t) documentation))
759 ;; remove unwanted packages from use list
760 (loop :for p :in (set-difference (package-use-list package) (append mix use))
761 :do (note-package-fishiness :over-use name (package-names p))
762 (unuse-package p package))
763 ;; mark unwanted packages for deletion
764 (loop :for p :in discarded
765 :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
767 :do (note-package-fishiness :nickname name (package-names p))
768 (cond (n (rename-package p (first n) (rest n)))
769 (t (rename-package-away p)
770 (push p to-delete))))
771 ;; give package its desired name
772 (rename-package package package-name nicknames)
773 ;; Handle local nicknames
774 #+package-local-nicknames
775 (install-package-local-nicknames package local-nicknames)
776 (dolist (name unintern)
777 (multiple-value-bind (existing status) (find-symbol name package)
779 (unless (eq status :inherited)
780 (note-package-fishiness
781 :unintern (package-name package) name (symbol-package-name existing) status)
782 (unintern* name package nil)))))
784 (dolist (name export)
785 (setf (gethash name exported) t))
788 (do-external-symbols (sym p)
789 (setf (gethash (string sym) exported) t)))
790 ;; unexport symbols not listed in (re)export
791 (do-external-symbols (sym package)
792 (let ((name (symbol-name sym)))
793 (unless (gethash name exported)
794 (note-package-fishiness
795 :over-export (package-name package) name
796 (or (home-package-p sym package) (symbol-package-name sym)))
797 (unexport sym package))))
798 ;; handle explicitly listed shadowed ssymbols
799 (dolist (name shadow)
800 (setf (gethash name shadowed) t)
801 (multiple-value-bind (existing status) (find-symbol name package)
802 (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
803 (let ((shadowing (and status (symbol-shadowing-p existing package))))
805 ((eq previous package))
807 (rehome-symbol recycled package))
808 ((or (member status '(nil :inherited))
809 (home-package-p existing package)))
811 (let ((dummy (make-symbol name)))
812 (note-package-fishiness
813 :shadow-imported (package-name package) name
814 (symbol-package-name existing) status shadowing)
815 (shadowing-import* dummy package)
816 (import* dummy package)))))))
817 (shadow* name package))
818 ;; handle shadowing imports
819 (loop :for (p . syms) :in shadowing-import-from
820 :for pp = (find-package* p) :do
821 (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
822 ;; handle mixed packages
824 :for pp = (find-package* p) :do
825 (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
826 ;; handle import-from packages
827 (loop :for (p . syms) :in import-from
828 ;; FOR NOW suppress errors in the case where the :import-from
829 ;; symbol list is empty (used only to establish a dependency by
830 ;; package-inferred-system users).
831 :for pp = (find-package* p syms) :do
833 ;; TODO: ASDF 3.4 Change to a full warning.
834 (warn 'define-package-style-warning
835 :format-control "When defining package ~a, attempting to import-from non-existent package ~a. This is deprecated behavior and will be removed from UIOP in the future."
836 :format-arguments (list name p)))
837 (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
838 ;; handle use-list and mix
839 (dolist (p (append use mix))
840 (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
841 (use-package p package))
842 (loop :for name :being :the :hash-keys :of exported :do
843 (ensure-symbol name package t recycle shadowed imported inherited exported)
844 (ensure-export name package recycle))
845 ;; intern dessired symbols
846 (dolist (name intern)
847 (ensure-symbol name package t recycle shadowed imported inherited exported))
848 (do-symbols (sym package)
849 (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
850 ;; delete now-deceased packages
851 (map () 'delete-package* to-delete)
855 (eval-when (:load-toplevel :compile-toplevel :execute)
856 (defun parse-define-package-form (package clauses)
858 :with use-p = nil :with recycle-p = nil
859 :with documentation = nil
860 :for (kw . args) :in clauses
861 :when (eq kw :nicknames) :append args :into nicknames :else
862 :when (eq kw :documentation)
864 (documentation (error "define-package: can't define documentation twice"))
865 ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
866 (t (setf documentation (car args)))) :else
867 :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
868 :when (eq kw :shadow) :append args :into shadow :else
869 :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
870 :when (eq kw :import-from) :collect args :into import-from :else
871 :when (eq kw :export) :append args :into export :else
872 :when (eq kw :intern) :append args :into intern :else
873 :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
874 :when (eq kw :mix) :append args :into mix :else
875 :when (eq kw :reexport) :append args :into reexport :else
876 :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport
877 :and :do (setf use-p t) :else
878 :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport
879 :and :do (setf use-p t) :else
880 :when (eq kw :unintern) :append args :into unintern :else
881 :when (eq kw :local-nicknames)
882 :if (symbol-call '#:uiop '#:featurep :package-local-nicknames)
883 :append args :into local-nicknames
885 :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.")
888 :do (error "unrecognized define-package keyword ~S" kw)
889 :finally (return `(',package
890 :nicknames ',nicknames :documentation ',documentation
891 :use ',(if use-p use '(:common-lisp))
892 :shadow ',shadow :shadowing-import-from ',shadowing-import-from
893 :import-from ',import-from :export ',export :intern ',intern
894 :recycle ',(if recycle-p recycle (cons package nicknames))
895 :mix ',mix :reexport ',reexport :unintern ',unintern
896 ,@(when local-nicknames
897 `(:local-nicknames ',local-nicknames)))))))
899 (defmacro define-package (package &rest clauses)
900 "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form
902 DEFINE-PACKAGE supports the following keywords:
903 SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN, NICKNAMES,
904 DOCUMENTATION -- as per CL:DEFPACKAGE.
905 USE -- as per CL:DEFPACKAGE, but if neither USE, USE-REEXPORT, MIX,
906 nor MIX-REEXPORT is supplied, then it is equivalent to specifying
907 (:USE :COMMON-LISP). This is unlike CL:DEFPACKAGE for which the
908 behavior of a form without USE is implementation-dependent.
909 RECYCLE -- Recycle the package's exported symbols from the specified packages,
910 in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE,
911 either through an :EXPORT option or a :REEXPORT option, if the symbol exists in
912 one of the :RECYCLE packages, the first such symbol is re-homed to the package
914 For the sake of idempotence, it is important that the package being defined
915 should appear in first position if it already exists, and even if it doesn't,
916 ahead of any package that is not going to be deleted afterwards and never
917 created again. In short, except for special cases, always make it the first
918 package on the list if the list is not empty.
919 MIX -- Takes a list of package designators. MIX behaves like
920 \(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to
921 resolve conflicts in favor of the first found symbol. It may still yield
922 an error if there is a conflict with an explicitly :IMPORT-FROM symbol.
923 REEXPORT -- Takes a list of package designators. For each package, p, in the list,
924 export symbols with the same name as those exported from p. Note that in the case
925 of shadowing, etc. the symbols with the same name may not be the same symbols.
926 UNINTERN -- Remove symbols here from PACKAGE. Note that this is primarily useful
927 when *redefining* a previously-existing package in the current image (e.g., when
928 upgrading ASDF). Most programmers will have no use for this option.
929 LOCAL-NICKNAMES -- If the host implementation supports package local nicknames
930 \(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of
931 nickname and package name pairs. Using this option will cause an error if the
932 host CL implementation does not support it.
933 USE-REEXPORT, MIX-REEXPORT -- Use or mix the specified packages as per the USE or
934 MIX directives, and reexport their contents as per the REEXPORT directive."
937 (funcall 'ensure-package ,@(parse-define-package-form package clauses))
938 #+sbcl (setf (sb-impl::package-source-location (find-package ',package))
939 (sb-c:source-location)))))
941 #+(or clasp ecl gcl mkcl) (defpackage ,package (:use))
942 (eval-when (:compile-toplevel :load-toplevel :execute)
945 ;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones.
946 (define-package :uiop/package*
947 (:use-reexport :uiop/package
948 #+package-local-nicknames :uiop/package-local-nicknames)
949 (:import-from :uiop/package
950 #:define-package-style-warning
951 #:no-such-package-error
952 #:package-designator)
953 (:export #:define-package-style-warning
954 #:no-such-package-error
955 #:package-designator))
956 ;;;; -------------------------------------------------------------------------
957 ;;;; Handle compatibility with multiple implementations.
958 ;;; This file is for papering over the deficiencies and peculiarities
959 ;;; of various Common Lisp implementations.
960 ;;; For implementation-specific access to the system, see os.lisp instead.
961 ;;; A few functions are defined here, but actually exported from utility;
962 ;;; from this package only common-lisp symbols are exported.
964 (uiop/package:define-package :uiop/common-lisp
965 (:nicknames :uiop/cl)
967 (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
968 #+allegro (:intern #:*acl-warn-save*)
969 #+cormanlisp (:shadow #:user-homedir-pathname)
972 #:logical-pathname #:translate-logical-pathname
973 #:make-broadcast-stream #:file-namestring)
974 #+genera (:shadowing-import-from :scl #:boolean)
975 #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
976 #+(or mcl cmucl) (:shadow #:user-homedir-pathname))
977 (in-package :uiop/common-lisp)
979 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
980 (error "ASDF is not supported on your implementation. Please help us port it.")
982 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
985 ;;;; Early meta-level tweaks
987 #+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl abcl)
988 (eval-when (:load-toplevel :compile-toplevel :execute)
989 (when (and #+allegro (member :ics *features*)
990 #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*)
991 #+clozure (member :openmcl-unicode-strings *features*)
992 #+sbcl (member :sb-unicode *features*)
994 ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
995 ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
996 (pushnew :asdf-unicode *features*)))
999 (eval-when (:load-toplevel :compile-toplevel :execute)
1000 ;; We need to disable autoloading BEFORE any mention of package ASDF.
1001 ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file
1002 ;; or any previous file.
1003 (setf excl::*autoload-package-name-alist*
1004 (remove "asdf" excl::*autoload-package-name-alist*
1005 :test 'equalp :key 'car))
1006 (defparameter *acl-warn-save*
1007 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
1008 excl:*warn-on-nested-reader-conditionals*))
1009 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
1010 (setf excl:*warn-on-nested-reader-conditionals* nil))
1011 (setf *print-readably* nil))
1014 (eval-when (:load-toplevel :compile-toplevel :execute)
1015 (setf *load-verbose* nil)
1016 (defun use-ecl-byte-compiler-p () nil))
1018 #+clozure (in-package :ccl)
1019 #+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
1020 (eval-when (:load-toplevel :compile-toplevel :execute)
1021 (unless (fboundp 'external-process-wait)
1022 (in-development-mode
1023 (defun external-process-wait (proc)
1024 (when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
1025 (with-interrupts-enabled
1026 (wait-on-semaphore (external-process-completed proc))))
1027 (values (external-process-%exit-code proc)
1028 (external-process-%status proc))))))
1029 #+clozure (in-package :uiop/common-lisp) ;; back in this package.
1032 (eval-when (:load-toplevel :compile-toplevel :execute)
1033 (setf ext:*gc-verbose* nil)
1034 (defun user-homedir-pathname ()
1035 (first (ext:search-list (cl:user-homedir-pathname)))))
1038 (eval-when (:load-toplevel :compile-toplevel :execute)
1039 (deftype logical-pathname () nil)
1040 (defun make-broadcast-stream () *error-output*)
1041 (defun translate-logical-pathname (x) x)
1042 (defun user-homedir-pathname (&optional host)
1043 (declare (ignore host))
1044 (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
1045 (defun file-namestring (p)
1046 (setf p (pathname p))
1047 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
1050 (eval-when (:load-toplevel :compile-toplevel :execute)
1051 (setf *load-verbose* nil)
1052 (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
1053 (unless (use-ecl-byte-compiler-p) (require :cmp)))
1056 (eval-when (:load-toplevel :compile-toplevel :execute)
1057 (unless (member :ansi-cl *features*)
1058 (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
1059 (setf compiler::*compiler-default-type* (pathname "")
1060 compiler::*lsp-ext* "")
1061 #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
1064 ((or (< system::*gcl-major-version* 2)
1065 (and (= system::*gcl-major-version* 2)
1066 (< system::*gcl-minor-version* 7)))
1067 '(error "GCL 2.7 or later required to use ASDF")))))
1072 (eval-when (:load-toplevel :compile-toplevel :execute)
1073 (unless (fboundp 'lambda)
1074 (defmacro lambda (&whole form &rest bvl-decls-and-body)
1075 (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
1076 `#',(cons 'lisp::lambda (cdr form))))
1077 (unless (fboundp 'ensure-directories-exist)
1078 (defun ensure-directories-exist (path)
1079 (fs:create-directories-recursively (pathname path))))
1080 (unless (fboundp 'read-sequence)
1081 (defun read-sequence (sequence stream &key (start 0) end)
1082 (scl:send stream :string-in nil sequence start end)))
1083 (unless (fboundp 'write-sequence)
1084 (defun write-sequence (sequence stream &key (start 0) end)
1085 (scl:send stream :string-out sequence start end)
1089 (eval-when (:load-toplevel :compile-toplevel :execute)
1090 ;; lispworks 3 and earlier cannot be checked for so we always assume
1091 ;; at least version 4
1092 (unless (member :lispworks4 *features*)
1093 (pushnew :lispworks5+ *features*)
1094 (unless (member :lispworks5 *features*)
1095 (pushnew :lispworks6+ *features*)
1096 (unless (member :lispworks6 *features*)
1097 (pushnew :lispworks7+ *features*)))))
1100 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
1102 "(eval-when (:load-toplevel :compile-toplevel :execute)
1103 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
1104 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
1105 ;; Note: ASDF may expect user-homedir-pathname to provide
1106 ;; the pathname of the current user's home directory, whereas
1107 ;; MCL by default provides the directory from which MCL was started.
1108 ;; See http://code.google.com/p/mcl/wiki/Portability
1109 (defun user-homedir-pathname ()
1110 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
1111 (defun probe-posix (posix-namestring)
1112 \"If a file exists for the posix namestring, return the pathname\"
1113 (ccl::with-cstrs ((cpath posix-namestring))
1114 (ccl::rlet ((is-dir :boolean)
1116 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
1117 (ccl::%path-from-fsref fsref is-dir))))))"))
1120 (eval-when (:load-toplevel :compile-toplevel :execute)
1122 (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
1125 ;;;; compatfmt: avoid fancy format directives when unsupported
1126 (eval-when (:load-toplevel :compile-toplevel :execute)
1127 (defun frob-substrings (string substrings &optional frob)
1128 "for each substring in SUBSTRINGS, find occurrences of it within STRING
1129 that don't use parts of matched occurrences of previous strings, and
1130 FROB them, that is to say, remove them if FROB is NIL,
1131 replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
1132 call FROB with the match and a function that emits a string in the output.
1133 Return a string made of the parts not omitted or emitted by FROB."
1134 (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
1135 (let ((length (length string)) (stream nil))
1136 (labels ((emit-string (x &optional (start 0) (end (length x)))
1138 (unless stream (setf stream (make-string-output-stream)))
1139 (write-string x stream :start start :end end)))
1140 (emit-substring (start end)
1141 (when (and (zerop start) (= end length))
1142 (return-from frob-substrings string))
1143 (emit-string string start end))
1144 (recurse (substrings start end)
1147 ((null substrings) (emit-substring start end))
1148 (t (let* ((sub-spec (first substrings))
1149 (sub (if (consp sub-spec) (car sub-spec) sub-spec))
1150 (fun (if (consp sub-spec) (cdr sub-spec) frob))
1151 (found (search sub string :start2 start :end2 end))
1152 (more (rest substrings)))
1155 (recurse more start found)
1158 (string (emit-string fun))
1159 (function (funcall fun sub #'emit-string)))
1160 (recurse substrings (+ found (length sub)) end))
1162 (recurse more start end))))))))
1163 (recurse substrings 0 length))
1164 (if stream (get-output-stream-string stream) "")))
1166 (defmacro compatfmt (format)
1168 (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
1169 #-(or gcl genera) format))
1170 ;;;; -------------------------------------------------------------------------
1171 ;;;; General Purpose Utilities for ASDF
1173 (uiop/package:define-package :uiop/utility
1174 (:use :uiop/common-lisp :uiop/package)
1175 ;; import and reexport a few things defined in :uiop/common-lisp
1176 (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings
1177 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1178 (:export #:compatfmt #:frob-substrings #:compatfmt
1179 #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
1181 ;; magic helper to define debugging functions:
1182 #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
1183 #:with-upgradability ;; (un)defining functions in an upgrade-friendly way
1184 #:nest #:if-let ;; basic flow control
1185 #:parse-body ;; macro definition helper
1186 #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
1187 #:remove-plist-keys #:remove-plist-key ;; plists
1188 #:emptyp ;; sequences
1189 #:+non-base-chars-exist-p+ ;; characters
1190 #:+max-character-type-index+ #:character-type-index #:+character-types+
1191 #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
1192 #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+
1193 #:string-prefix-p #:string-enclosed-p #:string-suffix-p
1194 #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols
1195 #:coerce-class ;; CLOS
1196 #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps
1197 #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp
1198 #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f
1199 #:list-to-hash-set #:ensure-gethash ;; hash-table
1200 #:ensure-function #:access-at #:access-at-count ;; functions
1201 #:call-function #:call-functions #:register-hook-function
1202 #:lexicographic< #:lexicographic<= ;; version
1203 #:simple-style-warning #:style-warn ;; simple style warnings
1204 #:match-condition-p #:match-any-condition-p ;; conditions
1205 #:call-with-muffled-conditions #:with-muffled-conditions
1206 #:not-implemented-error #:parameter-error
1207 #:symbol-test-to-feature-expression
1208 #:boolean-to-feature-expression))
1209 (in-package :uiop/utility)
1211 ;;;; Defining functions in a way compatible with hot-upgrade:
1212 ;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE,
1213 ;; so that new definitions are always seen by all callers, even those up the stack.
1214 ;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state
1215 ;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file.
1216 ;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it,
1217 ;; at least if that function is used by ASDF while performing the plan to load ASDF.
1218 ;; - THOU SHALT change the name of a function whenever thou makest an incompatible change.
1219 ;; - For instance, when the meanings of NIL and T for timestamps was inverted,
1220 ;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc.,
1221 ;; because the change other caused a huge incompatibility during upgrade.
1222 ;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc.,
1223 ;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND.
1224 ;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that
1225 ;; all the methods required for ASDF to successfully continue compiling itself
1226 ;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC.
1227 ;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND.
1228 ;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC,
1229 ;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN).
1230 ;; - Any time you change a signature, please keep a comment specifying the first release after the change;
1231 ;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND.
1232 (eval-when (:load-toplevel :compile-toplevel :execute)
1233 (defun ensure-function-notinline (definition &aux (name (second definition)))
1234 (assert (member (first definition) '(defun defgeneric)))
1236 ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL
1237 `(declaim (notinline ,name)))
1239 (defmacro with-upgradability ((&optional) &body body)
1240 "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
1241 to also declare the functions NOTINLINE and to accept a wrapping the function name
1242 specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
1243 is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
1244 to supersede any previous definition."
1245 `(eval-when (:compile-toplevel :load-toplevel :execute)
1246 ,@(loop :for form :in body :collect
1249 ((defun defgeneric) (ensure-function-notinline form))
1253 ;;; Magic debugging help. See contrib/debug.lisp
1254 (with-upgradability ()
1255 (defvar *uiop-debug-utility*
1256 '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp")
1257 "form that evaluates to the pathname to your favorite debugging utilities")
1259 (defmacro uiop-debug (&rest keys)
1260 "Load the UIOP debug utility at compile-time as well as runtime"
1261 `(eval-when (:compile-toplevel :load-toplevel :execute)
1262 (load-uiop-debug-utility ,@keys)))
1264 (defun load-uiop-debug-utility (&key package utility-file)
1265 "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*).
1266 Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)."
1267 (let* ((*package* (if package (find-package package) *package*))
1268 (keyword (read-from-string
1269 (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
1270 (unless (member keyword *features*)
1271 (let* ((utility-file (or utility-file *uiop-debug-utility*))
1272 (file (ignore-errors (probe-file (eval utility-file)))))
1273 (if file (load file)
1274 (error "Failed to locate debug utility file: ~S" utility-file)))))))
1277 (with-upgradability ()
1278 (defmacro nest (&rest things)
1279 "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer
1280 (reduce #'(lambda (outer inner) `(,@outer ,inner))
1281 things :from-end t))
1283 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
1284 ;; bindings can be (var form) or ((var1 form1) ...)
1285 (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
1288 (variables (mapcar #'car binding-list)))
1290 (if (and ,@variables)
1294 ;;; Macro definition helper
1295 (with-upgradability ()
1296 (defun parse-body (body &key documentation whole) ;; from alexandria
1297 "Parses BODY into (values remaining-forms declarations doc-string).
1298 Documentation strings are recognized only if DOCUMENTATION is true.
1299 Syntax errors in body are signalled and WHOLE is used in the signal
1300 arguments when given."
1306 (setf current (car body))
1307 (when (and documentation (stringp current) (cdr body))
1309 (error "Too many documentation strings in ~S." (or whole body))
1310 (setf doc (pop body)))
1312 (when (and (listp current) (eql (first current) 'declare))
1313 (push (pop body) decls)
1314 (go :declarations)))
1315 (values body (nreverse decls) doc))))
1318 ;;; List manipulation
1319 (with-upgradability ()
1320 (defmacro while-collecting ((&rest collectors) &body body)
1321 "COLLECTORS should be a list of names for collections. A collector
1322 defines a function that, when applied to an argument inside BODY, will
1323 add its argument to the corresponding collection. Returns multiple values,
1324 a list for each collection, in order.
1326 \(while-collecting \(foo bar\)
1327 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
1329 \(bar \(second x\)\)\)\)
1330 Returns two values: \(A B C\) and \(1 2 3\)."
1331 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
1332 (initial-values (mapcar (constantly nil) collectors)))
1333 `(let ,(mapcar #'list vars initial-values)
1334 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
1336 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
1338 (define-modify-macro appendf (&rest args)
1339 append "Append onto list") ;; only to be used on short lists.
1341 (defun length=n-p (x n) ;is it that (= (length x) n) ?
1342 (check-type n (integer 0 *))
1344 :for l = x :then (cdr l)
1345 :for i :downfrom n :do
1347 ((zerop i) (return (null l)))
1348 ((not (consp l)) (return nil)))))
1350 (defun ensure-list (x)
1351 (if (listp x) x (list x))))
1354 ;;; Remove a key from a plist, i.e. for keyword argument cleanup
1355 (with-upgradability ()
1356 (defun remove-plist-key (key plist)
1357 "Remove a single key from a plist"
1358 (loop :for (k v) :on plist :by #'cddr
1360 :append (list k v)))
1362 (defun remove-plist-keys (keys plist)
1363 "Remove a list of keys from a plist"
1364 (loop :for (k v) :on plist :by #'cddr
1365 :unless (member k keys)
1366 :append (list k v))))
1370 (with-upgradability ()
1372 "Predicate that is true for an empty sequence"
1373 (or (null x) (and (vectorp x) (zerop (length x))))))
1377 (with-upgradability ()
1378 ;; base-char != character on ECL, LW, SBCL, Genera.
1379 ;; NB: We assume a total order on character types.
1380 ;; If that's not true... this code will need to be updated.
1381 (defparameter +character-types+ ;; assuming a simple hierarchy
1382 #.(coerce (loop :for (type next) :on
1383 '(;; In SCL, all characters seem to be 16-bit base-char
1384 ;; Yet somehow character fails to be a subtype of base-char
1386 ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER
1387 ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER
1388 #+lispworks7+ lw:bmp-char
1389 #+lispworks lw:simple-char
1391 :unless (and next (subtypep next type))
1392 :collect type) 'vector))
1393 (defparameter +max-character-type-index+ (1- (length +character-types+)))
1394 (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+))
1395 (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
1397 (with-upgradability ()
1398 (defun character-type-index (x)
1399 (declare (ignorable x))
1400 #.(case +max-character-type-index+
1403 (character (if (typep x 'base-char) 0 1))
1404 (symbol (if (subtypep x 'base-char) 0 1))))
1406 '(or (position-if (etypecase x
1407 (character #'(lambda (type) (typep x type)))
1408 (symbol #'(lambda (type) (subtypep x type))))
1410 (error "Not a character or character type: ~S" x))))))
1414 (with-upgradability ()
1415 (defun base-string-p (string)
1416 "Does the STRING only contain BASE-CHARs?"
1417 (declare (ignorable string))
1418 (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
1420 (defun strings-common-element-type (strings)
1421 "What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
1422 (declare (ignorable strings))
1423 #.(if +non-base-chars-exist-p+
1424 `(aref +character-types+
1425 (loop :with index = 0 :for s :in strings :do
1426 (flet ((consider (i)
1427 (cond ((= i ,+max-character-type-index+) (return i))
1428 ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i)))))))
1430 ((emptyp s)) ;; NIL or empty string
1431 ((characterp s) (consider (character-type-index s)))
1432 ((stringp s) (let ((string-type-index
1433 (character-type-index (array-element-type s))))
1434 (unless (>= index string-type-index)
1435 (loop :for c :across s :for i = (character-type-index c)
1437 ,@(when (> +max-character-type-index+ 1)
1438 `((when (= i string-type-index) (return))))))))
1439 (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))))
1440 :finally (return index)))
1443 (defun reduce/strcat (strings &key key start end)
1444 "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
1445 NIL is interpreted as an empty string. A character is interpreted as a string of length one."
1446 (when (or start end) (setf strings (subseq strings start end)))
1447 (when key (setf strings (mapcar key strings)))
1448 (loop :with output = (make-string (loop :for s :in strings
1449 :sum (if (characterp s) 1 (length s)))
1450 :element-type (strings-common-element-type strings))
1452 :for input :in strings
1453 :do (etypecase input
1455 (character (setf (char output pos) input) (incf pos))
1456 (string (replace output input :start1 pos) (incf pos (length input))))
1457 :finally (return output)))
1459 (defun strcat (&rest strings)
1460 "Concatenate strings.
1461 NIL is interpreted as an empty string, a character as a string of length one."
1462 (reduce/strcat strings))
1464 (defun first-char (s)
1465 "Return the first character of a non-empty string S, or NIL"
1466 (and (stringp s) (plusp (length s)) (char s 0)))
1468 (defun last-char (s)
1469 "Return the last character of a non-empty string S, or NIL"
1470 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
1472 (defun split-string (string &key max (separator '(#\Space #\Tab)))
1473 "Split STRING into a list of components separated by
1474 any of the characters in the sequence SEPARATOR.
1475 If MAX is specified, then no more than max(1,MAX) components will be returned,
1476 starting the separation from the end, e.g. when called with arguments
1477 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
1479 (let ((list nil) (words 0) (end (length string)))
1480 (when (zerop end) (return nil))
1481 (flet ((separatorp (char) (find char separator))
1482 (done () (return (cons (subseq string 0 end) list))))
1484 :for start = (if (and max (>= words (1- max)))
1486 (position-if #'separatorp string :end end :from-end t))
1487 :do (when (null start) (done))
1488 (push (subseq string (1+ start) end) list)
1490 (setf end start))))))
1492 (defun string-prefix-p (prefix string)
1493 "Does STRING begin with PREFIX?"
1494 (let* ((x (string prefix))
1498 (and (<= lx ly) (string= x y :end2 lx))))
1500 (defun string-suffix-p (string suffix)
1501 "Does STRING end with SUFFIX?"
1502 (let* ((x (string string))
1506 (and (<= ly lx) (string= x y :start1 (- lx ly)))))
1508 (defun string-enclosed-p (prefix string suffix)
1509 "Does STRING begin with PREFIX and end with SUFFIX?"
1510 (and (string-prefix-p prefix string)
1511 (string-suffix-p string suffix)))
1513 (defvar +cr+ (coerce #(#\Return) 'string))
1514 (defvar +lf+ (coerce #(#\Linefeed) 'string))
1515 (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string))
1518 "Strip a string X from any ending CR, LF or CRLF.
1519 Return two values, the stripped string and the ending that was stripped,
1520 or the original value and NIL if no stripping took place.
1521 Since our STRCAT accepts NIL as empty string designator,
1522 the two results passed to STRCAT always reconstitute the original string"
1523 (check-type x string)
1525 (flet ((c (end) (when (string-suffix-p x end)
1526 (return (values (subseq x 0 (- (length x) (length end))) end)))))
1527 (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil)))))
1529 (defun standard-case-symbol-name (name-designator)
1530 "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING;
1531 if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\"
1532 platform such as Allegro with modern syntax."
1533 (check-type name-designator (or string symbol))
1535 ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower))
1536 (string name-designator))
1537 ;; Should we be doing something on CLISP?
1538 (t (string-upcase name-designator))))
1540 (defun find-standard-case-symbol (name-designator package-designator &optional (error t))
1541 "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR,
1542 where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings.
1543 If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found."
1544 (find-symbol* (standard-case-symbol-name name-designator)
1545 (etypecase package-designator
1546 ((or package symbol) package-designator)
1547 (string (standard-case-symbol-name package-designator)))
1550 ;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity
1551 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
1552 (deftype timestamp () '(or real boolean)))
1553 (with-upgradability ()
1554 (defun timestamp< (x y)
1556 ((eql t) (not (eql y t)))
1562 (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y)))
1563 (defun timestamp*< (&rest list) (timestamps< list))
1564 (defun timestamp<= (x y) (not (timestamp< y x)))
1565 (defun earlier-timestamp (x y) (if (timestamp< x y) x y))
1566 (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil))
1567 (defun earliest-timestamp (&rest list) (timestamps-earliest list))
1568 (defun later-timestamp (x y) (if (timestamp< x y) y x))
1569 (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t))
1570 (defun latest-timestamp (&rest list) (timestamps-latest list))
1571 (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp))
1574 ;;; Function designators
1575 (with-upgradability ()
1576 (defun ensure-function (fun &key (package :cl))
1577 "Coerce the object FUN into a function.
1579 If FUN is a FUNCTION, return it.
1580 If the FUN is a non-sequence literal constant, return constantly that,
1581 i.e. for a boolean keyword character number or pathname.
1582 Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
1583 If FUN is a CONS, return the function that applies its CAR
1584 to the appended list of the rest of its CDR and the arguments,
1585 unless the CAR is LAMBDA, in which case the expression is evaluated.
1586 If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
1587 and EVAL that in a (FUNCTION ...) context."
1590 ((or boolean keyword character number pathname) (constantly fun))
1591 (hash-table #'(lambda (x) (gethash x fun)))
1592 (symbol (fdefinition fun))
1593 (cons (if (eq 'lambda (car fun))
1595 #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))))
1596 (string (eval `(function ,(with-standard-io-syntax
1597 (let ((*package* (find-package package)))
1598 (read-from-string fun))))))))
1600 (defun access-at (object at)
1601 "Given an OBJECT and an AT specifier, list of successive accessors,
1602 call each accessor on the result of the previous calls.
1603 An accessor may be an integer, meaning a call to ELT,
1604 a keyword, meaning a call to GETF,
1605 NIL, meaning identity,
1606 a function or other symbol, meaning itself,
1607 or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
1608 As a degenerate case, the AT specifier may be an atom of a single such accessor
1610 (flet ((access (object accessor)
1612 (function (funcall accessor object))
1613 (integer (elt object accessor))
1614 (keyword (getf object accessor))
1616 (symbol (funcall accessor object))
1617 (cons (funcall (ensure-function accessor) object)))))
1619 (dolist (accessor at object)
1620 (setf object (access object accessor)))
1621 (access object at))))
1623 (defun access-at-count (at)
1624 "From an AT specification, extract a COUNT of maximum number
1625 of sub-objects to read as per ACCESS-AT"
1629 ((and (consp at) (integerp (first at)))
1632 (defun call-function (function-spec &rest arguments)
1633 "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION,
1634 with the given ARGUMENTS"
1635 (apply (ensure-function function-spec) arguments))
1637 (defun call-functions (function-specs)
1638 "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION"
1639 (map () 'call-function function-specs))
1641 (defun register-hook-function (variable hook &optional call-now-p)
1642 "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE.
1643 When CALL-NOW-P is true, also call the function immediately."
1644 (pushnew hook (symbol-value variable) :test 'equal)
1645 (when call-now-p (call-function hook))))
1649 (with-upgradability ()
1650 (defun coerce-class (class &key (package :cl) (super t) (error 'error))
1651 "Coerce CLASS to a class that is subclass of SUPER if specified,
1652 or invoke ERROR handler as per CALL-FUNCTION.
1654 A keyword designates the name a symbol, which when found in either PACKAGE, designates a class.
1655 -- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future.
1656 A string is read as a symbol while in PACKAGE, the symbol designates a class.
1658 A class object designates itself.
1659 NIL designates itself (no class).
1660 A symbol otherwise designates a class by name."
1663 (keyword (or (find-symbol* class package nil)
1664 (find-symbol* class *package* nil)))
1665 (string (symbol-call :uiop :safe-read-from-string class :package package))
1668 (etypecase normalized
1669 ((or standard-class built-in-class) normalized)
1670 ((or null keyword) nil)
1671 (symbol (find-class normalized nil nil))))
1674 ((or standard-class built-in-class) super)
1675 ((or null keyword) nil)
1676 (symbol (find-class super nil nil)))))
1677 #+allegro (when found (mop:finalize-inheritance found))
1679 (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class))
1681 (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super)))))
1685 (with-upgradability ()
1686 (defun ensure-gethash (key table default)
1687 "Lookup the TABLE for a KEY as by GETHASH, but if not present,
1688 call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION,
1689 set the corresponding entry to the result in the table.
1690 Return two values: the entry after its optional computation, and whether it was found"
1691 (multiple-value-bind (value foundp) (gethash key table)
1695 (setf (gethash key table) (call-function default)))
1698 (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
1699 "Convert a LIST into hash-table that has the same elements when viewed as a set,
1700 up to the given equality TEST"
1701 (dolist (x list h) (setf (gethash x h) t))))
1704 ;;; Lexicographic comparison of lists of numbers
1705 (with-upgradability ()
1706 (defun lexicographic< (element< x y)
1707 "Lexicographically compare two lists of using the function element< to compare elements.
1708 element< is a strict total order; the resulting order on X and Y will also be strict."
1709 (cond ((null y) nil)
1711 ((funcall element< (car x) (car y)) t)
1712 ((funcall element< (car y) (car x)) nil)
1713 (t (lexicographic< element< (cdr x) (cdr y)))))
1715 (defun lexicographic<= (element< x y)
1716 "Lexicographically compare two lists of using the function element< to compare elements.
1717 element< is a strict total order; the resulting order on X and Y will be a non-strict total order."
1718 (not (lexicographic< element< y x))))
1721 ;;; Simple style warnings
1722 (with-upgradability ()
1723 (define-condition simple-style-warning
1724 #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning)
1727 (defun style-warn (datum &rest arguments)
1729 (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments)))
1730 (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments))
1731 (style-warning (apply 'warn datum arguments)))))
1734 ;;; Condition control
1736 (with-upgradability ()
1737 (defparameter +simple-condition-format-control-slot+
1738 #+abcl 'system::format-control
1739 #+allegro 'excl::format-control
1740 #+(or clasp ecl mkcl) 'si::format-control
1741 #+clisp 'system::$format-control
1742 #+clozure 'ccl::format-control
1743 #+(or cmucl scl) 'conditions::format-control
1744 #+(or gcl lispworks) 'conditions::format-string
1745 #+sbcl 'sb-kernel:format-control
1746 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil
1747 "Name of the slot for FORMAT-CONTROL in simple-condition")
1749 (defun match-condition-p (x condition)
1750 "Compare received CONDITION to some pattern X:
1751 a symbol naming a condition class,
1752 a simple vector of length 2, arguments to find-symbol* with result as above,
1753 or a string describing the format-control of a simple-condition."
1755 (symbol (typep condition x))
1757 (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
1758 (function (funcall x condition))
1759 (string (and (typep condition 'simple-condition)
1760 ;; On SBCL, it's always set and the check triggers a warning
1761 #+(or allegro clozure cmucl lispworks scl)
1762 (slot-boundp condition +simple-condition-format-control-slot+)
1763 (ignore-errors (equal (simple-condition-format-control condition) x))))))
1765 (defun match-any-condition-p (condition conditions)
1766 "match CONDITION against any of the patterns of CONDITIONS supplied"
1767 (loop :for x :in conditions :thereis (match-condition-p x condition)))
1769 (defun call-with-muffled-conditions (thunk conditions)
1770 "calls the THUNK in a context where the CONDITIONS are muffled"
1771 (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
1772 (muffle-warning c)))))
1775 (defmacro with-muffled-conditions ((conditions) &body body)
1776 "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
1777 `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
1781 (with-upgradability ()
1782 (define-condition not-implemented-error (error)
1783 ((functionality :initarg :functionality)
1784 (format-control :initarg :format-control)
1785 (format-arguments :initarg :format-arguments))
1786 (:report (lambda (condition stream)
1787 (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]"
1788 (nth-value 1 (symbol-call :uiop :implementation-type))
1789 (slot-value condition 'functionality)
1790 (slot-value condition 'format-control)
1791 (slot-value condition 'format-arguments)))))
1793 (defun not-implemented-error (functionality &optional format-control &rest format-arguments)
1794 "Signal an error because some FUNCTIONALITY is not implemented in the current version
1795 of the software on the current platform; it may or may not be implemented in different combinations
1796 of version of the software and of the underlying platform. Optionally, report a formatted error
1798 (error 'not-implemented-error
1799 :functionality functionality
1800 :format-control format-control
1801 :format-arguments format-arguments))
1803 (define-condition parameter-error (error)
1804 ((functionality :initarg :functionality)
1805 (format-control :initarg :format-control)
1806 (format-arguments :initarg :format-arguments))
1807 (:report (lambda (condition stream)
1808 (apply 'format stream
1809 (slot-value condition 'format-control)
1810 (slot-value condition 'functionality)
1811 (slot-value condition 'format-arguments)))))
1813 ;; Note that functionality MUST be passed as the second argument to parameter-error, just after
1814 ;; the format-control. If you want it to not appear in first position in actual message, use
1815 ;; ~* and ~:* to adjust parameter order.
1816 (defun parameter-error (format-control functionality &rest format-arguments)
1817 "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying
1818 platform does not accept a given parameter or combination of parameters. Report a formatted error
1819 message, that takes the functionality as its first argument (that can be skipped with ~*)."
1820 (error 'parameter-error
1821 :functionality functionality
1822 :format-control format-control
1823 :format-arguments format-arguments)))
1825 (with-upgradability ()
1826 (defun boolean-to-feature-expression (value)
1827 "Converts a boolean VALUE to a form suitable for testing with #+."
1832 (defun symbol-test-to-feature-expression (name package)
1833 "Check if a symbol with a given NAME exists in PACKAGE and returns a
1834 form suitable for testing with #+."
1835 (boolean-to-feature-expression
1836 (find-symbol* name package nil))))
1837 (uiop/package:define-package :uiop/version
1838 (:recycle :uiop/version :uiop/utility :asdf)
1839 (:use :uiop/common-lisp :uiop/package :uiop/utility)
1842 #:parse-version #:unparse-version #:version< #:version<= #:version= ;; version support, moved from uiop/utility
1844 #:deprecated-function-condition #:deprecated-function-name ;; deprecation control
1845 #:deprecated-function-style-warning #:deprecated-function-warning
1846 #:deprecated-function-error #:deprecated-function-should-be-deleted
1847 #:version-deprecation #:with-deprecation))
1848 (in-package :uiop/version)
1850 (with-upgradability ()
1851 (defparameter *uiop-version* "3.3.6")
1853 (defun unparse-version (version-list)
1854 "From a parsed version (a list of natural numbers), compute the version string"
1855 (format nil "~{~D~^.~}" version-list))
1857 (defun parse-version (version-string &optional on-error)
1858 "Parse a VERSION-STRING as a series of natural numbers separated by dots.
1859 Return a (non-null) list of integers if the string is valid;
1860 otherwise return NIL.
1862 When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
1863 with format arguments explaining why the version is invalid.
1864 ON-ERROR is also called if the version is not canonical
1865 in that it doesn't print back to itself, but the list is returned anyway."
1867 (unless (stringp version-string)
1868 (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
1870 (unless (loop :for prev = nil :then c :for c :across version-string
1871 :always (or (digit-char-p c)
1872 (and (eql c #\.) prev (not (eql prev #\.))))
1873 :finally (return (and c (digit-char-p c))))
1874 (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
1875 'parse-version version-string)
1877 (let* ((version-list
1878 (mapcar #'parse-integer (split-string version-string :separator ".")))
1879 (normalized-version (unparse-version version-list)))
1880 (unless (equal version-string normalized-version)
1881 (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
1884 (defun next-version (version)
1885 "When VERSION is not nil, it is a string, then parse it as a version, compute the next version
1886 and return it as a string."
1888 (let ((version-list (parse-version version)))
1889 (incf (car (last version-list)))
1890 (unparse-version version-list))))
1892 (defun version< (version1 version2)
1893 "Given two version strings, return T if the second is strictly newer"
1894 (let ((v1 (parse-version version1 nil))
1895 (v2 (parse-version version2 nil)))
1896 (lexicographic< '< v1 v2)))
1898 (defun version<= (version1 version2)
1899 "Given two version strings, return T if the second is newer or the same"
1900 (not (version< version2 version1))))
1902 (defun version= (version1 version2)
1903 "Given two version strings, return T if the first is newer or the same and
1904 the second is also newer or the same."
1905 (and (version<= version1 version2)
1906 (version<= version2 version1)))
1909 (with-upgradability ()
1910 (define-condition deprecated-function-condition (condition)
1911 ((name :initarg :name :reader deprecated-function-name)))
1912 (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ())
1913 (define-condition deprecated-function-warning (deprecated-function-condition warning) ())
1914 (define-condition deprecated-function-error (deprecated-function-condition error) ())
1915 (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ())
1917 (defun deprecated-function-condition-kind (type)
1919 ((deprecated-function-style-warning) :style-warning)
1920 ((deprecated-function-warning) :warning)
1921 ((deprecated-function-error) :error)
1922 ((deprecated-function-should-be-deleted) :delete)))
1924 (defmethod print-object ((c deprecated-function-condition) stream)
1925 (let ((name (deprecated-function-name c)))
1928 (let ((fmt "#.(make-condition '~S :name ~S)")
1929 (args (list (type-of c) name)))
1931 (apply 'format stream fmt args)
1932 (error "Can't print ~?" fmt args))))
1934 (print-unreadable-object (c stream :type t) (format stream ":name ~S" name)))
1936 (let ((*package* (find-package :cl))
1939 (if (eq type 'deprecated-function-should-be-deleted)
1940 "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete"
1941 "~A: Using deprecated function ~S -- please update your code to use a newer API.~
1942 ~@[~%The docstring for this function says:~%~A~%~]")
1943 type name (when (symbolp name) (documentation name 'function))))))))
1945 (defun notify-deprecated-function (status name)
1948 ((:style-warning) (style-warn 'deprecated-function-style-warning :name name))
1949 ((:warning) (warn 'deprecated-function-warning :name name))
1950 ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name))))
1952 (defun version-deprecation (version &key (style-warning nil)
1953 (warning (next-version style-warning))
1954 (error (next-version warning))
1955 (delete (next-version error)))
1956 "Given a VERSION string, and the starting versions for notifying the programmer of
1957 various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION
1958 that is the highest level that has a declared version older than the specified version.
1959 Each start version for a level of deprecation can be specified by a keyword argument, or
1960 if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation."
1962 ((and delete (version<= delete version)) :delete)
1963 ((and error (version<= error version)) :error)
1964 ((and warning (version<= warning version)) :warning)
1965 ((and style-warning (version<= style-warning version)) :style-warning)))
1967 (defmacro with-deprecation ((level) &body definitions)
1968 "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the
1969 DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function
1970 when it is compiled or called.
1972 Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet),
1973 :STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used),
1974 :ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while
1977 Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD
1978 from instrumentation by enclosing it in a PROGN."
1979 (let ((level (eval level)))
1980 (check-type level (member nil :style-warning :warning :error :delete))
1981 (when (eq level :delete)
1982 (error 'deprecated-function-should-be-deleted :name
1984 (remove-if-not #'(lambda (x) (member x '(defun defmethod)))
1985 definitions :key 'first))))
1986 (labels ((instrument (name head body whole)
1989 (intern (format nil "*~A-~A-~A-~A*"
1990 :deprecated-function level name :notified-p))))
1991 (multiple-value-bind (remaining-forms declarations doc-string)
1992 (parse-body body :documentation t :whole whole)
1994 (defparameter ,notifiedp nil)
1995 ;; tell some implementations to use the compiler-macro
1996 (declaim (inline ,name))
1997 (define-compiler-macro ,name (&whole form &rest args)
1998 (declare (ignore args))
1999 (notify-deprecated-function ,level ',name)
2001 (,@head ,@(when doc-string (list doc-string)) ,@declarations
2004 (notify-deprecated-function ,level ',name))
2005 ,@remaining-forms))))
2007 (eval-when (:compile-toplevel :load-toplevel :execute)
2008 (setf (compiler-macro-function ',name) nil))
2009 (declaim (notinline ,name))
2012 ,@(loop :for form :in definitions :collect
2014 ((and (consp form) (eq (car form) 'defun))
2015 (instrument (second form) (subseq form 0 3) (subseq form 3) form))
2016 ((and (consp form) (eq (car form) 'defmethod))
2017 (let ((body-start (if (listp (third form)) 3 4)))
2018 (instrument (second form)
2019 (subseq form 0 body-start)
2020 (subseq form body-start)
2024 ;;;; ---------------------------------------------------------------------------
2025 ;;;; Access to the Operating System
2027 (uiop/package:define-package :uiop/os
2028 (:use :uiop/common-lisp :uiop/package :uiop/utility)
2030 #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
2032 #:getenv #:getenvp ;; environment variables
2033 #:implementation-identifier ;; implementation identifier
2034 #:implementation-type #:*implementation-type*
2035 #:operating-system #:architecture #:lisp-version-string
2036 #:hostname #:getcwd #:chdir
2037 ;; Windows shortcut support
2038 #:read-null-terminated-string #:read-little-endian
2039 #:parse-file-location-info #:parse-windows-shortcut))
2040 (in-package :uiop/os)
2043 (with-upgradability ()
2044 (defun featurep (x &optional (*features* *features*))
2045 "Checks whether a feature expression X is true with respect to the *FEATURES* set,
2046 as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
2047 we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
2048 your reader will not have magically used the KEYWORD package, so you need specify
2049 keywords explicitly."
2051 ((atom x) (and (member x *features*) t))
2052 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
2053 ((eq :or (car x)) (some #'featurep (cdr x)))
2054 ((eq :and (car x)) (every #'featurep (cdr x)))
2055 (t (parameter-error "~S: malformed feature specification ~S" 'featurep x))))
2057 ;; Starting with UIOP 3.1.5, these are runtime tests.
2058 ;; You may bind *features* with a copy of what your target system offers to test its properties.
2059 (defun os-macosx-p ()
2060 "Is the underlying operating system MacOS X?"
2061 ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
2062 ;; in fact the former implies the latter.
2063 (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))
2066 "Is the underlying operating system some Unix variant?"
2067 (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p)))
2069 (defun os-windows-p ()
2070 "Is the underlying operating system Microsoft Windows?"
2071 (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64))))
2073 (defun os-genera-p ()
2074 "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
2077 (defun os-oldmac-p ()
2078 "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
2081 (defun os-haiku-p ()
2082 "Is the underlying operating system Haiku?"
2085 (defun os-mezzano-p ()
2086 "Is the underlying operating system Mezzano?"
2087 (featurep :mezzano))
2090 "Detects the current operating system. Only needs be run at compile-time,
2091 except on ABCL where it might change between FASL compilation and runtime."
2093 :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
2094 (:os-windows . os-windows-p)
2095 (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
2096 (:os-haiku . os-haiku-p)
2097 (:os-mezzano . os-mezzano-p))
2098 :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
2099 :do (setf o feature) (pushnew feature *features*)
2100 :else :do (setf *features* (remove feature *features*))
2102 (return (or o (error "Congratulations for trying ASDF on an operating system~%~
2103 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
2105 (defmacro os-cond (&rest clauses)
2106 #+abcl `(cond ,@clauses)
2107 #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))
2111 ;;;; Environment variables: getting them, and parsing them.
2112 (with-upgradability ()
2114 "Query the environment, as in C getenv.
2115 Beware: may return empty string if a variable is present but empty;
2116 use getenvp to return NIL in such a case."
2117 (declare (ignorable x))
2118 #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
2119 #+allegro (sys:getenv x)
2120 #+clozure (ccl:getenv x)
2121 #+cmucl (unix:unix-getenv x)
2122 #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
2124 (let* ((buffer (ct:malloc 1))
2125 (cname (ct:lisp-string-to-c-string x))
2126 (needed-size (win:getenvironmentvariable cname buffer 0))
2127 (buffer1 (ct:malloc (1+ needed-size))))
2128 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
2130 (ct:c-string-to-lisp-string buffer1))
2133 #+gcl (system:getenv x)
2134 #+(or genera mezzano) nil
2135 #+lispworks (lispworks:environment-variable x)
2136 #+mcl (ccl:with-cstrs ((name x))
2137 (let ((value (_getenv name)))
2138 (unless (ccl:%null-ptr-p value)
2139 (ccl:%get-cstring value))))
2140 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
2141 #+sbcl (sb-ext:posix-getenv x)
2142 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
2143 (not-implemented-error 'getenv))
2145 (defsetf getenv (x) (val)
2146 "Set an environment variable."
2147 (declare (ignorable x val))
2148 #+allegro `(setf (sys:getenv ,x) ,val)
2149 #+clasp `(ext:setenv ,x ,val)
2150 #+clisp `(system::setenv ,x ,val)
2151 #+clozure `(ccl:setenv ,x ,val)
2152 #+cmucl `(unix:unix-setenv ,x ,val 1)
2153 #+(or ecl clasp) `(ext:setenv ,x ,val)
2154 #+lispworks `(setf (lispworks:environment-variable ,x) ,val)
2155 #+mkcl `(mkcl:setenv ,x ,val)
2156 #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
2157 #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
2158 '(not-implemented-error '(setf getenv)))
2161 "Predicate that is true if the named variable is present in the libc environment,
2162 then returning the non-empty string value of the variable"
2163 (let ((g (getenv x))) (and (not (emptyp g)) g))))
2166 ;;;; implementation-identifier
2168 ;; produce a string to identify current implementation.
2169 ;; Initially stolen from SLIME's SWANK, completely rewritten since.
2170 ;; We're back to runtime checking, for the sake of e.g. ABCL.
2172 (with-upgradability ()
2173 (defun first-feature (feature-sets)
2174 "A helper for various feature detection functions"
2175 (dolist (x feature-sets)
2176 (multiple-value-bind (short long feature-expr)
2178 (values (first x) (second x) (cons :or (rest x)))
2180 (when (featurep feature-expr)
2181 (return (values short long))))))
2183 (defun implementation-type ()
2184 "The type of Lisp implementation used, as a short UIOP-standardized keyword"
2186 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
2187 (:cmu :cmucl :cmu) :clasp :ecl :gcl
2188 (:lwpe :lispworks-personal-edition) (:lw :lispworks)
2189 :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
2191 (defvar *implementation-type* (implementation-type)
2192 "The type of Lisp implementation used, as a short UIOP-standardized keyword")
2194 (defun operating-system ()
2195 "The operating system of the current host"
2198 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
2199 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
2200 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
2201 (:solaris :solaris :sunos)
2202 (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
2207 (defun architecture ()
2208 "The CPU architecture of the current host"
2210 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
2211 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
2212 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
2213 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
2214 :mipsel :mipseb :mips :alpha
2215 (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|)
2216 (:arm :arm :arm-target) :vlm :imach
2217 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
2218 ;; we may have to segregate the code still by architecture.
2219 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
2222 (defun ccl-fasl-version ()
2223 ;; the fasl version is target-dependent from CCL 1.8 on.
2224 (or (let ((s 'ccl::target-fasl-version))
2225 (and (fboundp s) (funcall s)))
2226 (and (boundp 'ccl::fasl-version)
2227 (symbol-value 'ccl::fasl-version))
2228 (error "Can't determine fasl version.")))
2230 (defun lisp-version-string ()
2231 "return a string that identifies the current Lisp implementation version"
2232 (let ((s (lisp-implementation-version)))
2233 (car ; as opposed to OR, this idiom prevents some unreachable code warning
2236 (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
2237 excl::*common-lisp-version-number*
2238 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
2239 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
2240 ;; Note if not using International ACL
2241 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2242 (excl:ics-target-case (:-ics "8"))
2243 (and (member :smp *features*) "S"))
2244 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
2246 (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
2248 (format nil "~d.~d-f~d" ; shorten for windows
2249 ccl::*openmcl-major-version*
2250 ccl::*openmcl-minor-version*
2251 (logand (ccl-fasl-version) #xFF))
2252 #+cmucl (substitute #\- #\/ s)
2253 #+scl (format nil "~A~A" s
2254 ;; ANSI upper case vs lower case.
2255 (ecase ext:*case-mode* (:upper "") (:lower "l")))
2256 #+ecl (format nil "~A~@[-~A~]" s
2257 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
2258 (unless (equal vcs-id "UNKNOWN")
2259 (subseq vcs-id 0 (min (length vcs-id) 8)))))
2260 #+gcl (subseq s (1+ (position #\space s)))
2262 (multiple-value-bind (major minor) (sct:get-system-version "System")
2263 (format nil "~D.~D" major minor))
2264 #+mcl (subseq s 8) ; strip the leading "Version "
2265 #+mezzano (format nil "~A-~D"
2266 (subseq s 0 (position #\space s)) ; strip commit hash
2267 sys.int::*llf-version*)
2268 ;; seems like there should be a shorter way to do this, like ACALL.
2270 (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil)))
2271 (when (and fname (fboundp fname))
2276 (defun implementation-identifier ()
2277 "Return a string that identifies the ABI of the current implementation,
2278 suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
2280 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
2281 (format nil "~(~a~@{~@[-~a~]~}~)"
2282 (or (implementation-type) (lisp-implementation-type))
2283 (lisp-version-string)
2284 (or (operating-system) (software-type))
2285 (or (architecture) (machine-type))))))
2288 ;;;; Other system information
2290 (with-upgradability ()
2292 "return the hostname of the current host"
2293 #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance)
2294 #+cormanlisp "localhost" ;; is there a better way? Does it matter?
2295 #+allegro (symbol-call :excl.osi :gethostname)
2296 #+clisp (first (split-string (machine-instance) :separator " "))
2297 #+gcl (system:gethostname)))
2300 ;;; Current directory
2301 (with-upgradability ()
2304 (defun parse-unix-namestring* (unix-namestring)
2305 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
2306 (multiple-value-bind (host device directory name type version)
2307 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
2308 (make-pathname :host (or host lisp::*unix-host*) :device device
2309 :directory directory :name name :type type :version version)))
2312 "Get the current working directory as per POSIX getcwd(3), as a pathname object"
2313 (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
2314 #+allegro (excl::current-directory)
2315 #+clisp (ext:default-directory)
2316 #+clozure (ccl:current-directory)
2317 #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
2318 (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
2319 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
2320 #+(or clasp ecl) (ext:getcwd)
2321 #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
2322 #+lispworks (hcl:get-working-directory)
2323 #+mkcl (mk-ext:getcwd)
2324 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
2325 #+xcl (extensions:current-directory)
2326 (not-implemented-error 'getcwd)))
2329 "Change current directory, as per POSIX chdir(2), to a given pathname object"
2330 (if-let (x (pathname x))
2331 #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
2332 #+allegro (excl:chdir x)
2334 #+clozure (setf (ccl:current-directory) x)
2335 #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
2336 #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
2337 (error "Could not set current directory to ~A" x))
2339 #+clasp (ext:chdir x t)
2340 #+gcl (system:chdir x)
2341 #+lispworks (hcl:change-directory x)
2342 #+mkcl (mk-ext:chdir x)
2343 #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
2344 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
2345 (not-implemented-error 'chdir))))
2348 ;;;; -----------------------------------------------------------------
2349 ;;;; Windows shortcut support. Based on:
2351 ;;;; Jesse Hager: The Windows Shortcut File Format.
2352 ;;;; http://www.wotsit.org/list.asp?fc=13
2354 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
2355 (with-upgradability ()
2356 (defparameter *link-initial-dword* 76)
2357 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
2359 (defun read-null-terminated-string (s)
2360 "Read a null-terminated string from an octet stream S"
2361 ;; note: doesn't play well with UNICODE
2362 (with-output-to-string (out)
2363 (loop :for code = (read-byte s)
2365 :do (write-char (code-char code) out))))
2367 (defun read-little-endian (s &optional (bytes 4))
2368 "Read a number in little-endian format from an byte (octet) stream S,
2369 the number having BYTES octets (defaulting to 4)."
2370 (loop :for i :from 0 :below bytes
2371 :sum (ash (read-byte s) (* 8 i))))
2373 (defun parse-file-location-info (s)
2374 "helper to parse-windows-shortcut"
2375 (let ((start (file-position s))
2376 (total-length (read-little-endian s))
2377 (end-of-header (read-little-endian s))
2378 (fli-flags (read-little-endian s))
2379 (local-volume-offset (read-little-endian s))
2380 (local-offset (read-little-endian s))
2381 (network-volume-offset (read-little-endian s))
2382 (remaining-offset (read-little-endian s)))
2383 (declare (ignore total-length end-of-header local-volume-offset))
2384 (unless (zerop fli-flags)
2386 ((logbitp 0 fli-flags)
2387 (file-position s (+ start local-offset)))
2388 ((logbitp 1 fli-flags)
2389 (file-position s (+ start
2390 network-volume-offset
2392 (strcat (read-null-terminated-string s)
2394 (file-position s (+ start remaining-offset))
2395 (read-null-terminated-string s))))))
2397 (defun parse-windows-shortcut (pathname)
2398 "From a .lnk windows shortcut, extract the pathname linked to"
2399 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
2400 (with-open-file (s pathname :element-type '(unsigned-byte 8))
2402 (when (and (= (read-little-endian s) *link-initial-dword*)
2403 (let ((header (make-array (length *link-guid*))))
2404 (read-sequence header s)
2405 (equalp header *link-guid*)))
2406 (let ((flags (read-little-endian s)))
2407 (file-position s 76) ;skip rest of header
2408 (when (logbitp 0 flags)
2409 ;; skip shell item id list
2410 (let ((length (read-little-endian s 2)))
2411 (file-position s (+ length (file-position s)))))
2414 (parse-file-location-info s))
2416 (when (logbitp 2 flags)
2417 ;; skip description string
2418 (let ((length (read-little-endian s 2)))
2419 (file-position s (+ length (file-position s)))))
2420 (when (logbitp 3 flags)
2421 ;; finally, our pathname
2422 (let* ((length (read-little-endian s 2))
2423 (buffer (make-array length)))
2424 (read-sequence buffer s)
2425 (map 'string #'code-char buffer)))))))
2427 (declare (ignore c))
2431 ;;;; -------------------------------------------------------------------------
2432 ;;;; Portability layer around Common Lisp pathnames
2433 ;; This layer allows for portable manipulation of pathname objects themselves,
2434 ;; which all is necessary prior to any access the filesystem or environment.
2436 (uiop/package:define-package :uiop/pathname
2437 (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic
2438 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
2440 ;; Making and merging pathnames, portably
2441 #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
2442 #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
2443 #:make-pathname-component-logical #:make-pathname-logical
2445 #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
2447 #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname
2448 #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
2450 #:pathname-directory-pathname #:pathname-parent-directory-pathname
2451 #:directory-pathname-p #:ensure-directory-pathname
2452 ;; Parsing filenames
2453 #:split-name-type #:parse-unix-namestring #:unix-namestring
2454 #:split-unix-namestring-directory-components
2455 ;; Absolute and relative pathnames
2456 #:subpathname #:subpathname*
2457 #:ensure-absolute-pathname
2458 #:pathname-root #:pathname-host-pathname
2459 #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname
2460 ;; Checking constraints
2461 #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
2462 ;; Wildcard pathnames
2463 #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory*
2464 #:*wild-inferiors* #:*wild-path* #:wilden
2465 ;; Translate a pathname
2466 #:relativize-directory-component #:relativize-pathname-directory
2467 #:directory-separator-for-host #:directorize-pathname-host-device
2468 #:translate-pathname*
2469 #:*output-translation-function*))
2470 (in-package :uiop/pathname)
2472 ;;; Normalizing pathnames across implementations
2474 (with-upgradability ()
2475 (defun normalize-pathname-directory-component (directory)
2476 "Convert the DIRECTORY component from a format usable by the underlying
2477 implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format
2478 that is a list and not a string."
2480 #-(or cmucl sbcl scl) ;; these implementations already normalize directory components.
2481 ((stringp directory) `(:absolute ,directory))
2482 ((or (null directory)
2483 (and (consp directory) (member (first directory) '(:absolute :relative))))
2487 (cons :relative directory))
2489 (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>")
2490 'normalize-pathname-directory-component directory))))
2492 (defun denormalize-pathname-directory-component (directory-component)
2493 "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable
2494 by the underlying implementation's MAKE-PATHNAME and other primitives"
2495 directory-component)
2497 (defun merge-pathname-directory-components (specified defaults)
2498 "Helper for MERGE-PATHNAMES* that handles directory components"
2499 (let ((directory (normalize-pathname-directory-component specified)))
2500 (ecase (first directory)
2502 (:absolute specified)
2504 (let ((defdir (normalize-pathname-directory-component defaults))
2505 (reldir (cdr directory)))
2509 ((not (eq :back (first reldir)))
2510 (append defdir reldir))
2512 (loop :with defabs = (first defdir)
2513 :with defrev = (reverse (rest defdir))
2514 :while (and (eq :back (car reldir))
2515 (or (and (eq :absolute defabs) (null defrev))
2516 (stringp (car defrev))))
2517 :do (pop reldir) (pop defrev)
2518 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
2520 ;; Giving :unspecific as :type argument to make-pathname is not portable.
2521 ;; See CLHS make-pathname and 19.2.2.2.3.
2522 ;; This will be :unspecific if supported, or NIL if not.
2523 (defparameter *unspecific-pathname-type*
2524 #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific
2525 #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil
2526 "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME")
2528 (defun make-pathname* (&rest keys &key directory host device name type version defaults
2529 #+scl &allow-other-keys)
2530 "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
2531 tries hard to make a pathname that will actually behave as documented,
2532 despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME."
2533 (declare (ignore host device directory name type version defaults))
2534 (apply 'make-pathname keys))
2536 (defun make-pathname-component-logical (x)
2537 "Make a pathname component suitable for use in a logical-pathname"
2539 ((eql :unspecific) nil)
2540 #+clisp (string (string-upcase x))
2541 #+clisp (cons (mapcar 'make-pathname-component-logical x))
2544 (defun make-pathname-logical (pathname host)
2545 "Take a PATHNAME's directory, name, type and version components,
2546 and make a new pathname with corresponding components and specified logical HOST"
2549 :directory (make-pathname-component-logical (pathname-directory pathname))
2550 :name (make-pathname-component-logical (pathname-name pathname))
2551 :type (make-pathname-component-logical (pathname-type pathname))
2552 :version (make-pathname-component-logical (pathname-version pathname))))
2554 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
2555 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
2556 if the SPECIFIED pathname does not have an absolute directory,
2557 then the HOST and DEVICE both come from the DEFAULTS, whereas
2558 if the SPECIFIED pathname does have an absolute directory,
2559 then the HOST and DEVICE both come from the SPECIFIED pathname.
2560 This is what users want on a modern Unix or Windows operating system,
2561 unlike the MERGE-PATHNAMES behavior.
2562 Also, if either argument is NIL, then the other argument is returned unmodified;
2563 this is unlike MERGE-PATHNAMES which always merges with a pathname,
2564 by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
2565 (when (null specified) (return-from merge-pathnames* defaults))
2566 (when (null defaults) (return-from merge-pathnames* specified))
2568 (ext:resolve-pathname specified defaults)
2570 (let* ((specified (pathname specified))
2571 (defaults (pathname defaults))
2572 (directory (normalize-pathname-directory-component (pathname-directory specified)))
2573 (name (or (pathname-name specified) (pathname-name defaults)))
2574 (type (or (pathname-type specified) (pathname-type defaults)))
2575 (version (or (pathname-version specified) (pathname-version defaults))))
2576 (labels ((unspecific-handler (p)
2577 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
2578 (multiple-value-bind (host device directory unspecific-handler)
2579 (ecase (first directory)
2581 (values (pathname-host specified)
2582 (pathname-device specified)
2584 (unspecific-handler specified)))
2586 (values (pathname-host defaults)
2587 (pathname-device defaults)
2588 (merge-pathname-directory-components directory (pathname-directory defaults))
2589 (unspecific-handler defaults))))
2590 (make-pathname :host host :device device :directory directory
2591 :name (funcall unspecific-handler name)
2592 :type (funcall unspecific-handler type)
2593 :version (funcall unspecific-handler version))))))
2595 (defun logical-pathname-p (x)
2596 "is X a logical-pathname?"
2597 (typep x 'logical-pathname))
2599 (defun physical-pathname-p (x)
2600 "is X a pathname that is not a logical-pathname?"
2601 (and (pathnamep x) (not (logical-pathname-p x))))
2603 (defun physicalize-pathname (x)
2604 "if X is a logical pathname, use translate-logical-pathname on it."
2605 ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP
2606 (let ((p (when x (pathname x))))
2607 (if (logical-pathname-p p) (translate-logical-pathname p) p)))
2609 (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
2610 "A pathname that is as neutral as possible for use as defaults
2611 when merging, making or parsing pathnames"
2612 ;; 19.2.2.2.1 says a NIL host can mean a default host;
2613 ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
2614 ;; strings and lists of strings or :unspecific
2615 ;; But CMUCL decides to die on NIL.
2616 ;; MCL has issues with make-pathname, nil and defaulting
2617 (declare (ignorable defaults))
2618 #.`(make-pathname :directory nil :name nil :type nil :version nil
2619 :device (or #+(and mkcl os-unix) :unspecific)
2620 :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost")
2621 #+scl ,@'(:scheme nil :scheme-specific-part nil
2622 :username nil :password nil :parameters nil :query nil :fragment nil)
2623 ;; the default shouldn't matter, but we really want something physical
2624 #-mcl ,@'(:defaults defaults)))
2626 (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname)))
2627 "A pathname that is as neutral as possible for use as defaults
2628 when merging, making or parsing pathnames")
2630 (defmacro with-pathname-defaults ((&optional defaults) &body body)
2631 "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified,
2632 where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except
2633 on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory."
2634 `(let ((*default-pathname-defaults*
2636 #-(or abcl genera xcl) '*nil-pathname*
2637 #+(or abcl genera xcl) '*default-pathname-defaults*)))
2641 ;;; Some pathname predicates
2642 (with-upgradability ()
2643 (defun pathname-equal (p1 p2)
2644 "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?"
2645 (when (stringp p1) (setf p1 (pathname p1)))
2646 (when (stringp p2) (setf p2 (pathname p2)))
2647 (flet ((normalize-component (x)
2648 (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
2650 (macrolet ((=? (&rest accessors)
2652 (reduce 'list (cons 'normalize-component accessors)
2653 :initial-value x :from-end t)))
2654 `(equal ,(frob 'p1) ,(frob 'p2)))))
2655 (or (and (null p1) (null p2))
2656 (and (pathnamep p1) (pathnamep p2)
2657 (and (=? pathname-host)
2658 #-(and mkcl os-unix) (=? pathname-device)
2659 (=? normalize-pathname-directory-component pathname-directory)
2662 #-mkcl (=? pathname-version)))))))
2664 (defun absolute-pathname-p (pathspec)
2665 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2666 possessing an :ABSOLUTE directory component, return the (parsed) pathname.
2667 Otherwise return NIL"
2669 (typep pathspec '(or null pathname string))
2670 (let ((pathname (pathname pathspec)))
2671 (and (eq :absolute (car (normalize-pathname-directory-component
2672 (pathname-directory pathname))))
2675 (defun relative-pathname-p (pathspec)
2676 "If PATHSPEC is a pathname or namestring object that parses as a pathname
2677 possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
2678 Otherwise return NIL"
2680 (typep pathspec '(or null pathname string))
2681 (let* ((pathname (pathname pathspec))
2682 (directory (normalize-pathname-directory-component
2683 (pathname-directory pathname))))
2684 (when (or (null directory) (eq :relative (car directory)))
2687 (defun hidden-pathname-p (pathname)
2688 "Return a boolean that is true if the pathname is hidden as per Unix style,
2689 i.e. its name starts with a dot."
2690 (and pathname (equal (first-char (pathname-name pathname)) #\.)))
2692 (defun file-pathname-p (pathname)
2693 "Does PATHNAME represent a file, i.e. has a non-null NAME component?
2695 Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
2697 Note that this does _not_ check to see that PATHNAME points to an
2698 actually-existing file.
2700 Returns the (parsed) PATHNAME when true"
2702 (let ((pathname (pathname pathname)))
2703 (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal)
2704 (member (pathname-type pathname) '(nil :unspecific "") :test 'equal))
2708 ;;; Directory pathnames
2709 (with-upgradability ()
2710 (defun pathname-directory-pathname (pathname)
2711 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
2712 and NIL NAME, TYPE and VERSION components"
2714 (make-pathname :name nil :type nil :version nil :defaults pathname)))
2716 (defun pathname-parent-directory-pathname (pathname)
2717 "Returns a new pathname that corresponds to the parent of the current pathname's directory,
2718 i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
2719 Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
2721 (make-pathname :name nil :type nil :version nil
2722 :directory (merge-pathname-directory-components
2723 '(:relative :back) (pathname-directory pathname))
2724 :defaults pathname)))
2726 (defun directory-pathname-p (pathname)
2727 "Does PATHNAME represent a directory?
2729 A directory-pathname is a pathname _without_ a filename. The three
2730 ways that the filename components can be missing are for it to be NIL,
2731 :UNSPECIFIC or the empty string.
2733 Note that this does _not_ check to see that PATHNAME points to an
2734 actually-existing directory."
2736 ;; I tried using Allegro's excl:file-directory-p, but this cannot be done,
2737 ;; because it rejects apparently legal pathnames as
2738 ;; ill-formed. [2014/02/10:rpg]
2739 (let ((pathname (pathname pathname)))
2740 (flet ((check-one (x)
2741 (member x '(nil :unspecific) :test 'equal)))
2742 (and (not (wild-pathname-p pathname))
2743 (check-one (pathname-name pathname))
2744 (check-one (pathname-type pathname))
2747 (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
2748 "Converts the non-wild pathname designator PATHSPEC to directory form."
2751 (ensure-directory-pathname (pathname pathspec)))
2752 ((not (pathnamep pathspec))
2753 (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
2754 ((wild-pathname-p pathspec)
2755 (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
2756 ((directory-pathname-p pathspec)
2760 (make-pathname :directory (append (or (normalize-pathname-directory-component
2761 (pathname-directory pathspec))
2763 (list #-genera (file-namestring pathspec)
2764 ;; On Genera's native filesystem (LMFS),
2765 ;; directories have a type and version
2766 ;; which must be ignored when converting
2767 ;; to a directory pathname
2768 #+genera (if (typep pathspec 'fs:lmfs-pathname)
2769 (pathname-name pathspec)
2770 (file-namestring pathspec))))
2771 :name nil :type nil :version nil :defaults pathspec)
2772 (error (c) (call-function on-error (compatfmt "~@<error while trying to create a directory pathname for ~S: ~A~@:>") pathspec c)))))))
2775 ;;; Parsing filenames
2776 (with-upgradability ()
2777 (declaim (ftype function ensure-pathname)) ; forward reference
2779 (defun split-unix-namestring-directory-components
2780 (unix-namestring &key ensure-directory dot-dot)
2781 "Splits the path string UNIX-NAMESTRING, returning four values:
2782 A flag that is either :absolute or :relative, indicating
2783 how the rest of the values are to be interpreted.
2784 A directory path --- a list of strings and keywords, suitable for
2785 use with MAKE-PATHNAME when prepended with the flag value.
2786 Directory components with an empty name or the name . are removed.
2787 Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
2788 A last-component, either a file-namestring including type extension,
2789 or NIL in the case of a directory pathname.
2790 A flag that is true iff the unix-style-pathname was just
2791 a file-namestring without / path specification.
2792 ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
2793 the third return value will be NIL, and final component of the namestring
2794 will be treated as part of the directory path.
2796 An empty string is thus read as meaning a pathname object with all fields nil.
2798 Note that colon characters #\: will NOT be interpreted as host specification.
2799 Absolute pathnames are only appropriate on Unix-style systems.
2801 The intention of this function is to support structured component names,
2802 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
2803 (check-type unix-namestring string)
2804 (check-type dot-dot (member nil :back :up))
2805 (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
2806 (plusp (length unix-namestring)))
2807 (values :relative () unix-namestring t)
2808 (let* ((components (split-string unix-namestring :separator "/"))
2809 (last-comp (car (last components))))
2810 (multiple-value-bind (relative components)
2811 (if (equal (first components) "")
2812 (if (equal (first-char unix-namestring) #\/)
2813 (values :absolute (cdr components))
2814 (values :relative nil))
2815 (values :relative components))
2816 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
2818 (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
2820 ((equal last-comp "")
2821 (values relative components nil nil)) ; "" already removed from components
2823 (values relative components nil nil))
2825 (values relative (butlast components) last-comp nil)))))))
2827 (defun split-name-type (filename)
2828 "Split a filename into two values NAME and TYPE that are returned.
2829 We assume filename has no directory component.
2830 The last . if any separates name and type from from type,
2831 except that if there is only one . and it is in first position,
2832 the whole filename is the NAME with an empty type.
2833 NAME is always a string.
2834 For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
2835 (check-type filename string)
2836 (assert (plusp (length filename)))
2837 (destructuring-bind (name &optional (type *unspecific-pathname-type*))
2838 (split-string filename :max 2 :separator ".")
2840 (values filename *unspecific-pathname-type*)
2841 (values name type))))
2843 (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
2845 "Coerce NAME into a PATHNAME using standard Unix syntax.
2847 Unix syntax is used whether or not the underlying system is Unix;
2848 on such non-Unix systems it is reliably usable only for relative pathnames.
2849 This function is especially useful to manipulate relative pathnames portably,
2850 where it is crucial to possess a portable pathname syntax independent of the underlying OS.
2851 This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
2853 When given a PATHNAME object, just return it untouched.
2854 When given NIL, just return NIL.
2855 When given a non-null SYMBOL, first downcase its name and treat it as a string.
2856 When given a STRING, portably decompose it into a pathname as below.
2858 #\\/ separates directory components.
2860 The last #\\/-separated substring is interpreted as follows:
2861 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
2862 the string is made the last directory component, and NAME and TYPE are NIL.
2863 if the string is empty, it's the empty pathname with all slots NIL.
2864 2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE
2865 are separated by SPLIT-NAME-TYPE.
2866 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
2868 Directory components with an empty name or the name \".\" are removed.
2869 Any directory named \"..\" is read as DOT-DOT,
2870 which must be one of :BACK or :UP and defaults to :BACK.
2872 HOST, DEVICE and VERSION components are taken from DEFAULTS,
2873 which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL.
2874 No host or device can be specified in the string itself,
2875 which makes it unsuitable for absolute pathnames outside Unix.
2877 For relative pathnames, these components (and hence the defaults) won't matter
2878 if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
2879 which is an important reason to always use MERGE-PATHNAMES*.
2881 Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
2882 with those keys, removing TYPE DEFAULTS and DOT-DOT.
2883 When you're manipulating pathnames that are supposed to make sense portably
2884 even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
2885 to throw an error if the pathname is absolute"
2887 (check-type type (or null string (eql :directory)))
2888 (when ensure-directory
2889 (setf type :directory))
2891 ((or null pathname) (return name))
2893 (setf name (string-downcase name)))
2895 (multiple-value-bind (relative path filename file-only)
2896 (split-unix-namestring-directory-components
2897 name :dot-dot dot-dot :ensure-directory (eq type :directory))
2898 (multiple-value-bind (name type)
2900 ((or (eq type :directory) (null filename))
2903 (values filename type))
2905 (split-name-type filename)))
2907 (unless file-only (cons relative path)))
2911 :directory directory
2912 :name name :type type
2913 :defaults (or #-mcl defaults *nil-pathname*))
2916 (ext:pathname-jar-p defaults)
2918 ;; When DEFAULTS is a jar, it will have the directory we want
2919 (make-pathname :name name :type type
2920 :defaults (or defaults *nil-pathname*))
2921 (make-pathname :name name :type type
2922 :defaults (or defaults *nil-pathname*)
2923 :directory directory))))
2924 (apply 'ensure-pathname
2926 (remove-plist-keys '(:type :dot-dot :defaults) keys)))))))
2928 (defun unix-namestring (pathname)
2929 "Given a non-wild PATHNAME, return a Unix-style namestring for it.
2930 If the PATHNAME is NIL or a STRING, return it unchanged.
2932 This only considers the DIRECTORY, NAME and TYPE components of the pathname.
2933 This is a portable solution for representing relative pathnames,
2934 But unless you are running on a Unix system, it is not a general solution
2935 to representing native pathnames.
2937 An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
2938 or if it is a PATHNAME but some of its components are not recognized."
2940 ((or null string) pathname)
2942 (with-output-to-string (s)
2943 (flet ((err () (parameter-error "~S: invalid unix-namestring ~S"
2944 'unix-namestring pathname)))
2945 (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
2946 (name (pathname-name pathname))
2947 (name (and (not (eq name :unspecific)) name))
2948 (type (pathname-type pathname))
2949 (type (and (not (eq type :unspecific)) type)))
2951 ((member dir '(nil :unspecific)))
2952 ((eq dir '(:relative)) (princ "./" s))
2954 (destructuring-bind (relabs &rest dirs) dir
2955 (or (member relabs '(:relative :absolute)) (err))
2956 (when (eq relabs :absolute) (princ #\/ s))
2957 (loop :for x :in dirs :do
2959 ((member x '(:back :up)) (princ "../" s))
2960 ((equal x "") (err))
2961 ;;((member x '("." "..") :test 'equal) (err))
2962 ((stringp x) (format s "~A/" x))
2967 (unless (and (stringp name) (or (null type) (stringp type))) (err))
2968 (format s "~A~@[.~A~]" name type))
2970 (or (null type) (err)))))))))))
2972 ;;; Absolute and relative pathnames
2973 (with-upgradability ()
2974 (defun subpathname (pathname subpath &key type)
2975 "This function takes a PATHNAME and a SUBPATH and a TYPE.
2976 If SUBPATH is already a PATHNAME object (not namestring),
2977 and is an absolute pathname at that, it is returned unchanged;
2978 otherwise, SUBPATH is turned into a relative pathname with given TYPE
2979 as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
2980 then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
2981 (or (and (pathnamep subpath) (absolute-pathname-p subpath))
2982 (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
2983 (pathname-directory-pathname pathname))))
2985 (defun subpathname* (pathname subpath &key type)
2986 "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
2988 (subpathname (ensure-directory-pathname pathname) subpath :type type)))
2990 (defun pathname-root (pathname)
2991 "return the root directory for the host and device of given PATHNAME"
2992 (make-pathname :directory '(:absolute)
2993 :name nil :type nil :version nil
2994 :defaults pathname ;; host device, and on scl, *some*
2995 ;; scheme-specific parts: port username password, not others:
2996 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
2998 (defun pathname-host-pathname (pathname)
2999 "return a pathname with the same host as given PATHNAME, and all other fields NIL"
3000 (make-pathname :directory nil
3001 :name nil :type nil :version nil :device nil
3002 :defaults pathname ;; host device, and on scl, *some*
3003 ;; scheme-specific parts: port username password, not others:
3004 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
3006 (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
3007 "Given a pathname designator PATH, return an absolute pathname as specified by PATH
3008 considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior,
3009 with a format control-string and other arguments as arguments"
3011 ((absolute-pathname-p path))
3012 ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
3013 ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
3014 ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
3015 (or (if (absolute-pathname-p default-pathname)
3016 (absolute-pathname-p (merge-pathnames* path default-pathname))
3017 (call-function on-error "Default pathname ~S is not an absolute pathname"
3019 (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
3020 path default-pathname))))
3021 (t (call-function on-error
3022 "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
3025 (defun subpathp (maybe-subpath base-pathname)
3026 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
3027 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
3028 (and (pathnamep maybe-subpath) (pathnamep base-pathname)
3029 (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
3030 (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
3031 (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
3032 (with-pathname-defaults (*nil-pathname*)
3033 (let ((enough (enough-namestring maybe-subpath base-pathname)))
3034 (and (relative-pathname-p enough) (pathname enough))))))
3036 (defun enough-pathname (maybe-subpath base-pathname)
3037 "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that
3038 when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH."
3039 (let ((sub (when maybe-subpath (pathname maybe-subpath)))
3040 (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname)))))
3041 (or (and base (subpathp sub base)) sub)))
3043 (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk)
3044 "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null,
3045 or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH
3046 given DEFAULTS-PATHNAME as a base pathname."
3047 (let ((enough (enough-pathname maybe-subpath defaults-pathname))
3048 (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*)))
3049 (funcall thunk enough)))
3051 (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var)
3052 (defaults *default-pathname-defaults*))
3054 "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME"
3055 `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))))
3058 ;;; Wildcard pathnames
3059 (with-upgradability ()
3060 (defparameter *wild* (or #+cormanlisp "*" :wild)
3061 "Wild component for use with MAKE-PATHNAME")
3062 (defparameter *wild-directory-component* (or :wild)
3063 "Wild directory component for use with MAKE-PATHNAME")
3064 (defparameter *wild-inferiors-component* (or :wild-inferiors)
3065 "Wild-inferiors directory component for use with MAKE-PATHNAME")
3066 (defparameter *wild-file*
3067 (make-pathname :directory nil :name *wild* :type *wild*
3068 :version (or #-(or allegro abcl xcl) *wild*))
3069 "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME")
3070 (defparameter *wild-file-for-directory*
3071 (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*)
3072 :version (or #-(or allegro abcl clisp gcl xcl) *wild*))
3073 "A pathname object with wildcards for matching any file with DIRECTORY")
3074 (defparameter *wild-directory*
3075 (make-pathname :directory `(:relative ,*wild-directory-component*)
3076 :name nil :type nil :version nil)
3077 "A pathname object with wildcards for matching any subdirectory")
3078 (defparameter *wild-inferiors*
3079 (make-pathname :directory `(:relative ,*wild-inferiors-component*)
3080 :name nil :type nil :version nil)
3081 "A pathname object with wildcards for matching any recursive subdirectory")
3082 (defparameter *wild-path*
3083 (merge-pathnames* *wild-file* *wild-inferiors*)
3084 "A pathname object with wildcards for matching any file in any recursive subdirectory")
3086 (defun wilden (path)
3087 "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory"
3088 (merge-pathnames* *wild-path* path)))
3091 ;;; Translate a pathname
3092 (with-upgradability ()
3093 (defun relativize-directory-component (directory-component)
3094 "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component"
3095 (let ((directory (normalize-pathname-directory-component directory-component)))
3097 ((stringp directory)
3098 (list :relative directory))
3099 ((eq (car directory) :absolute)
3100 (cons :relative (cdr directory)))
3104 (defun relativize-pathname-directory (pathspec)
3105 "Given a PATHNAME, return a relative pathname with otherwise the same components"
3106 (let ((p (pathname pathspec)))
3108 :directory (relativize-directory-component (pathname-directory p))
3111 (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
3112 "Given a PATHNAME, return the character used to delimit directory names on this host and device."
3113 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
3114 (last-char (namestring foo))))
3117 (defun directorize-pathname-host-device (pathname)
3118 "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
3119 added to its DIRECTORY component. This is useful for output translations."
3122 (when (physical-pathname-p pathname)
3123 (return-from directorize-pathname-host-device pathname))))
3124 (let* ((root (pathname-root pathname))
3125 (wild-root (wilden root))
3126 (absolute-pathname (merge-pathnames* pathname root))
3127 (separator (directory-separator-for-host root))
3128 (root-namestring (namestring root))
3131 #'(lambda (x) (or (eql x #\:)
3134 (multiple-value-bind (relative path filename)
3135 (split-unix-namestring-directory-components root-string :ensure-directory t)
3136 (declare (ignore relative filename))
3137 (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path))))
3138 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
3141 (defun directorize-pathname-host-device (pathname)
3142 (let ((scheme (ext:pathname-scheme pathname))
3143 (host (pathname-host pathname))
3144 (port (ext:pathname-port pathname))
3145 (directory (pathname-directory pathname)))
3146 (flet ((specificp (x) (and x (not (eq x :unspecific)))))
3147 (if (or (specificp port)
3148 (and (specificp host) (plusp (length host)))
3151 (when (specificp port)
3152 (setf prefix (format nil ":~D" port)))
3153 (when (and (specificp host) (plusp (length host)))
3154 (setf prefix (strcat host prefix)))
3155 (setf prefix (strcat ":" prefix))
3156 (when (specificp scheme)
3157 (setf prefix (strcat scheme prefix)))
3158 (assert (and directory (eq (first directory) :absolute)))
3159 (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
3160 :defaults pathname)))
3163 (defun translate-pathname* (path absolute-source destination &optional root source)
3164 "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility.
3165 PATH is the pathname to be translated.
3166 ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname,
3167 DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE,
3168 or a relative pathname, to be merged with ROOT and used as destination for translate-pathname
3169 or an absolute pathname, to be used as destination for translate-pathname.
3170 In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE."
3171 (declare (ignore source))
3173 ((functionp destination)
3174 (funcall destination path absolute-source))
3177 ((not (pathnamep destination))
3178 (parameter-error "~S: Invalid destination" 'translate-pathname*))
3179 ((not (absolute-pathname-p destination))
3180 (translate-pathname path absolute-source (merge-pathnames* destination root)))
3182 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3184 (translate-pathname path absolute-source destination))))
3186 (defvar *output-translation-function* 'identity
3187 "Hook for output translations.
3189 This function needs to be idempotent, so that actions can work
3190 whether their inputs were translated or not,
3191 which they will be if we are composing operations. e.g. if some
3192 create-lisp-op creates a lisp file from some higher-level input,
3193 you need to still be able to use compile-op on that lisp file."))
3194 ;;;; -------------------------------------------------------------------------
3195 ;;;; Portability layer around Common Lisp filesystem access
3197 (uiop/package:define-package :uiop/filesystem
3198 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
3200 ;; Native namestrings
3201 #:native-namestring #:parse-native-namestring
3202 ;; Probing the filesystem
3203 #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
3204 #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
3205 #:collect-sub*directories
3206 ;; Resolving symlinks somewhat
3207 #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
3209 #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
3210 ;; Environment pathnames
3211 #:inter-directory-separator #:split-native-pathnames-string
3212 #:getenv-pathname #:getenv-pathnames
3213 #:getenv-absolute-directory #:getenv-absolute-directories
3214 #:lisp-implementation-directory #:lisp-implementation-pathname-p
3215 ;; Simple filesystem operations
3216 #:ensure-all-directories-exist
3217 #:rename-file-overwriting-target
3218 #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
3219 (in-package :uiop/filesystem)
3221 ;;; Native namestrings, as seen by the operating system calls rather than Lisp
3222 (with-upgradability ()
3223 (defun native-namestring (x)
3224 "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
3226 (let ((p (pathname x)))
3227 #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
3228 #+(or cmucl scl) (ext:unix-namestring p nil)
3229 #+sbcl (sb-ext:native-namestring p)
3230 #-(or clozure cmucl sbcl scl)
3232 ((os-unix-p) (unix-namestring p))
3233 (t (namestring p))))))
3235 (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
3236 "From a native namestring suitable for use by the operating system, return
3237 a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
3238 (check-type string (or string null))
3241 (with-pathname-defaults ()
3242 #+clozure (ccl:native-to-pathname string)
3243 #+cmucl (uiop/os::parse-unix-namestring* string)
3244 #+sbcl (sb-ext:parse-native-namestring string)
3245 #+scl (lisp::parse-unix-namestring string)
3246 #-(or clozure cmucl sbcl scl)
3248 ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
3249 (t (parse-namestring string))))))
3251 (if ensure-directory
3252 (and pathname (ensure-directory-pathname pathname))
3254 (apply 'ensure-pathname pathname constraints))))
3257 ;;; Probing the filesystem
3258 (with-upgradability ()
3259 (defun truename* (p)
3260 "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
3262 (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p))))
3264 (or (ignore-errors (truename p))
3265 ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying
3266 ;; a trailing directory separator, causes an error on some lisps.
3267 #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d)))
3268 ;; On Genera, truename of a directory pathname will probably fail as Genera
3269 ;; will merge in a filename/type/version from *default-pathname-defaults* and
3270 ;; will try to get the truename of a file that probably doesn't exist.
3271 #+genera (when (directory-pathname-p p)
3272 (let ((d (scl:send p :directory-pathname-as-file)))
3273 (ensure-directory-pathname (ignore-errors (truename d)) nil)))))))
3275 (defun safe-file-write-date (pathname)
3276 "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
3277 ;; If FILE-WRITE-DATE returns NIL, it's possible that
3278 ;; the user or some other agent has deleted an input file.
3279 ;; Also, generated files will not exist at the time planning is done
3280 ;; and calls compute-action-stamp which calls safe-file-write-date.
3281 ;; So it is very possible that we can't get a valid file-write-date,
3282 ;; and we can survive and we will continue the planning
3283 ;; as if the file were very old.
3284 ;; (or should we treat the case in a different, special way?)
3286 (handler-case (file-write-date (physicalize-pathname pathname))
3287 (file-error () nil))))
3289 (defun probe-file* (p &key truename)
3290 "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
3291 probes the filesystem for a file or directory with given pathname.
3292 If it exists, return its truename if TRUENAME is true,
3293 or the original (parsed) pathname if it is false (the default)."
3296 (setf p (funcall 'ensure-pathname p
3299 :ensure-absolute t :defaults 'get-pathname-defaults
3304 (probe-file p :follow-symlinks truename)
3308 (let ((kind (car (si::stat p))))
3309 (when (eq kind :link)
3310 (setf kind (ignore-errors (car (si::stat (truename* p))))))
3315 ((file-pathname-p p) p)
3316 ((directory-pathname-p p)
3317 (subpathname p (car (last (pathname-directory p)))))))
3318 (:directory (ensure-directory-pathname p)))))
3320 #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil)))
3321 (pp (find-symbol* '#:probe-pathname :ext nil)))
3326 (truename* (ignore-errors (ensure-directory-pathname p)))))
3328 (fs `(and (,fs p) p))
3329 (pp `(nth-value 1 (,pp p)))
3330 (t '(or (and (truename* p) p)
3331 (if-let (d (ensure-directory-pathname p))
3332 (and (truename* d) d)))))))
3333 #-(or allegro clisp gcl)
3337 #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p))
3338 #+(and lispworks os-unix) (system:get-file-stat p)
3339 #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p))
3340 #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p)
3343 (defun directory-exists-p (x)
3344 "Is X the name of a directory that exists on the filesystem?"
3346 (excl:probe-directory x)
3348 (handler-case (ext:probe-directory x)
3349 (sys::simple-file-error ()
3351 #-(or allegro clisp)
3352 (let ((p (probe-file* x :truename t)))
3353 (and (directory-pathname-p p) p)))
3355 (defun file-exists-p (x)
3356 "Is X the name of a file that exists on the filesystem?"
3357 (let ((p (probe-file* x :truename t)))
3358 (and (file-pathname-p p) p)))
3360 (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
3361 "Return a list of the entries in a directory by calling DIRECTORY.
3362 Try to override the defaults to not resolving symlinks, if implementation allows."
3363 (apply 'directory pathname-spec
3364 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3365 #+(or clozure digitool) '(:follow-links nil)
3366 #+clisp '(:circle t :if-does-not-exist :ignore)
3367 #+(or cmucl scl) '(:follow-links nil :truenamep nil)
3368 #+lispworks '(:link-transparency nil)
3369 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
3370 '(:resolve-symlinks nil))))))
3372 (defun filter-logical-directory-results (directory entries merger)
3373 "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is,
3374 given ENTRIES in the DIRECTORY, remove the entries which are physical yet
3375 when transformed by MERGER have a different TRUENAME.
3376 Also remove duplicates as may appear with some translation rules.
3377 This function is used as a helper to DIRECTORY-FILES to avoid invalid entries
3378 when using logical-pathnames."
3379 (if (logical-pathname-p directory)
3380 (remove-duplicates ;; on CLISP, querying ~/ will return duplicates
3381 ;; Try hard to not resolve logical-pathname into physical pathnames;
3382 ;; otherwise logical-pathname users/lovers will be disappointed.
3383 ;; If directory* could use some implementation-dependent magic,
3384 ;; we will have logical pathnames already; otherwise,
3385 ;; we only keep pathnames for which specifying the name and
3386 ;; translating the LPN commute.
3387 (loop :for f :in entries
3388 :for p = (or (and (logical-pathname-p f) f)
3389 (let* ((u (ignore-errors (call-function merger f))))
3390 ;; The first u avoids a cumbersome (truename u) error.
3391 ;; At this point f should already be a truename,
3392 ;; but isn't quite in CLISP, for it doesn't have :version :newest
3393 (and u (equal (truename* u) (truename* f)) u)))
3395 :test 'pathname-equal)
3398 (defun directory-files (directory &optional (pattern *wild-file-for-directory*))
3399 "Return a list of the files in a directory according to the PATTERN.
3400 Subdirectories should NOT be returned.
3401 PATTERN defaults to a pattern carefully chosen based on the implementation;
3402 override the default at your own risk.
3403 DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this,
3404 but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3405 (let ((dir (ensure-directory-pathname directory)))
3406 (when (logical-pathname-p dir)
3407 ;; Because of the filtering we do below,
3408 ;; logical pathnames have restrictions on wild patterns.
3409 ;; Not that the results are very portable when you use these patterns on physical pathnames.
3410 (when (wild-pathname-p dir)
3411 (parameter-error "~S: Invalid wild pattern in logical directory ~S"
3412 'directory-files directory))
3413 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
3414 (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory))
3415 (setf pattern (make-pathname-logical pattern (pathname-host dir))))
3416 (let* ((pat (merge-pathnames* pattern dir))
3417 (entries (ignore-errors (directory* pat))))
3418 (remove-if 'directory-pathname-p
3419 (filter-logical-directory-results
3422 (make-pathname :defaults dir
3423 :name (make-pathname-component-logical (pathname-name f))
3424 :type (make-pathname-component-logical (pathname-type f))
3425 :version (make-pathname-component-logical (pathname-version f)))))))))
3427 (defun subdirectories (directory)
3428 "Given a DIRECTORY pathname designator, return a list of the subdirectories under it.
3429 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3430 (let* ((directory (ensure-directory-pathname directory))
3431 #-(or abcl cormanlisp genera xcl)
3432 (wild (merge-pathnames*
3433 #-(or abcl allegro cmucl lispworks sbcl scl xcl)
3435 #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
3438 #-(or abcl cormanlisp genera xcl)
3440 (directory* wild . #.(or #+clozure '(:directories t :files nil)
3441 #+mcl '(:directories t))))
3442 #+(or abcl xcl) (system:list-directory directory)
3443 #+cormanlisp (cl::directory-subdirs directory)
3444 #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil)))
3445 #+(or abcl allegro cmucl genera lispworks sbcl scl xcl)
3446 (dirs (loop :for x :in dirs
3447 :for d = #+(or abcl xcl) (extensions:probe-directory x)
3448 #+allegro (excl:probe-directory x)
3449 #+(or cmucl sbcl scl) (directory-pathname-p x)
3450 #+genera (getf (cdr x) :directory)
3451 #+lispworks (lw:file-directory-p x)
3452 :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d)
3453 #+genera (ensure-directory-pathname (first x))
3454 #+(or cmucl lispworks sbcl scl) x)))
3455 (filter-logical-directory-results
3457 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
3458 '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
3460 (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
3461 (and (consp dir) (consp (cdr dir))
3463 :defaults directory :name nil :type nil :version nil
3464 :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
3466 (defun collect-sub*directories (directory collectp recursep collector)
3467 "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory,
3468 call-function the COLLECTOR function designator on the directory,
3469 and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them.
3470 This function will thus let you traverse a filesystem hierarchy,
3471 superseding the functionality of CL-FAD:WALK-DIRECTORY.
3472 The behavior in presence of symlinks is not portable. Use IOlib to handle such situations."
3473 (when (call-function collectp directory)
3474 (call-function collector directory)
3475 (dolist (subdir (subdirectories directory))
3476 (when (call-function recursep subdir)
3477 (collect-sub*directories subdir collectp recursep collector))))))
3479 ;;; Resolving symlinks somewhat
3480 (with-upgradability ()
3481 (defun truenamize (pathname)
3482 "Resolve as much of a pathname as possible"
3484 (when (typep pathname '(or null logical-pathname)) (return pathname))
3486 (unless (absolute-pathname-p p)
3487 (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
3489 (when (logical-pathname-p p) (return p))
3490 (let ((found (probe-file* p :truename t)))
3491 (when found (return found)))
3492 (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
3493 (up-components (reverse (rest directory)))
3494 (down-components ()))
3495 (assert (eq :absolute (first directory)))
3496 (loop :while up-components :do
3499 (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components))
3500 :name nil :type nil :version nil :defaults p))))
3504 (make-pathname :directory `(:relative ,@down-components)
3506 (ensure-directory-pathname parent))))
3507 (return simplified)))
3508 (push (pop up-components) down-components)
3509 :finally (return p))))))
3511 (defun resolve-symlinks (path)
3512 "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
3513 #-allegro (truenamize path)
3515 (if (physical-pathname-p path)
3516 (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
3519 (defvar *resolve-symlinks* t
3520 "Determine whether or not ASDF resolves symlinks when defining systems.
3523 (defun resolve-symlinks* (path)
3524 "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
3525 (if *resolve-symlinks*
3526 (and path (resolve-symlinks path))
3530 ;;; Check pathname constraints
3531 (with-upgradability ()
3532 (defun ensure-pathname
3535 defaults type dot-dot namestring
3538 want-logical want-physical ensure-physical
3539 want-relative want-absolute ensure-absolute ensure-subpath
3540 want-non-wild want-wild wilden
3541 want-file want-directory ensure-directory
3542 want-existing ensure-directories-exist
3543 truename resolve-symlinks truenamize
3544 &aux (p pathname)) ;; mutable working copy, preserve original
3545 "Coerces its argument into a PATHNAME,
3546 optionally doing some transformations and checking specified constraints.
3548 If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
3550 If the argument is a STRING, it is first converted to a pathname via
3551 PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
3552 depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
3553 or else by using CALL-FUNCTION on the NAMESTRING argument;
3554 if :UNIX is specified (or NIL, the default, which specifies the same thing),
3555 then PARSE-UNIX-NAMESTRING it is called with the keywords
3556 DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
3557 the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
3559 The pathname passed or resulting from parsing the string
3560 is then subjected to all the checks and transformations below are run.
3562 Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
3563 The boolean T is an alias for ERROR.
3564 ERROR means that an error will be raised if the constraint is not satisfied.
3565 CERROR means that an continuable error will be raised if the constraint is not satisfied.
3566 IGNORE means just return NIL instead of the pathname.
3568 The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
3569 that will be called with the the following arguments:
3570 a generic format string for ensure pathname, the pathname,
3571 the keyword argument corresponding to the failed check or transformation,
3572 a format string for the reason ENSURE-PATHNAME failed,
3573 and a list with arguments to that format string.
3574 If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
3575 You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
3577 The transformations and constraint checks are done in this order,
3578 which is also the order in the lambda-list:
3580 EMPTY-IS-NIL returns NIL if the argument is an empty string.
3581 WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
3582 Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
3583 WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
3584 WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
3585 ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
3586 WANT-RELATIVE checks that pathname has a relative directory component
3587 WANT-ABSOLUTE checks that pathname does have an absolute directory component
3588 ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
3589 that the result absolute is an absolute pathname indeed.
3590 ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
3591 WANT-FILE checks that pathname has a non-nil FILE component
3592 WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
3593 ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
3594 any file and type components as being actually a last directory component.
3595 WANT-NON-WILD checks that pathname is not a wild pathname
3596 WANT-WILD checks that pathname is a wild pathname
3597 WILDEN merges the pathname with **/*.*.* if it is not wild
3598 WANT-EXISTING checks that a file (or directory) exists with that pathname.
3599 ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
3600 TRUENAME replaces the pathname by its truename, or errors if not possible.
3601 RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
3602 TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
3604 (flet ((report-error (keyword description &rest arguments)
3605 (call-function (or on-error 'error)
3606 "Invalid pathname ~S: ~*~?"
3607 pathname keyword description arguments)))
3608 (macrolet ((err (constraint &rest arguments)
3609 `(report-error ',(intern* constraint :keyword) ,@arguments))
3610 (check (constraint condition &rest arguments)
3612 (unless ,condition (err ,constraint ,@arguments))))
3613 (transform (transform condition expr)
3615 (,@(if condition `(when ,condition) '(progn))
3618 ((or null pathname))
3620 (when (and (emptyp p) empty-is-nil)
3621 (return-from ensure-pathname nil))
3622 (setf p (case namestring
3624 (parse-unix-namestring
3625 p :defaults defaults :type type :dot-dot dot-dot
3626 :ensure-directory ensure-directory :want-relative want-relative))
3628 (parse-native-namestring p))
3630 (parse-namestring p))
3632 (call-function namestring p))))))
3636 (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
3638 (check want-logical (logical-pathname-p p) "Expected a logical pathname")
3639 (check want-physical (physical-pathname-p p) "Expected a physical pathname")
3640 (transform ensure-physical () (physicalize-pathname p))
3641 (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
3642 (check want-relative (relative-pathname-p p) "Expected a relative pathname")
3643 (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
3644 (transform ensure-absolute (not (absolute-pathname-p p))
3645 (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
3646 (check ensure-absolute (absolute-pathname-p p)
3647 "Could not make into an absolute pathname even after merging with ~S" defaults)
3648 (check ensure-subpath (absolute-pathname-p defaults)
3649 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
3650 (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
3651 (check want-file (file-pathname-p p) "Expected a file pathname")
3652 (check want-directory (directory-pathname-p p) "Expected a directory pathname")
3653 (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
3654 (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
3655 (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
3656 (transform wilden (not (wild-pathname-p p)) (wilden p))
3658 (let ((existing (probe-file* p :truename truename)))
3662 (err want-existing "Expected an existing pathname"))))
3663 (when ensure-directories-exist (ensure-directories-exist p))
3665 (let ((truename (truename* p)))
3668 (err truename "Can't get a truename for pathname"))))
3669 (transform resolve-symlinks () (resolve-symlinks p))
3670 (transform truenamize () (truenamize p))
3674 ;;; Pathname defaults
3675 (with-upgradability ()
3676 (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
3677 "Find the actual DEFAULTS to use for pathnames, including
3678 resolving them with respect to GETCWD if the DEFAULTS were relative"
3679 (or (absolute-pathname-p defaults)
3680 (merge-pathnames* defaults (getcwd))))
3682 (defun call-with-current-directory (dir thunk)
3683 "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
3684 Note that this operation is usually NOT thread-safe."
3686 (let* ((dir (resolve-symlinks*
3687 (get-pathname-defaults
3688 (ensure-directory-pathname
3691 (*default-pathname-defaults* dir))
3698 (defmacro with-current-directory ((&optional dir) &body body)
3699 "Call BODY while the POSIX current working directory is set to DIR"
3700 `(call-with-current-directory ,dir #'(lambda () ,@body))))
3703 ;;; Environment pathnames
3704 (with-upgradability ()
3705 (defun inter-directory-separator ()
3706 "What character does the current OS conventionally uses to separate directories?"
3707 (os-cond ((os-unix-p) #\:) (t #\;)))
3709 (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
3710 "Given a string of pathnames specified in native OS syntax, separate them in a list,
3711 check constraints and normalize each one as per ENSURE-PATHNAME,
3712 where an empty string denotes NIL."
3713 (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
3714 :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints))))
3716 (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
3717 "Extract a pathname from a user-configured environment variable, as per native OS,
3718 check constraints and normalize as per ENSURE-PATHNAME."
3719 ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
3720 (apply 'parse-native-namestring (getenvp x)
3721 :ensure-directory (or ensure-directory want-directory)
3722 :on-error (or on-error
3723 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
3725 (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
3726 "Extract a list of pathname from a user-configured environment variable, as per native OS,
3727 check constraints and normalize each one as per ENSURE-PATHNAME.
3728 Any empty entries in the environment variable X will be returned as NILs."
3729 (unless (getf constraints :empty-is-nil t)
3730 (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames))
3731 (apply 'split-native-pathnames-string (getenvp x)
3732 :on-error (or on-error
3733 `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
3736 (defun getenv-absolute-directory (x)
3737 "Extract an absolute directory pathname from a user-configured environment variable,
3739 (getenv-pathname x :want-absolute t :ensure-directory t))
3740 (defun getenv-absolute-directories (x)
3741 "Extract a list of absolute directories from a user-configured environment variable,
3742 as per native OS. Any empty entries in the environment variable X will be returned as
3744 (getenv-pathnames x :want-absolute t :ensure-directory t))
3746 (defun lisp-implementation-directory (&key truename)
3747 "Where are the system files of the current installation of the CL implementation?"
3748 (declare (ignorable truename))
3750 #+abcl extensions:*lisp-home*
3751 #+(or allegro clasp ecl mkcl) #p"SYS:"
3752 #+clisp custom:*lib-directory*
3754 #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:")))
3755 #+gcl system::*system-directory*
3756 #+lispworks lispworks:*lispworks-directory*
3757 #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
3759 (getenv-pathname "SBCL_HOME" :ensure-directory t))
3760 #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/")))
3761 #+xcl ext:*xcl-home*))
3762 (if (and dir truename)
3766 (defun lisp-implementation-pathname-p (pathname)
3767 "Is the PATHNAME under the current installation of the CL implementation?"
3768 ;; Other builtin systems are those under the implementation directory
3770 (if-let (impdir (lisp-implementation-directory))
3771 (or (subpathp pathname impdir)
3772 (when *resolve-symlinks*
3773 (if-let (truename (truename* pathname))
3774 (if-let (trueimpdir (truename* impdir))
3775 (subpathp truename trueimpdir)))))))
3779 ;;; Simple filesystem operations
3780 (with-upgradability ()
3781 (defun ensure-all-directories-exist (pathnames)
3782 "Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
3783 (dolist (pathname pathnames)
3785 (ensure-directories-exist (physicalize-pathname pathname)))))
3787 (defun delete-file-if-exists (x)
3788 "Delete a file X if it already exists"
3789 (when x (handler-case (delete-file x) (file-error () nil))))
3791 (defun rename-file-overwriting-target (source target)
3792 "Rename a file, overwriting any previous file with the TARGET name,
3793 in an atomic way if the implementation allows."
3794 (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t))
3795 (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t)))
3796 #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
3797 (progn (funcall 'require "syscalls")
3798 (symbol-call :posix :copy-file source target :method :rename))
3799 #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic
3801 (rename-file source target
3802 #+(or clasp clozure ecl) :if-exists
3803 #+clozure :rename-and-delete #+(or clasp ecl) t)))
3805 (defun delete-empty-directory (directory-pathname)
3806 "Delete an empty directory"
3807 #+(or abcl digitool gcl) (delete-file directory-pathname)
3808 #+allegro (excl:delete-directory directory-pathname)
3809 #+clisp (ext:delete-directory directory-pathname)
3810 #+clozure (ccl::delete-empty-directory directory-pathname)
3811 #+(or cmucl scl) (multiple-value-bind (ok errno)
3812 (unix:unix-rmdir (native-namestring directory-pathname))
3814 #+cmucl (error "Error number ~A when trying to delete directory ~A"
3815 errno directory-pathname)
3816 #+scl (error "~@<Error deleting ~S: ~A~@:>"
3817 directory-pathname (unix:get-unix-error-msg errno))))
3818 #+cormanlisp (win32:delete-directory directory-pathname)
3819 #+(or clasp ecl) (si:rmdir directory-pathname)
3820 #+genera (fs:delete-directory directory-pathname)
3821 #+lispworks (lw:delete-directory directory-pathname)
3822 #+mkcl (mkcl:rmdir directory-pathname)
3823 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
3824 `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
3825 `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
3826 #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname)))
3827 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl)
3828 (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera
3830 (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
3831 "Delete a directory including all its recursive contents, aka rm -rf.
3833 To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
3834 a physical non-wildcard directory pathname (not namestring).
3836 If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
3837 if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
3839 Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
3840 the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
3841 which in practice is thus compulsory, and validates by returning a non-NIL result.
3842 If you're suicidal or extremely confident, just use :VALIDATE T."
3843 (check-type if-does-not-exist (member :error :ignore))
3844 (setf directory-pathname (ensure-pathname directory-pathname
3845 :want-pathname t :want-non-wild t
3846 :want-physical t :want-directory t))
3849 (parameter-error "~S was asked to delete ~S but was not provided a validation predicate"
3850 'delete-directory-tree directory-pathname))
3851 ((not (call-function validate directory-pathname))
3852 (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
3853 'delete-directory-tree directory-pathname validate))
3854 ((not (directory-exists-p directory-pathname))
3855 (ecase if-does-not-exist
3857 (error "~S was asked to delete ~S but the directory does not exist"
3858 'delete-directory-tree directory-pathname))
3860 #-(or allegro cmucl clozure genera sbcl scl)
3861 ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
3862 ;; except on implementations where we can prevent DIRECTORY from following symlinks;
3863 ;; instead spawn a standard external program to do the dirty work.
3864 (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
3866 ;; On supported implementation, call supported system functions
3867 #+allegro (symbol-call :excl.osi :delete-directory-and-files
3868 directory-pathname :if-does-not-exist if-does-not-exist)
3869 #+clozure (ccl:delete-directory directory-pathname)
3870 #+genera (fs:delete-directory directory-pathname :confirm nil)
3871 #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
3872 `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
3873 '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
3874 ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
3875 ;; do things the hard way.
3876 #-(or allegro clozure genera sbcl)
3877 (let ((sub*directories
3878 (while-collecting (c)
3879 (collect-sub*directories directory-pathname t t #'c))))
3880 (dolist (d (nreverse sub*directories))
3881 (map () 'delete-file (directory-files d))
3882 (delete-empty-directory d)))))))
3883 ;;;; ---------------------------------------------------------------------------
3884 ;;;; Utilities related to streams
3886 (uiop/package:define-package :uiop/stream
3887 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
3889 #:*default-stream-element-type*
3890 #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr
3891 #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
3892 #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
3893 #:*default-encoding* #:*utf-8-external-format*
3894 #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
3895 #:with-output #:output-string #:with-input #:input-string
3896 #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
3897 #:null-device-pathname #:call-with-null-input #:with-null-input
3898 #:call-with-null-output #:with-null-output
3899 #:finish-outputs #:format! #:safe-format!
3900 #:copy-stream-to-stream #:concatenate-files #:copy-file
3901 #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
3902 #:slurp-stream-forms #:slurp-stream-form
3903 #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line
3904 #:read-file-forms #:read-file-form #:safe-read-file-form
3905 #:eval-input #:eval-thunk #:standard-eval-thunk
3907 #:file-stream-p #:file-or-synonym-stream-p
3909 #:*temporary-directory* #:temporary-directory #:default-temporary-directory
3910 #:setup-temporary-directory
3911 #:call-with-temporary-file #:with-temporary-file
3912 #:add-pathname-suffix #:tmpize-pathname
3913 #:call-with-staging-pathname #:with-staging-pathname))
3914 (in-package :uiop/stream)
3916 (with-upgradability ()
3917 (defvar *default-stream-element-type*
3918 (or #+(or abcl cmucl cormanlisp scl xcl) 'character
3919 #+lispworks 'lw:simple-char
3921 "default element-type for open (depends on the current CL implementation)")
3923 (defvar *stdin* *standard-input*
3924 "the original standard input stream at startup")
3926 (defun setup-stdin ()
3928 #.(or #+clozure 'ccl::*stdin*
3929 #+(or cmucl scl) 'system:*stdin*
3930 #+(or clasp ecl) 'ext::+process-standard-input+
3931 #+sbcl 'sb-sys:*stdin*
3932 '*standard-input*)))
3934 (defvar *stdout* *standard-output*
3935 "the original standard output stream at startup")
3937 (defun setup-stdout ()
3939 #.(or #+clozure 'ccl::*stdout*
3940 #+(or cmucl scl) 'system:*stdout*
3941 #+(or clasp ecl) 'ext::+process-standard-output+
3942 #+sbcl 'sb-sys:*stdout*
3943 '*standard-output*)))
3945 (defvar *stderr* *error-output*
3946 "the original error output stream at startup")
3948 (defun setup-stderr ()
3950 #.(or #+allegro 'excl::*stderr*
3951 #+clozure 'ccl::*stderr*
3952 #+(or cmucl scl) 'system:*stderr*
3953 #+(or clasp ecl) 'ext::+process-error-output+
3954 #+sbcl 'sb-sys:*stderr*
3957 ;; Run them now. In image.lisp, we'll register them to be run at image restart.
3958 (setup-stdin) (setup-stdout) (setup-stderr))
3961 ;;; Encodings (mostly hooks only; full support requires asdf-encodings)
3962 (with-upgradability ()
3963 (defparameter *default-encoding*
3964 ;; preserve explicit user changes to something other than the legacy default :default
3965 (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
3966 (unless (eq previous :default) previous))
3968 "Default encoding for source files.
3969 The default value :utf-8 is the portable thing.
3970 The legacy behavior was :default.
3971 If you (asdf:load-system :asdf-encodings) then
3972 you will have autodetection via *encoding-detection-hook* below,
3973 reading emacs-style -*- coding: utf-8 -*- specifications,
3974 and falling back to utf-8 or latin1 if nothing is specified.")
3976 (defparameter *utf-8-external-format*
3977 (if (featurep :asdf-unicode)
3978 (or #+clisp charset:utf-8 :utf-8)
3980 "Default :external-format argument to pass to CL:OPEN and also
3981 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
3982 On modern implementations, this will decode UTF-8 code points as CL characters.
3983 On legacy implementations, it may fall back on some 8-bit encoding,
3984 with non-ASCII code points being read as several CL characters;
3985 hopefully, if done consistently, that won't affect program behavior too much.")
3987 (defun always-default-encoding (pathname)
3988 "Trivial function to use as *encoding-detection-hook*,
3989 always 'detects' the *default-encoding*"
3990 (declare (ignore pathname))
3993 (defvar *encoding-detection-hook* #'always-default-encoding
3994 "Hook for an extension to define a function to automatically detect a file's encoding")
3996 (defun detect-encoding (pathname)
3997 "Detects the encoding of a specified file, going through user-configurable hooks"
3998 (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
3999 (funcall *encoding-detection-hook* pathname)
4000 *default-encoding*))
4002 (defun default-encoding-external-format (encoding)
4003 "Default, ignorant, function to transform a character ENCODING as a
4004 portable keyword to an implementation-dependent EXTERNAL-FORMAT specification.
4005 Load system ASDF-ENCODINGS to hook in a better one."
4007 (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
4008 (:utf-8 *utf-8-external-format*)
4010 (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)
4013 (defvar *encoding-external-format-hook*
4014 #'default-encoding-external-format
4015 "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping
4016 from non-default encodings to and implementation-defined external-format's")
4018 (defun encoding-external-format (encoding)
4019 "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT,
4020 going through all the proper hooks."
4021 (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
4025 (with-upgradability ()
4026 (defvar *standard-readtable* (with-standard-io-syntax *readtable*)
4027 "The standard readtable, implementing the syntax specified by the CLHS.
4028 It must never be modified, though only good implementations will even enforce that.")
4030 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
4031 "Establish safe CL reader options around the evaluation of BODY"
4032 `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
4034 (defun call-with-safe-io-syntax (thunk &key (package :cl))
4035 (with-standard-io-syntax
4036 (let ((*package* (find-package package))
4037 (*read-default-float-format* 'double-float)
4038 (*print-readably* nil)
4042 (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
4043 "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX"
4044 (with-safe-io-syntax (:package package)
4045 (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
4048 (with-upgradability ()
4049 (defun call-with-output-file (pathname thunk
4051 (element-type *default-stream-element-type*)
4052 (external-format *utf-8-external-format*)
4054 (if-does-not-exist :create))
4055 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
4056 Other keys are accepted but discarded."
4057 (with-open-file (s pathname :direction :output
4058 :element-type element-type
4059 :external-format external-format
4060 :if-exists if-exists
4061 :if-does-not-exist if-does-not-exist)
4064 (defmacro with-output-file ((var pathname &rest keys
4065 &key element-type external-format if-exists if-does-not-exist)
4067 (declare (ignore element-type external-format if-exists if-does-not-exist))
4068 `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))
4070 (defun call-with-output (output function &key (element-type 'character))
4071 "Calls FUNCTION with an actual stream argument,
4072 behaving like FORMAT with respect to how stream designators are interpreted:
4073 If OUTPUT is a STREAM, use it as the stream.
4074 If OUTPUT is NIL, use a STRING-OUTPUT-STREAM of given ELEMENT-TYPE as the stream, and
4075 return the resulting string.
4076 If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
4077 If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE.
4078 If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE
4079 -- this latter as an extension since ASDF 3.1.
4080 \(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\)
4081 Otherwise, signal an error."
4084 (with-output-to-string (stream nil :element-type element-type) (funcall function stream)))
4086 (funcall function *standard-output*))
4088 (funcall function output))
4090 (assert (fill-pointer output))
4091 (with-output-to-string (stream output :element-type element-type) (funcall function stream)))
4093 (call-with-output-file output function :element-type element-type)))))
4095 (with-upgradability ()
4096 (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
4097 (handler-bind (#+sbcl (style-warning #'muffle-warning))
4098 (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body)
4099 "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding
4100 of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in
4101 the scope of this binding."
4102 `(call-with-output ,value #'(lambda (,output-var) ,@body)
4103 ,@(when element-type `(:element-type ,element-type)))))))
4105 (defun output-string (string &optional output)
4106 "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
4108 (with-output (output) (princ string output))
4113 (with-upgradability ()
4114 (defun call-with-input-file (pathname thunk
4116 (element-type *default-stream-element-type*)
4117 (external-format *utf-8-external-format*)
4118 (if-does-not-exist :error))
4119 "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
4120 Other keys are accepted but discarded."
4121 (with-open-file (s pathname :direction :input
4122 :element-type element-type
4123 :external-format external-format
4124 :if-does-not-exist if-does-not-exist)
4127 (defmacro with-input-file ((var pathname &rest keys
4128 &key element-type external-format if-does-not-exist)
4130 (declare (ignore element-type external-format if-does-not-exist))
4131 `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
4133 (defun call-with-input (input function &key keys)
4134 "Calls FUNCTION with an actual stream argument, interpreting
4135 stream designators like READ, but also coercing strings to STRING-INPUT-STREAM,
4136 and PATHNAME to FILE-STREAM.
4137 If INPUT is a STREAM, use it as the stream.
4138 If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
4139 If INPUT is T, use *TERMINAL-IO* as the stream.
4140 If INPUT is a STRING, use it as a string-input-stream.
4141 If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE
4142 -- the latter is an extension since ASDF 3.1.
4143 Otherwise, signal an error."
4145 (null (funcall function *standard-input*))
4146 ((eql t) (funcall function *terminal-io*))
4147 (stream (funcall function input))
4148 (string (with-input-from-string (stream input) (funcall function stream)))
4149 (pathname (apply 'call-with-input-file input function keys))))
4151 (defmacro with-input ((input-var &optional (value input-var)) &body body)
4152 "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
4153 as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
4154 `(call-with-input ,value #'(lambda (,input-var) ,@body)))
4156 (defun input-string (&optional input)
4157 "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string
4161 (with-input (input) (funcall 'slurp-stream-string input)))))
4164 (with-upgradability ()
4165 (defun null-device-pathname ()
4166 "Pathname to a bit bucket device that discards any information written to it
4167 and always returns EOF when read from"
4169 ((os-unix-p) #p"/dev/null")
4170 ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax?
4171 (t (error "No /dev/null on your OS"))))
4172 (defun call-with-null-input (fun &key element-type external-format if-does-not-exist)
4173 "Call FUN with an input stream that always returns end of file.
4174 The keyword arguments are allowed for backward compatibility, but are ignored."
4175 (declare (ignore element-type external-format if-does-not-exist))
4176 (with-open-stream (input (make-concatenated-stream))
4177 (funcall fun input)))
4178 (defmacro with-null-input ((var &rest keys
4179 &key element-type external-format if-does-not-exist)
4181 (declare (ignore element-type external-format if-does-not-exist))
4182 "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file.
4183 The keyword arguments are allowed for backward compatibility, but are ignored."
4184 `(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
4185 (defun call-with-null-output (fun
4186 &key (element-type *default-stream-element-type*)
4187 (external-format *utf-8-external-format*)
4188 (if-exists :overwrite)
4189 (if-does-not-exist :error))
4190 (declare (ignore element-type external-format if-exists if-does-not-exist))
4191 "Call FUN with an output stream that discards all output.
4192 The keyword arguments are allowed for backward compatibility, but are ignored."
4193 (with-open-stream (output (make-broadcast-stream))
4194 (funcall fun output)))
4195 (defmacro with-null-output ((var &rest keys
4196 &key element-type external-format if-does-not-exist if-exists)
4198 "Evaluate BODY in a context when VAR is bound to an output stream that discards all output.
4199 The keyword arguments are allowed for backward compatibility, but are ignored."
4200 (declare (ignore element-type external-format if-exists if-does-not-exist))
4201 `(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
4203 ;;; Ensure output buffers are flushed
4204 (with-upgradability ()
4205 (defun finish-outputs (&rest streams)
4206 "Finish output on the main output streams as well as any specified one.
4207 Useful for portably flushing I/O before user input or program exit."
4208 ;; CCL notably buffers its stream output by default.
4209 (dolist (s (append streams
4210 (list *stdout* *stderr* *error-output* *standard-output* *trace-output*
4211 *debug-io* *terminal-io* *query-io*)))
4212 (ignore-errors (finish-output s)))
4215 (defun format! (stream format &rest args)
4216 "Just like format, but call finish-outputs before and after the output."
4217 (finish-outputs stream)
4218 (apply 'format stream format args)
4219 (finish-outputs stream))
4221 (defun safe-format! (stream format &rest args)
4222 "Variant of FORMAT that is safe against both
4223 dangerous syntax configuration and errors while printing."
4224 (with-safe-io-syntax ()
4225 (ignore-errors (apply 'format! stream format args))
4226 (finish-outputs stream)))) ; just in case format failed
4229 ;;; Simple Whole-Stream processing
4230 (with-upgradability ()
4231 (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
4232 "Copy the contents of the INPUT stream into the OUTPUT stream.
4233 If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
4234 Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
4235 (with-open-stream (input input)
4237 (loop :for (line eof) = (multiple-value-list (read-line input nil nil))
4239 (when prefix (princ prefix output))
4241 (unless eof (terpri output))
4242 (finish-output output)
4243 (when eof (return)))
4245 :with buffer-size = (or buffer-size 8192)
4246 :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
4247 :for end = (read-sequence buffer input)
4249 :do (write-sequence buffer output :end end)
4250 (when (< end buffer-size) (return))))))
4252 (defun concatenate-files (inputs output)
4253 "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
4254 (with-open-file (o output :element-type '(unsigned-byte 8)
4255 :direction :output :if-exists :rename-and-delete)
4256 (dolist (input inputs)
4257 (with-open-file (i input :element-type '(unsigned-byte 8)
4258 :direction :input :if-does-not-exist :error)
4259 (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
4261 (defun copy-file (input output)
4262 "Copy contents of the INPUT file to the OUTPUT file"
4263 ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
4265 (excl.osi:copy-file input output)
4267 (ext:copy-file input output)
4269 (concatenate-files (list input) output))
4271 (defun slurp-stream-string (input &key (element-type 'character) stripped)
4272 "Read the contents of the INPUT stream as a string"
4274 (with-open-stream (input input)
4275 (with-output-to-string (output nil :element-type element-type)
4276 (copy-stream-to-stream input output :element-type element-type)))))
4277 (if stripped (stripln string) string)))
4279 (defun slurp-stream-lines (input &key count)
4280 "Read the contents of the INPUT stream as a list of lines, return those lines.
4282 Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR
4283 from the line-ending if the file or stream had CR+LF but Lisp only removed LF.
4285 Read no more than COUNT lines."
4286 (check-type count (or null integer))
4287 (with-open-stream (input input)
4288 (loop :for n :from 0
4289 :for l = (and (or (not count) (< n count))
4290 (read-line input nil nil))
4291 ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF
4292 :while l :collect (stripln l))))
4294 (defun slurp-stream-line (input &key (at 0))
4295 "Read the contents of the INPUT stream as a list of lines,
4296 then return the ACCESS-AT of that list of lines using the AT specifier.
4297 PATH defaults to 0, i.e. return the first line.
4298 PATH is typically an integer, or a list of an integer and a function.
4299 If PATH is NIL, it will return all the lines in the file.
4301 The stream will not be read beyond the Nth lines,
4302 where N is the index specified by path
4303 if path is either an integer or a list that starts with an integer."
4304 (access-at (slurp-stream-lines input :count (access-at-count at)) at))
4306 (defun slurp-stream-forms (input &key count)
4307 "Read the contents of the INPUT stream as a list of forms,
4308 and return those forms.
4310 If COUNT is null, read to the end of the stream;
4311 if COUNT is an integer, stop after COUNT forms were read.
4313 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4314 (check-type count (or null integer))
4315 (loop :with eof = '#:eof
4317 :for form = (if (and count (>= n count))
4319 (read-preserving-whitespace input nil eof))
4320 :until (eq form eof) :collect form))
4322 (defun slurp-stream-form (input &key (at 0))
4323 "Read the contents of the INPUT stream as a list of forms,
4324 then return the ACCESS-AT of these forms following the AT.
4325 AT defaults to 0, i.e. return the first form.
4326 AT is typically a list of integers.
4327 If AT is NIL, it will return all the forms in the file.
4329 The stream will not be read beyond the Nth form,
4330 where N is the index specified by path,
4331 if path is either an integer or a list that starts with an integer.
4333 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4334 (access-at (slurp-stream-forms input :count (access-at-count at)) at))
4336 (defun read-file-string (file &rest keys)
4337 "Open FILE with option KEYS, read its contents as a string"
4338 (apply 'call-with-input-file file 'slurp-stream-string keys))
4340 (defun read-file-lines (file &rest keys)
4341 "Open FILE with option KEYS, read its contents as a list of lines
4342 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4343 (apply 'call-with-input-file file 'slurp-stream-lines keys))
4345 (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys)
4346 "Open input FILE with option KEYS (except AT),
4347 and read its contents as per SLURP-STREAM-LINE with given AT specifier.
4348 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4349 (apply 'call-with-input-file file
4350 #'(lambda (input) (slurp-stream-line input :at at))
4351 (remove-plist-key :at keys)))
4353 (defun read-file-forms (file &rest keys &key count &allow-other-keys)
4354 "Open input FILE with option KEYS (except COUNT),
4355 and read its contents as per SLURP-STREAM-FORMS with given COUNT.
4356 If COUNT is null, read to the end of the stream;
4357 if COUNT is an integer, stop after COUNT forms were read.
4358 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4359 (apply 'call-with-input-file file
4360 #'(lambda (input) (slurp-stream-forms input :count count))
4361 (remove-plist-key :count keys)))
4363 (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
4364 "Open input FILE with option KEYS (except AT),
4365 and read its contents as per SLURP-STREAM-FORM with given AT specifier.
4366 BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
4367 (apply 'call-with-input-file file
4368 #'(lambda (input) (slurp-stream-form input :at at))
4369 (remove-plist-key :at keys)))
4371 (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys)
4372 "Reads the specified line from the top of a file using a safe standardized syntax.
4373 Extracts the line using READ-FILE-LINE,
4374 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
4375 (with-safe-io-syntax (:package package)
4376 (apply 'read-file-line pathname (remove-plist-key :package keys))))
4378 (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
4379 "Reads the specified form from the top of a file using a safe standardized syntax.
4380 Extracts the form using READ-FILE-FORM,
4381 within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
4382 (with-safe-io-syntax (:package package)
4383 (apply 'read-file-form pathname (remove-plist-key :package keys))))
4385 (defun eval-input (input)
4386 "Portably read and evaluate forms from INPUT, return the last values."
4388 (loop :with results :with eof ='#:eof
4389 :for form = (read input nil eof)
4390 :until (eq form eof)
4391 :do (setf results (multiple-value-list (eval form)))
4392 :finally (return (values-list results)))))
4394 (defun eval-thunk (thunk)
4395 "Evaluate a THUNK of code:
4396 If a function, FUNCALL it without arguments.
4397 If a constant literal and not a sequence, return it.
4398 If a cons or a symbol, EVAL it.
4399 If a string, repeatedly read and evaluate from it, returning the last values."
4401 ((or boolean keyword number character pathname) thunk)
4402 ((or cons symbol) (eval thunk))
4403 (function (funcall thunk))
4404 (string (eval-input thunk))))
4406 (defun standard-eval-thunk (thunk &key (package :cl))
4407 "Like EVAL-THUNK, but in a more standardized evaluation context."
4408 ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
4410 (with-safe-io-syntax (:package package)
4411 (let ((*read-eval* t))
4412 (eval-thunk thunk))))))
4414 (with-upgradability ()
4415 (defun println (x &optional (stream *standard-output*))
4416 "Variant of PRINC that also calls TERPRI afterwards"
4417 (princ x stream) (terpri stream) (finish-output stream) (values))
4419 (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
4420 "Variant of WRITE that also calls TERPRI afterwards"
4421 (apply 'write x keys) (terpri stream) (finish-output stream) (values)))
4424 ;;; Using temporary files
4425 (with-upgradability ()
4426 (defun default-temporary-directory ()
4427 "Return a default directory to use for temporary files"
4430 (or (getenv-pathname "TMPDIR" :ensure-directory t)
4431 (parse-native-namestring "/tmp/")))
4433 (getenv-pathname "TEMP" :ensure-directory t))
4434 (t (subpathname (user-homedir-pathname) "tmp/"))))
4436 (defvar *temporary-directory* nil "User-configurable location for temporary files")
4438 (defun temporary-directory ()
4439 "Return a directory to use for temporary files"
4440 (or *temporary-directory* (default-temporary-directory)))
4442 (defun setup-temporary-directory ()
4443 "Configure a default temporary directory to use."
4444 (setf *temporary-directory* (default-temporary-directory))
4445 #+gcl (setf system::*tmp-dir* *temporary-directory*))
4447 (defun call-with-temporary-file
4449 (want-stream-p t) (want-pathname-p t) (direction :io) keep after
4450 directory (type "tmp" typep) prefix (suffix (when typep "-tmp"))
4451 (element-type *default-stream-element-type*)
4452 (external-format *utf-8-external-format*))
4453 "Call a THUNK with stream and/or pathname arguments identifying a temporary file.
4455 The temporary file's pathname will be based on concatenating
4456 PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string,
4457 and optional SUFFIX (defaults to \"-tmp\" if a type was provided)
4458 and TYPE (defaults to \"tmp\", using a dot as separator if not NIL),
4459 within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute.
4461 The file will be open with specified DIRECTION (defaults to :IO),
4462 ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and
4463 EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*).
4464 If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed
4465 with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T),
4466 and stream will be closed after the THUNK exits (either normally or abnormally).
4467 If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then
4468 THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument.
4469 Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument.
4470 If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned.
4471 Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true."
4472 #+xcl (declare (ignorable typep))
4473 (check-type direction (member :output :io))
4474 (assert (or want-stream-p want-pathname-p))
4476 :with prefix-pn = (ensure-absolute-pathname
4478 (or (ensure-pathname
4483 #'temporary-directory))
4484 :with prefix-nns = (native-namestring prefix-pn)
4485 :with results = (progn (ensure-directories-exist prefix-pn)
4487 :for counter :from (random (expt 36 #-gcl 8 #+gcl 5))
4488 :for pathname = (parse-native-namestring
4489 (format nil "~A~36R~@[~A~]~@[.~A~]"
4490 prefix-nns counter suffix (unless (eq type :unspecific) type)))
4492 ;; TODO: on Unix, do something about umask
4493 ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
4494 ;; TODO: on Unix, use CFFI and mkstemp --
4495 ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr.
4496 ;; Can we at least design some hook?
4499 (ensure-directories-exist pathname)
4500 (with-open-file (stream pathname
4501 :direction direction
4502 :element-type element-type
4503 :external-format external-format
4504 :if-exists nil :if-does-not-exist :create)
4508 ;; Note: can't return directly from within with-open-file
4509 ;; or the non-local return causes the file creation to be undone.
4510 (setf results (multiple-value-list
4512 (call-function thunk stream pathname)
4513 (call-function thunk stream)))))))
4514 ;; if we don't want a stream, then we must call the thunk *after*
4515 ;; the stream is closed, but only if it was successfully opened.
4517 (when (and want-pathname-p (not want-stream-p))
4518 (setf results (multiple-value-list (call-function thunk okp))))
4519 ;; if the stream was successfully opened, then return a value,
4520 ;; either one computed already, or one from AFTER, if that exists.
4522 (return (call-function after pathname))
4523 (return (values-list results)))))
4524 (when (and okp (not (call-function keep)))
4525 (ignore-errors (delete-file-if-exists okp))))))
4527 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
4528 (pathname (gensym "PATHNAME") pathnamep)
4529 directory prefix suffix type
4530 keep direction element-type external-format)
4532 "Evaluate BODY where the symbols specified by keyword arguments
4533 STREAM and PATHNAME (if respectively specified) are bound corresponding
4534 to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
4535 At least one of STREAM or PATHNAME must be specified.
4536 If the STREAM is not specified, it will be closed before the BODY is evaluated.
4537 If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY,
4538 separates forms run before and after the stream is closed.
4539 The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned.
4540 Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE."
4541 (check-type stream symbol)
4542 (check-type pathname symbol)
4543 (assert (or streamp pathnamep))
4544 (let* ((afterp (position :close-stream body))
4545 (before (if afterp (subseq body 0 afterp) body))
4546 (after (when afterp (subseq body (1+ afterp))))
4547 (beforef (gensym "BEFORE"))
4548 (afterf (gensym "AFTER")))
4549 (when (eql afterp 0)
4550 (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM."))
4551 `(flet (,@(when before
4552 `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname)))
4553 ,@(when after `((declare (ignorable ,pathname))))
4557 `((,afterf (,pathname) ,@after))))
4558 #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf))))
4559 (call-with-temporary-file
4560 ,(when before `#',beforef)
4561 :want-stream-p ,streamp
4562 :want-pathname-p ,pathnamep
4563 ,@(when direction `(:direction ,direction))
4564 ,@(when directory `(:directory ,directory))
4565 ,@(when prefix `(:prefix ,prefix))
4566 ,@(when suffix `(:suffix ,suffix))
4567 ,@(when type `(:type ,type))
4568 ,@(when keep `(:keep ,keep))
4569 ,@(when after `(:after #',afterf))
4570 ,@(when element-type `(:element-type ,element-type))
4571 ,@(when external-format `(:external-format ,external-format))))))
4573 (defun get-temporary-file (&key directory prefix suffix type (keep t))
4574 (with-temporary-file (:pathname pn :keep keep
4575 :directory directory :prefix prefix :suffix suffix :type type)
4578 ;; Temporary pathnames in simple cases where no contention is assumed
4579 (defun add-pathname-suffix (pathname suffix &rest keys)
4580 "Add a SUFFIX to the name of a PATHNAME, return a new pathname.
4581 Further KEYS can be passed to MAKE-PATHNAME."
4582 (apply 'make-pathname :name (strcat (pathname-name pathname) suffix)
4583 :defaults pathname keys))
4585 (defun tmpize-pathname (x)
4586 "Return a new pathname modified from X by adding a trivial random suffix.
4587 A new empty file with said temporary pathname is created, to ensure there is no
4588 clash with any concurrent process attempting the same thing."
4589 (let* ((px (ensure-pathname x :ensure-physical t))
4590 (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp"))
4591 (directory (pathname-directory-pathname px)))
4592 ;; Genera uses versioned pathnames -- If we leave the empty file in place,
4593 ;; the system will create a new version of the file when the caller opens
4594 ;; it for output. That empty file will remain after the operation is completed.
4595 ;; As Genera is a single core processor, the possibility of a name conflict is
4596 ;; minimal if not nil. (And, in the event of a collision, the two processes
4597 ;; would be writing to different versions of the file.)
4598 (get-temporary-file :directory directory :prefix prefix :type (pathname-type px)
4599 #+genera :keep #+genera nil)))
4601 (defun call-with-staging-pathname (pathname fun)
4602 "Calls FUN with a staging pathname, and atomically
4603 renames the staging pathname to the PATHNAME in the end.
4604 NB: this protects only against failure of the program, not against concurrent attempts.
4605 For the latter case, we ought pick a random suffix and atomically open it."
4606 (let* ((pathname (pathname pathname))
4607 (staging (tmpize-pathname pathname)))
4609 (multiple-value-prog1
4610 (funcall fun staging)
4611 (rename-file-overwriting-target staging pathname))
4612 (delete-file-if-exists staging))))
4614 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
4615 "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
4616 `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
4618 (with-upgradability ()
4619 (defun file-stream-p (stream)
4620 (typep stream 'file-stream))
4621 (defun file-or-synonym-stream-p (stream)
4622 (or (file-stream-p stream)
4623 (and (typep stream 'synonym-stream)
4624 (file-or-synonym-stream-p
4625 (symbol-value (synonym-stream-symbol stream)))))))
4626 ;;;; -------------------------------------------------------------------------
4627 ;;;; Starting, Stopping, Dumping a Lisp image
4629 (uiop/package:define-package :uiop/image
4630 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
4632 #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
4633 #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
4634 #:*lisp-interaction*
4635 #:fatal-condition #:fatal-condition-p
4636 #:handle-fatal-condition
4637 #:call-with-fatal-condition-handler #:with-fatal-condition-handler
4638 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
4639 #:*image-postlude* #:*image-dump-hook*
4640 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
4641 #:shell-boolean-exit
4642 #:register-image-restore-hook #:register-image-dump-hook
4643 #:call-image-restore-hook #:call-image-dump-hook
4644 #:restore-image #:dump-image #:create-image
4646 (in-package :uiop/image)
4648 (with-upgradability ()
4649 (defvar *lisp-interaction* t
4650 "Is this an interactive Lisp environment, or is it batch processing?")
4652 (defvar *command-line-arguments* nil
4653 "Command-line arguments")
4655 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
4656 "Is this a dumped image? As a standalone executable?")
4658 (defvar *image-restore-hook* nil
4659 "Functions to call (in reverse order) when the image is restored")
4661 (defvar *image-restored-p* nil
4662 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
4664 (defvar *image-prelude* nil
4665 "a form to evaluate, or string containing forms to read and evaluate
4666 when the image is restarted, but before the entry point is called.")
4668 (defvar *image-entry-point* nil
4669 "a function with which to restart the dumped image when execution is restored from it.")
4671 (defvar *image-postlude* nil
4672 "a form to evaluate, or string containing forms to read and evaluate
4673 before the image dump hooks are called and before the image is dumped.")
4675 (defvar *image-dump-hook* nil
4676 "Functions to call (in order) when before an image is dumped"))
4678 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
4679 (deftype fatal-condition ()
4680 `(and serious-condition #+clozure (not ccl:process-reset))))
4682 ;;; Exiting properly or im-
4683 (with-upgradability ()
4684 (defun quit (&optional (code 0) (finish-output t))
4685 "Quits from the Lisp world, with the given exit status if provided.
4686 This is designed to abstract away the implementation specific quit forms."
4687 (when finish-output ;; essential, for ClozureCL, and for standard compliance.
4689 #+(or abcl xcl) (ext:quit :status code)
4690 #+allegro (excl:exit code :quiet t)
4691 #+(or clasp ecl) (si:quit code)
4692 #+clisp (ext:quit code)
4693 #+clozure (ccl:quit code)
4694 #+cormanlisp (win32:exitprocess code)
4695 #+(or cmucl scl) (unix:unix-exit code)
4696 #+gcl (system:quit code)
4697 #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
4698 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
4699 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
4700 #+mkcl (mk-ext:quit :exit-code code)
4701 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
4702 (quit (find-symbol* :quit :sb-ext nil)))
4704 (exit `(,exit :code code :abort (not finish-output)))
4705 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
4706 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
4707 (not-implemented-error 'quit "(called with exit code ~S)" code))
4709 (defun die (code format &rest arguments)
4710 "Die in error with some error message"
4711 (with-safe-io-syntax ()
4713 (format! *stderr* "~&~?~&" format arguments)))
4716 (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
4717 "Print a backtrace, directly accessing the implementation"
4718 (declare (ignorable stream count condition))
4720 (loop :for i :from 0
4721 :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
4722 (safe-format! stream "~&~D: ~A~%" i frame))
4724 (let ((*terminal-io* stream)
4725 (*standard-output* stream)
4726 (tpl:*zoom-print-circle* *print-circle*)
4727 (tpl:*zoom-print-level* *print-level*)
4728 (tpl:*zoom-print-length* *print-length*))
4729 (tpl:do-command "zoom"
4730 :from-read-eval-print-loop nil
4734 (clasp-debug:print-backtrace :stream stream :count count)
4736 (let* ((top (si:ihs-top))
4737 (repeats (if count (min top count) top))
4738 (backtrace (loop :for ihs :from 0 :below top
4739 :collect (list (si::ihs-fun ihs)
4740 (si::ihs-env ihs)))))
4741 (loop :for i :from 0 :below repeats
4742 :for frame :in (nreverse backtrace) :do
4743 (safe-format! stream "~&~D: ~S~%" i frame)))
4745 (system::print-backtrace :out stream :limit count)
4747 (let ((*debug-io* stream))
4748 #+clozure (ccl:print-call-history :count count :start-frame-number 1)
4749 #+mcl (ccl:print-call-history :detailed-p nil)
4750 (finish-output stream))
4752 (let ((debug:*debug-print-level* *print-level*)
4753 (debug:*debug-print-length* *print-length*))
4754 (debug:backtrace (or count most-positive-fixnum) stream))
4756 (let ((*debug-io* stream))
4758 (with-safe-io-syntax ()
4760 (conditions::condition-backtrace condition)
4761 (system::simple-backtrace)))))
4763 (let ((dbg::*debugger-stack*
4764 (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
4766 (dbg:*debug-print-level* *print-level*)
4767 (dbg:*debug-print-length* *print-length*))
4768 (dbg:bug-backtrace nil))
4770 (let ((*standard-output* stream))
4771 (sys.int::backtrace count))
4773 (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
4775 (loop :for i :from 0 :below (or count most-positive-fixnum)
4776 :for frame :in (extensions:backtrace-as-list) :do
4777 (safe-format! stream "~&~D: ~S~%" i frame)))
4779 (defun print-backtrace (&rest keys &key stream count condition)
4781 (declare (ignore stream count condition))
4782 (with-safe-io-syntax (:package :cl)
4783 (let ((*print-readably* nil)
4785 (*print-miser-width* 75)
4786 (*print-length* nil)
4789 (ignore-errors (apply 'raw-print-backtrace keys)))))
4791 (defun print-condition-backtrace (condition &key (stream *stderr*) count)
4792 "Print a condition after a backtrace triggered by that condition"
4793 ;; We print the condition *after* the backtrace,
4794 ;; for the sake of who sees the backtrace at a terminal.
4795 ;; It is up to the caller to print the condition *before*, with some context.
4796 (print-backtrace :stream stream :count count :condition condition)
4798 (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
4801 (defun fatal-condition-p (condition)
4802 "Is the CONDITION fatal?"
4803 (typep condition 'fatal-condition))
4805 (defun handle-fatal-condition (condition)
4806 "Handle a fatal CONDITION:
4807 depending on whether *LISP-INTERACTION* is set, enter debugger or die"
4810 (invoke-debugger condition))
4812 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
4813 (print-condition-backtrace condition :stream *stderr*)
4814 (die 99 "~A" condition))))
4816 (defun call-with-fatal-condition-handler (thunk)
4817 "Call THUNK in a context where fatal conditions are appropriately handled"
4818 (handler-bind ((fatal-condition #'handle-fatal-condition))
4821 (defmacro with-fatal-condition-handler ((&optional) &body body)
4822 "Execute BODY in a context where fatal conditions are appropriately handled"
4823 `(call-with-fatal-condition-handler #'(lambda () ,@body)))
4825 (defun shell-boolean-exit (x)
4826 "Quit with a return code that is 0 iff argument X is true"
4830 ;;; Using image hooks
4831 (with-upgradability ()
4832 (defun register-image-restore-hook (hook &optional (call-now-p t))
4833 "Regiter a hook function to be run when restoring a dumped image"
4834 (register-hook-function '*image-restore-hook* hook call-now-p))
4836 (defun register-image-dump-hook (hook &optional (call-now-p nil))
4837 "Register a the hook function to be run before to dump an image"
4838 (register-hook-function '*image-dump-hook* hook call-now-p))
4840 (defun call-image-restore-hook ()
4841 "Call the hook functions registered to be run when restoring a dumped image"
4842 (call-functions (reverse *image-restore-hook*)))
4844 (defun call-image-dump-hook ()
4845 "Call the hook functions registered to be run before to dump an image"
4846 (call-functions *image-dump-hook*)))
4849 ;;; Proper command-line arguments
4850 (with-upgradability ()
4851 (defun raw-command-line-arguments ()
4852 "Find what the actual command line for this process was."
4853 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
4854 #+allegro (sys:command-line-arguments) ; default: :application t
4855 #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
4856 #+clisp (coerce (ext:argv) 'list)
4857 #+clozure ccl:*command-line-argument-list*
4858 #+(or cmucl scl) extensions:*command-line-strings*
4859 #+gcl si:*command-args*
4860 #+(or genera mcl mezzano) nil
4861 #+lispworks sys:*line-arguments-list*
4862 #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
4863 #+sbcl sb-ext:*posix-argv*
4865 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
4866 (not-implemented-error 'raw-command-line-arguments))
4868 (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
4869 "Extract user arguments from command-line invocation of current process.
4870 Assume the calling conventions of a generated script that uses --
4871 if we are not called from a directly executable image."
4873 #+abcl (return arguments)
4874 ;; SBCL and Allegro already separate user arguments from implementation arguments.
4876 (unless (eq *image-dumped-p* :executable)
4877 ;; LispWorks command-line processing isn't transparent to the user
4878 ;; unless you create a standalone executable; in that case,
4879 ;; we rely on cl-launch or some other script to set the arguments for us.
4880 #+lispworks (return *command-line-arguments*)
4881 ;; On other implementations, on non-standalone executables,
4882 ;; we trust cl-launch or whichever script starts the program
4883 ;; to use -- as a delimiter between implementation arguments and user arguments.
4884 #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
4888 "On supported implementations (most that matter), or when invoked by a proper wrapper script,
4889 return a string that for the name with which the program was invoked, i.e. argv[0] in C.
4890 Otherwise, return NIL."
4892 ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
4893 ;; NB: not currently available on ABCL, Corman, Genera, MCL
4894 (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl)
4895 (first (raw-command-line-arguments))
4896 #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
4897 (t ;; argv[0] is the name of the interpreter.
4898 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
4899 (getenvp "__CL_ARGV0"))))
4901 (defun setup-command-line-arguments ()
4902 (setf *command-line-arguments* (command-line-arguments)))
4904 (defun restore-image (&key
4905 (lisp-interaction *lisp-interaction*)
4906 (restore-hook *image-restore-hook*)
4907 (prelude *image-prelude*)
4908 (entry-point *image-entry-point*)
4909 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
4910 "From a freshly restarted Lisp image, restore the saved Lisp environment
4911 by setting appropriate variables, running various hooks, and calling any specified entry point.
4913 If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
4914 call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
4915 immediately to the surrounding restore process if allowed to continue.
4917 Then, comes the restore process itself:
4918 First, call each function in the RESTORE-HOOK,
4919 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
4920 Second, evaluate the prelude, which is often Lisp text that is read,
4922 Third, call the ENTRY-POINT function, if any is specified, with no argument.
4924 The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
4925 any unhandled error leads to a backtrace and an exit with an error status.
4926 If LISP-INTERACTION is NIL, the process also exits when no error occurs:
4927 if neither restart nor entry function is provided, the program will exit with status 0 (success);
4928 if a function was provided, the program will exit after the function returns (if it returns),
4929 with status 0 if and only if the primary return value of result is generalized boolean true,
4930 and with status 1 if this value is NIL.
4932 If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
4933 of the function will be returned rather than interpreted as a boolean designating an exit code."
4934 (when *image-restored-p*
4935 (if if-already-restored
4936 (call-function if-already-restored "Image already ~:[being ~;~]restored"
4937 (eq *image-restored-p* t))
4938 (return-from restore-image)))
4939 (with-fatal-condition-handler ()
4940 (setf *lisp-interaction* lisp-interaction)
4941 (setf *image-restore-hook* restore-hook)
4942 (setf *image-prelude* prelude)
4943 (setf *image-restored-p* :in-progress)
4944 (call-image-restore-hook)
4945 (standard-eval-thunk prelude)
4946 (setf *image-restored-p* t)
4947 (let ((results (multiple-value-list
4949 (call-function entry-point)
4951 (if lisp-interaction
4952 (values-list results)
4953 (shell-boolean-exit (first results)))))))
4956 ;;; Dumping an image
4958 (with-upgradability ()
4959 (defun dump-image (filename &key output-name executable
4960 (postlude *image-postlude*)
4961 (dump-hook *image-dump-hook*)
4962 #+clozure prepend-symbols #+clozure (purify t)
4964 #+(and sbcl os-windows) application-type)
4965 "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
4967 First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
4968 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-IMAGE-DUMP-HOOK.
4970 If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
4972 Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
4973 or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
4974 ;; Note: at least SBCL saves only global values of variables in the heap image,
4975 ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
4976 (declare (ignorable filename output-name executable))
4977 (setf *image-dumped-p* (if executable :executable t))
4978 (setf *image-restored-p* :in-regress)
4979 (setf *image-postlude* postlude)
4980 (standard-eval-thunk *image-postlude*)
4981 (setf *image-dump-hook* dump-hook)
4982 (call-image-dump-hook)
4983 (setf *image-restored-p* nil)
4984 #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
4986 (not-implemented-error 'dump-image "dumping an executable"))
4989 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
4990 (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
4992 (apply #'ext:saveinitmem filename
4994 :start-package *package*
4995 :keep-global-handlers nil
4996 ;; Faré explains the odd executable value (slightly paraphrased):
4997 ;; 0 is very different from t in clisp and there for a good reason:
4998 ;; 0 turns the executable into one that has its own command-line handling, so hackers can't
4999 ;; use the underlying -i or -x to turn your would-be restricted binary into an unrestricted evaluator.
5000 :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
5003 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
5004 :norc t :script nil :init-function #'restore-image)))
5006 (flet ((dump (prepend-kernel)
5007 (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
5008 :toplevel-function (when executable #'restore-image))))
5009 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
5011 (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
5013 (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
5019 (setf ext:*batch-mode* nil)
5020 (setf ext::*gc-run-time* 0)
5021 (apply 'ext:save-lisp filename
5022 :allow-other-keys t ;; hush SCL and old versions of CMUCL
5023 #+(and cmucl executable) :executable #+(and cmucl executable) t
5024 (when executable '(:init-function restore-image :process-command-line nil
5025 :quiet t :load-init-file nil :site-init nil))))
5028 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
5029 (si::save-system filename))
5032 (lispworks:deliver 'restore-image filename 0 :interface nil)
5033 (hcl:save-image filename :environment nil))
5036 ;;(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
5037 (setf sb-ext::*gc-run-time* 0)
5038 (apply 'sb-ext:save-lisp-and-die filename
5039 :executable t ;--- always include the runtime that goes with the core
5041 (when compression (list :compression compression))
5042 ;;--- only save runtime-options for standalone executables
5043 (when executable (list :toplevel #'restore-image :save-runtime-options t))
5044 #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
5045 ;; the default is :console - only works with SBCL 1.1.15 or later.
5046 (when application-type (list :application-type application-type)))))
5047 #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
5048 (not-implemented-error 'dump-image))
5050 (defun create-image (destination lisp-object-files
5051 &key kind output-name prologue-code epilogue-code extra-object-files
5052 (prelude () preludep) (postlude () postludep)
5053 (entry-point () entry-point-p) build-args no-uiop)
5054 (declare (ignorable destination lisp-object-files extra-object-files kind output-name
5055 prologue-code epilogue-code prelude preludep postlude postludep
5056 entry-point entry-point-p build-args no-uiop))
5057 "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
5058 ;; Is it meaningful to run these in the current environment?
5059 ;; only if we also track the object files that constitute the "current" image,
5060 ;; and otherwise simulate dump-image, including quitting at the end.
5061 #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
5062 #+(or clasp ecl mkcl)
5063 (let ((epilogue-code
5068 (when epilogue-code `(,epilogue-code))
5069 (when postludep `((setf *image-postlude* ',postlude)))
5070 (when preludep `((setf *image-prelude* ',prelude)))
5071 (when entry-point-p `((setf *image-entry-point* ',entry-point)))
5074 (setf kind :program) ;; to ECL, it's just another program.
5075 `((setf *image-dumped-p* t)
5076 (si::top-level #+(or clasp ecl) t) (quit)))
5078 `((setf *image-dumped-p* :executable)
5080 (restore-image))))))))
5081 (when forms `(progn ,@forms))))))
5082 (check-type kind (member :dll :shared-library :lib :static-library
5083 :fasl :fasb :program))
5084 (apply #+clasp 'cmp:builder #+clasp kind
5087 ((:dll :shared-library)
5088 #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library)
5089 ((:lib :static-library)
5090 #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library)
5091 ((:fasl #+ecl :fasb)
5092 #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl)
5093 #+mkcl ((:fasb) 'compiler:build-bundle)
5095 #+ecl 'c::build-program #+mkcl 'compiler:build-program))
5096 (pathname destination)
5097 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files
5098 (append lisp-object-files #+(or clasp ecl) extra-object-files)
5100 #+ecl (getf build-args :init-name)
5102 (when prologue-code `(:prologue-code ,prologue-code))
5103 (when epilogue-code `(:epilogue-code ,epilogue-code))
5104 #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
5108 ;;; Some universal image restore hooks
5109 (with-upgradability ()
5110 (map () 'register-image-restore-hook
5111 '(setup-stdin setup-stdout setup-stderr
5112 setup-command-line-arguments setup-temporary-directory
5114 ;;;; -------------------------------------------------------------------------
5115 ;;;; Support to build (compile and load) Lisp files
5117 (uiop/package:define-package :uiop/lisp-build
5118 (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp
5119 (:use :uiop/common-lisp :uiop/package :uiop/utility
5120 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
5123 #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
5124 #:*output-translation-function*
5125 #:*optimization-settings* #:*previous-optimization-settings*
5126 #:*base-build-directory*
5127 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
5128 #:compile-warned-warning #:compile-failed-warning
5129 #:check-lisp-compile-results #:check-lisp-compile-warnings
5130 #:*uninteresting-conditions* #:*usual-uninteresting-conditions*
5131 #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
5133 #+sbcl #:sb-grovel-unknown-constant-condition
5134 ;; Functions & Macros
5135 #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
5136 #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
5137 #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
5138 #:reify-simple-sexp #:unreify-simple-sexp
5139 #:reify-deferred-warnings #:unreify-deferred-warnings
5140 #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
5141 #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
5142 #:enable-deferred-warnings-check #:disable-deferred-warnings-check
5143 #:current-lisp-file-pathname #:load-pathname
5144 #:lispize-pathname #:compile-file-type #:call-around-hook
5145 #:compile-file* #:compile-file-pathname* #:*compile-check*
5146 #:load* #:load-from-string #:combine-fasls)
5147 (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
5148 (in-package :uiop/lisp-build)
5150 (with-upgradability ()
5151 (defvar *compile-file-warnings-behaviour*
5152 (or #+clisp :ignore :warn)
5153 "How should ASDF react if it encounters a warning when compiling a file?
5154 Valid values are :error, :warn, and :ignore.")
5156 (defvar *compile-file-failure-behaviour*
5157 (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
5158 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
5159 when compiling a file, which includes any non-style-warning warning.
5160 Valid values are :error, :warn, and :ignore.
5161 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
5163 (defvar *base-build-directory* nil
5164 "When set to a non-null value, it should be an absolute directory pathname,
5165 which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE,
5166 what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it.
5167 This can help you produce more deterministic output for FASLs."))
5169 ;;; Optimization settings
5170 (with-upgradability ()
5171 (defvar *optimization-settings* nil
5172 "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
5173 (defvar *previous-optimization-settings* nil
5174 "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
5175 (defparameter +optimization-variables+
5176 ;; TODO: allegro genera corman mcl
5177 (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
5178 #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
5179 #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
5180 ccl::*nx-debug* ccl::*nx-cspeed*)
5181 #+(or cmucl scl) '(c::*default-cookie*)
5183 #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
5184 #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
5185 #+lispworks '(compiler::*optimization-level*)
5186 #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
5187 #+sbcl '(sb-c::*policy*)))
5188 (defun get-optimization-settings ()
5189 "Get current compiler optimization settings, ready to PROCLAIM again"
5190 #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
5191 (warn "~S does not support ~S. Please help me fix that."
5192 'get-optimization-settings (implementation-type))
5193 #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*))
5194 #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl)
5195 (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity)))
5196 #.`(loop #+(or allegro clozure)
5197 ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
5198 #+clozure (ccl:declaration-information 'optimize nil))
5200 ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
5201 :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
5202 #+clisp (gethash x system::*optimize* 1)
5203 #+(or abcl ecl mkcl xcl) (symbol-value v)
5204 #+(or cmucl scl) (slot-value c::*default-cookie*
5205 (case x (compilation-speed 'c::cspeed)
5207 #+lispworks (slot-value compiler::*optimization-level* x)
5208 #+sbcl (sb-c::policy-quality sb-c::*policy* x))
5209 :when y :collect (list x y))))
5210 (defun proclaim-optimization-settings ()
5211 "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
5212 (proclaim `(optimize ,@*optimization-settings*))
5213 (let ((settings (get-optimization-settings)))
5214 (unless (equal *previous-optimization-settings* settings)
5215 (setf *previous-optimization-settings* settings))))
5216 (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
5217 #+(or allegro clasp clisp)
5218 (let ((previous-settings (gensym "PREVIOUS-SETTINGS"))
5219 (reset-settings (gensym "RESET-SETTINGS")))
5220 `(let* ((,previous-settings (get-optimization-settings))
5221 (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings))
5222 ,@(when settings `((proclaim `(optimize ,@,settings))))
5223 (unwind-protect (progn ,@body)
5224 (proclaim `(optimize ,@,reset-settings)))))
5225 #-(or allegro clasp clisp)
5226 `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
5227 ,@(when settings `((proclaim `(optimize ,@,settings))))
5231 ;;; Condition control
5232 (with-upgradability ()
5235 (defun sb-grovel-unknown-constant-condition-p (c)
5236 "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
5238 (and (typep c 'sb-int:simple-style-warning)
5240 "Couldn't grovel for "
5241 (simple-condition-format-control c)
5242 " (unknown to the C compiler)."))))
5243 (deftype sb-grovel-unknown-constant-condition ()
5244 '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
5246 (defvar *usual-uninteresting-conditions*
5248 ;;#+clozure '(ccl:compiler-warning)
5249 #+cmucl '("Deleting unreachable code.")
5250 #+lispworks '("~S being redefined in ~A (previously in ~A)."
5251 "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
5253 '(sb-c::simple-compiler-note
5254 "&OPTIONAL and &KEY found in the same lambda list: ~S"
5255 sb-kernel:undefined-alien-style-warning
5256 sb-grovel-unknown-constant-condition ; defined above.
5257 sb-ext:implicit-generic-function-warning ;; Controversial.
5258 sb-int:package-at-variance
5259 sb-kernel:uninteresting-redefinition
5260 ;; BEWARE: the below four are controversial to include here.
5261 sb-kernel:redefinition-with-defun
5262 sb-kernel:redefinition-with-defgeneric
5263 sb-kernel:redefinition-with-defmethod
5264 sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
5266 (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil)))
5269 '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
5270 "A suggested value to which to set or bind *uninteresting-conditions*.")
5272 (defvar *uninteresting-conditions* '()
5273 "Conditions that may be skipped while compiling or loading Lisp code.")
5274 (defvar *uninteresting-compiler-conditions* '()
5275 "Additional conditions that may be skipped while compiling Lisp code.")
5276 (defvar *uninteresting-loader-conditions*
5278 '("Overwriting already existing readtable ~S." ;; from named-readtables
5279 #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
5280 #+clisp '(clos::simple-gf-replacing-method-warning))
5281 "Additional conditions that may be skipped while loading Lisp code."))
5283 ;;;; ----- Filtering conditions while building -----
5284 (with-upgradability ()
5285 (defun call-with-muffled-compiler-conditions (thunk)
5286 "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
5287 (call-with-muffled-conditions
5288 thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
5289 (defmacro with-muffled-compiler-conditions ((&optional) &body body)
5290 "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
5291 `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
5292 (defun call-with-muffled-loader-conditions (thunk)
5293 "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
5294 (call-with-muffled-conditions
5295 thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
5296 (defmacro with-muffled-loader-conditions ((&optional) &body body)
5297 "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
5298 `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
5301 ;;;; Handle warnings and failures
5302 (with-upgradability ()
5303 (define-condition compile-condition (condition)
5305 :initform nil :reader compile-condition-context-format :initarg :context-format)
5307 :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
5309 :initform nil :reader compile-condition-description :initarg :description))
5310 (:report (lambda (c s)
5311 (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
5312 (or (compile-condition-description c) (type-of c))
5313 (compile-condition-context-format c)
5314 (compile-condition-context-arguments c)))))
5315 (define-condition compile-file-error (compile-condition error) ())
5316 (define-condition compile-warned-warning (compile-condition warning) ())
5317 (define-condition compile-warned-error (compile-condition error) ())
5318 (define-condition compile-failed-warning (compile-condition warning) ())
5319 (define-condition compile-failed-error (compile-condition error) ())
5321 (defun check-lisp-compile-warnings (warnings-p failure-p
5322 &optional context-format context-arguments)
5323 "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
5324 raise an error or warning as appropriate"
5326 (case *compile-file-failure-behaviour*
5327 (:warn (warn 'compile-failed-warning
5328 :description "Lisp compilation failed"
5329 :context-format context-format
5330 :context-arguments context-arguments))
5331 (:error (error 'compile-failed-error
5332 :description "Lisp compilation failed"
5333 :context-format context-format
5334 :context-arguments context-arguments))
5337 (case *compile-file-warnings-behaviour*
5338 (:warn (warn 'compile-warned-warning
5339 :description "Lisp compilation had style-warnings"
5340 :context-format context-format
5341 :context-arguments context-arguments))
5342 (:error (error 'compile-warned-error
5343 :description "Lisp compilation had style-warnings"
5344 :context-format context-format
5345 :context-arguments context-arguments))
5348 (defun check-lisp-compile-results (output warnings-p failure-p
5349 &optional context-format context-arguments)
5350 "Given the results of COMPILE-FILE, raise an error or warning as appropriate"
5352 (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
5353 (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
5356 ;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
5358 ;;; To support an implementation, three functions must be implemented:
5359 ;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
5360 ;;; See their respective docstrings.
5361 (with-upgradability ()
5362 (defun reify-simple-sexp (sexp)
5363 "Given a simple SEXP, return a representation of it as a portable SEXP.
5364 Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
5366 (symbol (reify-symbol sexp))
5367 ((or number character simple-string pathname) sexp)
5368 (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
5369 (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
5371 (defun unreify-simple-sexp (sexp)
5372 "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
5374 ((or symbol number character simple-string pathname) sexp)
5375 (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
5376 ((simple-vector 2) (unreify-symbol sexp))
5377 ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
5381 (defun reify-source-note (source-note)
5383 (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
5384 (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
5385 (declare (ignorable source))
5386 (list :filename filename :start-pos start-pos :end-pos end-pos
5387 #|:source (reify-source-note source)|#))))
5388 (defun unreify-source-note (source-note)
5390 (destructuring-bind (&key filename start-pos end-pos source) source-note
5391 (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
5392 :source (unreify-source-note source)))))
5393 (defun unsymbolify-function-name (name)
5394 (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
5397 (defun symbolify-function-name (name)
5398 (if (and (consp name) (eq (first name) 'setf))
5399 (let ((setfed (second name)))
5400 (gethash setfed ccl::%setf-function-names%))
5402 (defun reify-function-name (function-name)
5403 (let ((name (or (first function-name) ;; defun: extract the name
5404 (let ((sec (second function-name)))
5405 (or (and (atom sec) sec) ; scoped method: drop scope
5406 (first sec)))))) ; method: keep gf name, drop method specializers
5408 (defun unreify-function-name (function-name)
5410 (defun nullify-non-literals (sexp)
5412 ((or number character simple-string symbol pathname) sexp)
5413 (cons (cons (nullify-non-literals (car sexp))
5414 (nullify-non-literals (cdr sexp))))
5416 (defun reify-deferred-warning (deferred-warning)
5417 (with-accessors ((warning-type ccl::compiler-warning-warning-type)
5418 (args ccl::compiler-warning-args)
5419 (source-note ccl:compiler-warning-source-note)
5420 (function-name ccl:compiler-warning-function-name)) deferred-warning
5421 (list :warning-type warning-type :function-name (reify-function-name function-name)
5422 :source-note (reify-source-note source-note)
5423 :args (destructuring-bind (fun &rest more)
5425 (cons (unsymbolify-function-name fun)
5426 (nullify-non-literals more))))))
5427 (defun unreify-deferred-warning (reified-deferred-warning)
5428 (destructuring-bind (&key warning-type function-name source-note args)
5429 reified-deferred-warning
5430 (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
5431 'ccl::compiler-warning)
5432 :function-name (unreify-function-name function-name)
5433 :source-note (unreify-source-note source-note)
5434 :warning-type warning-type
5435 :args (destructuring-bind (fun . more) args
5436 (cons (symbolify-function-name fun) more))))))
5438 (defun reify-undefined-warning (warning)
5439 ;; Extracting undefined-warnings from the compilation-unit
5440 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5442 (c::undefined-warning-kind warning)
5443 (c::undefined-warning-name warning)
5444 (c::undefined-warning-count warning)
5447 ;; the lexenv slot can be ignored for reporting purposes
5448 `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob)
5449 :source ,(c::compiler-error-context-source frob)
5450 :original-source ,(c::compiler-error-context-original-source frob)
5451 :context ,(c::compiler-error-context-context frob)
5452 :file-name ,(c::compiler-error-context-file-name frob) ; a pathname
5453 :file-position ,(c::compiler-error-context-file-position frob) ; an integer
5454 :original-source-path ,(c::compiler-error-context-original-source-path frob)))
5455 (c::undefined-warning-warnings warning))))
5458 (defun reify-undefined-warning (warning)
5459 ;; Extracting undefined-warnings from the compilation-unit
5460 ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
5462 (sb-c::undefined-warning-kind warning)
5463 (sb-c::undefined-warning-name warning)
5464 (sb-c::undefined-warning-count warning)
5465 ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we
5466 ;; handle deferred warnings must change... TODO: when enough time has
5467 ;; gone by, just assume all versions of SBCL are adequately
5468 ;; up-to-date, and cut this material.[2018/05/30:rpg]
5471 ;; the lexenv slot can be ignored for reporting purposes
5473 #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
5474 ,@`(:enclosing-source
5475 ,(sb-c::compiler-error-context-enclosing-source frob)
5477 ,(sb-c::compiler-error-context-source frob)
5479 ,(sb-c::compiler-error-context-original-source frob))
5480 #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c)
5481 ,@ `(:%enclosing-source
5482 ,(sb-c::compiler-error-context-enclosing-source frob)
5484 ,(sb-c::compiler-error-context-source frob)
5486 ,(sb-c::compiler-error-context-original-form frob))
5487 :context ,(sb-c::compiler-error-context-context frob)
5488 :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
5489 :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
5490 :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
5491 (sb-c::undefined-warning-warnings warning))))
5493 (defun reify-deferred-warnings ()
5494 "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
5495 using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
5496 WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
5498 (list :functions-defined excl::.functions-defined.
5499 :functions-called excl::.functions-called.)
5501 (mapcar 'reify-deferred-warning
5502 (if-let (dw ccl::*outstanding-deferred-warnings*)
5503 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
5504 (ccl::deferred-warnings.warnings mdw))))
5506 (when lisp::*in-compilation-unit*
5507 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5508 `(,@(when c::*undefined-warnings*
5509 `((c::*undefined-warnings*
5510 ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*))))
5511 ,@(loop :for what :in '(c::*compiler-error-count*
5512 c::*compiler-warning-count*
5513 c::*compiler-note-count*)
5514 :for value = (symbol-value what)
5516 :collect `(,what . ,value))))
5518 (when sb-c::*in-compilation-unit*
5519 ;; Try to send nothing through the pipe if nothing needs to be accumulated
5520 `(,@(when sb-c::*undefined-warnings*
5521 `((sb-c::*undefined-warnings*
5522 ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*))))
5523 ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count*
5524 sb-c::*compiler-error-count*
5525 sb-c::*compiler-warning-count*
5526 sb-c::*compiler-style-warning-count*
5527 sb-c::*compiler-note-count*)
5528 :for value = (symbol-value what)
5530 :collect `(,what . ,value)))))
5532 (defun unreify-deferred-warnings (reified-deferred-warnings)
5533 "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding
5534 deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT.
5535 Handle any warning that has been resolved already,
5536 such as an undefined function that has been defined since.
5537 One of three functions required for deferred-warnings support in ASDF."
5538 (declare (ignorable reified-deferred-warnings))
5540 (destructuring-bind (&key functions-defined functions-called)
5541 reified-deferred-warnings
5542 (setf excl::.functions-defined.
5543 (append functions-defined excl::.functions-defined.)
5544 excl::.functions-called.
5545 (append functions-called excl::.functions-called.)))
5547 (let ((dw (or ccl::*outstanding-deferred-warnings*
5548 (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t)))))
5549 (appendf (ccl::deferred-warnings.warnings dw)
5550 (mapcar 'unreify-deferred-warning reified-deferred-warnings)))
5552 (dolist (item reified-deferred-warnings)
5553 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5554 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5555 ;; For everything else, it's an integer.
5556 (destructuring-bind (symbol . adjustment) item
5558 ((c::*undefined-warnings*)
5559 (setf c::*undefined-warnings*
5562 (destructuring-bind (kind name count . rest) stuff
5563 (unless (case kind (:function (fboundp name)))
5565 (c::make-undefined-warning
5570 (mapcar #'(lambda (x)
5571 (apply #'c::make-compiler-error-context x))
5574 c::*undefined-warnings*)))
5576 (set symbol (+ (symbol-value symbol) adjustment))))))
5578 (dolist (item reified-deferred-warnings)
5579 ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol.
5580 ;; For *undefined-warnings*, the adjustment is a list of initargs.
5581 ;; For everything else, it's an integer.
5582 (destructuring-bind (symbol . adjustment) item
5584 ((sb-c::*undefined-warnings*)
5585 (setf sb-c::*undefined-warnings*
5588 (destructuring-bind (kind name count . rest) stuff
5589 (unless (case kind (:function (fboundp name)))
5591 (sb-c::make-undefined-warning
5596 (mapcar #'(lambda (x)
5597 (apply #'sb-c::make-compiler-error-context x))
5600 sb-c::*undefined-warnings*)))
5602 (set symbol (+ (symbol-value symbol) adjustment)))))))
5604 (defun reset-deferred-warnings ()
5605 "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT.
5606 One of three functions required for deferred-warnings support in ASDF."
5608 (setf excl::.functions-defined. nil
5609 excl::.functions-called. nil)
5611 (if-let (dw ccl::*outstanding-deferred-warnings*)
5612 (let ((mdw (ccl::ensure-merged-deferred-warnings dw)))
5613 (setf (ccl::deferred-warnings.warnings mdw) nil)))
5615 (when lisp::*in-compilation-unit*
5616 (setf c::*undefined-warnings* nil
5617 c::*compiler-error-count* 0
5618 c::*compiler-warning-count* 0
5619 c::*compiler-note-count* 0))
5621 (when sb-c::*in-compilation-unit*
5622 (setf sb-c::*undefined-warnings* nil
5623 sb-c::*aborted-compilation-unit-count* 0
5624 sb-c::*compiler-error-count* 0
5625 sb-c::*compiler-warning-count* 0
5626 sb-c::*compiler-style-warning-count* 0
5627 sb-c::*compiler-note-count* 0)))
5629 (defun save-deferred-warnings (warnings-file)
5630 "Save forward reference conditions so they may be issued at a latter time,
5631 possibly in a different process."
5632 (with-open-file (s warnings-file :direction :output :if-exists :supersede
5633 :element-type *default-stream-element-type*
5634 :external-format *utf-8-external-format*)
5635 (with-safe-io-syntax ()
5636 (let ((*read-eval* t))
5637 (write (reify-deferred-warnings) :stream s :pretty t :readably t))
5640 (defun warnings-file-type (&optional implementation-type)
5641 "The pathname type for warnings files on given IMPLEMENTATION-TYPE,
5642 where NIL designates the current one"
5643 (case (or implementation-type *implementation-type*)
5644 ((:acl :allegro) "allegro-warnings")
5645 ;;((:clisp) "clisp-warnings")
5646 ((:cmu :cmucl) "cmucl-warnings")
5647 ((:sbcl) "sbcl-warnings")
5648 ((:clozure :ccl) "ccl-warnings")
5649 ((:scl) "scl-warnings")))
5651 (defvar *warnings-file-type* nil
5652 "Pathname type for warnings files, or NIL if disabled")
5654 (defun enable-deferred-warnings-check ()
5655 "Enable the saving of deferred warnings"
5656 (setf *warnings-file-type* (warnings-file-type)))
5658 (defun disable-deferred-warnings-check ()
5659 "Disable the saving of deferred warnings"
5660 (setf *warnings-file-type* nil))
5662 (defun warnings-file-p (file &optional implementation-type)
5663 "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
5664 If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
5665 (if-let (type (if implementation-type
5666 (warnings-file-type implementation-type)
5667 *warnings-file-type*))
5668 (equal (pathname-type file) type)))
5670 (defun check-deferred-warnings (files &optional context-format context-arguments)
5671 "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS,
5672 re-intern and raise any warnings that are still meaningful."
5673 (let ((file-errors nil)
5677 ((warning #'(lambda (c)
5679 (unless (typep c 'style-warning)
5680 (setf failure-p t)))))
5681 (with-compilation-unit (:override t)
5682 (reset-deferred-warnings)
5683 (dolist (file files)
5684 (unreify-deferred-warnings
5686 (with-safe-io-syntax ()
5687 (let ((*read-eval* t))
5688 (read-file-form file)))
5690 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
5691 (push c file-errors)
5693 (dolist (error file-errors) (error error))
5694 (check-lisp-compile-warnings
5695 (or failure-p warnings-p) failure-p context-format context-arguments)))
5698 Mini-guide to adding support for deferred warnings on an implementation.
5700 First, look at what such a warning looks like:
5704 (and (eval '(lambda () (some-undefined-function))) nil)
5707 Then you can grep for the condition type in your compiler sources
5708 and see how to catch those that have been deferred,
5709 and/or read, clear and restore the deferred list.
5712 (macroexpand-1 '(with-compilation-unit () foo))
5715 (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring)
5716 "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
5717 and save those warnings to the given file for latter use,
5718 possibly in a different process. Otherwise just call THUNK."
5719 (declare (ignorable source-namestring))
5721 (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring)
5723 (let (#+sbcl (sb-c::*undefined-warnings* nil))
5724 (multiple-value-prog1
5726 (save-deferred-warnings warnings-file)))
5727 (reset-deferred-warnings)))
5730 (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body)
5731 "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
5732 `(call-with-saved-deferred-warnings
5733 #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring)))
5737 (with-upgradability ()
5738 (defun current-lisp-file-pathname ()
5739 "Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
5740 (or *compile-file-pathname* *load-pathname*))
5742 (defun load-pathname ()
5743 "Portably return the LOAD-PATHNAME of the current source file or fasl.
5744 May return a relative pathname."
5745 *load-pathname*) ;; magic no longer needed for GCL.
5747 (defun lispize-pathname (input-file)
5748 "From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
5749 (make-pathname :type "lisp" :defaults input-file))
5751 (defun compile-file-type (&rest keys)
5752 "pathname TYPE for lisp FASt Loading files"
5753 (declare (ignorable keys))
5754 #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp")))
5755 #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
5757 (defun call-around-hook (hook function)
5758 "Call a HOOK around the execution of FUNCTION"
5759 (call-function (or hook 'funcall) function))
5761 (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
5762 "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
5764 (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format
5765 ,@(unless output-file '(:output-file))) keys)))
5766 (if (absolute-pathname-p output-file)
5767 ;; what cfp should be doing, w/ mp* instead of mp
5768 (let* ((type (pathname-type (apply 'compile-file-type keys)))
5769 (defaults (make-pathname
5770 :type type :defaults (merge-pathnames* input-file))))
5771 (merge-pathnames* output-file defaults))
5772 (funcall *output-translation-function*
5773 (apply 'compile-file-pathname input-file keys)))))
5775 (defvar *compile-check* nil
5776 "A hook for user-defined compile-time invariants")
5778 (defun compile-file* (input-file &rest keys
5779 &key (compile-check *compile-check*) output-file warnings-file
5780 #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl
5782 "This function provides a portable wrapper around COMPILE-FILE.
5783 It ensures that the OUTPUT-FILE value is only returned and
5784 the file only actually created if the compilation was successful,
5785 even though your implementation may not do that. It also checks an optional
5786 user-provided consistency function COMPILE-CHECK to determine success;
5787 it will call this function if not NIL at the end of the compilation
5788 with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE
5789 where TMP-FILE is the name of a temporary output-file.
5790 It also checks two flags (with legacy british spelling from ASDF1),
5791 *COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR*
5792 with appropriate implementation-dependent defaults,
5793 and if a failure (respectively warnings) are reported by COMPILE-FILE,
5794 it will consider that an error unless the respective behaviour flag
5795 is one of :SUCCESS :WARN :IGNORE.
5796 If WARNINGS-FILE is defined, deferred warnings are saved to that file.
5797 On ECL or MKCL, it creates both the linkable object and loadable fasl files.
5798 On implementations that erroneously do not recognize standard keyword arguments,
5799 it will filter them appropriately."
5801 (when (and object-file (equal (compile-file-type) (pathname object-file)))
5802 (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%"
5803 'compile-file* output-file object-file)
5804 (rotatef output-file object-file))
5805 (let* ((keywords (remove-plist-keys
5806 `(:output-file :compile-check :warnings-file
5807 #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys))
5810 (apply 'compile-file-pathname* input-file :output-file output-file keywords)))
5811 (physical-output-file (physicalize-pathname output-file))
5814 (unless (use-ecl-byte-compiler-p)
5816 #+ecl (compile-file-pathname output-file :type :object)
5817 #+clasp (compile-file-pathname output-file :output-type :object))))
5821 (compile-file-pathname output-file :fasl-p nil)))
5822 (tmp-file (tmpize-pathname physical-output-file))
5824 (tmp-object-file (compile-file-pathname tmp-file :output-type :object))
5826 (cfasl-file (etypecase emit-cfasl
5828 ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file))
5829 (string (parse-namestring emit-cfasl))
5830 (pathname emit-cfasl)))
5832 (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
5834 (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
5835 (multiple-value-bind (output-truename warnings-p failure-p)
5836 (with-enough-pathname (input-file :defaults *base-build-directory*)
5837 (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file))
5838 (with-muffled-compiler-conditions ()
5839 (or #-(or clasp ecl mkcl)
5840 (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
5841 (apply 'compile-file input-file :output-file tmp-file
5842 #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
5844 #+ecl (apply 'compile-file input-file :output-file
5846 (list* object-file :system-p t keywords)
5847 (list* tmp-file keywords)))
5848 #+clasp (apply 'compile-file input-file :output-file
5850 (list* tmp-object-file :output-type :object #|:system-p t|# keywords)
5851 (list* tmp-file keywords)))
5852 #+mkcl (apply 'compile-file input-file
5853 :output-file object-file :fasl-p nil keywords)))))
5855 ((and output-truename
5856 (flet ((check-flag (flag behaviour)
5857 (or (not flag) (member behaviour '(:success :warn :ignore)))))
5858 (and (check-flag failure-p *compile-file-failure-behaviour*)
5859 (check-flag warnings-p *compile-file-warnings-behaviour*)))
5861 #+(or clasp ecl mkcl)
5862 (when (and #+(or clasp ecl) object-file)
5863 (setf output-truename
5864 (compiler::build-fasl tmp-file
5865 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file))))
5866 (or (not compile-check)
5867 (apply compile-check input-file
5868 :output-file output-truename
5870 (delete-file-if-exists physical-output-file)
5871 (when output-truename
5872 ;; see CLISP bug 677
5875 (setf tmp-lib (make-pathname :type "lib" :defaults output-truename))
5876 (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file)))
5877 (rename-file-overwriting-target tmp-lib lib-file))
5878 #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
5881 ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now
5883 (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf")))
5884 (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf"))))
5885 (when (probe-file temp-dwarf)
5886 (rename-file-overwriting-target temp-dwarf target-dwarf)))
5887 ;;; need to rename the bc or ll file as well or test-bundle.script fails
5888 ;;; They might not exist with parallel compilation
5889 (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode))
5890 (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode)))
5891 (when (probe-file bitcode-src)
5892 (rename-file-overwriting-target bitcode-src bitcode-target)))
5893 (rename-file-overwriting-target tmp-object-file object-file))
5894 (rename-file-overwriting-target output-truename physical-output-file)
5895 (setf output-truename (truename physical-output-file)))
5896 #+clasp (delete-file-if-exists tmp-file)
5897 #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677
5898 (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup
5899 (t ;; error or failed check
5900 (delete-file-if-exists output-truename)
5901 #+clisp (delete-file-if-exists tmp-lib)
5902 #+sbcl (delete-file-if-exists tmp-cfasl)
5903 (setf output-truename nil)))
5904 (values output-truename warnings-p failure-p))))
5906 (defun load* (x &rest keys &key &allow-other-keys)
5907 "Portable wrapper around LOAD that properly handles loading from a stream."
5908 (with-muffled-loader-conditions ()
5909 (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t))
5911 ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream)
5912 (apply 'load x keys))
5913 ;; Genera can't load from a string-input-stream
5914 ;; ClozureCL 1.6 can only load from file input stream
5915 ;; Allegro 5, I don't remember but it must have been broken when I tested.
5916 #+(or allegro clozure genera)
5917 (stream ;; make do this way
5918 (let ((*package* *package*)
5919 (*readtable* *readtable*)
5920 (*load-pathname* nil)
5921 (*load-truename* nil))
5922 (eval-input x)))))))
5924 (defun load-from-string (string)
5925 "Portably read and evaluate forms from a STRING."
5926 (with-input-from-string (s string) (load* s))))
5928 ;;; Links FASLs together
5929 (with-upgradability ()
5930 (defun combine-fasls (inputs output)
5931 "Combine a list of FASLs INPUTS into a single FASL OUTPUT"
5932 #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl)
5933 (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output)
5934 #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
5935 #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output)
5936 #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
5941 (loop :for i :in inputs
5943 :for f = (add-pathname-suffix
5944 output (format nil "-FASL~D" n))
5947 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))
5948 (eval `(scm:defsystem :fasls-to-concatenate
5949 (:default-pathname ,(pathname-directory-pathname output))
5951 ,(loop :for f :in (reverse fasls)
5952 :collect `(,(namestring f) :load-only t))))
5953 (scm:concatenate-system output :fasls-to-concatenate :force t))
5954 (loop :for f :in fasls :do (ignore-errors (delete-file f)))
5955 (ignore-errors (lispworks:delete-system :fasls-to-concatenate))))))
5956 ;;;; -------------------------------------------------------------------------
5957 ;;;; launch-program - semi-portably spawn asynchronous subprocesses
5959 (uiop/package:define-package :uiop/launch-program
5960 (:use :uiop/common-lisp :uiop/package :uiop/utility
5961 :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream
5964 ;;; Escaping the command invocation madness
5965 #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
5966 #:escape-windows-token #:escape-windows-command
5967 #:escape-shell-token #:escape-shell-command
5968 #:escape-token #:escape-command
5972 #:close-streams #:process-alive-p #:terminate-process #:wait-process
5974 #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid))
5975 (in-package :uiop/launch-program)
5977 ;;;; ----- Escaping strings for the shell -----
5978 (with-upgradability ()
5979 (defun requires-escaping-p (token &key good-chars bad-chars)
5980 "Does this token require escaping, given the specification of
5981 either good chars that don't need escaping or bad chars that do need escaping,
5982 as either a recognizing function or a sequence of characters."
5985 ((and good-chars bad-chars)
5986 (parameter-error "~S: only one of good-chars and bad-chars can be provided"
5987 'requires-escaping-p))
5988 ((typep good-chars 'function)
5989 (complement good-chars))
5990 ((typep bad-chars 'function)
5992 ((and good-chars (typep good-chars 'sequence))
5993 #'(lambda (c) (not (find c good-chars))))
5994 ((and bad-chars (typep bad-chars 'sequence))
5995 #'(lambda (c) (find c bad-chars)))
5996 (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p)))
5999 (defun escape-token (token &key stream quote good-chars bad-chars escaper)
6000 "Call the ESCAPER function on TOKEN string if it needs escaping as per
6001 REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
6002 using STREAM as output (or returning result as a string if NIL)"
6003 (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
6004 (with-output (stream)
6005 (apply escaper token stream (when quote `(:quote ,quote))))
6006 (output-string token stream)))
6008 (defun escape-windows-token-within-double-quotes (x &optional s)
6009 "Escape a string token X within double-quotes
6010 for use within a MS Windows command-line, outputing to S."
6011 (labels ((issue (c) (princ c s))
6012 (issue-backslash (n) (loop :repeat n :do (issue #\\))))
6014 :initially (issue #\") :finally (issue #\")
6015 :with l = (length x) :with i = 0
6016 :for i+1 = (1+ i) :while (< i l) :do
6018 ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
6020 (let* ((j (and (< i+1 l) (position-if-not
6021 #'(lambda (c) (eql c #\\)) x :start i+1)))
6025 (issue-backslash (* 2 n)) (setf i l))
6026 ((and (< j l) (eql (char x j) #\"))
6027 (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
6029 (issue-backslash n) (setf i j)))))
6031 (issue (char x i)) (setf i i+1))))))
6033 (defun easy-windows-character-p (x)
6034 "Is X an \"easy\" character that does not require quoting by the shell?"
6035 (or (alphanumericp x) (find x "+-_.,@:/=")))
6037 (defun escape-windows-token (token &optional s)
6038 "Escape a string TOKEN within double-quotes if needed
6039 for use within a MS Windows command-line, outputing to S."
6040 (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil
6041 :escaper 'escape-windows-token-within-double-quotes))
6043 (defun escape-sh-token-within-double-quotes (x s &key (quote t))
6044 "Escape a string TOKEN within double-quotes
6045 for use within a POSIX Bourne shell, outputing to S;
6046 omit the outer double-quotes if key argument :QUOTE is NIL"
6047 (when quote (princ #\" s))
6048 (loop :for c :across x :do
6049 (when (find c "$`\\\"") (princ #\\ s))
6051 (when quote (princ #\" s)))
6053 (defun easy-sh-character-p (x)
6054 "Is X an \"easy\" character that does not require quoting by the shell?"
6055 (or (alphanumericp x) (find x "+-_.,%@:/=")))
6057 (defun escape-sh-token (token &optional s)
6058 "Escape a string TOKEN within double-quotes if needed
6059 for use within a POSIX Bourne shell, outputing to S."
6060 (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p
6061 :escaper 'escape-sh-token-within-double-quotes))
6063 (defun escape-shell-token (token &optional s)
6064 "Escape a token for the current operating system shell"
6066 ((os-unix-p) (escape-sh-token token s))
6067 ((os-windows-p) (escape-windows-token token s))))
6069 (defun escape-command (command &optional s
6070 (escaper 'escape-shell-token))
6071 "Given a COMMAND as a list of tokens, return a string of the
6072 spaced, escaped tokens, using ESCAPER to escape."
6074 (string (output-string command s))
6075 (list (with-output (s)
6076 (loop :for first = t :then nil :for token :in command :do
6077 (unless first (princ #\space s))
6078 (funcall escaper token s))))))
6080 (defun escape-windows-command (command &optional s)
6081 "Escape a list of command-line arguments into a string suitable for parsing
6082 by CommandLineToArgv in MS Windows"
6083 ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
6084 ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
6085 (escape-command command s 'escape-windows-token))
6087 (defun escape-sh-command (command &optional s)
6088 "Escape a list of command-line arguments into a string suitable for parsing
6089 by /bin/sh in POSIX"
6090 (escape-command command s 'escape-sh-token))
6092 (defun escape-shell-command (command &optional stream)
6093 "Escape a command for the current operating system's shell"
6094 (escape-command command stream 'escape-shell-token)))
6097 (with-upgradability ()
6098 ;;; Internal helpers for run-program
6099 (defun %normalize-io-specifier (specifier &optional role)
6100 "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent
6101 argument to pass to the internal RUN-PROGRAM"
6102 (declare (ignorable role))
6104 (null (or #+(or allegro lispworks) (null-device-pathname)))
6105 (string (parse-native-namestring specifier))
6106 (pathname specifier)
6108 ((eql :stream) :stream)
6110 #+(or allegro lispworks) nil
6112 #+(or abcl clasp clozure cmucl ecl mkcl sbcl scl) t
6113 #-(or abcl clasp clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp)
6114 (not-implemented-error :interactive-output
6115 "On this lisp implementation, cannot interpret ~a value of ~a"
6118 (cond ((eq role :error-output)
6119 #+(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
6121 #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
6122 (not-implemented-error :error-output-redirect
6123 "Can't send ~a to ~a on this lisp implementation."
6125 (t (parameter-error "~S IO specifier invalid for ~S" specifier role))))
6127 #+ (or lispworks abcl)
6128 (not-implemented-error :interactive-output
6129 "On this lisp implementation, cannot interpret ~a value of ~a"
6131 #- (or lispworks abcl)
6132 (cond ((eq role :error-output) *error-output*)
6133 ((eq role :output) #+lispworks *terminal-io* #-lispworks *standard-output*)
6134 ((eq role :input) *standard-input*)))
6136 (parameter-error "Incorrect I/O specifier ~S for ~S"
6139 (defun %interactivep (input output error-output)
6140 (member :interactive (list input output error-output)))
6142 (defun %signal-to-exit-code (signum)
6145 (defun %code-to-status (exit-code signal-code)
6146 (cond ((null exit-code) :running)
6147 ((null signal-code) (values :exited exit-code))
6148 (t (values :signaled signal-code))))
6151 (defun %mkcl-signal-to-number (signal)
6153 (symbol-value (find-symbol signal :mk-unix)))
6155 (defclass process-info ()
6156 (;; The process field is highly platform-, implementation-, and
6157 ;; even version-dependent.
6158 ;; Prior to LispWorks 7, the only information that
6159 ;; `sys:run-shell-command` with `:wait nil` was certain to return
6160 ;; is a PID (e.g. when all streams are nil), hence we stored it
6161 ;; and used `sys:pid-exit-status` to obtain an exit status
6162 ;; later. That is still what we do.
6163 ;; From LispWorks 7 on, if `sys:run-shell-command` does not
6164 ;; return a proper stream, we are instead given a dummy stream.
6165 ;; We can thus always store a stream and use
6166 ;; `sys:pipe-exit-status` to obtain an exit status later.
6167 ;; The advantage of dealing with streams instead of PID is the
6168 ;; availability of functions like `sys:pipe-kill-process`.
6169 (process :initform nil)
6170 (input-stream :initform nil)
6171 (output-stream :initform nil)
6172 (bidir-stream :initform nil)
6173 (error-output-stream :initform nil)
6174 ;; For backward-compatibility, to maintain the property (zerop
6175 ;; exit-code) <-> success, an exit in response to a signal is
6176 ;; encoded as 128+signum.
6177 (exit-code :initform nil)
6178 ;; If the platform allows it, distinguish exiting with a code
6179 ;; >128 from exiting in response to a signal by setting this code
6180 (signal-code :initform nil))
6181 (:documentation "This class should be treated as opaque by programmers, except for the
6182 exported PROCESS-INFO-* functions. It should never be directly instantiated by
6183 MAKE-INSTANCE. Primarily, it is being made available to enable type-checking."))
6185 ;;;---------------------------------------------------------------------------
6186 ;;; The following two helper functions take care of handling the IF-EXISTS and
6187 ;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the
6188 ;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master
6189 ;;; function to treat input and output files unconditionally for reading and
6191 ;;;---------------------------------------------------------------------------
6193 (defun %handle-if-exists (file if-exists)
6194 (when (or (stringp file) (pathnamep file))
6196 ((:append :supersede :error)
6197 (with-open-file (dummy file :direction :output :if-exists if-exists)
6198 (declare (ignorable dummy)))))))
6200 (defun %handle-if-does-not-exist (file if-does-not-exist)
6201 (when (or (stringp file) (pathnamep file))
6202 (ecase if-does-not-exist
6204 (with-open-file (dummy file :direction :probe
6205 :if-does-not-exist if-does-not-exist)
6206 (declare (ignorable dummy)))))))
6208 (defun process-info-error-output (process-info)
6209 (slot-value process-info 'error-output-stream))
6210 (defun process-info-input (process-info)
6211 (or (slot-value process-info 'bidir-stream)
6212 (slot-value process-info 'input-stream)))
6213 (defun process-info-output (process-info)
6214 (or (slot-value process-info 'bidir-stream)
6215 (slot-value process-info 'output-stream)))
6217 (defun process-info-pid (process-info)
6218 (let ((process (slot-value process-info 'process)))
6219 (declare (ignorable process))
6220 #+abcl (symbol-call :sys :process-pid process)
6222 #+clasp (if (find-symbol* '#:external-process-pid :ext nil)
6223 (symbol-call :ext '#:external-process-pid process)
6224 (not-implemented-error 'process-info-pid))
6225 #+clozure (ccl:external-process-id process)
6226 #+ecl (ext:external-process-pid process)
6227 #+(or cmucl scl) (ext:process-pid process)
6228 #+lispworks7+ (sys:pipe-pid process)
6229 #+(and lispworks (not lispworks7+)) process
6230 #+mkcl (mkcl:process-id process)
6231 #+sbcl (sb-ext:process-pid process)
6232 #-(or abcl allegro clasp clozure cmucl ecl mkcl lispworks sbcl scl)
6233 (not-implemented-error 'process-info-pid)))
6235 (defun %process-status (process-info)
6236 (if-let (exit-code (slot-value process-info 'exit-code))
6237 (return-from %process-status
6238 (if-let (signal-code (slot-value process-info 'signal-code))
6239 (values :signaled signal-code)
6240 (values :exited exit-code))))
6241 #-(or allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
6242 (not-implemented-error '%process-status)
6243 (if-let (process (slot-value process-info 'process))
6244 (multiple-value-bind (status code)
6246 #+allegro (multiple-value-bind (exit-code pid signal-code)
6247 (sys:reap-os-subprocess :pid process :wait nil)
6249 (%code-to-status exit-code signal-code))
6250 #+clasp (if (find-symbol* '#:external-process-status :ext nil)
6251 (symbol-call :ext '#:external-process-status process)
6252 (not-implemented-error '%process-status))
6253 #+clozure (ccl:external-process-status process)
6254 #+(or cmucl scl) (let ((status (ext:process-status process)))
6255 (if (member status '(:exited :signaled))
6256 ;; Calling ext:process-exit-code on
6257 ;; processes that are still alive
6258 ;; yields an undefined result
6259 (values status (ext:process-exit-code process))
6261 #+ecl (ext:external-process-status process)
6263 ;; a signal is only returned on LispWorks 7+
6264 (multiple-value-bind (exit-code signal-code)
6266 #+lispworks7+ :pipe-exit-status
6267 #-lispworks7+ :pid-exit-status
6269 (%code-to-status exit-code signal-code))
6270 #+mkcl (let ((status (mk-ext:process-status process)))
6271 (if (eq status :exited)
6272 ;; Only call mk-ext:process-exit-code when
6273 ;; necessary since it leads to another waitpid()
6274 (let ((code (mk-ext:process-exit-code process)))
6276 (values :signaled (%mkcl-signal-to-number code))
6277 (values :exited code)))
6279 #+sbcl (let ((status (sb-ext:process-status process)))
6280 (if (eq status :running)
6282 ;; sb-ext:process-exit-code can also be
6283 ;; called for stopped processes to determine
6284 ;; the signal that stopped them
6285 (values status (sb-ext:process-exit-code process)))))
6287 (:exited (setf (slot-value process-info 'exit-code) code))
6288 (:signaled (let ((%code (%signal-to-exit-code code)))
6289 (setf (slot-value process-info 'exit-code) %code
6290 (slot-value process-info 'signal-code) code))))
6292 (values status code)
6295 (defun process-alive-p (process-info)
6296 "Check if a process has yet to exit."
6297 (unless (slot-value process-info 'exit-code)
6298 #+abcl (sys:process-alive-p (slot-value process-info 'process))
6299 #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process))
6300 #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process))
6301 #-(or abcl cmucl sbcl scl) (find (%process-status process-info)
6302 '(:running :stopped :continued :resumed))))
6304 (defun wait-process (process-info)
6305 "Wait for the process to terminate, if it is still running.
6306 Otherwise, return immediately. An exit code (a number) will be
6307 returned, with 0 indicating success, and anything else indicating
6308 failure. If the process exits after receiving a signal, the exit code
6309 will be the sum of 128 and the (positive) numeric signal code. A second
6310 value may be returned in this case: the numeric signal code itself.
6311 Any asynchronously spawned process requires this function to be run
6312 before it is garbage-collected in order to free up resources that
6313 might otherwise be irrevocably lost."
6314 (if-let (exit-code (slot-value process-info 'exit-code))
6315 (if-let (signal-code (slot-value process-info 'signal-code))
6316 (values exit-code signal-code)
6318 (let ((process (slot-value process-info 'process)))
6319 #-(or abcl allegro clasp clozure cmucl ecl lispworks mkcl sbcl scl)
6320 (not-implemented-error 'wait-process)
6323 #+clozure (ccl::external-process-wait process)
6324 #+(or cmucl scl) (ext:process-wait process)
6325 #+sbcl (sb-ext:process-wait process)
6326 ;; 2- extract result
6327 (multiple-value-bind (exit-code signal-code)
6329 #+abcl (sys:process-wait process)
6330 #+allegro (multiple-value-bind (exit-code pid signal)
6331 (sys:reap-os-subprocess :pid process :wait t)
6333 (values exit-code signal))
6334 #+clasp (if (find-symbol* '#:external-process-wait :ext nil)
6335 (multiple-value-bind (status code)
6336 (symbol-call :ext '#:external-process-wait process t)
6337 (if (eq status :signaled)
6340 (not-implemented-error 'wait-process))
6341 #+clozure (multiple-value-bind (status code)
6342 (ccl:external-process-status process)
6343 (if (eq status :signaled)
6346 #+(or cmucl scl) (let ((status (ext:process-status process))
6347 (code (ext:process-exit-code process)))
6348 (if (eq status :signaled)
6351 #+ecl (multiple-value-bind (status code)
6352 (ext:external-process-wait process t)
6353 (if (eq status :signaled)
6356 #+lispworks (symbol-call :sys
6357 #+lispworks7+ :pipe-exit-status
6358 #-lispworks7+ :pid-exit-status
6360 #+mkcl (let ((code (mkcl:join-process process)))
6362 (values nil (%mkcl-signal-to-number code))
6364 #+sbcl (let ((status (sb-ext:process-status process))
6365 (code (sb-ext:process-exit-code process)))
6366 (if (eq status :signaled)
6370 (let ((%exit-code (%signal-to-exit-code signal-code)))
6371 (setf (slot-value process-info 'exit-code) %exit-code
6372 (slot-value process-info 'signal-code) signal-code)
6373 (values %exit-code signal-code))
6374 (progn (setf (slot-value process-info 'exit-code) exit-code)
6377 ;; WARNING: For signals other than SIGTERM and SIGKILL this may not
6378 ;; do what you expect it to. Sending SIGSTOP to a process spawned
6379 ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used
6380 ;; to run the command (via `sh -c command`) but not the actual
6383 (defun %posix-send-signal (process-info signal)
6384 #+allegro (excl.osi:kill (slot-value process-info 'process) signal)
6385 #+clozure (ccl:signal-external-process (slot-value process-info 'process)
6386 signal :error-if-exited nil)
6387 #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal)
6388 #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal)
6389 #-(or allegro clozure cmucl sbcl scl)
6390 (if-let (pid (process-info-pid process-info))
6391 (symbol-call :uiop :run-program
6392 (format nil "kill -~a ~a" signal pid) :ignore-error-status t)))
6394 ;;; this function never gets called on Windows, but the compiler cannot tell
6395 ;;; that. [2016/09/25:rpg]
6397 (defun %posix-send-signal (process-info signal)
6398 (declare (ignore process-info signal))
6401 (defun terminate-process (process-info &key urgent)
6402 "Cause the process to exit. To that end, the process may or may
6403 not be sent a signal, which it will find harder (or even impossible)
6404 to ignore if URGENT is T. On some platforms, it may also be subject to
6406 (declare (ignorable urgent))
6407 #+abcl (sys:process-kill (slot-value process-info 'process))
6408 ;; On ECL, this will only work on versions later than 2016-09-06,
6409 ;; but we still want to compile on earlier versions, so we use symbol-call
6410 #+(or clasp ecl) (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent)
6411 #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process))
6412 #+mkcl (mk-ext:terminate-process (slot-value process-info 'process)
6414 #-(or abcl clasp ecl lispworks7+ mkcl)
6416 ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15)))
6417 ((os-windows-p) (if-let (pid (process-info-pid process-info))
6418 (symbol-call :uiop :run-program
6419 (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid)
6420 :ignore-error-status t)))
6421 (t (not-implemented-error 'terminate-process))))
6423 (defun close-streams (process-info)
6424 "Close any stream that the process might own. Needs to be run
6425 whenever streams were requested by passing :stream to :input, :output,
6428 (cons (slot-value process-info 'error-output-stream)
6429 (if-let (bidir-stream (slot-value process-info 'bidir-stream))
6431 (list (slot-value process-info 'input-stream)
6432 (slot-value process-info 'output-stream)))))
6433 (when stream (close stream))))
6435 (defun launch-program (command &rest keys
6437 input (if-input-does-not-exist :error)
6438 output (if-output-exists :supersede)
6439 error-output (if-error-output-exists :supersede)
6440 (element-type #-clozure *default-stream-element-type*
6441 #+clozure 'character)
6442 (external-format *utf-8-external-format*)
6444 #+allegro separate-streams
6446 "Launch program specified by COMMAND,
6447 either a list of strings specifying a program and list of arguments,
6448 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on
6449 Windows) _asynchronously_.
6451 If OUTPUT is a pathname, a string designating a pathname, or NIL (the
6452 default) designating the null device, the file at that path is used as
6454 If it's :INTERACTIVE, output is inherited from the current process;
6455 beware that this may be different from your *STANDARD-OUTPUT*, and
6456 under SLIME will be on your *inferior-lisp* buffer. If it's T, output
6457 goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new
6458 stream will be made available that can be accessed via
6459 PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value
6460 that the underlying lisp implementation knows how to handle.
6462 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
6463 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
6464 default). The meaning of these values and their effect on the case
6465 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
6466 to OPEN with :DIRECTION :OUTPUT.
6468 ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*,
6469 :OUTPUT means redirecting the error output to the output stream,
6470 and :STREAM causes a stream to be made available via
6471 PROCESS-INFO-ERROR-OUTPUT.
6473 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
6474 affects ERROR-OUTPUT rather than OUTPUT.
6476 INPUT is similar to OUTPUT, except that T designates the
6477 *STANDARD-INPUT* and a stream requested through the :STREAM keyword
6478 would be available through PROCESS-INFO-INPUT.
6480 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
6481 or a pathname, can take the values :CREATE and :ERROR (the
6482 default). The meaning of these values is analogous to the
6483 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
6485 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp
6486 implementation, when applicable, for creation of the output stream.
6488 LAUNCH-PROGRAM returns a PROCESS-INFO object.
6490 LAUNCH-PROGRAM currently does not smooth over all the differences between
6491 implementations. Of particular note is when streams are provided for OUTPUT or
6492 ERROR-OUTPUT. Some implementations don't support this at all, some support only
6493 certain subclasses of streams, and some support any arbitrary
6494 stream. Additionally, the implementations that support streams may have
6495 differing behavior on how those streams are filled with data. If data is not
6496 periodically read from the child process and sent to the stream, the child
6497 could block because its output buffers are full."
6498 #-(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
6499 (progn command keys input output error-output directory element-type external-format
6500 if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore
6501 (not-implemented-error 'launch-program))
6503 (when (some #'(lambda (stream)
6504 (and (streamp stream)
6505 (not (file-stream-p stream))))
6506 (list input output error-output))
6507 (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp"
6509 #+(or abcl clisp lispworks)
6510 (when (some #'streamp (list input output error-output))
6511 (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp"
6514 (unless (eq error-output :interactive)
6515 (parameter-error "~S: The only admissible value for ~S is ~S on this lisp"
6516 'launch-program :error-output :interactive))
6518 (when (and #+ecl (version< (lisp-implementation-version) "20.4.24")
6519 (some #'(lambda (stream)
6520 (and (streamp stream)
6521 (not (file-or-synonym-stream-p stream))))
6522 (list input output error-output)))
6523 (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp"
6525 #+(or abcl allegro clasp clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
6527 (progn ;; see comments for these functions
6528 (%handle-if-does-not-exist input if-input-does-not-exist)
6529 (%handle-if-exists output if-output-exists)
6530 (%handle-if-exists error-output if-error-output-exists))
6531 #+(or clasp ecl) (let ((*standard-input* *stdin*)
6532 (*standard-output* *stdout*)
6533 (*error-output* *stderr*)))
6534 (let ((process-info (make-instance 'process-info))
6535 (input (%normalize-io-specifier input :input))
6536 (output (%normalize-io-specifier output :output))
6537 (error-output (%normalize-io-specifier error-output :error-output))
6538 #+(and allegro os-windows) (interactive (%interactivep input output error-output))
6541 #+os-unix (string `("/bin/sh" "-c" ,command))
6542 #+os-unix (list command)
6545 ;; NB: On other Windows implementations, this is utterly bogus
6546 ;; except in the most trivial cases where no quoting is needed.
6547 ;; Use at your own risk.
6548 #-(or allegro clasp clisp clozure ecl)
6550 #+(or clasp ecl sbcl) (unless (find-symbol* :escape-arguments #+(or clasp ecl) :ext #+sbcl :sb-impl nil))
6551 (parameter-error "~S doesn't support string commands on Windows on this Lisp"
6552 'launch-program command))
6553 ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified
6554 ;; when the command contains spaces or special characters:
6555 ;; IIUC, the system will use space as a separator,
6556 ;; but the C++ argv-decoding libraries won't, and
6557 ;; you're supposed to use an extra argument to CreateProcess to bridge the gap,
6558 ;; yet neither allegro nor clisp provide access to that argument.
6559 #+(or allegro clisp) (strcat "cmd /c " command)
6560 ;; On ClozureCL for Windows, we assume you are using
6561 ;; r15398 or later in 1.9 or later,
6562 ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
6563 ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304
6564 ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13)
6565 #+(or clasp clozure ecl sbcl) (cons "cmd" (strcat "/c " command)))
6568 #+allegro (escape-windows-command command)
6569 #-allegro command)))))
6570 #+(or abcl (and allegro os-unix) clasp clozure cmucl ecl mkcl sbcl)
6571 (let ((program (car command))
6572 #-allegro (arguments (cdr command))))
6573 #+(and (or clasp ecl sbcl) os-windows)
6574 (multiple-value-bind (arguments escape-arguments)
6575 (if (listp arguments)
6576 (values arguments t)
6577 (values (list arguments) nil)))
6578 #-(or allegro mkcl sbcl) (with-current-directory (directory))
6579 (multiple-value-bind
6580 #+(or abcl clozure cmucl sbcl scl) (process)
6581 #+allegro (in-or-io out-or-err err-or-pid pid-or-nil)
6582 #+(or clasp ecl) (stream code process)
6583 #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil)
6584 #+mkcl (stream process code)
6586 #+abcl 'sys:run-program
6587 #+allegro ,@'('excl:run-shell-command
6588 #+os-unix (coerce (cons program command) 'vector)
6589 #+os-windows command)
6590 #+clasp (if (find-symbol* '#:run-program :ext nil)
6591 (find-symbol* '#:run-program :ext nil)
6592 (not-implemented-error 'launch-program))
6593 #+clozure 'ccl:run-program
6594 #+(or cmucl ecl scl) 'ext:run-program
6596 #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed
6597 #+mkcl 'mk-ext:run-program
6598 #+sbcl 'sb-ext:run-program
6599 #+(or abcl clasp clozure cmucl ecl mkcl sbcl) ,@'(program arguments)
6600 #+(and (or clasp ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments)
6601 :input input :if-input-does-not-exist :error
6602 :output output :if-output-exists :append
6603 ,(or #+(or allegro lispworks) :error-output :error) error-output
6604 ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append
6605 :wait nil :element-type element-type :external-format external-format
6607 #+allegro ,@`(:directory directory
6608 #+os-windows ,@'(:show-window (if interactive nil :hide)))
6609 #+lispworks ,@'(:save-exit-status t)
6610 #+mkcl ,@'(:directory (native-namestring directory))
6611 #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys
6612 #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys)))))
6613 (labels ((prop (key value) (setf (slot-value process-info key) value)))
6617 (prop 'process pid-or-nil)
6618 (when (eq input :stream) (prop 'input-stream in-or-io))
6619 (when (eq output :stream) (prop 'output-stream out-or-err))
6620 (when (eq error-output :stream) (prop 'error-output-stream err-or-pid)))
6622 (prop 'process err-or-pid)
6623 (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
6625 (1 (prop 'input-stream in-or-io))
6626 (2 (prop 'output-stream in-or-io))
6627 (3 (prop 'bidir-stream in-or-io)))
6628 (when (eq error-output :stream)
6629 (prop 'error-output-stream out-or-err))))
6630 #+(or abcl clozure cmucl sbcl scl)
6632 (prop 'process process)
6633 (when (eq input :stream)
6635 (prop 'input-stream)
6636 #+abcl (symbol-call :sys :process-input)
6637 #+clozure (ccl:external-process-input-stream)
6638 #+(or cmucl scl) (ext:process-input)
6639 #+sbcl (sb-ext:process-input)
6641 (when (eq output :stream)
6643 (prop 'output-stream)
6644 #+abcl (symbol-call :sys :process-output)
6645 #+clozure (ccl:external-process-output-stream)
6646 #+(or cmucl scl) (ext:process-output)
6647 #+sbcl (sb-ext:process-output)
6649 (when (eq error-output :stream)
6651 (prop 'error-output-stream)
6652 #+abcl (symbol-call :sys :process-error)
6653 #+clozure (ccl:external-process-error-stream)
6654 #+(or cmucl scl) (ext:process-error)
6655 #+sbcl (sb-ext:process-error)
6657 #+(or clasp ecl mkcl)
6658 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
6660 (unless (zerop mode)
6661 (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))
6662 (when (eq error-output :stream)
6663 (prop 'error-output-stream
6664 (if (and #+clasp nil #-clasp t (version< (lisp-implementation-version) "16.0.0"))
6665 (symbol-call :ext :external-process-error process)
6666 (symbol-call :ext :external-process-error-stream process))))
6667 (prop 'process process))
6669 ;; See also the comments on the process-info class
6670 (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
6672 ((or (plusp mode) (eq error-output :stream))
6673 (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil)
6675 (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream))
6677 (when (eq error-output :stream)
6678 (prop 'error-output-stream err-or-nil)))
6679 ;; Prior to Lispworks 7, this returned (pid); now it
6680 ;; returns (io err pid) of which we keep io.
6681 (t (prop 'process io-or-pid)))))
6684 ;;;; -------------------------------------------------------------------------
6685 ;;;; run-program initially from xcvb-driver.
6687 (uiop/package:define-package :uiop/run-program
6688 (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv.
6689 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
6690 :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program)
6693 #:slurp-input-stream #:vomit-output-stream
6695 #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process)
6696 (:import-from :uiop/launch-program
6697 #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep
6698 #:input-stream #:output-stream #:error-output-stream))
6699 (in-package :uiop/run-program)
6701 ;;;; Slurping a stream, typically the output of another program
6702 (with-upgradability ()
6703 (defun call-stream-processor (fun processor stream)
6704 "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
6705 a PROCESSOR specification which is either an atom or a list specifying
6706 a processor an keyword arguments, call the specified processor with
6707 the given STREAM as input"
6708 (if (consp processor)
6709 (apply fun (first processor) stream (rest processor))
6710 (funcall fun processor stream)))
6712 (defgeneric slurp-input-stream (processor input-stream &key)
6714 "SLURP-INPUT-STREAM is a generic function with two positional arguments
6715 PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps)
6716 the contents of the INPUT-STREAM and processes them according to a method
6717 specified by PROCESSOR.
6719 Built-in methods include the following:
6720 * if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument
6721 * if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the
6722 INPUT-STREAM and the rest of the list. That is (x . y) will be treated as
6723 \(APPLY x <stream> y\)
6724 * if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream,
6725 per copy-stream-to-stream, with appropriate keyword arguments.
6726 * if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM
6727 are returned as a string, as per SLURP-STREAM-STRING.
6728 * if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES.
6729 * if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE.
6730 * if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS.
6731 * if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM.
6732 * if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned.
6734 Programmers are encouraged to define their own methods for this generic function."))
6737 (defmethod slurp-input-stream ((function function) input-stream &key)
6738 (funcall function input-stream))
6740 (defmethod slurp-input-stream ((list cons) input-stream &key)
6741 (apply (first list) input-stream (rest list)))
6744 (defmethod slurp-input-stream ((output-stream stream) input-stream
6745 &key linewise prefix (element-type 'character) buffer-size)
6746 (copy-stream-to-stream
6747 input-stream output-stream
6748 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
6750 (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped)
6751 (slurp-stream-string stream :stripped stripped))
6753 (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped)
6754 (slurp-stream-string stream :stripped stripped))
6756 (defmethod slurp-input-stream ((x (eql :lines)) stream &key count)
6757 (slurp-stream-lines stream :count count))
6759 (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0))
6760 (slurp-stream-line stream :at at))
6762 (defmethod slurp-input-stream ((x (eql :forms)) stream &key count)
6763 (slurp-stream-forms stream :count count))
6765 (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0))
6766 (slurp-stream-form stream :at at))
6768 (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
6769 (apply 'slurp-input-stream *standard-output* stream keys))
6771 (defmethod slurp-input-stream ((x null) (stream t) &key)
6774 (defmethod slurp-input-stream ((pathname pathname) input
6776 (element-type *default-stream-element-type*)
6777 (external-format *utf-8-external-format*)
6778 (if-exists :rename-and-delete)
6779 (if-does-not-exist :create)
6782 (with-output-file (output pathname
6783 :element-type element-type
6784 :external-format external-format
6785 :if-exists if-exists
6786 :if-does-not-exist if-does-not-exist)
6787 (copy-stream-to-stream
6789 :element-type element-type :buffer-size buffer-size :linewise linewise)))
6791 (defmethod slurp-input-stream (x stream
6792 &key linewise prefix (element-type 'character) buffer-size)
6793 (declare (ignorable stream linewise prefix element-type buffer-size))
6796 ((functionp x) (funcall x stream))
6798 ((output-stream-p x)
6799 (copy-stream-to-stream
6801 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
6803 (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
6805 ;;;; Vomiting a stream, typically into the input of another program.
6806 (with-upgradability ()
6807 (defgeneric vomit-output-stream (processor output-stream &key)
6809 "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments
6810 PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits)
6811 some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR.
6813 Built-in methods include the following:
6814 * if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument
6815 * if PROCESSOR is a list, its first element should be a function.
6816 It will be applied to a cons of the OUTPUT-STREAM and the rest of the list.
6817 That is (x . y) will be treated as \(APPLY x <stream> y\)
6818 * if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM,
6819 per copy-stream-to-stream, with appropriate keyword arguments.
6820 * if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM.
6821 * if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done.
6823 Programmers are encouraged to define their own methods for this generic function."))
6826 (defmethod vomit-output-stream ((function function) output-stream &key)
6827 (funcall function output-stream))
6829 (defmethod vomit-output-stream ((list cons) output-stream &key)
6830 (apply (first list) output-stream (rest list)))
6833 (defmethod vomit-output-stream ((input-stream stream) output-stream
6834 &key linewise prefix (element-type 'character) buffer-size)
6835 (copy-stream-to-stream
6836 input-stream output-stream
6837 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
6839 (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri)
6841 (when fresh-line (fresh-line stream))
6842 (when terpri (terpri stream))
6845 (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
6846 (apply 'vomit-output-stream *standard-input* stream keys))
6848 (defmethod vomit-output-stream ((x null) (stream t) &key)
6851 (defmethod vomit-output-stream ((pathname pathname) input
6853 (element-type *default-stream-element-type*)
6854 (external-format *utf-8-external-format*)
6855 (if-exists :rename-and-delete)
6856 (if-does-not-exist :create)
6859 (with-output-file (output pathname
6860 :element-type element-type
6861 :external-format external-format
6862 :if-exists if-exists
6863 :if-does-not-exist if-does-not-exist)
6864 (copy-stream-to-stream
6866 :element-type element-type :buffer-size buffer-size :linewise linewise)))
6868 (defmethod vomit-output-stream (x stream
6869 &key linewise prefix (element-type 'character) buffer-size)
6870 (declare (ignorable stream linewise prefix element-type buffer-size))
6873 ((functionp x) (funcall x stream))
6876 (copy-stream-to-stream
6878 :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
6880 (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x)))))
6883 ;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output.
6884 (with-upgradability ()
6885 (define-condition subprocess-error (error)
6886 ((code :initform nil :initarg :code :reader subprocess-error-code)
6887 (command :initform nil :initarg :command :reader subprocess-error-command)
6888 (process :initform nil :initarg :process :reader subprocess-error-process))
6889 (:report (lambda (condition stream)
6890 (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]"
6891 (subprocess-error-process condition)
6892 (subprocess-error-command condition)
6893 (subprocess-error-code condition)))))
6895 (defun %check-result (exit-code &key command process ignore-error-status)
6896 (unless ignore-error-status
6897 (unless (eql exit-code 0)
6898 (cerror "IGNORE-ERROR-STATUS"
6899 'subprocess-error :command command :code exit-code :process process)))
6902 (defun %active-io-specifier-p (specifier)
6903 "Determines whether a run-program I/O specifier requires Lisp-side processing
6904 via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T),
6905 or whether it's already taken care of by the implementation's underlying run-program."
6906 (not (typep specifier '(or null string pathname (member :interactive :output)
6907 #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t))
6908 #+lispworks file-stream))))
6910 (defun %run-program (command &rest keys &key &allow-other-keys)
6911 "DEPRECATED. Use LAUNCH-PROGRAM instead."
6912 (apply 'launch-program command keys))
6914 (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner
6916 (element-type #-clozure *default-stream-element-type* #+clozure 'character)
6917 (external-format *utf-8-external-format*) &allow-other-keys)
6918 ;; handle redirection for run-program and system
6919 ;; SPEC is the specification for the subprocess's input or output or error-output
6920 ;; TVAL is the value used if the spec is T
6921 ;; GF is the generic function to call to handle arbitrary values of SPEC
6922 ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
6923 ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
6924 ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
6925 ;; FUN is a function of the new reduced spec and an activity function to call with a stream
6926 ;; when the subprocess is active and communicating through that stream.
6927 ;; ACTIVEP is a boolean true if we will get to run code while the process is running
6928 ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open.
6929 ;; RETURNER is a function called with the value of the activity.
6930 ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
6931 (declare (ignorable stream-easy-p))
6932 (let* ((actual-spec (if (eq spec t) tval spec))
6933 (activity-spec (if (eq actual-spec :output)
6936 (parameter-error "~S does not allow ~S as a ~S spec"
6937 'run-program :output direction))
6941 (labels ((activity (stream)
6942 (call-function returner (call-stream-processor gf activity-spec stream)))
6944 (funcall fun actual-spec nil))
6947 (funcall fun :stream #'activity)
6948 (with-temporary-file (:pathname tmp)
6951 (with-output-file (s tmp :if-exists :overwrite
6952 :external-format external-format
6953 :element-type element-type)
6955 (funcall fun tmp nil))
6956 ((:output :error-output)
6957 (multiple-value-prog1 (funcall fun tmp nil)
6958 (with-input-file (s tmp
6959 :external-format external-format
6960 :element-type element-type)
6961 (activity s)))))))))
6962 (typecase activity-spec
6963 ((or null string pathname (eql :interactive))
6965 #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard
6967 (if stream-easy-p (easy-case) (hard-case)))
6971 (defmacro place-setter (place)
6973 (let ((value (gensym)))
6974 `#'(lambda (,value) (setf ,place ,value)))))
6976 (defmacro with-program-input (((reduced-input-var
6977 &optional (input-activity-var (gensym) iavp))
6978 input-form &key setf stream-easy-p active keys) &body body)
6979 `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p
6980 #'(lambda (,reduced-input-var ,input-activity-var)
6981 ,@(unless iavp `((declare (ignore ,input-activity-var))))
6983 :input ,input-form ,active (place-setter ,setf) ,keys))
6985 (defmacro with-program-output (((reduced-output-var
6986 &optional (output-activity-var (gensym) oavp))
6987 output-form &key setf stream-easy-p active keys) &body body)
6988 `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p
6989 #'(lambda (,reduced-output-var ,output-activity-var)
6990 ,@(unless oavp `((declare (ignore ,output-activity-var))))
6992 :output ,output-form ,active (place-setter ,setf) ,keys))
6994 (defmacro with-program-error-output (((reduced-error-output-var
6995 &optional (error-output-activity-var (gensym) eoavp))
6996 error-output-form &key setf stream-easy-p active keys)
6998 `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p
6999 #'(lambda (,reduced-error-output-var ,error-output-activity-var)
7000 ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
7002 :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
7004 (defun %use-launch-program (command &rest keys
7005 &key input output error-output ignore-error-status &allow-other-keys)
7006 ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM
7007 #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl)
7009 command keys input output error-output ignore-error-status ;; ignore
7010 (not-implemented-error '%use-launch-program))
7011 (when (member :stream (list input output error-output))
7012 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
7013 'run-program :stream))
7014 (let* ((active-input-p (%active-io-specifier-p input))
7015 (active-output-p (%active-io-specifier-p output))
7016 (active-error-output-p (%active-io-specifier-p error-output))
7019 (active-output-p :output)
7020 (active-input-p :input)
7021 (active-error-output-p :error-output)
7023 output-result error-output-result exit-code process-info)
7024 (with-program-output ((reduced-output output-activity)
7025 output :keys keys :setf output-result
7026 :stream-easy-p t :active (eq activity :output))
7027 (with-program-error-output ((reduced-error-output error-output-activity)
7028 error-output :keys keys :setf error-output-result
7029 :stream-easy-p t :active (eq activity :error-output))
7030 (with-program-input ((reduced-input input-activity)
7032 :stream-easy-p t :active (eq activity :input))
7034 (apply 'launch-program command
7035 :input reduced-input :output reduced-output
7036 :error-output (if (eq error-output :output) :output reduced-error-output)
7038 (labels ((get-stream (stream-name &optional fallbackp)
7039 (or (slot-value process-info stream-name)
7041 (slot-value process-info 'bidir-stream))))
7042 (run-activity (activity stream-name &optional fallbackp)
7043 (if-let (stream (get-stream stream-name fallbackp))
7044 (funcall activity stream)
7045 (error 'subprocess-error
7046 :code `(:missing ,stream-name)
7047 :command command :process process-info))))
7051 (:input (run-activity input-activity 'input-stream t))
7052 (:output (run-activity output-activity 'output-stream t))
7053 (:error-output (run-activity error-output-activity 'error-output-stream)))
7054 (close-streams process-info)
7055 (setf exit-code (wait-process process-info)))))))
7056 (%check-result exit-code
7057 :command command :process process-info
7058 :ignore-error-status ignore-error-status)
7059 (values output-result error-output-result exit-code)))
7061 (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
7064 (list (escape-shell-command
7066 ((os-unix-p) (cons "exec" command))
7069 (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
7070 (flet ((redirect (spec operator)
7073 (null (null-device-pathname))
7074 (string (parse-native-namestring spec))
7077 (unless (equal operator " 2>>")
7078 (parameter-error "~S: only the ~S argument can be ~S"
7079 'run-program :error-output :output))
7080 (return-from redirect '(" 2>&1"))))))
7083 (escape-shell-token (native-namestring pathname)))))))
7084 (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>")))
7085 (normalized (%normalize-system-command command))
7086 (directory (or directory #+(or abcl xcl) (getcwd)))
7087 (chdir (when directory
7088 (let ((dir-arg (escape-shell-token (native-namestring directory))))
7090 ((os-unix-p) `("cd " ,dir-arg " ; "))
7091 ((os-windows-p) `("cd /d " ,dir-arg " & ")))))))
7094 ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized))
7095 ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")")))))))
7097 (defun %system (command &rest keys &key directory
7098 input (if-input-does-not-exist :error)
7099 output (if-output-exists :supersede)
7100 error-output (if-error-output-exists :supersede)
7102 "A portable abstraction of a low-level call to libc's system()."
7103 (declare (ignorable keys directory input if-input-does-not-exist output
7104 if-output-exists error-output if-error-output-exists))
7105 (when (member :stream (list input output error-output))
7106 (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument"
7107 'run-program :stream))
7108 #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl)
7109 (let (#+(or abcl ecl mkcl)
7110 (version (parse-version
7112 (lisp-implementation-version)
7114 (second (split-string (implementation-identifier) :separator '(#\-))))))
7116 #+abcl (unless (lexicographic< '< version '(1 4 0)))
7117 #+ecl (unless (lexicographic<= '< version '(16 0 0)))
7118 #+mkcl (unless (lexicographic<= '< version '(1 1 9)))
7119 (return-from %system
7121 (apply 'launch-program (%normalize-system-command command) keys)))))
7122 #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl)
7123 (let ((%command (%redirected-system-command command input output error-output directory)))
7124 ;; see comments for these functions
7125 (%handle-if-does-not-exist input if-input-does-not-exist)
7126 (%handle-if-exists output if-output-exists)
7127 (%handle-if-exists error-output if-error-output-exists)
7128 #+abcl (ext:run-shell-command %command)
7129 #+(or clasp ecl) (let ((*standard-input* *stdin*)
7130 (*standard-output* *stdout*)
7131 (*error-output* *stderr*))
7132 (ext:system %command))
7134 (let ((raw-exit-code
7136 #.`(#+os-windows ,@'(ext:run-shell-command %command)
7137 #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command))
7138 :wait t :input :terminal :output :terminal)
7140 (if (minusp raw-exit-code)
7141 (- 128 raw-exit-code)
7143 #+cormanlisp (win32:system %command)
7144 #+gcl (system:system %command)
7145 #+genera (not-implemented-error '%system)
7146 #+(and lispworks os-windows)
7147 (system:call-system %command :current-directory directory :wait t)
7148 #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command))
7149 #+mkcl (mkcl:system %command)
7150 #+xcl (system:%run-shell-command %command)))
7152 (defun %use-system (command &rest keys
7153 &key input output error-output ignore-error-status &allow-other-keys)
7154 ;; helper for RUN-PROGRAM when using %system
7155 (let (output-result error-output-result exit-code)
7156 (with-program-output ((reduced-output)
7157 output :keys keys :setf output-result)
7158 (with-program-error-output ((reduced-error-output)
7159 error-output :keys keys :setf error-output-result)
7160 (with-program-input ((reduced-input) input :keys keys)
7161 (setf exit-code (apply '%system command
7162 :input reduced-input :output reduced-output
7163 :error-output reduced-error-output keys)))))
7164 (%check-result exit-code
7166 :ignore-error-status ignore-error-status)
7167 (values output-result error-output-result exit-code)))
7169 (defun run-program (command &rest keys
7170 &key ignore-error-status (force-shell nil force-shell-suppliedp)
7171 input (if-input-does-not-exist :error)
7172 output (if-output-exists :supersede)
7173 error-output (if-error-output-exists :supersede)
7174 (element-type #-clozure *default-stream-element-type* #+clozure 'character)
7175 (external-format *utf-8-external-format*)
7177 "Run program specified by COMMAND,
7178 either a list of strings specifying a program and list of arguments,
7179 or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
7180 _synchronously_ process its output as specified and return the processing results
7181 when the program and its output processing are complete.
7183 Always call a shell (rather than directly execute the command when possible)
7184 if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is
7185 specified to be NIL.
7187 Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
7188 unless IGNORE-ERROR-STATUS is specified.
7190 If OUTPUT is a pathname, a string designating a pathname, or NIL (the default)
7191 designating the null device, the file at that path is used as output.
7192 If it's :INTERACTIVE, output is inherited from the current process;
7193 beware that this may be different from your *STANDARD-OUTPUT*,
7194 and under SLIME will be on your *inferior-lisp* buffer.
7195 If it's T, output goes to your current *STANDARD-OUTPUT* stream.
7196 Otherwise, OUTPUT should be a value that is a suitable first argument to
7197 SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments.
7198 In this case, RUN-PROGRAM will create a temporary stream for the program output;
7199 the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM,
7200 using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords).
7201 The primary value resulting from that call (or NIL if no call was needed)
7202 will be the first value returned by RUN-PROGRAM.
7203 E.g., using :OUTPUT :STRING will have it return the entire output stream as a string.
7204 And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string
7205 stripped of any ending newline.
7207 IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a
7208 pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the
7209 default). The meaning of these values and their effect on the case
7210 where OUTPUT does not exist, is analogous to the IF-EXISTS parameter
7211 to OPEN with :DIRECTION :OUTPUT.
7213 ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned
7214 as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*.
7215 Also :OUTPUT means redirecting the error output to the output stream,
7216 in which case NIL is returned.
7218 IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it
7219 affects ERROR-OUTPUT rather than OUTPUT.
7221 INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used,
7222 no value is returned, and T designates the *STANDARD-INPUT*.
7224 IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string
7225 or a pathname, can take the values :CREATE and :ERROR (the
7226 default). The meaning of these values is analogous to the
7227 IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT.
7229 ELEMENT-TYPE and EXTERNAL-FORMAT are passed on
7230 to your Lisp implementation, when applicable, for creation of the output stream.
7232 One and only one of the stream slurping or vomiting may or may not happen
7233 in parallel in parallel with the subprocess,
7234 depending on options and implementation,
7235 and with priority being given to output processing.
7236 Other streams are completely produced or consumed
7237 before or after the subprocess is spawned, using temporary files.
7239 RUN-PROGRAM returns 3 values:
7240 0- the result of the OUTPUT slurping if any, or NIL
7241 1- the result of the ERROR-OUTPUT slurping if any, or NIL
7242 2- either 0 if the subprocess exited with success status,
7243 or an indication of failure via the EXIT-CODE of the process"
7244 (declare (ignorable input output error-output if-input-does-not-exist if-output-exists
7245 if-error-output-exists element-type external-format ignore-error-status))
7246 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl)
7247 (not-implemented-error 'run-program)
7248 (apply (if (or force-shell
7249 ;; Per doc string, set FORCE-SHELL to T if we get command as a string.
7250 ;; But don't override user's specified preference. [2015/06/29:rpg]
7251 (and (stringp command)
7252 (or (not force-shell-suppliedp)
7253 #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t))))
7254 #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t
7255 ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program
7256 #+ecl #.(if-let (ver (parse-version (lisp-implementation-version)))
7257 (lexicographic<= '< ver '(16 0 0)))
7258 #+(and lispworks os-unix) (%interactivep input output error-output))
7259 '%use-system '%use-launch-program)
7262 ;;;; ---------------------------------------------------------------------------
7263 ;;;; Generic support for configuration files
7265 (uiop/package:define-package :uiop/configuration
7266 (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27.
7267 (:use :uiop/package :uiop/common-lisp :uiop/utility
7268 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
7270 #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver
7271 #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem
7273 #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs
7274 #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames
7275 #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames
7276 #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname
7277 #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
7278 #:configuration-inheritance-directive-p
7279 #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
7280 #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
7281 #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
7282 #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration
7284 (in-package :uiop/configuration)
7286 (with-upgradability ()
7287 (define-condition invalid-configuration ()
7288 ((form :reader condition-form :initarg :form)
7289 (location :reader condition-location :initarg :location)
7290 (format :reader condition-format :initarg :format)
7291 (arguments :reader condition-arguments :initarg :arguments :initform nil))
7292 (:report (lambda (c s)
7293 (format s (compatfmt "~@<~? (will be skipped)~@:>")
7294 (condition-format c)
7295 (list* (condition-form c) (condition-location c)
7296 (condition-arguments c))))))
7298 (defun configuration-inheritance-directive-p (x)
7299 "Is X a configuration inheritance directive?"
7300 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
7302 (and (length=n-p x 1) (member (car x) kw)))))
7304 (defun report-invalid-form (reporter &rest args)
7305 "Report an invalid form according to REPORTER and various ARGS"
7308 (apply 'error 'invalid-configuration args))
7310 (apply reporter args))
7312 (apply 'error reporter args))
7314 (apply 'apply (append reporter args)))))
7316 (defvar *ignored-configuration-form* nil
7317 "Have configuration forms been ignored while parsing the configuration?")
7319 (defun validate-configuration-form (form tag directive-validator
7320 &key location invalid-form-reporter)
7321 "Validate a configuration FORM. By default it will raise an error if the
7322 FORM is not valid. Otherwise it will return the validated form.
7323 Arguments control the behavior:
7324 The configuration FORM should be of the form (TAG . <rest>)
7325 Each element of <rest> will be checked by first seeing if it's a configuration inheritance
7326 directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR
7328 In the event of an invalid form, INVALID-FORM-REPORTER will be used to control
7329 reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where
7330 the configuration form appeared."
7331 (unless (and (consp form) (eq (car form) tag))
7332 (setf *ignored-configuration-form* t)
7333 (report-invalid-form invalid-form-reporter :form form :location location)
7334 (return-from validate-configuration-form nil))
7335 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
7336 :for directive :in (cdr form)
7338 ((configuration-inheritance-directive-p directive)
7340 ((eq directive :ignore-invalid-entries)
7341 (setf ignore-invalid-p t) t)
7342 ((funcall directive-validator directive)
7347 (setf *ignored-configuration-form* t)
7348 (report-invalid-form invalid-form-reporter :form directive :location location)
7350 :do (push directive x)
7352 (unless (= inherit 1)
7353 (report-invalid-form invalid-form-reporter
7354 :form form :location location
7355 ;; we throw away the form and location arguments, hence the ~2*
7356 ;; this is necessary because of the report in INVALID-CONFIGURATION
7357 :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~
7358 One and only one of ~S or ~S is required.~@:>")
7359 :arguments '(:inherit-configuration :ignore-inherited-configuration)))
7360 (return (nreverse x))))
7362 (defun validate-configuration-file (file validator &key description)
7363 "Validate a configuration FILE. The configuration file should have only one s-expression
7364 in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error
7366 (let ((forms (read-file-forms file)))
7367 (unless (length=n-p forms 1)
7368 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
7370 (funcall validator (car forms) :location file)))
7372 (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter)
7373 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
7374 be applied to the results to yield a configuration form. Current
7375 values of TAG include :source-registry and :output-translations."
7376 (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list
7379 (directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
7380 #'string< :key #'namestring)))
7382 ,@(loop :for file :in files :append
7383 (loop :with ignore-invalid-p = nil
7384 :for form :in (read-file-forms file)
7385 :when (eq form :ignore-invalid-entries)
7386 :do (setf ignore-invalid-p t)
7388 :when (funcall validator form)
7391 :when ignore-invalid-p
7392 :do (setf *ignored-configuration-form* t)
7394 :do (report-invalid-form invalid-form-reporter :form form :location file)))
7395 :inherit-configuration)))
7397 (defun resolve-relative-location (x &key ensure-directory wilden)
7398 "Given a designator X for an relative location, resolve it to a pathname."
7403 (string (parse-unix-namestring
7404 x :ensure-directory ensure-directory))
7407 (resolve-relative-location
7408 (car x) :ensure-directory ensure-directory :wilden wilden)
7409 (let* ((car (resolve-relative-location
7410 (car x) :ensure-directory t :wilden nil)))
7412 (resolve-relative-location
7413 (cdr x) :ensure-directory ensure-directory :wilden wilden)
7415 ((eql :*/) *wild-directory*)
7416 ((eql :**/) *wild-inferiors*)
7417 ((eql :*.*.*) *wild-file*)
7418 ((eql :implementation)
7419 (parse-unix-namestring
7420 (implementation-identifier) :ensure-directory t))
7421 ((eql :implementation-type)
7422 (parse-unix-namestring
7423 (string-downcase (implementation-type)) :ensure-directory t))
7425 (parse-unix-namestring (hostname) :ensure-directory t)))
7426 :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*))))
7429 (defvar *here-directory* nil
7430 "This special variable is bound to the currect directory during calls to
7431 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
7434 (defvar *user-cache* nil
7435 "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
7437 (defun resolve-absolute-location (x &key ensure-directory wilden)
7438 "Given a designator X for an absolute location, resolve it to a pathname"
7444 (let ((p #-mcl (parse-namestring x)
7445 #+mcl (probe-posix x)))
7446 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
7447 (if ensure-directory (ensure-directory-pathname p) p)))
7449 (return-from resolve-absolute-location
7451 (resolve-absolute-location
7452 (car x) :ensure-directory ensure-directory :wilden wilden)
7454 (resolve-relative-location
7455 (cdr x) :ensure-directory ensure-directory :wilden wilden)
7456 (resolve-absolute-location
7457 (car x) :ensure-directory t :wilden nil)))))
7459 ;; special magic! we return a relative pathname,
7460 ;; but what it means to the output-translations is
7461 ;; "relative to the root of the source pathname's host and device".
7462 (return-from resolve-absolute-location
7463 (let ((p (make-pathname :directory '(:relative))))
7464 (if wilden (wilden p) p))))
7465 ((eql :home) (user-homedir-pathname))
7466 ((eql :here) (resolve-absolute-location
7467 (or *here-directory* (pathname-directory-pathname (truename (load-pathname))))
7468 :ensure-directory t :wilden nil))
7469 ((eql :user-cache) (resolve-absolute-location
7470 *user-cache* :ensure-directory t :wilden nil)))
7471 :wilden (and wilden (not (pathnamep x)))
7472 :resolve-symlinks *resolve-symlinks*
7475 ;; Try to override declaration in previous versions of ASDF.
7476 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)
7477 (:ensure-directory boolean)) t) resolve-location))
7479 (defun resolve-location (x &key ensure-directory wilden directory)
7480 "Resolve location designator X into a PATHNAME"
7481 ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
7482 (loop :with dirp = (or directory ensure-directory)
7483 :with (first . rest) = (if (atom x) (list x) x)
7484 :with path = (or (resolve-absolute-location
7485 first :ensure-directory (and (or dirp rest) t)
7486 :wilden (and wilden (null rest)))
7488 :for (element . morep) :on rest
7489 :for dir = (and (or morep dirp) t)
7490 :for wild = (and wilden (not morep))
7491 :for sub = (merge-pathnames*
7492 (resolve-relative-location
7493 element :ensure-directory dir :wilden wild)
7495 :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub))
7496 :finally (return path)))
7498 (defun location-designator-p (x)
7499 "Is X a designator for a location?"
7500 ;; NIL means "skip this entry", or as an output translation, same as translation input.
7501 ;; T means "any input" for a translation, or as output, same as translation input.
7502 (flet ((absolute-component-p (c)
7503 (typep c '(or string pathname
7504 (member :root :home :here :user-cache))))
7505 (relative-component-p (c)
7506 (typep c '(or string pathname
7507 (member :*/ :**/ :*.*.* :implementation :implementation-type)))))
7508 (or (typep x 'boolean)
7509 (absolute-component-p x)
7510 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
7512 (defun location-function-p (x)
7513 "Is X the specification of a location function?"
7514 ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support.
7515 (and (length=n-p x 2) (eq (car x) :function)))
7517 (defvar *clear-configuration-hook* '())
7519 (defun register-clear-configuration-hook (hook-function &optional call-now-p)
7520 "Register a function to be called when clearing configuration"
7521 (register-hook-function '*clear-configuration-hook* hook-function call-now-p))
7523 (defun clear-configuration ()
7524 "Call the functions in *CLEAR-CONFIGURATION-HOOK*"
7525 (call-functions *clear-configuration-hook*))
7527 (register-image-dump-hook 'clear-configuration)
7529 (defun upgrade-configuration ()
7530 "If a previous version of ASDF failed to read some configuration, try again now."
7531 (when *ignored-configuration-form*
7532 (clear-configuration)
7533 (setf *ignored-configuration-form* nil)))
7536 (defun get-folder-path (folder)
7537 "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
7538 this function tries to locate the Windows FOLDER for one of
7539 :LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA.
7540 Returns NIL when the folder is not defined (e.g., not on Windows)."
7541 (or #+(and lispworks os-windows) (sys:get-folder-path folder)
7542 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
7544 (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA")
7545 (subpathname* (get-folder-path :appdata) "Local")))
7546 (:appdata (getenv-absolute-directory "APPDATA"))
7547 (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
7548 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
7551 ;; Support for the XDG Base Directory Specification
7552 (defun xdg-data-home (&rest more)
7553 "Returns an absolute pathname for the directory containing user-specific data files.
7554 MORE may contain specifications for a subpath relative to this directory: a
7555 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7556 also \"Configuration DSL\"\) in the ASDF manual."
7557 (resolve-absolute-location
7558 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
7560 ((os-windows-p) (get-folder-path :local-appdata))
7561 (t (subpathname (user-homedir-pathname) ".local/share/"))))
7564 (defun xdg-config-home (&rest more)
7565 "Returns a pathname for the directory containing user-specific configuration files.
7566 MORE may contain specifications for a subpath relative to this directory: a
7567 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7568 also \"Configuration DSL\"\) in the ASDF manual."
7569 (resolve-absolute-location
7570 `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME")
7572 ((os-windows-p) (xdg-data-home "config/"))
7573 (t (subpathname (user-homedir-pathname) ".config/"))))
7576 (defun xdg-data-dirs (&rest more)
7577 "The preference-ordered set of additional paths to search for data files.
7578 Returns a list of absolute directory pathnames.
7579 MORE may contain specifications for a subpath relative to these directories: a
7580 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7581 also \"Configuration DSL\"\) in the ASDF manual."
7582 (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
7583 (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS"))
7585 ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata)))
7586 ;; macOS' separate read-only system volume means that the contents
7587 ;; of /usr/share are frozen by Apple. Unlike when running natively
7588 ;; on macOS, Genera must access the filesystem through NFS. Attempting
7589 ;; to export either the root (/) or /usr/share simply doesn't work.
7590 ;; (Genera will go into an infinite loop trying to access those mounts.)
7591 ;; So, when running Genera on macOS, only search /usr/local/share.
7593 #+Genera (sys:system-case
7594 (darwin-vlm (mapcar 'parse-unix-namestring '("/usr/local/share/")))
7595 (otherwise (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))
7596 (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/")))))))
7598 (defun xdg-config-dirs (&rest more)
7599 "The preference-ordered set of additional base paths to search for configuration files.
7600 Returns a list of absolute directory pathnames.
7601 MORE may contain specifications for a subpath relative to these directories:
7602 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7603 also \"Configuration DSL\"\) in the ASDF manual."
7604 (mapcar #'(lambda (d) (resolve-location `(,d ,more)))
7605 (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS"))
7607 ((os-windows-p) (xdg-data-dirs "config/"))
7608 (t (mapcar 'parse-unix-namestring '("/etc/xdg/")))))))
7610 (defun xdg-cache-home (&rest more)
7611 "The base directory relative to which user specific non-essential data files should be stored.
7612 Returns an absolute directory pathname.
7613 MORE may contain specifications for a subpath relative to this directory: a
7614 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7615 also \"Configuration DSL\"\) in the ASDF manual."
7616 (resolve-absolute-location
7617 `(,(or (getenv-absolute-directory "XDG_CACHE_HOME")
7619 ((os-windows-p) (xdg-data-home "cache/"))
7620 (t (subpathname* (user-homedir-pathname) ".cache/"))))
7623 (defun xdg-runtime-dir (&rest more)
7624 "Pathname for user-specific non-essential runtime files and other file objects,
7625 such as sockets, named pipes, etc.
7626 Returns an absolute directory pathname.
7627 MORE may contain specifications for a subpath relative to this directory: a
7628 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7629 also \"Configuration DSL\"\) in the ASDF manual."
7630 ;; The XDG spec says that if not provided by the login system, the application should
7631 ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL.
7632 (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more)))
7634 ;;; NOTE: modified the docstring because "system user configuration
7635 ;;; directories" seems self-contradictory. I'm not sure my wording is right.
7636 (defun system-config-pathnames (&rest more)
7637 "Return a list of directories where are stored the system's default user configuration information.
7638 MORE may contain specifications for a subpath relative to these directories: a
7639 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7640 also \"Configuration DSL\"\) in the ASDF manual."
7641 (declare (ignorable more))
7643 ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more))))))
7645 (defun filter-pathname-set (dirs)
7646 "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list."
7647 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal))
7649 (defun xdg-data-pathnames (&rest more)
7650 "Return a list of absolute pathnames for application data directories. With APP,
7651 returns directory for data for that application, without APP, returns the set of directories
7652 for storing all application configurations.
7653 MORE may contain specifications for a subpath relative to these directories: a
7654 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7655 also \"Configuration DSL\"\) in the ASDF manual."
7656 (filter-pathname-set
7657 `(,(xdg-data-home more)
7658 ,@(xdg-data-dirs more))))
7660 (defun xdg-config-pathnames (&rest more)
7661 "Return a list of pathnames for application configuration.
7662 MORE may contain specifications for a subpath relative to these directories: a
7663 subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see
7664 also \"Configuration DSL\"\) in the ASDF manual."
7665 (filter-pathname-set
7666 `(,(xdg-config-home more)
7667 ,@(xdg-config-dirs more))))
7669 (defun find-preferred-file (files &key (direction :input))
7670 "Find first file in the list of FILES that exists (for direction :input or :probe)
7671 or just the first one (for direction :output or :io).
7672 Note that when we say \"file\" here, the files in question may be directories."
7673 (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files))
7675 (defun xdg-data-pathname (&optional more (direction :input))
7676 (find-preferred-file (xdg-data-pathnames more) :direction direction))
7678 (defun xdg-config-pathname (&optional more (direction :input))
7679 (find-preferred-file (xdg-config-pathnames more) :direction direction))
7681 (defun compute-user-cache ()
7682 "Compute (and return) the location of the default user-cache for translate-output
7683 objects. Side-effects for cached file location computation."
7684 (setf *user-cache* (xdg-cache-home "common-lisp" :implementation)))
7685 (register-image-restore-hook 'compute-user-cache)
7687 (defun uiop-directory ()
7688 "Try to locate the UIOP source directory at runtime"
7689 (labels ((pf (x) (ignore-errors (probe-file* x)))
7690 (sub (x y) (pf (subpathname x y)))
7691 (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x))))
7692 ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname)
7694 ;; Look under uiop if available as source override, under asdf if avaiable as source
7696 (sub (ssd "asdf") "uiop/")
7697 ;; Look in recommended path for user-visible source installation
7698 (sub (user-homedir-pathname) "common-lisp/asdf/uiop/")
7699 ;; Look in XDG paths under known package names for user-invisible source installation
7700 (xdg-data-pathname "common-lisp/source/asdf/uiop/")
7701 (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location
7702 ;; The last one below is useful for Fare, primary (sole?) known user
7703 (sub (user-homedir-pathname) "cl/asdf/uiop/")
7704 (cerror "Configure source registry to include UIOP source directory and retry."
7705 "Unable to find UIOP directory")
7706 (uiop-directory)))))
7707 ;;; -------------------------------------------------------------------------
7708 ;;; Hacks for backward-compatibility with older versions of UIOP
7710 (uiop/package:define-package :uiop/backward-driver
7711 (:recycle :uiop/backward-driver :asdf/backward-driver :uiop)
7712 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version
7713 :uiop/pathname :uiop/stream :uiop/os :uiop/image
7714 :uiop/run-program :uiop/lisp-build :uiop/configuration)
7717 #:user-configuration-directories #:system-configuration-directories
7718 #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory
7719 #:version-compatible-p))
7720 (in-package :uiop/backward-driver)
7722 (eval-when (:compile-toplevel :load-toplevel :execute)
7723 (with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4"))
7724 ;; Backward compatibility with ASDF 2.000 to 2.26
7726 ;; For backward-compatibility only, for people using internals
7727 ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release)
7728 ;; Will be removed after 2015-12.
7729 (defun coerce-pathname (name &key type defaults)
7730 "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead."
7731 (parse-unix-namestring name :type type :defaults defaults))
7733 ;; Backward compatibility for ASDF 2.27 to 3.1.4
7734 (defun user-configuration-directories ()
7735 "Return the current user's list of user configuration directories
7736 for configuring common-lisp.
7737 DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead."
7738 (xdg-config-pathnames "common-lisp"))
7739 (defun system-configuration-directories ()
7740 "Return the list of system configuration directories for common-lisp.
7741 DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"),
7743 (system-config-pathnames "common-lisp"))
7744 (defun in-first-directory (dirs x &key (direction :input))
7745 "Finds the first appropriate file named X in the list of DIRS for I/O
7746 in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE).
7747 If direction is :INPUT or :PROBE, will return the first extant file named
7748 X in one of the DIRS.
7749 If direction is :OUTPUT or :IO, will simply return the file named X in the
7750 first element of DIRS that exists. DEPRECATED."
7751 (find-preferred-file
7752 (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs)
7753 :direction direction))
7754 (defun in-user-configuration-directory (x &key (direction :input))
7755 "Return the file named X in the user configuration directory for common-lisp.
7757 (xdg-config-pathname `("common-lisp" ,x) direction))
7758 (defun in-system-configuration-directory (x &key (direction :input))
7759 "Return the pathname for the file named X under the system configuration directory
7760 for common-lisp. DEPRECATED."
7761 (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction))
7764 ;; Backward compatibility with ASDF 1 to ASDF 2.32
7766 (defun version-compatible-p (provided-version required-version)
7767 "Is the provided version a compatible substitution for the required-version?
7768 If major versions differ, it's not compatible.
7769 If they are equal, then any later version is compatible,
7770 with later being determined by a lexicographical comparison of minor numbers.
7772 (let ((x (parse-version provided-version nil))
7773 (y (parse-version required-version nil)))
7774 (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))))
7776 ;;;; ---------------------------------------------------------------------------
7777 ;;;; Re-export all the functionality in UIOP
7779 (uiop/package:define-package :uiop/driver
7780 (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols.
7781 :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore.
7782 ;; We should remove the name :asdf/driver at some point,
7783 ;; but not until it has been eradicated from Quicklisp for a year or two.
7784 ;; The last known user was cffi (PR merged in May 2020).
7785 (:use :uiop/common-lisp)
7786 ;; NB: We are not reexporting uiop/common-lisp
7787 ;; which include all of CL with compatibility modifications on select platforms,
7788 ;; because that would cause potential conflicts for packages that
7789 ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc.
7791 :uiop/package* :uiop/utility :uiop/version
7792 :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image
7793 :uiop/launch-program :uiop/run-program
7794 :uiop/lisp-build :uiop/configuration :uiop/backward-driver))
7796 ;; Provide both lowercase and uppercase, to satisfy more implementations.
7797 (provide "uiop") (provide "UIOP")
7798 ;;;; -------------------------------------------------------------------------
7799 ;;;; Handle upgrade as forward- and backward-compatibly as possible
7800 ;; See https://bugs.launchpad.net/asdf/+bug/485687
7802 (uiop/package:define-package :asdf/upgrade
7803 (:recycle :asdf/upgrade :asdf)
7804 (:use :uiop/common-lisp :uiop)
7806 #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
7807 #:asdf-message #:*verbose-out*
7808 #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter*
7809 #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf
7810 ;; There will be no symbol left behind!
7811 #:with-asdf-deprecation
7813 (:import-from :uiop/package #:intern* #:find-symbol*))
7814 (in-package :asdf/upgrade)
7816 ;;; Special magic to detect if this is an upgrade
7818 (with-upgradability ()
7819 (defun asdf-version ()
7820 "Exported interface to the version of ASDF currently installed. A string.
7821 You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
7822 (when (find-package :asdf)
7823 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
7824 (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
7825 (rev (and revsym (boundp revsym) (symbol-value revsym))))
7828 (cons (format nil "~{~D~^.~}" rev))
7830 ;; This (private) variable contains a list of versions of previously loaded variants of ASDF,
7831 ;; from which ASDF was upgraded.
7832 ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly.
7833 (defvar *previous-asdf-versions*
7834 (let ((previous (asdf-version)))
7836 ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package.
7837 (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature.
7838 (let ((away (format nil "~A-~A" :asdf previous)))
7839 (rename-package :asdf away)
7840 (when *load-verbose*
7841 (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))
7843 ;; This public variable will be bound shortly to the currently loaded version of ASDF.
7844 (defvar *asdf-version* nil)
7845 ;; We need to clear systems from versions older than the one in this (private) parameter.
7846 ;; The latest incompatible defclass is 2.32.13 renaming a slot in component,
7847 ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses).
7848 ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below).
7849 (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2")
7850 ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages
7851 (defvar *verbose-out* nil)
7852 ;; Private function by which ASDF outputs progress messages and warning messages:
7853 (defun asdf-message (format-string &rest format-args)
7854 (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
7855 ;; Private hook for functions to run after ASDF has upgraded itself from an older variant:
7856 (defvar *post-upgrade-cleanup-hook* ())
7857 ;; Private variable for post upgrade cleanup to communicate if an upgrade has
7858 ;; actually occured.
7859 (defvar *asdf-upgraded-p*)
7860 ;; Private function to detect whether the current upgrade counts as an incompatible
7861 ;; data schema upgrade implying the need to drop data.
7862 (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
7863 (and *previous-asdf-versions*
7864 (version< (first *previous-asdf-versions*) oldest-compatible-version)))
7865 ;; Private variant of defparameter that works in presence of incompatible upgrades:
7866 ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change),
7867 ;; but behaves like defparameter if in presence of an incompatible upgrade.
7868 (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
7869 (let* ((name (string-trim "*" var))
7870 (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
7872 (defun ,valfun () ,value)
7873 (defvar ,var (,valfun) ,@(ensure-list docstring))
7874 (when (upgrading-p ,version)
7875 (setf ,var (,valfun))))))
7876 ;; Private macro to declare sections of code that are only compiled and run when upgrading.
7877 ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects,
7878 ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs.
7879 (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
7880 (upgrading-p `(upgrading-p ,version)) when) &body body)
7881 "A wrapper macro for code that should only be run when upgrading a
7882 previously-loaded version of ASDF."
7883 `(with-upgradability ()
7884 (when (and ,upgrading-p ,@(when when `(,when)))
7885 (handler-bind ((style-warning #'muffle-warning))
7886 (eval '(progn ,@body))))))
7887 ;; Only now can we safely update the version.
7888 (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
7889 ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
7890 ;; can help you do these changes in synch (look at the source for documentation).
7891 ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp.
7892 ;; "3.4" would be the general branch for major version 3, minor version 4.
7893 ;; "3.4.5" would be an official release in the 3.4 branch.
7894 ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
7895 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
7896 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
7897 (asdf-version "3.3.6")
7898 (existing-version (asdf-version)))
7899 (setf *asdf-version* asdf-version)
7900 (when (and existing-version (not (equal asdf-version existing-version)))
7901 (push existing-version *previous-asdf-versions*)
7902 (when (or *verbose-out* *load-verbose*)
7903 (format (or *verbose-out* *trace-output*)
7904 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
7905 existing-version asdf-version)))))
7907 ;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined
7909 (let* ((previous-version (first *previous-asdf-versions*))
7910 (redefined-functions ;; List of functions that changed incompatibly since 2.27:
7911 ;; gf signature changed, defun that became a generic function (but not way around),
7912 ;; method removed that will mess up with new ones
7913 ;; (especially :around :before :after, more specific or call-next-method'ed method)
7914 ;; and/or semantics otherwise modified. Oops.
7915 ;; NB: it's too late to do anything about functions in UIOP!
7916 ;; If you introduce some critical incompatibility there, you MUST change the function name.
7917 ;; Note that we don't need do anything about functions that changed incompatibly
7918 ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
7919 ;; Also, the strong constraints apply most importantly for functions called from
7920 ;; the continuation of compiling or loading some of the code in ASDF or UIOP.
7921 ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
7922 ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141
7923 `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key
7924 ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
7925 ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered
7927 ;; with the old ASDF during upgrade, and many implementations bork
7928 (when (or #+(or clozure mkcl) t)
7929 '((#:compile-concatenated-source-op (#:operation) ())
7930 (#:compile-bundle-op (#:operation) ())
7931 (#:concatenate-source-op (#:operation) ())
7932 (#:dll-op (#:operation) ())
7933 (#:lib-op (#:operation) ())
7934 (#:monolithic-compile-bundle-op (#:operation) ())
7935 (#:monolithic-concatenate-source-op (#:operation) ())))))
7936 (loop :for name :in redefined-functions
7937 :for sym = (find-symbol* name :asdf nil)
7938 :do (when sym (fmakunbound sym)))
7939 (labels ((asym (x) (multiple-value-bind (s p)
7940 (if (consp x) (values (car x) (cadr x)) (values x :asdf))
7941 (find-symbol* s p nil)))
7942 (asyms (l) (mapcar #'asym l)))
7943 (loop :for (name superclasses slots) :in redefined-classes
7944 :for sym = (find-symbol* name :asdf nil)
7945 :when (and sym (find-class sym))
7946 :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))
7947 #-ccl (setf (find-class sym) nil))))) ;; mkcl
7949 ;;; Self-upgrade functions
7950 (with-upgradability ()
7951 ;; This private function is called at the end of asdf/footer and ensures that,
7952 ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called.
7953 (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
7954 (let ((new-version (asdf-version)))
7955 (unless (equal old-version new-version)
7956 (push new-version *previous-asdf-versions*)
7957 (when (boundp '*asdf-upgraded-p*)
7958 (setf *asdf-upgraded-p* t))
7960 (if (version<= new-version old-version)
7961 (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
7962 old-version new-version)
7963 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
7964 old-version new-version))
7965 ;; In case the previous version was too old to be forward-compatible, clear systems.
7966 ;; TODO: if needed, we may have to define a separate hook to run
7967 ;; in case of forward-compatible upgrade.
7968 ;; Or to move the tests forward-compatibility test inside each hook function?
7969 (unless (version<= *oldest-forward-compatible-asdf-version* old-version)
7970 (call-functions (reverse *post-upgrade-cleanup-hook*)))
7973 (defun upgrade-asdf ()
7974 "Try to upgrade of ASDF. If a different version was used, return T.
7975 We need do that before we operate on anything that may possibly depend on ASDF."
7976 (let ((*load-print* nil)
7977 (*compile-print* nil)
7978 (*asdf-upgraded-p* nil))
7979 (handler-bind (((or style-warning) #'muffle-warning))
7980 (symbol-call :asdf :load-system :asdf :verbose nil))
7983 (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body)
7984 `(with-upgradability ()
7985 (with-deprecation ((version-deprecation *asdf-version* ,@keys))
7987 ;;;; -------------------------------------------------------------------------
7990 (uiop/package:define-package :asdf/session
7991 (:recycle :asdf/session :asdf/cache :asdf/component
7992 :asdf/action :asdf/find-system :asdf/plan :asdf)
7993 (:use :uiop/common-lisp :uiop :asdf/upgrade)
7995 #:get-file-stamp #:compute-file-stamp #:register-file-stamp
7996 #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache
7997 #:do-asdf-cache #:normalize-namestring
7998 #:call-with-asdf-session #:with-asdf-session
7999 #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session
8000 #:session-cache #:forcing #:asdf-upgraded-p
8001 #:visited-actions #:visiting-action-set #:visiting-action-list
8002 #:total-action-count #:planned-action-count #:planned-output-action-count
8003 #:clear-configuration-and-retry #:retry
8006 #:system-definition-error ;; top level, moved here because this is the earliest place for it.
8007 #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error))
8008 (in-package :asdf/session)
8011 (with-upgradability ()
8012 ;; The session variable.
8013 ;; NIL when outside a session.
8014 (defvar *asdf-session* nil)
8015 (defparameter* *asdf-session-class* 'session
8016 "The default class for sessions")
8018 (defclass session ()
8019 (;; The ASDF session cache is used to memoize some computations.
8020 ;; It is instrumental in achieving:
8021 ;; * Consistency in the view of the world relied on by ASDF within a given session.
8022 ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops
8023 ;; (a.k.a. stack overflows) and other erratic behavior.
8024 ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and
8025 ;; no expensive recomputations of transitive dependencies for input-files or output-files.
8026 ;; * Testability of ASDF with the ability to fake timestamps without actually touching files.
8028 :initform nil :initarg :ancestor :reader session-ancestor
8029 :documentation "Top level session that this is part of")
8031 :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache
8032 :documentation "Memoize expensive computations")
8034 :initform 0 :initarg :operate-level :accessor session-operate-level
8035 :documentation "Number of nested calls to operate we're under (for toplevel session only)")
8036 ;; shouldn't the below be superseded by the session-wide caching of action-status
8037 ;; for (load-op "asdf") ?
8039 :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p
8040 :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.")
8042 :initform nil :initarg :forcing :accessor forcing
8043 :documentation "Forcing parameters for the session")
8044 ;; Table that to actions already visited while walking the dependencies associates status
8045 (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions)
8046 ;; Actions that depend on those being currently walked through, to detect circularities
8047 (visiting-action-set ;; as a set
8048 :initform (make-hash-table :test 'equal) :accessor visiting-action-set)
8049 (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list
8050 ;; Counts of total actions in plan
8051 (total-action-count :initform 0 :accessor total-action-count)
8052 ;; Count of actions that need to be performed
8053 (planned-action-count :initform 0 :accessor planned-action-count)
8054 ;; Count of actions that need to be performed that have a non-empty list of output-files.
8055 (planned-output-action-count :initform 0 :accessor planned-output-action-count))
8056 (:documentation "An ASDF session with a cache to memoize some computations"))
8058 (defun toplevel-asdf-session ()
8059 (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*)))
8061 (defun operate-level ()
8062 (session-operate-level (toplevel-asdf-session)))
8064 (defun (setf operate-level) (new-level)
8065 (setf (session-operate-level (toplevel-asdf-session)) new-level))
8067 (defun asdf-cache ()
8068 (session-cache *asdf-session*))
8070 ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session.
8071 ;; Return those values.
8072 (defun set-asdf-cache-entry (key value-list)
8073 (values-list (if *asdf-session*
8074 (setf (gethash key (asdf-cache)) value-list)
8077 ;; Unset the session cache entry for KEY, when inside a session.
8078 (defun unset-asdf-cache-entry (key)
8079 (when *asdf-session*
8080 (remhash key (session-cache *asdf-session*))))
8082 ;; Consult the session cache entry for KEY if present and in a session;
8083 ;; if not present, compute it by calling the THUNK,
8084 ;; and set the session cache entry accordingly, if in a session.
8085 ;; Return the values from the cache and/or the thunk computation.
8086 (defun consult-asdf-cache (key &optional thunk)
8088 (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*))
8090 (values-list results)
8091 (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
8092 (call-function thunk)))
8094 ;; Syntactic sugar for consult-asdf-cache
8095 (defmacro do-asdf-cache (key &body body)
8096 `(consult-asdf-cache ,key #'(lambda () ,@body)))
8098 ;; Compute inside a ASDF session with a cache.
8099 ;; First, make sure an ASDF session is underway, by binding the session cache variable
8100 ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true).
8101 ;; Second, if a new session was started, establish restarts for retrying the overall computation.
8102 ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache
8103 ;; entry isn't found, or just call the THUNK if no KEY was specified.
8104 (defun call-with-asdf-session (thunk &key override key override-cache override-forcing)
8105 (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk)))
8106 (if (and (not override) *asdf-session*)
8110 (let ((*asdf-session*
8111 (apply 'make-instance *asdf-session-class*
8112 (when *asdf-session*
8113 `(:ancestor ,(toplevel-asdf-session)
8114 ,@(unless override-forcing
8115 `(:forcing ,(forcing *asdf-session*)))
8116 ,@(unless override-cache
8117 `(:session-cache ,(session-cache *asdf-session*))))))))
8118 (return (funcall fun)))
8121 (format s (compatfmt "~@<Retry ASDF operation.~@:>"))))
8122 (clear-configuration-and-retry ()
8124 (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>")))
8125 (unless (null *asdf-session*)
8126 (clrhash (session-cache *asdf-session*)))
8127 (clear-configuration)))))))
8129 ;; Syntactic sugar for call-with-asdf-session
8130 (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body)
8131 `(call-with-asdf-session
8132 #'(lambda () ,@body)
8133 :override ,override :key ,key
8134 :override-cache ,override-cache :override-forcing ,override-forcing))
8137 ;;; Define specific accessor for file (date) stamp.
8139 ;; Normalize a namestring for use as a key in the session cache.
8140 (defun normalize-namestring (pathname)
8141 (let ((resolved (resolve-symlinks*
8142 (ensure-absolute-pathname
8143 (physicalize-pathname pathname)
8144 'get-pathname-defaults))))
8145 (with-pathname-defaults () (namestring resolved))))
8147 ;; Compute the file stamp for a normalized namestring
8148 (defun compute-file-stamp (normalized-namestring)
8149 (with-pathname-defaults ()
8150 (or (safe-file-write-date normalized-namestring) t)))
8152 ;; Override the time STAMP associated to a given FILE in the session cache.
8153 ;; If no STAMP is specified, recompute a new one from the filesystem.
8154 (defun register-file-stamp (file &optional (stamp nil stampp))
8155 (let* ((namestring (normalize-namestring file))
8156 (stamp (if stampp stamp (compute-file-stamp namestring))))
8157 (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp))))
8159 ;; Get or compute a memoized stamp for given FILE from the session cache.
8160 (defun get-file-stamp (file)
8162 (let ((namestring (normalize-namestring file)))
8163 (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))
8168 (define-condition system-definition-error (error) ()
8169 ;; [this use of :report should be redundant, but unfortunately it's not.
8170 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
8171 ;; over print-object; this is always conditions::%print-condition for
8172 ;; condition objects, which in turn does inheritance of :report options at
8173 ;; run-time. fortunately, inheritance means we only need this kludge here in
8174 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
8175 #+cmucl (:report print-object))
8177 (define-condition formatted-system-definition-error (system-definition-error)
8178 ((format-control :initarg :format-control :reader format-control)
8179 (format-arguments :initarg :format-arguments :reader format-arguments))
8180 (:report (lambda (c s)
8181 (apply 'format s (format-control c) (format-arguments c)))))
8183 (defun sysdef-error (format &rest arguments)
8184 (error 'formatted-system-definition-error :format-control
8185 format :format-arguments arguments)))
8186 ;;;; -------------------------------------------------------------------------
8189 (uiop/package:define-package :asdf/component
8190 (:recycle :asdf/component :asdf/find-component :asdf)
8191 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
8193 #:component #:component-find-path
8194 #:find-component ;; methods defined in find-component
8195 #:component-name #:component-pathname #:component-relative-pathname
8196 #:component-parent #:component-system #:component-parent-pathname
8197 #:child-component #:parent-component #:module
8199 #:source-file #:c-source-file #:java-source-file
8200 #:static-file #:doc-file #:html-file
8202 #:source-file-type #:source-file-explicit-type ;; backward-compatibility
8203 #:component-in-order-to #:component-sideway-dependencies
8204 #:component-if-feature #:around-compile-hook
8205 #:component-description #:component-long-description
8206 #:component-version #:version-satisfies
8207 #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
8208 #:component-operation-times ;; For internal use only.
8209 ;; portable ASDF encoding and implementation-specific external-format
8210 #:component-external-format #:component-encoding
8211 #:component-children-by-name #:component-children #:compute-children-by-name
8212 #:component-build-operation
8213 #:module-default-component-class
8214 #:module-components ;; backward-compatibility. DO NOT USE.
8220 ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
8221 #:name #:version #:description #:long-description #:author #:maintainer #:licence
8222 #:components-by-name #:components #:children #:children-by-name
8223 #:default-component-class #:source-file
8224 #:defsystem-depends-on ; This symbol retained for backward compatibility.
8225 #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
8226 #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
8227 #:%encoding #:properties #:component-properties #:parent))
8228 (in-package :asdf/component)
8230 (with-upgradability ()
8231 (defgeneric component-name (component)
8232 (:documentation "Name of the COMPONENT, unique relative to its parent"))
8233 (defgeneric component-system (component)
8234 (:documentation "Top-level system containing the COMPONENT"))
8235 (defgeneric component-pathname (component)
8236 (:documentation "Pathname of the COMPONENT if any, or NIL."))
8237 (defgeneric component-relative-pathname (component)
8238 ;; in ASDF4, rename that to component-specified-pathname ?
8239 (:documentation "Specified pathname of the COMPONENT,
8240 intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
8241 Despite the function's name, the return value can be an absolute pathname, in which case the merge
8242 will leave it unmodified."))
8243 (defgeneric component-external-format (component)
8244 (:documentation "The external-format of the COMPONENT.
8245 By default, deduced from the COMPONENT-ENCODING."))
8246 (defgeneric component-encoding (component)
8247 (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported.
8248 Use asdf-encodings to support more encodings."))
8249 (defgeneric version-satisfies (component version)
8250 (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent
8251 as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL."))
8252 (defgeneric component-version (component)
8253 (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated
8254 natural numbers, or NIL."))
8255 (defgeneric (setf component-version) (new-version component)
8256 (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated
8257 natural numbers, or NIL."))
8258 (defgeneric component-parent (component)
8259 (:documentation "The parent of a child COMPONENT,
8260 or NIL for top-level components (a.k.a. systems)"))
8261 ;; NIL is a designator for the absence of a component, in which case the parent is also absent.
8262 (defmethod component-parent ((component null)) nil)
8264 ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
8265 (with-asdf-deprecation (:style-warning "3.4")
8266 (defgeneric source-file-type (component system)
8267 (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead.")))
8269 (define-condition duplicate-names (system-definition-error)
8270 ((name :initarg :name :reader duplicate-names-name))
8271 (:report (lambda (c s)
8272 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
8273 (duplicate-names-name c))))))
8276 (with-upgradability ()
8277 (defclass component ()
8278 ((name :accessor component-name :initarg :name :type string :documentation
8279 "Component name: designator for a string composed of portable pathname characters")
8280 ;; We might want to constrain version with
8281 ;; :type (and string (satisfies parse-version))
8282 ;; but we cannot until we fix all systems that don't use it correctly!
8283 (version :accessor component-version :initarg :version :initform nil)
8284 (description :accessor component-description :initarg :description :initform nil)
8285 (long-description :accessor component-long-description :initarg :long-description :initform nil)
8286 (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
8287 (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
8288 ;; In the ASDF object model, dependencies exist between *actions*,
8289 ;; where an action is a pair of an operation and a component.
8290 ;; Dependencies are represented as alists of operations
8291 ;; to a list where each entry is a pair of an operation and a list of component specifiers.
8292 ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
8293 ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
8294 ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
8295 ;; and do-first things that modify the current image (such as loading a fasl).
8296 ;; These are now unified because we now correctly propagate timestamps between dependencies.
8297 ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
8298 ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
8299 ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
8300 ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
8301 ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
8302 ;; See our ASDF 2 paper for more complete explanations.
8303 (in-order-to :initform nil :initarg :in-order-to
8304 :accessor component-in-order-to)
8305 ;; Methods defined using the "inline" style inside a defsystem form:
8306 ;; we store them here so we can delete them when the system is re-evaluated.
8307 (inline-methods :accessor component-inline-methods :initform nil)
8308 ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
8309 ;; There is no initform and no direct accessor for this specified pathname,
8310 ;; so we only access the information through appropriate methods, after it has been processed.
8311 ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
8312 (relative-pathname :initarg :pathname)
8313 ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
8314 ;; The slot is but a cache used by component-pathname.
8316 (operation-times :initform (make-hash-table)
8317 :accessor component-operation-times)
8318 (around-compile :initarg :around-compile)
8319 ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
8320 (properties :accessor component-properties :initarg :properties
8322 (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
8323 ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
8324 (parent :initarg :parent :initform nil :reader component-parent)
8326 :initarg :build-operation :initform nil :reader component-build-operation)
8327 ;; Cache for ADDITIONAL-INPUT-FILES function.
8328 (additional-input-files :accessor %additional-input-files :initform nil))
8329 (:documentation "Base class for all components of a build"))
8331 (defgeneric find-component (base path &key registered)
8332 (:documentation "Find a component by resolving the PATH starting from BASE parent.
8333 If REGISTERED is true, only search currently registered systems."))
8335 (defun component-find-path (component)
8336 "Return a path from a root system to the COMPONENT.
8337 The return value is a list of component NAMES; a list of strings."
8338 (check-type component (or null component))
8340 (loop :for c = component :then (component-parent c)
8341 :while c :collect (component-name c))))
8343 (defmethod print-object ((c component) stream)
8344 (print-unreadable-object (c stream :type t :identity nil)
8345 (format stream "~{~S~^ ~}" (component-find-path c))))
8347 (defmethod component-system ((component component))
8348 (if-let (system (component-parent component))
8349 (component-system system)
8353 ;;;; Component hierarchy within a system
8354 ;; The tree typically but not necessarily follows the filesystem hierarchy.
8355 (with-upgradability ()
8356 (defclass child-component (component) ()
8357 (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of
8358 a PARENT-COMPONENT."))
8360 (defclass file-component (child-component)
8361 ((type :accessor file-type :initarg :type)) ; no default
8362 (:documentation "a COMPONENT that represents a file"))
8363 (defclass source-file (file-component)
8364 ((type :accessor source-file-explicit-type ;; backward-compatibility
8365 :initform nil))) ;; NB: many systems have come to rely on this default.
8366 (defclass c-source-file (source-file)
8367 ((type :initform "c")))
8368 (defclass java-source-file (source-file)
8369 ((type :initform "java")))
8370 (defclass static-file (source-file)
8371 ((type :initform nil))
8372 (:documentation "Component for a file to be included as is in the build output"))
8373 (defclass doc-file (static-file) ())
8374 (defclass html-file (doc-file)
8375 ((type :initform "html")))
8377 (defclass parent-component (component)
8380 :initarg :components
8381 :reader module-components ; backward-compatibility
8382 :accessor component-children)
8384 :reader module-components-by-name ; backward-compatibility
8385 :accessor component-children-by-name)
8386 (default-component-class
8388 :initarg :default-component-class
8389 :accessor module-default-component-class))
8390 (:documentation "A PARENT-COMPONENT is a component that may have children.")))
8392 (with-upgradability ()
8393 ;; (Private) Function that given a PARENT component,
8394 ;; the list of children of which has been initialized,
8395 ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name.
8396 ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated.
8397 (defun compute-children-by-name (parent &key only-if-needed-p)
8398 (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
8399 (let ((hash (make-hash-table :test 'equal)))
8400 (setf (component-children-by-name parent) hash)
8401 (loop :for c :in (component-children parent)
8402 :for name = (component-name c)
8403 :for previous = (gethash name hash)
8404 :do (when previous (error 'duplicate-names :name name))
8405 (setf (gethash name hash) c))
8408 (with-upgradability ()
8409 (defclass module (child-component parent-component)
8410 (#+clisp (components)) ;; backward compatibility during upgrade only
8411 (:documentation "A module is a intermediate component with both a parent and children,
8412 typically but not necessarily representing the files in a subdirectory of the build source.")))
8415 ;;;; component pathnames
8416 (with-upgradability ()
8417 (defgeneric component-parent-pathname (component)
8418 (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
8419 (defmethod component-parent-pathname (component)
8420 (component-pathname (component-parent component)))
8422 ;; The default method for component-pathname tries to extract a cached precomputed
8423 ;; absolute-pathname from the relevant slot, and if not, computes it by merging the
8424 ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute)
8425 ;; with the directory of the component-parent-pathname.
8426 (defmethod component-pathname ((component component))
8427 (if (slot-boundp component 'absolute-pathname)
8428 (slot-value component 'absolute-pathname)
8431 (component-relative-pathname component)
8432 (pathname-directory-pathname (component-parent-pathname component)))))
8433 (unless (or (null pathname) (absolute-pathname-p pathname))
8434 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
8435 pathname (component-find-path component)))
8436 (setf (slot-value component 'absolute-pathname) pathname)
8439 ;; Default method for component-relative-pathname:
8440 ;; combine the contents of slot relative-pathname (from specified initarg :pathname)
8441 ;; with the appropriate source-file-type, which defaults to the file-type of the component.
8442 (defmethod component-relative-pathname ((component component))
8443 ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
8444 ;; We ought to be able to extract this from the component alone with FILE-TYPE.
8445 ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
8446 ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
8449 (component-parent-pathname component)))
8450 (parse-unix-namestring
8451 (or (and (slot-boundp component 'relative-pathname)
8452 (slot-value component 'relative-pathname))
8453 (component-name component))
8456 ;; JAR-PATHNAMES always have absolute directories
8457 #+abcl (not (ext:pathname-jar-p parent))
8458 :type (source-file-type component (component-system component))
8459 :defaults (component-parent-pathname component))))
8461 (defmethod source-file-type ((component parent-component) (system parent-component))
8464 (defmethod source-file-type ((component file-component) (system parent-component))
8465 (file-type component)))
8469 (with-upgradability ()
8470 (defmethod component-encoding ((c component))
8471 (or (loop :for x = c :then (component-parent x)
8472 :while x :thereis (%component-encoding x))
8473 (detect-encoding (component-pathname c))))
8475 (defmethod component-external-format ((c component))
8476 (encoding-external-format (component-encoding c))))
8479 ;;;; around-compile-hook
8480 (with-upgradability ()
8481 (defgeneric around-compile-hook (component)
8482 (:documentation "An optional hook function that will be called with one argument, a thunk.
8483 The hook function must call the thunk, that will compile code from the component, and may or may not
8484 also evaluate the compiled results. The hook function may establish dynamic variable bindings around
8485 this compilation, or check its results, etc."))
8486 (defmethod around-compile-hook ((c component))
8488 ((slot-boundp c 'around-compile)
8489 (slot-value c 'around-compile))
8490 ((component-parent c)
8491 (around-compile-hook (component-parent c))))))
8494 ;;;; version-satisfies
8495 (with-upgradability ()
8496 ;; short-circuit testing of null version specifications.
8497 ;; this is an all-pass, without warning
8498 (defmethod version-satisfies :around ((c t) (version null))
8500 (defmethod version-satisfies ((c component) version)
8501 (unless (and version (slot-boundp c 'version) (component-version c))
8503 (warn "Requested version ~S but ~S has no version" version c))
8504 (return-from version-satisfies nil))
8505 (version-satisfies (component-version c) version))
8507 (defmethod version-satisfies ((cver string) version)
8508 (version<= version cver)))
8511 ;;; all sub-components (of a given type)
8512 (with-upgradability ()
8513 (defun sub-components (component &key (type t))
8514 "Compute the transitive sub-components of given COMPONENT that are of given TYPE"
8515 (while-collecting (c)
8516 (labels ((recurse (x)
8517 (when (if-let (it (component-if-feature x)) (featurep it) t)
8518 (when (typep x type)
8520 (when (typep x 'parent-component)
8521 (map () #'recurse (component-children x))))))
8522 (recurse component)))))
8524 ;;;; -------------------------------------------------------------------------
8527 (uiop/package:define-package :asdf/operation
8528 (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
8529 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session)
8532 #:*operations* #:make-operation #:find-operation
8533 #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature.
8534 (in-package :asdf/operation)
8536 ;;; Operation Classes
8537 (when-upgrading (:version "2.27" :when (find-class 'operation nil))
8538 ;; override any obsolete shared-initialize method when upgrading from ASDF2.
8539 (defmethod shared-initialize :after ((o operation) (slot-names t) &key)
8542 (with-upgradability ()
8543 (defclass operation ()
8545 (:documentation "The base class for all ASDF operations.
8547 ASDF does NOT and never did distinguish between multiple operations of the same class.
8548 Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions.
8551 (defvar *in-make-operation* nil)
8553 (defun check-operation-constructor ()
8554 "Enforce that OPERATION instances must be created with MAKE-OPERATION."
8555 (unless *in-make-operation*
8556 (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION.")))
8558 (defmethod print-object ((o operation) stream)
8559 (print-unreadable-object (o stream :type t :identity nil)))
8561 ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking.
8562 #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8
8563 (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys)
8564 (unless (null initargs)
8565 (parameter-error "~S does not accept initargs" 'operation))))
8568 ;;; make-operation, find-operation
8570 (with-upgradability ()
8571 ;; A table to memoize instances of a given operation. There shall be only one.
8572 (defparameter* *operations* (make-hash-table :test 'equal))
8574 ;; A memoizing way of creating instances of operation.
8575 (defun make-operation (operation-class)
8576 "This function creates and memoizes an instance of OPERATION-CLASS.
8577 All operation instances MUST be created through this function.
8579 Use of INITARGS is not supported at this time."
8580 (let ((class (coerce-class operation-class
8581 :package :asdf/interface :super 'operation :error 'sysdef-error))
8582 (*in-make-operation* t))
8583 (ensure-gethash class *operations* `(make-instance ,class))))
8585 ;; This function is mostly for backward and forward compatibility:
8586 ;; operations used to preserve the operation-original-initargs of the context,
8587 ;; and may in the future preserve some operation-canonical-initargs.
8588 ;; Still, the treatment of NIL as a disabling context is useful in some cases.
8589 (defgeneric find-operation (context spec)
8590 (:documentation "Find an operation by resolving the SPEC in the CONTEXT"))
8591 (defmethod find-operation ((context t) (spec operation))
8593 (defmethod find-operation ((context t) (spec symbol))
8594 (when spec ;; NIL designates itself, i.e. absence of operation
8595 (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
8596 (defmethod find-operation ((context t) (spec string))
8597 (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context)
8599 ;;;; -------------------------------------------------------------------------
8602 (uiop/package:define-package :asdf/system
8603 (:recycle :asdf :asdf/system :asdf/find-system)
8604 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component)
8606 #:system #:proto-system #:undefined-system #:reset-system-class
8607 #:system-source-file #:system-source-directory #:system-relative-pathname
8608 #:system-description #:system-long-description
8609 #:system-author #:system-maintainer #:system-licence #:system-license
8611 #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on
8612 #:system-depends-on #:system-weakly-depends-on
8613 #:component-build-pathname #:build-pathname
8614 #:component-entry-point #:entry-point
8615 #:homepage #:system-homepage
8616 #:bug-tracker #:system-bug-tracker
8617 #:mailto #:system-mailto
8618 #:long-name #:system-long-name
8619 #:source-control #:system-source-control
8620 #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename
8621 #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system
8622 (in-package :asdf/system)
8624 (with-upgradability ()
8625 ;; The method is actually defined in asdf/find-system,
8626 ;; but we declare the function here to avoid a forward reference.
8627 (defgeneric find-system (system &optional error-p)
8628 (:documentation "Given a system designator, find the actual corresponding system object.
8629 If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL.
8630 A system designator is usually a string (conventionally all lowercase) or a symbol, designating
8631 the same system as its downcased name; it can also be a system object (designating itself)."))
8633 (defgeneric system-source-file (system)
8634 (:documentation "Return the source file in which system is defined."))
8636 ;; This is bad design, but was the easiest kluge I found to let the user specify that
8637 ;; some special actions create outputs at locations controled by the user that are not affected
8638 ;; by the usual output-translations.
8639 ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't
8640 ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert
8641 ;; *there* the ability of specifying special output paths, not in the system definition.
8642 (defgeneric component-build-pathname (component)
8643 (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the
8644 output pathname for the action using the COMPONENT-BUILD-OPERATION.
8646 NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
8648 ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead?
8649 (defgeneric component-entry-point (component)
8650 (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call
8651 (with no argument) when running an image dumped from the COMPONENT.
8653 NB: This interface is subject to change. Please contact ASDF maintainers if you use it."))
8655 (defmethod component-entry-point ((c component))
8659 ;;;; The system class
8661 (with-upgradability ()
8662 (defclass proto-system () ; slots to keep when resetting a system
8663 ;; To preserve identity for all objects, we'd need keep the components slots
8664 ;; but also to modify parse-component-form to reset the recycled objects.
8667 ;; These two slots contains the *inferred* dependencies of define-op,
8668 ;; from loading the .asd file, as list and as set.
8669 (definition-dependency-list
8670 :initform nil :accessor definition-dependency-list)
8671 (definition-dependency-set
8672 :initform (list-to-hash-set nil) :accessor definition-dependency-set))
8673 (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when
8674 a SYSTEM is redefined and its class is modified."))
8676 (defclass system (module proto-system)
8677 ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component.
8678 (;; {,long-}description is now inherited from component, but we add the legacy accessors
8679 (description :writer (setf system-description))
8680 (long-description :writer (setf system-long-description))
8681 (author :writer (setf system-author) :initarg :author :initform nil)
8682 (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil)
8683 (licence :writer (setf system-licence) :initarg :licence
8684 :writer (setf system-license) :initarg :license
8686 (homepage :writer (setf system-homepage) :initarg :homepage :initform nil)
8687 (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil)
8688 (mailto :writer (setf system-mailto) :initarg :mailto :initform nil)
8689 (long-name :writer (setf system-long-name) :initarg :long-name :initform nil)
8690 ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced.
8691 ;; I'm introducing the slot before the conventions are set for maximum compatibility.
8692 (source-control :writer (setf system-source-control) :initarg :source-control :initform nil)
8694 (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p)
8696 :initform nil :initarg :build-pathname :accessor component-build-pathname)
8698 :initform nil :initarg :entry-point :accessor component-entry-point)
8699 (source-file :initform nil :initarg :source-file :accessor system-source-file)
8700 ;; This slot contains the *declared* defsystem-depends-on dependencies
8701 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on
8703 ;; these two are specially set in parse-component-form, so have no :INITARGs.
8704 (depends-on :reader system-depends-on :initform nil)
8705 (weakly-depends-on :reader system-weakly-depends-on :initform nil))
8706 (:documentation "SYSTEM is the base class for top-level components that users may request
8709 (defclass undefined-system (system) ()
8710 (:documentation "System that was not defined yet."))
8712 (defun reset-system-class (system new-class &rest keys &key &allow-other-keys)
8713 "Erase any data from a SYSTEM except its basic identity, then reinitialize it
8714 based on supplied KEYS."
8715 (change-class (change-class system 'proto-system) new-class)
8716 (apply 'reinitialize-instance system keys)))
8719 ;;; Canonicalizing system names
8721 (with-upgradability ()
8722 (defun coerce-name (name)
8723 "Given a designator for a component NAME, return the name as a string.
8724 The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component),
8725 a SYMBOL (designing its name, downcased), or a STRING (designing itself)."
8727 (component (component-name name))
8728 (symbol (string-downcase name))
8730 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
8732 (defun primary-system-name (system-designator)
8733 "Given a system designator NAME, return the name of the corresponding
8734 primary system, after which the .asd file in which it is defined is named.
8735 If given a string or symbol (to downcase), do it syntactically
8736 by stripping anything from the first slash on.
8737 If given a component, do it semantically by extracting
8738 the system-primary-system-name of its system from its source-file if any,
8739 falling back to the syntactic criterion if none."
8740 (etypecase system-designator
8741 (string (if-let (p (position #\/ system-designator))
8742 (subseq system-designator 0 p) system-designator))
8743 (symbol (primary-system-name (coerce-name system-designator)))
8744 (component (let* ((system (component-system system-designator))
8745 (source-file (physicalize-pathname (system-source-file system))))
8747 (and (equal (pathname-type source-file) "asd")
8748 (pathname-name source-file))
8749 (primary-system-name (component-name system)))))))
8751 (defun primary-system-p (system)
8752 "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL.
8753 If given a string, do it syntactically and return true if the name does not contain a slash.
8754 If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T).
8755 If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name
8756 is the same as its component-name."
8758 (string (not (find #\/ system)))
8759 (symbol (primary-system-p (coerce-name system)))
8760 (component (and (typep system 'system)
8761 (equal (component-name system) (primary-system-name system))))))
8763 (defun coerce-filename (name)
8764 "Coerce a system designator NAME into a string suitable as a filename component.
8765 The (current) transformation is to replace characters /:\\ each by --,
8766 the former being forbidden in a filename component.
8767 NB: The onus is unhappily on the user to avoid clashes."
8768 (frob-substrings (coerce-name name) '("/" ":" "\\") "--")))
8771 ;;; System virtual slot readers, recursing to the primary system if needed.
8772 (with-upgradability ()
8773 (defvar *system-virtual-slots* '(long-name description long-description
8774 author maintainer mailto
8775 homepage source-control
8776 licence version bug-tracker)
8777 "The list of system virtual slot names.")
8778 (defun system-virtual-slot-value (system slot-name)
8779 "Return SYSTEM's virtual SLOT-NAME value.
8780 If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in
8782 (or (slot-value system slot-name)
8783 (unless (primary-system-p system)
8784 (slot-value (find-system (primary-system-name system))
8786 (defmacro define-system-virtual-slot-reader (slot-name)
8787 (let ((name (intern (strcat (string :system-) (string slot-name)))))
8789 (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11
8790 (declaim (notinline ,name))
8791 (defun ,name (system) (system-virtual-slot-value system ',slot-name)))))
8792 (defmacro define-system-virtual-slot-readers ()
8793 `(progn ,@(mapcar (lambda (slot-name)
8794 `(define-system-virtual-slot-reader ,slot-name))
8795 *system-virtual-slots*)))
8796 (define-system-virtual-slot-readers)
8797 (defun system-license (system)
8798 (system-virtual-slot-value system 'licence)))
8803 (with-upgradability ()
8804 ;; Resolve a system designator to a system before extracting its system-source-file
8805 (defmethod system-source-file ((system-name string))
8806 (system-source-file (find-system system-name)))
8807 (defmethod system-source-file ((system-name symbol))
8809 (system-source-file (find-system system-name))))
8811 (defun system-source-directory (system-designator)
8812 "Return a pathname object corresponding to the directory
8813 in which the system specification (.asd file) is located."
8814 (pathname-directory-pathname (system-source-file system-designator)))
8816 (defun system-relative-pathname (system name &key type)
8817 "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
8818 return the absolute pathname of a corresponding file under that system's source code pathname."
8819 (subpathname (system-source-directory system) name :type type))
8821 (defmethod component-pathname ((system system))
8822 "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE,
8823 return the absolute pathname of a corresponding file under that system's source code pathname."
8824 (let ((pathname (or (call-next-method) (system-source-directory system))))
8825 (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
8826 (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
8827 (setf (slot-value system 'relative-pathname) pathname))
8830 ;; The default method of component-relative-pathname for a system:
8831 ;; if a pathname was specified in the .asd file, it must be relative to the .asd file
8832 ;; (actually, to its truename* if *resolve-symlinks* it true, the default).
8833 ;; The method will return an *absolute* pathname, once again showing that the historical name
8834 ;; component-relative-pathname is misleading and should have been component-specified-pathname.
8835 (defmethod component-relative-pathname ((system system))
8836 (parse-unix-namestring
8837 (and (slot-boundp system 'relative-pathname)
8838 (slot-value system 'relative-pathname))
8842 :defaults (system-source-directory system)))
8844 ;; A system has no parent; if some method wants to make a path "relative to its parent",
8845 ;; it will instead be relative to the system itself.
8846 (defmethod component-parent-pathname ((system system))
8847 (system-source-directory system))
8849 ;; Most components don't have a specified component-build-pathname, and therefore
8850 ;; no magic redirection of their output that disregards the output-translations.
8851 (defmethod component-build-pathname ((c component))
8854 ;;;; -------------------------------------------------------------------------
8855 ;;;; Finding systems
8857 (uiop/package:define-package :asdf/system-registry
8858 (:recycle :asdf/system-registry :asdf/find-system :asdf)
8859 (:use :uiop/common-lisp :uiop :asdf/upgrade
8860 :asdf/session :asdf/component :asdf/system)
8862 #:remove-entry-from-registry #:coerce-entry-to-directory
8863 #:registered-system #:register-system
8864 #:registered-systems* #:registered-systems
8865 #:clear-system #:map-systems
8866 #:*system-definition-search-functions* #:search-for-system-definition
8867 #:*central-registry* #:probe-asd #:sysdef-central-registry-search
8868 #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
8869 #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
8870 #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system
8871 #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems*
8872 #:*registered-systems* #:clear-registered-systems
8873 ;; defined in source-registry, but specially mentioned here:
8874 #:sysdef-source-registry-search))
8875 (in-package :asdf/system-registry)
8877 (with-upgradability ()
8878 ;;; Registry of Defined Systems
8880 (defvar *registered-systems* (make-hash-table :test 'equal)
8881 "This is a hash table whose keys are strings -- the names of systems --
8882 and whose values are systems.
8883 A system is referred to as \"registered\" if it is present in this table.")
8885 (defun registered-system (name)
8886 "Return a system of given NAME that was registered already,
8887 if such a system exists. NAME is a system designator, to be
8888 normalized by COERCE-NAME. The value returned is a system object,
8889 or NIL if not found."
8890 (gethash (coerce-name name) *registered-systems*))
8892 (defun registered-systems* ()
8893 "Return a list containing every registered system (as a system object)."
8894 (loop :for registered :being :the :hash-values :of *registered-systems*
8895 :collect registered))
8897 (defun registered-systems ()
8898 "Return a list of the names of every registered system."
8899 (mapcar 'coerce-name (registered-systems*)))
8901 (defun register-system (system)
8902 "Given a SYSTEM object, register it."
8903 (check-type system system)
8904 (let ((name (component-name system)))
8905 (check-type name string)
8906 (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name)
8907 (setf (gethash name *registered-systems*) system)))
8909 (defun map-systems (fn)
8910 "Apply FN to each defined system.
8912 FN should be a function of one argument. It will be
8913 called with an object of type asdf:system."
8914 (loop :for registered :being :the :hash-values :of *registered-systems*
8915 :do (funcall fn registered)))
8918 ;;; Preloaded systems: in the image even if you can't find source files backing them.
8920 (defvar *preloaded-systems* (make-hash-table :test 'equal)
8921 "Registration table for preloaded systems.")
8923 (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system
8925 (defun make-preloaded-system (name keys)
8926 "Make a preloaded system of given NAME with build information from KEYS"
8927 (let ((system (apply 'make-instance (getf keys :class 'system)
8928 :name name :source-file (getf keys :source-file)
8929 (remove-plist-keys '(:class :name :source-file) keys))))
8930 (mark-component-preloaded system)
8933 (defun sysdef-preloaded-system-search (requested)
8934 "If REQUESTED names a system registered as preloaded, return a new system
8935 with its registration information."
8936 (let ((name (coerce-name requested)))
8937 (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
8939 (make-preloaded-system name keys)))))
8941 (defun ensure-preloaded-system-registered (name)
8942 "If there isn't a registered _defined_ system of given NAME,
8943 and a there is a registered _preloaded_ system of given NAME,
8944 then define and register said preloaded system."
8945 (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name)))
8946 (register-system system)))
8948 (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys)
8949 "Register a system as being preloaded. If the system has not been loaded from the filesystem
8950 yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be
8951 registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION).
8952 If VERSION is the default T, and a system was already loaded, then its version will be preserved."
8953 (let ((name (coerce-name system-name)))
8954 (when (eql version t)
8955 (if-let (system (registered-system name))
8956 (setf (getf keys :version) (component-version system))))
8957 (setf (gethash name *preloaded-systems*) keys)
8958 (ensure-preloaded-system-registered system-name)))
8961 ;;; Immutable systems: in the image and can't be reloaded from source.
8963 (defvar *immutable-systems* nil
8964 "A hash-set (equal hash-table mapping keys to T) of systems that are immutable,
8965 i.e. already loaded in memory and not to be refreshed from the filesystem.
8966 They will be treated specially by find-system, and passed as :force-not argument to make-plan.
8968 For instance, to can deliver an image with many systems precompiled, that *will not* check the
8969 filesystem for them every time a user loads an extension, what more risk a problematic upgrade
8970 or catastrophic downgrade, before you dump an image, you may use:
8971 (map () 'asdf:register-immutable-system (asdf:already-loaded-systems))
8973 Note that direct access to this variable from outside ASDF is not supported.
8974 Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and
8975 contact maintainers if you need a stable API to do more than that.")
8977 (defun sysdef-immutable-system-search (requested)
8978 (let ((name (coerce-name requested)))
8979 (when (and *immutable-systems* (gethash name *immutable-systems*))
8980 (or (registered-system requested)
8981 (error 'formatted-system-definition-error
8982 :format-control "Requested system ~A registered as an immutable-system, ~
8983 but not even registered as defined"
8984 :format-arguments (list name))))))
8986 (defun register-immutable-system (system-name &rest keys)
8987 "Register SYSTEM-NAME as preloaded and immutable.
8988 It will automatically be considered as passed to FORCE-NOT in a plan."
8989 (let ((system-name (coerce-name system-name)))
8990 (apply 'register-preloaded-system system-name keys)
8991 (unless *immutable-systems*
8992 (setf *immutable-systems* (list-to-hash-set nil)))
8993 (setf (gethash system-name *immutable-systems*) t)))
8996 ;;; Making systems undefined.
8998 (defun clear-system (system)
8999 "Clear the entry for a SYSTEM in the database of systems previously defined.
9000 However if the system was registered as PRELOADED (which it is if it is IMMUTABLE),
9001 then a new system with the same name will be defined and registered in its place
9002 from which build details will have been cleared.
9003 Note that this does NOT in any way cause any of the code of the system to be unloaded.
9004 Returns T if system was or is now undefined, NIL if a new preloaded system was redefined."
9005 ;; There is no "unload" operation in Common Lisp, and
9006 ;; a general such operation cannot be portably written,
9007 ;; considering how much CL relies on side-effects to global data structures.
9008 (let ((name (coerce-name system)))
9009 (remhash name *registered-systems*)
9010 (unset-asdf-cache-entry `(find-system ,name))
9011 (not (ensure-preloaded-system-registered name))))
9013 (defun clear-registered-systems ()
9014 "Clear all currently registered defined systems.
9015 Preloaded systems (including immutable ones) will be reset, other systems will be de-registered."
9016 (map () 'clear-system (registered-systems)))
9019 ;;; Searching for system definitions
9021 ;; For the sake of keeping things reasonably neat, we adopt a convention that
9022 ;; only symbols are to be pushed to this list (rather than e.g. function objects),
9023 ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF-
9024 (defvar *system-definition-search-functions* '()
9025 "A list that controls the ways that ASDF looks for system definitions.
9026 It contains symbols to be funcalled in order, with a requested system name as argument,
9027 until one returns a non-NIL result (if any), which must then be a fully initialized system object
9030 ;; Initialize and/or upgrade the *system-definition-search-functions*
9031 ;; so it doesn't contain obsolete symbols, and does contain the current ones.
9032 (defun cleanup-system-definition-search-functions ()
9033 (setf *system-definition-search-functions*
9035 ;; Remove known-incompatible sysdef functions from old versions of asdf.
9036 ;; Order matters, so we can't just use set-difference.
9038 '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search)))
9039 (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*))
9040 ;; Tuck our defaults at the end of the list if they were absent.
9041 ;; This is imperfect, in case they were removed on purpose,
9042 ;; but then it will be the responsibility of whoever removes these symmbols
9043 ;; to upgrade asdf before he does such a thing rather than after.
9044 (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
9045 '(sysdef-central-registry-search
9046 sysdef-source-registry-search)))))
9047 (cleanup-system-definition-search-functions)
9049 ;; This (private) function does the search for a system definition using *s-d-s-f*;
9050 ;; it is to be called by locate-system.
9051 (defun search-for-system-definition (system)
9052 ;; Search for valid definitions of the system available in the current session.
9053 ;; Previous definitions as registered in *registered-systems* MUST NOT be considered;
9054 ;; they will be reconciled by locate-system then find-system.
9055 ;; There are two special treatments: first, specially search for objects being defined
9056 ;; in the current session, to avoid definition races between several files;
9057 ;; second, specially search for immutable systems, so they cannot be redefined.
9058 ;; Finally, use the search functions specified in *system-definition-search-functions*.
9059 (let ((name (coerce-name system)))
9060 (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x))))
9061 (try 'find-system-if-being-defined)
9062 (try 'sysdef-immutable-system-search)
9063 (map () #'try *system-definition-search-functions*))))
9066 ;;; The legacy way of finding a system: the *central-registry*
9068 ;; This variable contains a list of directories to be lazily searched for the requested asd
9069 ;; by sysdef-central-registry-search.
9070 (defvar *central-registry* nil
9071 "A list of 'system directory designators' ASDF uses to find systems.
9073 A 'system directory designator' is a pathname or an expression
9074 which evaluates to a pathname. For example:
9076 (setf asdf:*central-registry*
9077 (list '*default-pathname-defaults*
9078 #p\"/home/me/cl/systems/\"
9079 #p\"/usr/share/common-lisp/systems/\"))
9081 This variable is for backward compatibility.
9082 Going forward, we recommend new users should be using the source-registry.")
9084 ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS.
9085 ;; Return the truename of that file if it is found and TRUENAME is true.
9086 ;; Return NIL if the file is not found.
9087 ;; On Windows, follow shortcuts to .asd files.
9088 (defun probe-asd (name defaults &key truename)
9090 (when (directory-pathname-p defaults)
9091 (if-let (file (probe-file*
9092 (ensure-absolute-pathname
9093 (parse-unix-namestring name :type "asd")
9094 #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil))
9096 :truename truename))
9098 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
9101 (when (physical-pathname-p defaults)
9104 :defaults defaults :case :local
9105 :name (strcat name ".asd")
9107 (when (probe-file* shortcut)
9108 (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
9110 ;; Function to push onto *s-d-s-f* to use the *central-registry*
9111 (defun sysdef-central-registry-search (system)
9112 (let ((name (primary-system-name system))
9117 (dolist (dir *central-registry*)
9118 (let ((defaults (eval dir))
9121 (cond ((directory-pathname-p defaults)
9122 (let* ((file (probe-asd name defaults :truename *resolve-symlinks*)))
9127 (let* ((*print-circle* nil)
9130 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not an absolute directory.~@:>")
9131 system dir defaults)))
9133 (remove-entry-from-registry ()
9134 :report "Remove entry from *central-registry* and continue"
9135 (push dir to-remove))
9136 (coerce-entry-to-directory ()
9137 :test (lambda (c) (declare (ignore c))
9138 (and (not (directory-pathname-p defaults))
9139 (directory-pathname-p
9141 (ensure-directory-pathname defaults)))))
9143 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
9145 (push (cons dir directorized) to-replace))))))))
9147 (dolist (dir to-remove)
9148 (setf *central-registry* (remove dir *central-registry*)))
9149 (dolist (pair to-replace)
9150 (let* ((current (car pair))
9152 (position (position current *central-registry*)))
9153 (setf *central-registry*
9154 (append (subseq *central-registry* 0 position)
9156 (subseq *central-registry* (1+ position)))))))))))
9158 ;;;; -------------------------------------------------------------------------
9161 (uiop/package:define-package :asdf/action
9162 (:nicknames :asdf-action)
9163 (:recycle :asdf/action :asdf/plan :asdf)
9164 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation)
9165 (:import-from :asdf/operation #:check-operation-constructor)
9166 (:import-from :asdf/component #:%additional-input-files)
9168 #:action #:define-convenience-action-methods
9169 #:action-description #:format-action
9170 #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
9171 #:non-propagating-operation
9172 #:component-depends-on
9173 #:input-files #:output-files #:output-file #:operation-done-p
9174 #:action-operation #:action-component #:make-action
9175 #:component-operation-time #:mark-operation-done #:compute-action-stamp
9176 #:perform #:perform-with-restarts #:retry #:accept
9177 #:action-path #:find-action
9178 #:operation-definition-warning #:operation-definition-error ;; condition
9180 #:circular-dependency #:circular-dependency-actions
9181 #:call-while-visiting-action #:while-visiting-action
9182 #:additional-input-files))
9183 (in-package :asdf/action)
9185 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning
9188 "A pair of operation and component uniquely identifies a node in the dependency graph
9189 of steps to be performed while building a system."
9190 '(cons operation component))
9192 (deftype operation-designator ()
9193 "An operation designates itself. NIL designates a context-dependent current operation,
9194 and a class-name or class designates the canonical instance of the designated class."
9195 '(or operation null symbol class)))
9197 ;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan
9199 (with-upgradability ()
9200 (defun make-action (operation component)
9201 (cons operation component))
9202 (defun action-operation (action)
9204 (defun action-component (action)
9207 ;;;; Reified representation for storage or debugging. Note: an action is identified by its class.
9208 (with-upgradability ()
9209 (defun action-path (action)
9210 "A readable data structure that identifies the action."
9212 (let ((o (action-operation action))
9213 (c (action-component action)))
9214 (cons (type-of o) (component-find-path c)))))
9215 (defun find-action (path)
9216 "Reconstitute an action from its action-path"
9217 (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c)))))
9219 ;;;; Convenience methods
9220 (with-upgradability ()
9221 ;; A macro that defines convenience methods for a generic function (gf) that
9222 ;; dispatches on operation and component. The convenience methods allow users
9223 ;; to call the gf with operation and/or component designators, that the
9224 ;; methods will resolve into actual operation and component objects, so that
9225 ;; the users can interact using readable designators, but developers only have
9226 ;; to write methods that handle operation and component objects.
9227 ;; FUNCTION is the generic function name
9228 ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT.
9229 ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found.
9230 ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found.
9231 (defmacro define-convenience-action-methods
9232 (function formals &key if-no-operation if-no-component)
9233 (let* ((rest (gensym "REST"))
9234 (found (gensym "FOUND"))
9235 (keyp (equal (last formals) '(&key)))
9236 (formals-no-key (if keyp (butlast formals) formals))
9237 (len (length formals-no-key))
9238 (operation 'operation)
9239 (component 'component)
9240 (opix (position operation formals))
9241 (coix (position component formals))
9242 (prefix (subseq formals 0 opix))
9243 (suffix (subseq formals (1+ coix) len))
9244 (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
9245 (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
9246 (flet ((next-method (o c)
9248 `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
9249 `(,function ,@prefix ,o ,c ,@suffix))))
9251 (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args)
9252 (declare (notinline ,function))
9253 (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on
9254 ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component)))
9255 (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args)
9256 (declare (notinline ,function))
9259 `(make-operation ,operation)
9260 `(or (find-component () ,component) ,if-no-component))
9262 (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
9263 (declare (notinline ,function))
9264 (if (typep ,component 'component)
9265 (error "No defined method for ~S on ~/asdf-action:format-action/"
9266 ',function (make-action ,operation ,component))
9267 (if-let (,found (find-component () ,component))
9268 ,(next-method operation found)
9269 ,if-no-component))))))))
9272 ;;;; Self-description
9273 (with-upgradability ()
9274 (defgeneric action-description (operation component)
9275 (:documentation "returns a phrase that describes performing this operation
9276 on this component, e.g. \"loading /a/b/c\".
9277 You can put together sentences using this phrase."))
9278 (defmethod action-description (operation component)
9279 (format nil (compatfmt "~@<~A on ~A~@:>")
9280 operation component))
9282 (defun format-action (stream action &optional colon-p at-sign-p)
9283 "FORMAT helper to display an action's action-description.
9284 Use it in FORMAT control strings as ~/asdf-action:format-action/"
9285 (assert (null colon-p)) (assert (null at-sign-p))
9286 (destructuring-bind (operation . component) action
9287 (princ (action-description operation component) stream))))
9290 ;;;; Detection of circular dependencies
9291 (with-upgradability ()
9292 (defun action-valid-p (operation component)
9293 "Is this action valid to include amongst dependencies?"
9294 ;; If either the operation or component was resolved to nil, the action is invalid.
9295 ;; :if-feature will invalidate actions on components for which the features don't apply.
9296 (and operation component
9297 (if-let (it (component-if-feature component)) (featurep it) t)))
9299 (define-condition circular-dependency (system-definition-error)
9300 ((actions :initarg :actions :reader circular-dependency-actions))
9301 (:report (lambda (c s)
9302 (format s (compatfmt "~@<Circular dependency of ~s on: ~3i~_~S~@:>")
9303 (first (circular-dependency-actions c))
9304 (circular-dependency-actions c)))))
9306 (defun call-while-visiting-action (operation component fun)
9307 "Detect circular dependencies"
9308 (with-asdf-session ()
9309 (with-accessors ((action-set visiting-action-set)
9310 (action-list visiting-action-list)) *asdf-session*
9311 (let ((action (cons operation component)))
9312 (when (gethash action action-set)
9313 (error 'circular-dependency :actions
9314 (member action (reverse action-list) :test 'equal)))
9315 (setf (gethash action action-set) t)
9316 (push action action-list)
9320 (setf (gethash action action-set) nil))))))
9322 ;; Syntactic sugar for call-while-visiting-action
9323 (defmacro while-visiting-action ((o c) &body body)
9324 `(call-while-visiting-action ,o ,c #'(lambda () ,@body))))
9328 (with-upgradability ()
9329 (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
9331 "Returns a list of dependencies needed by the component to perform
9332 the operation. A dependency has one of the following forms:
9334 (<operation> <component>*), where <operation> is an operation designator
9335 with respect to FIND-OPERATION in the context of the OPERATION argument,
9336 and each <component> is a component designator with respect to
9337 FIND-COMPONENT in the context of the COMPONENT argument,
9338 and means that the component depends on
9339 <operation> having been performed on each <component>;
9341 [Note: an <operation> is an operation designator -- it can be either an
9342 operation name or an operation object. Similarly, a <component> may be
9343 a component name or a component object. Also note that, the degenerate
9344 case of (<operation>) is a no-op.]
9346 Methods specialized on subclasses of existing component types
9347 should usually append the results of CALL-NEXT-METHOD to the list."))
9348 (define-convenience-action-methods component-depends-on (operation component))
9350 (defmethod component-depends-on :around ((o operation) (c component))
9351 (do-asdf-cache `(component-depends-on ,o ,c)
9352 (call-next-method))))
9355 ;;;; upward-operation, downward-operation, sideway-operation, selfward-operation
9356 ;; These together handle actions that propagate along the component hierarchy or operation universe.
9357 (with-upgradability ()
9358 (defclass downward-operation (operation)
9359 ((downward-operation
9360 :initform nil :reader downward-operation
9361 :type operation-designator :allocation :class))
9362 (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy.
9363 I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then
9364 the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M.
9365 The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself.
9366 E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the
9367 children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP."))
9368 (defun downward-operation-depends-on (o c)
9369 `((,(or (downward-operation o) o) ,@(component-children c))))
9370 (defmethod component-depends-on ((o downward-operation) (c parent-component))
9371 `(,@(downward-operation-depends-on o c) ,@(call-next-method)))
9373 (defclass upward-operation (operation)
9375 :initform nil :reader upward-operation
9376 :type operation-designator :allocation :class))
9377 (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy.
9378 I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U,
9379 then the action (O . C) of O on a component C that has the parent P will depends on (U . P).
9380 The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself.
9381 E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT
9382 must first be prepared for loading or compiling with PREPARE-OP."))
9383 ;; For backward-compatibility reasons, a system inherits from module and is a child-component
9384 ;; so we must guard against this case. ASDF4: remove that.
9385 (defun upward-operation-depends-on (o c)
9386 (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p))))
9387 (defmethod component-depends-on ((o upward-operation) (c child-component))
9388 `(,@(upward-operation-depends-on o c) ,@(call-next-method)))
9390 (defclass sideway-operation (operation)
9392 :initform nil :reader sideway-operation
9393 :type operation-designator :allocation :class))
9394 (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings
9395 that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot
9396 designates operation S (where NIL designates O itself), then the action (O . C) of O on component C
9397 depends on each of (S . D) where D is a declared dependency of C.
9398 E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP,
9399 each of its declared dependencies must first be loaded as by LOAD-OP."))
9400 (defun sideway-operation-depends-on (o c)
9401 `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c))))
9402 (defmethod component-depends-on ((o sideway-operation) (c component))
9403 `(,@(sideway-operation-depends-on o c) ,@(call-next-method)))
9405 (defclass selfward-operation (operation)
9406 ((selfward-operation
9407 ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which
9408 :type (or operation-designator list) :reader selfward-operation :allocation :class))
9409 (:documentation "A SELFWARD-OPERATION depends on another operation on the same component.
9410 I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L,
9411 then the action (O . C) of O on component C depends on each (S . C) for S in L.
9412 E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP.
9413 A operation-designator designates a singleton list of the designated operation;
9414 a list of operation-designators designates the list of designated operations;
9415 NIL is not a valid operation designator in that context. Note that any dependency
9416 ordering between the operations in a list of SELFWARD-OPERATION should be specified separately
9417 in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly."))
9418 (defun selfward-operation-depends-on (o c)
9419 (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c)))
9420 (defmethod component-depends-on ((o selfward-operation) (c component))
9421 `(,@(selfward-operation-depends-on o c) ,@(call-next-method)))
9423 (defclass non-propagating-operation (operation)
9425 (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates
9426 no dependencies whatsoever. It is supplied in order that the programmer be able
9427 to specify that s/he is intentionally specifying an operation which invokes no
9431 ;;;---------------------------------------------------------------------------
9432 ;;; Help programmers catch obsolete OPERATION subclasses
9433 ;;;---------------------------------------------------------------------------
9434 (with-upgradability ()
9435 (define-condition operation-definition-warning (simple-warning)
9437 (:documentation "Warning condition related to definition of obsolete OPERATION objects."))
9439 (define-condition operation-definition-error (simple-error)
9441 (:documentation "Error condition related to definition of incorrect OPERATION objects."))
9443 (defmethod initialize-instance :before ((o operation) &key)
9444 (check-operation-constructor)
9445 (unless (typep o '(or downward-operation upward-operation sideway-operation
9446 selfward-operation non-propagating-operation))
9447 (warn 'operation-definition-warning
9449 "No dependency propagating scheme specified for operation class ~S.
9450 The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins."
9451 :format-arguments (list (type-of o)))))
9453 (defmethod initialize-instance :before ((o non-propagating-operation) &key)
9454 (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation))
9455 (error 'operation-definition-error
9457 "Inconsistent class: ~S
9458 NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses."
9460 (list (type-of o)))))
9462 (defun backward-compatible-depends-on (o c)
9463 "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of
9464 DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION.
9465 The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that
9466 don't. In the future this functionality will be removed, and the default will be no propagation."
9467 (uiop/version::notify-deprecated-function
9468 (version-deprecation *asdf-version* :style-warning "3.2")
9469 `(backward-compatible-depends-on :for-operation ,o))
9470 `(,@(sideway-operation-depends-on o c)
9471 ,@(when (typep c 'parent-component) (downward-operation-depends-on o c))))
9473 (defmethod component-depends-on ((o operation) (c component))
9474 `(;; Normal behavior, to allow user-specified in-order-to dependencies
9475 ,@(cdr (assoc (type-of o) (component-in-order-to c)))
9476 ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation
9477 ;; or non-propagation through an appropriate mixin will be downward and sideway.
9478 ,@(unless (typep o '(or downward-operation upward-operation sideway-operation
9479 selfward-operation non-propagating-operation))
9480 (backward-compatible-depends-on o c))))
9482 (defmethod downward-operation ((o operation)) nil)
9483 (defmethod sideway-operation ((o operation)) nil))
9486 ;;;---------------------------------------------------------------------------
9487 ;;; End of OPERATION class checking
9488 ;;;---------------------------------------------------------------------------
9491 ;;;; Inputs, Outputs, and invisible dependencies
9492 (with-upgradability ()
9493 (defgeneric output-files (operation component)
9494 (:documentation "Methods for this function return two values: a list of output files
9495 corresponding to this action, and a boolean indicating if they have already been subjected
9496 to relevant output translations and should not be further translated.
9498 Methods on PERFORM *must* call this function to determine where their outputs are to be located.
9499 They may rely on the order of the files to discriminate between outputs.
9501 (defgeneric input-files (operation component)
9502 (:documentation "A list of input files corresponding to this action.
9504 Methods on PERFORM *must* call this function to determine where their inputs are located.
9505 They may rely on the order of the files to discriminate between inputs.
9507 (defgeneric operation-done-p (operation component)
9508 (:documentation "Returns a boolean which is NIL if the action must be performed (again)."))
9509 (define-convenience-action-methods output-files (operation component))
9510 (define-convenience-action-methods input-files (operation component))
9511 (define-convenience-action-methods operation-done-p (operation component))
9513 (defmethod operation-done-p ((o operation) (c component))
9516 ;; Translate output files, unless asked not to. Memoize the result.
9517 (defmethod output-files :around ((operation t) (component t))
9518 (do-asdf-cache `(output-files ,operation ,component)
9520 (multiple-value-bind (pathnames fixedp) (call-next-method)
9521 ;; 1- Make sure we have absolute pathnames
9522 (let* ((directory (pathname-directory-pathname
9523 (component-pathname (find-component () component))))
9526 :for pathname :in pathnames
9527 :collect (ensure-absolute-pathname pathname directory))))
9528 ;; 2- Translate those pathnames as required
9531 (mapcar *output-translation-function* absolute-pathnames))))
9533 (defmethod output-files ((o operation) (c component))
9535 (defun output-file (operation component)
9536 "The unique output file of performing OPERATION on COMPONENT"
9537 (let ((files (output-files operation component)))
9538 (assert (length=n-p files 1))
9541 (defgeneric additional-input-files (operation component)
9542 (:documentation "Additional input files for the operation on this
9543 component. These are files that are inferred, rather than
9544 explicitly specified, and these are typically NOT files that
9545 undergo operations directly. Instead, they are files that it is
9546 important for ASDF to know about in order to compute operation times,etc."))
9547 (define-convenience-action-methods additional-input-files (operation component))
9548 (defmethod additional-input-files ((op operation) (comp component))
9549 (cdr (assoc op (%additional-input-files comp))))
9551 ;; Memoize input files.
9552 (defmethod input-files :around (operation component)
9553 (do-asdf-cache `(input-files ,operation ,component)
9554 ;; get the additional input files, if any
9555 (append (call-next-method)
9556 ;; must come after the first, for other code that
9557 ;; assumes the first will be the "key" file
9558 (additional-input-files operation component))))
9560 ;; By default an action has no input-files.
9561 (defmethod input-files ((o operation) (c component))
9564 ;; An action with a selfward-operation by default gets its input-files from the output-files of
9565 ;; the actions using selfward-operations it depends on (and the same component),
9566 ;; or if there are none, on the component-pathname of the component if it's a file
9567 ;; -- and then on the results of the next-method.
9568 (defmethod input-files ((o selfward-operation) (c component))
9569 `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
9570 :append (or (output-files dep-o c) (input-files dep-o c)))
9571 (if-let ((pathname (component-pathname c)))
9572 (and (file-pathname-p pathname) (list pathname))))
9573 ,@(call-next-method))))
9576 ;;;; Done performing
9577 (with-upgradability ()
9578 ;; ASDF4: hide it behind plan-action-stamp
9579 (defgeneric component-operation-time (operation component)
9580 (:documentation "Return the timestamp for when an action was last performed"))
9581 (defgeneric (setf component-operation-time) (time operation component)
9582 (:documentation "Update the timestamp for when an action was last performed"))
9583 (define-convenience-action-methods component-operation-time (operation component))
9585 ;; ASDF4: hide it behind (setf plan-action-stamp)
9586 (defgeneric mark-operation-done (operation component)
9587 (:documentation "Mark a action as having been just done.
9589 Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP
9590 using the JUST-DONE flag."))
9591 (defgeneric compute-action-stamp (plan- operation component &key just-done)
9592 ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!)
9593 (:documentation "Has this action been successfully done already,
9594 and at what known timestamp has it been done at or will it be done at?
9595 * PLAN is a plan object modelling future effects of actions,
9596 or NIL to denote what actually happened.
9597 * OPERATION and COMPONENT denote the action.
9598 Takes keyword JUST-DONE:
9599 * JUST-DONE is a boolean that is true if the action was just successfully performed,
9600 at which point we want compute the actual stamp and warn if files are missing;
9601 otherwise we are making plans, anticipating the effects of the action.
9603 * a STAMP saying when it was done or will be done,
9604 or T if the action involves files that need to be recomputed.
9605 * a boolean DONE-P that indicates whether the action has actually been done,
9606 and both its output-files and its in-image side-effects are up to date."))
9608 (defmethod component-operation-time ((o operation) (c component))
9609 (gethash o (component-operation-times c)))
9611 (defmethod (setf component-operation-time) (stamp (o operation) (c component))
9612 (assert stamp () "invalid null stamp for ~A" (action-description o c))
9613 (setf (gethash o (component-operation-times c)) stamp))
9615 (defmethod mark-operation-done ((o operation) (c component))
9616 (let ((stamp (compute-action-stamp nil o c :just-done t)))
9617 (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1
9618 (setf (component-operation-time o c) stamp))))
9622 (with-upgradability ()
9623 (defgeneric perform (operation component)
9624 (:documentation "PERFORM an action, consuming its input-files and building its output-files"))
9625 (define-convenience-action-methods perform (operation component))
9627 (defmethod perform :around ((o operation) (c component))
9628 (while-visiting-action (o c) (call-next-method)))
9629 (defmethod perform :before ((o operation) (c component))
9630 (ensure-all-directories-exist (output-files o c)))
9631 (defmethod perform :after ((o operation) (c component))
9632 (mark-operation-done o c))
9633 (defmethod perform ((o operation) (c parent-component))
9635 (defmethod perform ((o operation) (c source-file))
9636 ;; For backward compatibility, don't error on operations that don't specify propagation.
9637 (when (typep o '(or downward-operation upward-operation sideway-operation
9638 selfward-operation non-propagating-operation))
9640 (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>")
9641 'perform (make-action o c))))
9643 ;; The restarts of the perform-with-restarts variant matter in an interactive context.
9644 ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build
9645 ;; may call perform directly rather than call p-w-r.
9646 (defgeneric perform-with-restarts (operation component)
9647 (:documentation "PERFORM an action in a context where suitable restarts are in place."))
9648 (defmethod perform-with-restarts (operation component)
9649 (perform operation component))
9650 (defmethod perform-with-restarts :around (operation component)
9653 (return (call-next-method))
9657 (format s (compatfmt "~@<Retry ~A.~@:>")
9658 (action-description operation component))))
9662 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
9663 (action-description operation component)))
9664 (mark-operation-done operation component)
9666 ;;;; -------------------------------------------------------------------------
9667 ;;;; Actions to build Common Lisp software
9669 (uiop/package:define-package :asdf/lisp-action
9670 (:recycle :asdf/lisp-action :asdf)
9671 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
9672 :asdf/component :asdf/system :asdf/operation :asdf/action)
9675 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
9676 #:basic-load-op #:basic-compile-op
9677 #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
9678 #:call-with-around-compile-hook
9679 #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
9680 #:lisp-compilation-output-files))
9681 (in-package :asdf/lisp-action)
9684 ;;;; Component classes
9685 (with-upgradability ()
9686 (defclass cl-source-file (source-file)
9687 ((type :initform "lisp"))
9688 (:documentation "Component class for a Common Lisp source file (using type \"lisp\")"))
9689 (defclass cl-source-file.cl (cl-source-file)
9690 ((type :initform "cl"))
9691 (:documentation "Component class for a Common Lisp source file using type \"cl\""))
9692 (defclass cl-source-file.lsp (cl-source-file)
9693 ((type :initform "lsp"))
9694 (:documentation "Component class for a Common Lisp source file using type \"lsp\"")))
9697 ;;;; Operation classes
9698 (with-upgradability ()
9699 (defclass basic-load-op (operation) ()
9700 (:documentation "Base class for operations that apply the load-time effects of a file"))
9701 (defclass basic-compile-op (operation) ()
9702 (:documentation "Base class for operations that apply the compile-time effects of a file")))
9705 ;;; Our default operations: loading into the current lisp image
9706 (with-upgradability ()
9707 (defclass prepare-op (upward-operation sideway-operation)
9708 ((sideway-operation :initform 'load-op :allocation :class))
9709 (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT."))
9710 (defclass load-op (basic-load-op downward-operation selfward-operation)
9711 ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
9712 ;; so we need to directly depend on prepare-op for its side-effects in the current image.
9713 ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))
9714 (:documentation "Operation for loading the compiled FASL for a Lisp file"))
9715 (defclass compile-op (basic-compile-op downward-operation selfward-operation)
9716 ((selfward-operation :initform 'prepare-op :allocation :class))
9717 (:documentation "Operation for compiling a Lisp file to a FASL"))
9720 (defclass prepare-source-op (upward-operation sideway-operation)
9721 ((sideway-operation :initform 'load-source-op :allocation :class))
9722 (:documentation "Operation for loading the dependencies of a Lisp file as source."))
9723 (defclass load-source-op (basic-load-op downward-operation selfward-operation)
9724 ((selfward-operation :initform 'prepare-source-op :allocation :class))
9725 (:documentation "Operation for loading a Lisp file as source."))
9727 (defclass test-op (selfward-operation)
9728 ((selfward-operation :initform 'load-op :allocation :class))
9729 (:documentation "Operation for running the tests for system.
9730 If the tests fail, an error will be signaled.")))
9733 ;;;; Methods for prepare-op, compile-op and load-op
9736 (with-upgradability ()
9737 (defmethod action-description ((o prepare-op) (c component))
9738 (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c))
9739 (defmethod perform ((o prepare-op) (c component))
9741 (defmethod input-files ((o prepare-op) (s system))
9742 (if-let (it (system-source-file s)) (list it))))
9745 (with-upgradability ()
9746 (defmethod action-description ((o compile-op) (c component))
9747 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c))
9748 (defmethod action-description ((o compile-op) (c parent-component))
9749 (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c))
9750 (defgeneric call-with-around-compile-hook (component thunk)
9751 (:documentation "A method to be called around the PERFORM'ing of actions that apply the
9752 compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used
9753 to setup readtables and other variables that control reading, macroexpanding, and compiling, etc.
9754 Note that it will NOT be called around the performing of LOAD-OP."))
9755 (defmethod call-with-around-compile-hook ((c component) function)
9756 (call-around-hook (around-compile-hook c) function))
9757 (defun perform-lisp-compilation (o c)
9758 "Perform the compilation of the Lisp file associated to the specified action (O . C)."
9759 (let (;; Before 2.26.53, that was unfortunately component-pathname. Now,
9760 ;; we consult input-files, the first of which should be the one to compile-file
9761 (input-file (first (input-files o c)))
9762 ;; On some implementations, there are more than one output-file,
9763 ;; but the first one should always be the primary fasl that gets loaded.
9764 (outputs (output-files o c)))
9765 (multiple-value-bind (output warnings-p failure-p)
9769 #+(or clasp ecl mkcl) object-file
9771 warnings-file &rest rest) outputs
9772 ;; Allow for extra outputs that are not of type warnings-file
9773 ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
9774 (declare (ignore rest))
9776 (unless (equal (pathname-type warnings-file) (warnings-file-type))
9777 (setf warnings-file nil)))
9778 (let ((*package* (find-package* '#:common-lisp-user)))
9779 (call-with-around-compile-hook
9780 c #'(lambda (&rest flags)
9781 (apply 'compile-file* input-file
9782 :output-file output-file
9783 :external-format (component-external-format c)
9784 :warnings-file warnings-file
9786 #+clisp (list :lib-file lib-file)
9787 #+(or clasp ecl mkcl) (list :object-file object-file)
9789 (check-lisp-compile-results output warnings-p failure-p
9790 "~/asdf-action::format-action/" (list (cons o c))))))
9791 (defun report-file-p (f)
9792 "Is F a build report file containing, e.g., warnings to check?"
9793 (equalp (pathname-type f) "build-report"))
9794 (defun perform-lisp-warnings-check (o c)
9795 "Check the warnings associated with the dependencies of an action."
9796 (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
9797 (actual-warnings-files (loop :for w :in expected-warnings-files
9798 :when (get-file-stamp w)
9800 :else :do (warn "Missing warnings file ~S while ~A"
9801 w (action-description o c)))))
9802 (check-deferred-warnings actual-warnings-files)
9803 (let* ((output (output-files o c))
9804 (report (find-if #'report-file-p output)))
9806 (with-open-file (s report :direction :output :if-exists :supersede)
9807 (format s ":success~%"))))))
9808 (defmethod perform ((o compile-op) (c cl-source-file))
9809 (perform-lisp-compilation o c))
9810 (defun lisp-compilation-output-files (o c)
9811 "Compute the output-files for compiling the Lisp file for the specified action (O . C),
9812 an OPERATION and a COMPONENT."
9813 (let* ((i (first (input-files o c)))
9814 (f (compile-file-pathname
9815 i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl
9816 #+mkcl :fasl-p #+mkcl t)))
9817 `(,f ;; the fasl is the primary output, in first position
9819 ,@(unless nil ;; was (use-ecl-byte-compiler-p)
9820 `(,(compile-file-pathname i :output-type :object)))
9822 ,@`(,(make-pathname :type "lib" :defaults f))
9824 ,@(unless (use-ecl-byte-compiler-p)
9825 `(,(compile-file-pathname i :type :object)))
9827 ,(compile-file-pathname i :fasl-p nil) ;; object file
9828 ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
9829 `(,(make-pathname :type *warnings-file-type* :defaults f))))))
9830 (defmethod output-files ((o compile-op) (c cl-source-file))
9831 (lisp-compilation-output-files o c))
9832 (defmethod perform ((o compile-op) (c static-file))
9835 ;; Performing compile-op on a system will check the deferred warnings for the system
9836 (defmethod perform ((o compile-op) (c system))
9837 (when (and *warnings-file-type* (not (builtin-system-p c)))
9838 (perform-lisp-warnings-check o c)))
9839 (defmethod input-files ((o compile-op) (c system))
9840 (when (and *warnings-file-type* (not (builtin-system-p c)))
9841 ;; The most correct way to do it would be to use:
9842 ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file)
9843 ;; but it's expensive and we don't care too much about file order or ASDF extensions.
9844 (loop :for sub :in (sub-components c :type 'cl-source-file)
9845 :nconc (remove-if-not 'warnings-file-p (output-files o sub)))))
9846 (defmethod output-files ((o compile-op) (c system))
9847 (when (and *warnings-file-type* (not (builtin-system-p c)))
9848 (if-let ((pathname (component-pathname c)))
9849 (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
9852 (with-upgradability ()
9853 (defmethod action-description ((o load-op) (c cl-source-file))
9854 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c))
9855 (defmethod action-description ((o load-op) (c parent-component))
9856 (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c))
9857 (defmethod action-description ((o load-op) (c component))
9858 (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c))
9859 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
9862 (return (call-next-method))
9865 (format s "Recompile ~a and try loading it again"
9866 (component-name c)))
9867 (perform (find-operation o 'compile-op) c)))))
9868 (defun perform-lisp-load-fasl (o c)
9869 "Perform the loading of a FASL associated to specified action (O . C),
9870 an OPERATION and a COMPONENT."
9871 (if-let (fasl (first (input-files o c)))
9872 (let ((*package* (find-package '#:common-lisp-user)))
9874 (defmethod perform ((o load-op) (c cl-source-file))
9875 (perform-lisp-load-fasl o c))
9876 (defmethod perform ((o load-op) (c static-file))
9880 ;;;; prepare-source-op, load-source-op
9882 ;;; prepare-source-op
9883 (with-upgradability ()
9884 (defmethod action-description ((o prepare-source-op) (c component))
9885 (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c))
9886 (defmethod input-files ((o prepare-source-op) (s system))
9887 (if-let (it (system-source-file s)) (list it)))
9888 (defmethod perform ((o prepare-source-op) (c component))
9892 (with-upgradability ()
9893 (defmethod action-description ((o load-source-op) (c component))
9894 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c))
9895 (defmethod action-description ((o load-source-op) (c parent-component))
9896 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
9897 (defun perform-lisp-load-source (o c)
9898 "Perform the loading of a Lisp file as associated to specified action (O . C)"
9899 (call-with-around-compile-hook
9901 (load* (first (input-files o c))
9902 :external-format (component-external-format c)))))
9904 (defmethod perform ((o load-source-op) (c cl-source-file))
9905 (perform-lisp-load-source o c))
9906 (defmethod perform ((o load-source-op) (c static-file))
9911 (with-upgradability ()
9912 (defmethod perform ((o test-op) (c component))
9914 (defmethod operation-done-p ((o test-op) (c system))
9915 "Testing a system is _never_ done."
9917 ;;;; -------------------------------------------------------------------------
9918 ;;;; Finding components
9920 (uiop/package:define-package :asdf/find-component
9921 (:recycle :asdf/find-component :asdf/find-system :asdf)
9922 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
9923 :asdf/component :asdf/system :asdf/system-registry)
9926 #:resolve-dependency-name #:resolve-dependency-spec
9927 #:resolve-dependency-combination
9929 #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry
9930 #:missing-dependency #:missing-dependency-of-version
9931 #:missing-requires #:missing-parent
9932 #:missing-required-by #:missing-version))
9933 (in-package :asdf/find-component)
9935 ;;;; Missing component conditions
9937 (with-upgradability ()
9938 (define-condition missing-component (system-definition-error)
9939 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
9940 (parent :initform nil :reader missing-parent :initarg :parent)))
9942 (define-condition missing-component-of-version (missing-component)
9943 ((version :initform nil :reader missing-version :initarg :version)))
9945 (define-condition missing-dependency (missing-component)
9946 ((required-by :initarg :required-by :reader missing-required-by)))
9948 (defmethod print-object ((c missing-dependency) s)
9949 (format s (compatfmt "~@<~A, required by ~A~@:>")
9950 (call-next-method c nil) (missing-required-by c)))
9952 (define-condition missing-dependency-of-version (missing-dependency
9953 missing-component-of-version)
9956 (defmethod print-object ((c missing-component) s)
9957 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
9958 (missing-requires c)
9959 (when (missing-parent c)
9960 (coerce-name (missing-parent c)))))
9962 (defmethod print-object ((c missing-component-of-version) s)
9963 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
9964 (missing-requires c)
9966 (when (missing-parent c)
9967 (coerce-name (missing-parent c))))))
9970 ;;;; Finding components
9972 (with-upgradability ()
9973 (defgeneric resolve-dependency-combination (component combinator arguments)
9974 (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
9975 in the context of COMPONENT"))
9977 ;; Methods for find-component
9979 ;; If the base component is a string, resolve it as a system, then if not nil follow the path.
9980 (defmethod find-component ((base string) path &key registered)
9981 (if-let ((s (if registered
9982 (registered-system base)
9983 (find-system base nil))))
9984 (find-component s path :registered registered)))
9986 ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that.
9987 ;; If nil, use the path as base if not nil, or else return nil.
9988 (defmethod find-component ((base symbol) path &key registered)
9990 (base (find-component (coerce-name base) path :registered registered))
9991 (path (find-component path nil :registered registered))
9994 ;; If the base component is a cons cell, resolve its car, and add its cdr to the path.
9995 (defmethod find-component ((base cons) path &key registered)
9996 (find-component (car base) (cons (cdr base) path) :registered registered))
9998 ;; If the base component is a parent-component and the path a string, find the named child.
9999 (defmethod find-component ((parent parent-component) (name string) &key registered)
10000 (declare (ignorable registered))
10001 (compute-children-by-name parent :only-if-needed-p t)
10002 (values (gethash name (component-children-by-name parent))))
10004 ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base.
10005 (defmethod find-component (base (name symbol) &key registered)
10007 (find-component base (coerce-name name) :registered registered)
10010 ;; If the path is a cons, first resolve its car as path, then its cdr.
10011 (defmethod find-component ((c component) (name cons) &key registered)
10012 (find-component (find-component c (car name) :registered registered)
10013 (cdr name) :registered registered))
10015 ;; If the path is a component, return it, disregarding the base.
10016 (defmethod find-component ((base t) (actual component) &key registered)
10017 (declare (ignorable registered))
10020 ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint.
10021 ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec.
10022 (defun resolve-dependency-name (component name &optional version)
10026 (let ((comp (find-component (component-parent component) name)))
10028 (error 'missing-dependency
10029 :required-by component
10032 (unless (version-satisfies comp version)
10033 (error 'missing-dependency-of-version
10034 :required-by component
10039 :report (lambda (s)
10040 (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
10044 (and (typep c 'missing-dependency)
10045 (eq (missing-required-by c) component)
10046 (equal (missing-requires c) name))))
10047 (unless (component-parent component)
10048 (let ((name (coerce-name name)))
10049 (unset-asdf-cache-entry `(find-system ,name))))))))
10051 ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
10052 ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
10053 ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON.
10054 (defun resolve-dependency-spec (component dep-spec)
10055 (let ((component (find-component () component)))
10056 (if (atom dep-spec)
10057 (resolve-dependency-name component dep-spec)
10058 (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))
10060 ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications.
10061 (defmethod resolve-dependency-combination (component combinator arguments)
10062 (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
10063 'resolve-dependency-combination (cons combinator arguments) component))
10065 (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
10066 (when (featurep (first arguments))
10067 (resolve-dependency-spec component (second arguments))))
10069 (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
10070 (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
10072 ;;;; -------------------------------------------------------------------------
10075 (uiop/package:define-package :asdf/forcing
10076 (:recycle :asdf/forcing :asdf/plan :asdf)
10077 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
10078 :asdf/component :asdf/operation :asdf/system :asdf/system-registry)
10080 #:forcing #:make-forcing #:forced #:forced-not #:performable-p
10081 #:normalize-forced-systems #:normalize-forced-not-systems
10082 #:action-forced-p #:action-forced-not-p))
10083 (in-package :asdf/forcing)
10086 (with-upgradability ()
10087 (defclass forcing ()
10088 (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not
10089 ;; settings than the session can only be used for read-only queries that do not cause the
10090 ;; status of any action to be raised.
10091 (performable-p :initform nil :initarg :performable-p :reader performable-p)
10093 (parameters :initform nil :initarg :parameters :reader parameters)
10094 ;; Table of systems specified via :force arguments
10095 (forced :initarg :forced :reader forced)
10096 ;; Table of systems specified via :force-not argument (and/or immutable)
10097 (forced-not :initarg :forced-not :reader forced-not)))
10099 (defgeneric action-forced-p (forcing operation component)
10100 (:documentation "Is this action forced to happen in this plan?"))
10101 (defgeneric action-forced-not-p (forcing operation component)
10102 (:documentation "Is this action forced to not happen in this plan?
10103 Takes precedence over action-forced-p."))
10105 (defun normalize-forced-systems (force system)
10106 "Given a SYSTEM on which operate is called and the specified FORCE argument,
10107 extract a hash-set of systems that are forced, or a predicate on system names,
10108 or NIL if none are forced, or :ALL if all are."
10110 ((or (member nil :all) hash-table function) force)
10111 (cons (list-to-hash-set (mapcar #'coerce-name force)))
10112 ((eql t) (when system (list-to-hash-set (list (coerce-name system)))))))
10114 (defun normalize-forced-not-systems (force-not system)
10115 "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument,
10116 and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not,
10117 or predicate on system names, or NIL if none are forced, or :ALL if all are."
10119 (etypecase force-not
10120 ((or (member nil :all) hash-table function) force-not)
10121 (cons (list-to-hash-set (mapcar #'coerce-name force-not)))
10122 ((eql t) (if system (let ((name (coerce-name system)))
10123 #'(lambda (x) (not (equal x name))))
10125 (if (and *immutable-systems* requested)
10126 #'(lambda (x) (or (call-function requested x)
10127 (call-function *immutable-systems* x)))
10128 (or *immutable-systems* requested))))
10130 ;; TODO: shouldn't we be looking up the primary system name, rather than the system name?
10131 (defun action-override-p (forcing operation component override-accessor)
10132 "Given a plan, an action, and a function that given the plan accesses a set of overrides,
10133 i.e. force or force-not, see if the override applies to the current action."
10134 (declare (ignore operation))
10135 (call-function (funcall override-accessor forcing)
10136 (coerce-name (component-system (find-component () component)))))
10138 (defmethod action-forced-p (forcing operation component)
10140 ;; Did the user ask us to re-perform the action?
10141 (action-override-p forcing operation component 'forced)
10142 ;; You really can't force a builtin system and :all doesn't apply to it.
10143 (not (builtin-system-p (component-system component)))))
10145 (defmethod action-forced-not-p (forcing operation component)
10146 ;; Did the user ask us to not re-perform the action?
10147 ;; NB: force-not takes precedence over force, as it should
10148 (action-override-p forcing operation component 'forced-not))
10150 ;; Null forcing means no forcing either way
10151 (defmethod action-forced-p ((forcing null) (operation operation) (component component))
10153 (defmethod action-forced-not-p ((forcing null) (operation operation) (component component))
10156 (defun or-function (fun1 fun2)
10158 ((or (null fun2) (eq fun1 :all)) fun1)
10159 ((or (null fun1) (eq fun2 :all)) fun2)
10160 (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x))))))
10162 (defun make-forcing (&key performable-p system
10163 (force nil force-p) (force-not nil force-not-p) &allow-other-keys)
10164 (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*)))
10165 (system (and system (coerce-name system)))
10166 (forced (normalize-forced-systems force system))
10167 (forced-not (normalize-forced-not-systems force-not system))
10168 (parameters `(,@(when force `(:force ,force))
10169 ,@(when force-not `(:force-not ,force-not))
10170 ,@(when (or (eq force t) (eq force-not t)) `(:system ,system))
10171 ,@(when performable-p `(:performable-p t))))
10174 ((not session-forcing)
10175 (setf forcing (make-instance 'forcing
10176 :performable-p performable-p :parameters parameters
10177 :forced forced :forced-not forced-not))
10178 (when (and performable-p *asdf-session*)
10179 (setf (forcing *asdf-session*) forcing)))
10181 (when (and (not (equal parameters (parameters session-forcing)))
10182 (or force-p force-not-p))
10183 (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~
10184 unless identically to toplevel"
10185 (find-symbol* :operate :asdf) :force :force-not))
10186 (setf forcing session-forcing))
10188 (setf forcing (make-instance 'forcing
10189 ;; Combine force and force-not with values from the toplevel-plan
10190 :parameters `(,@parameters :on-top-of ,(parameters session-forcing))
10191 :forced (or-function (forced session-forcing) forced)
10192 :forced-not (or-function (forced-not session-forcing) forced-not)))))
10195 (defmethod print-object ((forcing forcing) stream)
10196 (print-unreadable-object (forcing stream :type t)
10197 (format stream "~{~S~^ ~}" (parameters forcing))))
10199 ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case.
10200 (defmethod forcing ((x null))
10201 (if-let (session (toplevel-asdf-session))
10203 (make-forcing :performable-p t)))
10205 ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing.
10206 (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session))))
10207 ;;;; -------------------------------------------------------------------------
10210 (uiop/package:define-package :asdf/plan
10211 ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions
10212 ;; that used to live there before 3.2.0.
10213 (:recycle :asdf/plan :asdf/action :asdf)
10214 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
10215 :asdf/component :asdf/operation :asdf/action :asdf/lisp-action
10216 :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
10218 #:plan #:plan-traversal #:sequential-plan #:*plan-class*
10219 #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p
10220 #:action-already-done-p
10221 #:+status-good+ #:+status-todo+ #:+status-void+
10222 #:system-out-of-date #:action-up-to-date-p
10223 #:circular-dependency #:circular-dependency-actions
10224 #:needed-in-image-p
10225 #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
10226 #:compute-action-stamp #:traverse-action #:record-dependency
10227 #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done
10228 #:required-components #:filtered-sequential-plan
10229 #:plan-component-type #:plan-keep-operation #:plan-keep-component))
10230 (in-package :asdf/plan)
10232 ;;;; Generic plan traversal class
10233 (with-upgradability ()
10234 (defclass plan () ()
10235 (:documentation "Base class for a plan based on which ASDF can build a system"))
10236 (defclass plan-traversal (plan)
10237 (;; The forcing parameters for this plan. Also indicates whether the plan is performable,
10238 ;; in which case the forcing is the same as for the entire session.
10239 (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing))
10240 (:documentation "Base class for plans that simply traverse dependencies"))
10241 ;; Sequential plans (the default)
10242 (defclass sequential-plan (plan-traversal)
10243 ((actions-r :initform nil :accessor plan-actions-r))
10244 (:documentation "Simplest, default plan class, accumulating a sequence of actions"))
10246 (defgeneric plan-actions (plan)
10247 (:documentation "Extract from a plan a list of actions to perform in sequence"))
10248 (defmethod plan-actions ((plan list))
10250 (defmethod plan-actions ((plan sequential-plan))
10251 (reverse (plan-actions-r plan)))
10253 (defgeneric record-dependency (plan operation component)
10254 (:documentation "Record that, within PLAN, performing OPERATION on COMPONENT depends on all
10255 of the (OPERATION . COMPONENT) actions in the current ASDF session's VISITING-ACTION-LIST.
10257 You can get a single action which dominates the set of dependencies corresponding to this call with
10258 (first (visiting-action-list *asdf-session*))
10259 since VISITING-ACTION-LIST is a stack whose top action depends directly on its second action,
10260 and whose second action depends directly on its third action, and so forth."))
10262 ;; No need to record a dependency to build a full graph, just accumulate nodes in order.
10263 (defmethod record-dependency ((plan sequential-plan) (o operation) (c component))
10266 (when-upgrading (:version "3.3.0")
10267 (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys)))
10270 ;;;; Planned action status
10271 (with-upgradability ()
10272 (defclass action-status ()
10274 :type fixnum :initarg :bits :reader status-bits
10275 :documentation "bitmap describing the status of the action.")
10277 :type (or integer boolean) :initarg :stamp :reader status-stamp
10278 :documentation "STAMP associated with the ACTION if it has been completed already in some
10279 previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.")
10281 :type fixnum :initarg :level :initform 0 :reader status-level
10282 :documentation "the highest (operate-level) at which the action was needed")
10284 :type (or integer null) :initarg :index :initform nil :reader status-index
10285 :documentation "INDEX associated with the ACTION in the current session,
10286 or NIL if no the status is considered outside of a specific plan."))
10287 (:documentation "Status of an action in a plan"))
10289 ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently
10290 ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded)
10291 ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done
10292 ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load)
10293 ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled)
10294 ;; not-nil NIL T T => DONE 3 out-of-date done
10295 ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?)
10296 ;; NIL NIL NIL T => TODO 1 out-of-date planned
10297 ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned
10299 ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node
10300 ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an
10301 ;; action is up-to-date with ACTION-UP-TO-DATE-P.
10303 ;; When calling TRAVERSE-ACTION, the +need-bit+ is set,
10304 ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP).
10305 ;; When PERFORMing an action, the +done-bit+ is set.
10306 ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of
10307 ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then
10308 ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be
10309 ;; done before the end of this level of operate.
10311 ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value.
10313 (defparameter +keep-bit+ 4)
10314 (defparameter +done-bit+ 2)
10315 (defparameter +need-bit+ 1)
10316 (defparameter +good-bits+ 7)
10317 (defparameter +todo-bits+ 1)
10318 (defparameter +void-bits+ 0)
10320 (defparameter +status-good+
10321 (make-instance 'action-status :bits +good-bits+ :stamp t))
10322 (defparameter +status-todo+
10323 (make-instance 'action-status :bits +todo-bits+ :stamp nil))
10324 (defparameter +status-void+
10325 (make-instance 'action-status :bits +void-bits+ :stamp nil)))
10327 (with-upgradability ()
10328 (defun make-action-status (&key bits stamp (level 0) index)
10329 (check-type bits (integer 0 7))
10330 (check-type stamp (or integer boolean))
10331 (check-type level (integer 0 #.most-positive-fixnum))
10332 (check-type index (or integer null))
10333 (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) ()
10334 "Bad action-status :bits ~S :stamp ~S" bits stamp)
10336 (when (and (null index) (zerop level))
10338 (#.+void-bits+ (return +status-void+))
10339 (#.+todo-bits+ (return +status-todo+))
10340 (#.+good-bits+ (when (eq stamp t) (return +status-good+)))))
10341 (make-instance 'action-status :bits bits :stamp stamp :level level :index index)))
10343 (defun status-keep-p (status)
10344 (plusp (logand (status-bits status) #.+keep-bit+)))
10345 (defun status-done-p (status)
10346 (plusp (logand (status-bits status) #.+done-bit+)))
10347 (defun status-need-p (status)
10348 (plusp (logand (status-bits status) #.+need-bit+)))
10350 (defun merge-action-status (status1 status2) ;; status-and
10351 "Return the earliest status later than both status1 and status2"
10352 (make-action-status
10353 :bits (logand (status-bits status1) (status-bits status2))
10354 :stamp (latest-timestamp (status-stamp status1) (status-stamp status2))
10355 :level (min (status-level status1) (status-level status2))
10356 :index (or (status-index status1) (status-index status2))))
10358 (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or
10359 "Return the same status but with the need bit set, for the given level"
10360 (if (and (status-need-p status)
10361 (>= (status-level status) level))
10363 (make-action-status
10364 :bits (logior (status-bits status) +need-bit+)
10365 :level (max level (status-level status))
10366 :stamp (status-stamp status)
10367 :index (status-index status))))
10369 (defmethod print-object ((status action-status) stream)
10370 (print-unreadable-object (status stream :type t)
10371 (with-slots (bits stamp level index) status
10372 (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index)))))
10374 (defgeneric action-status (plan operation component)
10375 (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT
10376 in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN."))
10378 (defgeneric (setf action-status) (new-status plan operation component)
10379 (:documentation "Sets the ACTION-STATUS associated to
10380 the action of OPERATION on COMPONENT in the PLAN"))
10382 (defmethod action-status ((plan null) (o operation) (c component))
10383 (multiple-value-bind (stamp done-p) (component-operation-time o c)
10385 (make-action-status :bits #.+keep-bit+ :stamp stamp)
10388 (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
10389 (let ((times (component-operation-times c)))
10390 (if (status-done-p new-status)
10391 (setf (gethash o times) (status-stamp new-status))
10392 (remhash o times)))
10395 ;; Handle FORCED-NOT: it makes an action return its current timestamp as status
10396 (defmethod action-status ((p plan) (o operation) (c component))
10397 ;; TODO: should we instead test something like:
10398 ;; (action-forced-not-p plan operation (primary-system component))
10399 (or (gethash (make-action o c) (visited-actions *asdf-session*))
10400 (when (action-forced-not-p (forcing p) o c)
10401 (let ((status (action-status nil o c)))
10402 (setf (gethash (make-action o c) (visited-actions *asdf-session*))
10403 (make-action-status
10405 :stamp (or (and status (status-stamp status)) t)
10406 :index (incf (total-action-count *asdf-session*))))))))
10408 (defmethod (setf action-status) (new-status (p plan) (o operation) (c component))
10409 (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status))
10411 (defmethod (setf action-status) :after
10412 (new-status (p sequential-plan) (o operation) (c component))
10413 (unless (status-done-p new-status)
10414 (push (make-action o c) (plan-actions-r p)))))
10417 ;;;; Is the action needed in this image?
10418 (with-upgradability ()
10419 (defgeneric needed-in-image-p (operation component)
10420 (:documentation "Is the action of OPERATION on COMPONENT needed in the current image
10421 to be meaningful, or could it just as well have been done in another Lisp image?"))
10423 (defmethod needed-in-image-p ((o operation) (c component))
10424 ;; We presume that actions that modify the filesystem don't need be run
10425 ;; in the current image if they have already been done in another,
10426 ;; and can be run in another process (e.g. a fork),
10427 ;; whereas those that don't are meant to side-effect the current image and can't.
10428 (not (output-files o c))))
10431 ;;;; Visiting dependencies of an action and computing action stamps
10432 (with-upgradability ()
10433 (defun map-direct-dependencies (operation component fun)
10434 "Call FUN on all the valid dependencies of the given action in the given plan"
10435 (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
10436 :for dep-o = (find-operation operation dep-o-spec)
10438 :do (loop :for dep-c-spec :in dep-c-specs
10439 :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
10440 :when (action-valid-p dep-o dep-c)
10441 :do (funcall fun dep-o dep-c))))
10443 (defun reduce-direct-dependencies (operation component combinator seed)
10444 "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR
10445 for each dependency action on the dependency's operation and component and an accumulator
10446 initialized with SEED."
10447 (map-direct-dependencies
10448 operation component
10449 #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed))))
10452 (defun direct-dependencies (operation component)
10453 "Compute a list of the direct dependencies of the action within the plan"
10454 (reverse (reduce-direct-dependencies operation component #'acons nil)))
10456 ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp
10457 ;; shall also be parametrized by the plan, or by a second model object,
10458 ;; so they need not refer to the state of the filesystem,
10459 ;; and the stamps could be cryptographic checksums rather than timestamps.
10460 ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP.
10461 (define-condition dependency-not-done (warning)
10465 :initarg :component)
10469 :initarg :dep-component)
10473 (:report (lambda (condition stream)
10474 (with-slots (op component dep-op dep-component plan) condition
10475 (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!"
10477 (action-path (make-action op component))
10478 (action-path (make-action dep-op dep-component)))))))
10480 (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done)
10481 ;; Given an action, figure out at what time in the past it has been done,
10482 ;; or if it has just been done, return the time that it has.
10483 ;; Returns two values:
10484 ;; 1- the TIMESTAMP of the action if it has already been done and is up to date,
10485 ;; or NIL is either hasn't been done or is out of date.
10486 ;; (An ASDF extension could use a cryptographic digest instead.)
10487 ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done
10488 ;; in the current image, or NIL if it hasn't.
10489 ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
10490 ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp,
10491 ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
10492 ;; i.e. that of the input-files.
10493 ;; If just-done is NIL, these values return are the notional fields of
10494 ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error).
10495 ;; If just-done is T, they are the notional fields of DONE status
10496 ;; (or, if something went wrong, TODO).
10499 (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date)
10500 (reduce-direct-dependencies
10502 #'(lambda (do dc status)
10503 ;; out-of-date dependency: don't bother looking further
10504 (let ((action-status (action-status plan do dc)))
10506 ((and action-status (or (status-keep-p action-status)
10507 (and just-done (status-stamp action-status))))
10508 (merge-action-status action-status status))
10510 ;; It's OK to lose some ASDF action stamps during self-upgrade
10511 (unless (equal "asdf" (primary-system-name dc))
10512 (warn 'dependency-not-done
10515 :dep-op do :dep-component dc))
10518 (return (values nil nil))))))
10520 (dep-stamp (status-stamp dep-status))))
10521 (let* (;; collect timestamps from inputs, and exit early if any is missing
10522 (in-files (input-files o c))
10523 (in-stamps (mapcar #'get-file-stamp in-files))
10524 (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f))
10525 (latest-in (timestamps-latest (cons dep-stamp in-stamps))))
10526 (when (and missing-in (not just-done)) (return (values nil nil))))
10527 (let* (;; collect timestamps from outputs, and exit early if any is missing
10528 (out-files (remove-if 'null (output-files o c)))
10529 (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
10530 (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
10531 (earliest-out (timestamps-earliest out-stamps)))
10532 (when (and missing-out (not just-done)) (return (values nil nil))))
10533 (let (;; Time stamps from the files at hand, and whether any is missing
10534 (all-present (not (or missing-in missing-out)))
10535 ;; Has any input changed since we last generated the files?
10536 ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files.
10537 ;; Any race condition is intrinsic to the limited timestamp resolution.
10538 (up-to-date-p (timestamp<= latest-in earliest-out))
10539 ;; If everything is up to date, the latest of inputs and outputs is our stamp
10540 (done-stamp (timestamps-latest (cons latest-in out-stamps))))
10541 ;; Warn if some files are missing:
10542 ;; either our model is wrong or some other process is messing with our files.
10543 (when (and just-done (not all-present))
10544 ;; Shouldn't that be an error instead?
10545 (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
10546 ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
10547 (action-description o c)
10548 missing-in (length missing-in) (and missing-in missing-out)
10549 missing-out (length missing-out))))
10550 (let (;; There are three kinds of actions:
10551 (out-op (and out-files t)) ; those that create files on the filesystem
10552 ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
10553 ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
10555 (if (or just-done ;; The done-stamp is valid: if we're just done, or
10556 (and all-present ;; if all filesystem effects are up-to-date
10558 (operation-done-p o c) ;; and there's no invalidating reason.
10559 (not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
10560 (values done-stamp ;; return the hard-earned timestamp
10562 out-op ;; A file-creating op is done when all files are up to date.
10563 ;; An image-effecting operation is done when
10564 (and (status-done-p dep-status) ;; all the dependencies were done, and
10565 (multiple-value-bind (perform-stamp perform-done-p)
10566 (component-operation-time o c)
10567 (and perform-done-p ;; the op was actually run,
10568 (equal perform-stamp done-stamp)))))) ;; with a matching stamp.
10569 ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
10570 (values nil nil)))))
10573 ;;;; The four different actual traversals:
10574 ;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned
10575 ;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not
10576 ;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date
10577 ;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status
10578 (with-upgradability ()
10580 ;; Compute the action status for a newly visited action.
10581 (defun compute-action-status (plan operation component need-p)
10582 (multiple-value-bind (stamp done-p)
10583 (compute-action-stamp plan operation component)
10584 (assert (or stamp (not done-p)))
10585 (make-action-status
10586 :bits (logior (if stamp #.+keep-bit+ 0)
10587 (if done-p #.+done-bit+ 0)
10588 (if need-p #.+need-bit+ 0))
10590 :level (operate-level)
10591 :index (incf (total-action-count *asdf-session*)))))
10593 ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data,
10594 ;; visits the action defined by its OPERATION and COMPONENT arguments,
10595 ;; and all its transitive dependencies (unless already visited),
10596 ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P,
10597 ;; i.e. needs to be done in the current image vs merely have been done in a previous image.
10599 ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its
10600 ;; transitive dependencies (that haven't been sufficiently visited so far).
10601 ;; It does not return any usable value.
10603 ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action,
10604 ;; the below method would be insufficient, since it assumes a single image
10605 ;; to traverse each node at most twice; non-niip actions would be traversed only once,
10606 ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action.
10608 (defun traverse-action (plan operation component needed-in-image-p)
10610 (unless (action-valid-p operation component) (return))
10611 ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph,
10612 ;; instead of just a dependency order as in vanilla ASDF.
10613 ;; TODO: It is also needed to detect OPERATE-in-PERFORM.
10614 (record-dependency plan operation component)
10615 (while-visiting-action (operation component) ; maintain context, handle circularity.
10616 ;; needed-in-image distinguishes b/w things that must happen in the
10617 ;; current image and those things that simply need to have been done in a previous one.
10618 (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image
10619 ;; effective niip: meaningful for the action and required by the plan as traversed
10620 (eniip (and aniip needed-in-image-p))
10621 ;; status: have we traversed that action previously, and if so what was its status?
10622 (status (action-status plan operation component))
10623 (level (operate-level)))
10625 (or (status-done-p status) ;; all done
10626 (and (status-need-p status) (<= level (status-level status))) ;; already visited
10627 (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip
10628 (return)) ; Already visited with sufficient need-in-image level!
10629 (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T
10630 (map-direct-dependencies ; recursively traverse dependencies
10631 operation component #'(lambda (o c) (traverse-action plan o c niip)))
10632 ;; AFTER dependencies have been traversed, compute action stamp
10633 (let* ((status (if status
10634 (mark-status-needed status level)
10635 (compute-action-status plan operation component t)))
10636 (out-of-date-p (not (status-keep-p status)))
10637 (to-perform-p (or out-of-date-p (and niip (not (status-done-p status))))))
10638 (cond ; it needs be done if it's out of date or needed in image but absent
10639 ((and out-of-date-p (not niip)) ; if we need to do it,
10640 (visit-action t)) ; then we need to do it *in the (current) image*!
10642 (setf (action-status plan operation component) status)
10643 (when (status-done-p status)
10644 (setf (component-operation-time operation component)
10645 (status-stamp status)))
10646 (when to-perform-p ; if it needs to be added to the plan, count it
10647 (incf (planned-action-count *asdf-session*))
10648 (unless aniip ; if it's output-producing, count it
10649 (incf (planned-output-action-count *asdf-session*)))))))))
10650 (visit-action eniip)))))) ; visit the action
10652 ;; NB: This is not an error, not a warning, but a normal expected condition,
10653 ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system,
10654 ;; *before* it tries to replace it with a new definition.
10655 (define-condition system-out-of-date (condition)
10656 ((name :initarg :name :reader component-name))
10657 (:documentation "condition signaled when a system is detected as being out of date")
10658 (:report (lambda (c s)
10659 (format s "system ~A is out of date" (component-name c)))))
10661 (defun action-up-to-date-p (plan operation component)
10662 "Check whether an action was up-to-date at the beginning of the session.
10663 Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN."
10665 (unless (action-valid-p operation component) (return t))
10666 (while-visiting-action (operation component) ; maintain context, handle circularity.
10667 ;; Do NOT record the dependency: it might be out of date.
10668 (let ((status (or (action-status plan operation component)
10669 (setf (action-status plan operation component)
10670 (let ((dependencies-up-to-date-p
10673 (map-direct-dependencies
10674 operation component
10676 (unless (action-up-to-date-p plan o c)
10679 (system-out-of-date () nil))))
10680 (if dependencies-up-to-date-p
10681 (compute-action-status plan operation component nil)
10682 +status-void+))))))
10683 (and (status-keep-p status) (status-stamp status)))))))
10686 ;;;; Incidental traversals
10688 ;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source
10689 ;;; files required by a bundling operation.
10690 (with-upgradability ()
10691 (defclass filtered-sequential-plan (sequential-plan)
10692 ((component-type :initform t :initarg :component-type :reader plan-component-type)
10693 (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation)
10694 (keep-component :initform t :initarg :keep-component :reader plan-keep-component))
10695 (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions."))
10697 (defmethod initialize-instance :after ((plan filtered-sequential-plan)
10698 &key system other-systems)
10699 ;; Ignore force and force-not, rely on other-systems:
10700 ;; force traversal of what we're interested in, i.e. current system or also others;
10701 ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems.
10702 (setf (slot-value plan 'forcing)
10703 (make-forcing :system system :force :all :force-not (if other-systems nil t))))
10705 (defmethod plan-actions ((plan filtered-sequential-plan))
10706 (with-slots (keep-operation keep-component) plan
10707 (loop :for action :in (call-next-method)
10708 :as o = (action-operation action)
10709 :as c = (action-component action)
10710 :when (and (typep o keep-operation) (typep c keep-component))
10711 :collect (make-action o c))))
10713 (defun collect-action-dependencies (plan operation component)
10714 (when (action-valid-p operation component)
10715 (while-visiting-action (operation component) ; maintain context, handle circularity.
10716 (let ((action (make-action operation component)))
10717 (unless (nth-value 1 (gethash action (visited-actions *asdf-session*)))
10718 (setf (gethash action (visited-actions *asdf-session*)) nil)
10719 (when (and (typep component (plan-component-type plan))
10720 (not (action-forced-not-p (forcing plan) operation component)))
10721 (map-direct-dependencies operation component
10722 #'(lambda (o c) (collect-action-dependencies plan o c)))
10723 (push action (plan-actions-r plan))))))))
10725 (defgeneric collect-dependencies (operation component &key &allow-other-keys)
10726 (:documentation "Given an action, build a plan for all of its dependencies."))
10727 (define-convenience-action-methods collect-dependencies (operation component &key))
10728 (defmethod collect-dependencies ((operation operation) (component component)
10729 &rest keys &key &allow-other-keys)
10730 (let ((plan (apply 'make-instance 'filtered-sequential-plan
10731 :system (component-system component) keys)))
10732 (loop :for action :in (direct-dependencies operation component)
10733 :do (collect-action-dependencies plan (action-operation action) (action-component action)))
10734 (plan-actions plan)))
10736 (defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
10737 "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and
10738 return a list of the components involved in building the desired action."
10739 (with-asdf-session (:override t)
10741 (mapcar 'action-component
10742 (apply 'collect-dependencies goal-operation system
10743 (remove-plist-key :goal-operation keys)))
10747 ;;;; High-level interface: make-plan, perform-plan
10748 (with-upgradability ()
10749 (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
10750 (:documentation "Generate and return a plan for performing OPERATION on COMPONENT."))
10751 (define-convenience-action-methods make-plan (plan-class operation component &key))
10753 (defgeneric mark-as-done (plan-class operation component)
10754 (:documentation "Mark an action as done in a plan, after performing it."))
10755 (define-convenience-action-methods mark-as-done (plan-class operation component))
10757 (defgeneric perform-plan (plan &key)
10758 (:documentation "Actually perform a plan and build the requested actions"))
10760 (defparameter* *plan-class* 'sequential-plan
10761 "The default plan class to use when building with ASDF")
10763 (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
10764 (with-asdf-session ()
10765 (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys)))
10766 (traverse-action plan o c t)
10769 (defmethod perform-plan :around ((plan t) &key)
10770 (assert (performable-p (forcing plan)) () "plan not performable")
10771 (let ((*package* *package*)
10772 (*readtable* *readtable*))
10773 (with-compilation-unit () ;; backward-compatibility.
10774 (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
10776 (defun action-already-done-p (plan operation component)
10777 (if-let (status (action-status plan operation component))
10778 (status-done-p status)))
10780 (defmethod perform-plan ((plan t) &key)
10781 (loop :for action :in (plan-actions plan)
10782 :as o = (action-operation action)
10783 :as c = (action-component action) :do
10784 (unless (action-already-done-p plan o c)
10785 (perform-with-restarts o c)
10786 (mark-as-done plan o c))))
10788 (defmethod mark-as-done ((plan plan) (o operation) (c component))
10789 (let ((plan-status (action-status plan o c))
10790 (perform-status (action-status nil o c)))
10791 (assert (and (status-stamp perform-status) (status-keep-p perform-status)) ()
10792 "Just performed ~A but failed to mark it done" (action-description o c))
10793 (setf (action-status plan o c)
10794 (make-action-status
10795 :bits (logior (status-bits plan-status) +done-bit+)
10796 :stamp (status-stamp perform-status)
10797 :level (status-level plan-status)
10798 :index (status-index plan-status))))))
10799 ;;;; -------------------------------------------------------------------------
10800 ;;;; Invoking Operations
10802 (uiop/package:define-package :asdf/operate
10803 (:recycle :asdf/operate :asdf)
10804 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
10805 :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
10806 :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan)
10808 #:operate #:oos #:build-op #:make
10809 #:load-system #:load-systems #:load-systems*
10810 #:compile-system #:test-system #:require-system #:module-provide-asdf
10811 #:component-loaded-p #:already-loaded-systems
10812 #:recursive-operate))
10813 (in-package :asdf/operate)
10815 (with-upgradability ()
10816 (defgeneric operate (operation component &key)
10818 "Operate does mainly four things for the user:
10820 1. Resolves the OPERATION designator into an operation object.
10821 OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION.
10822 2. Resolves the COMPONENT designator into a component object.
10823 COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM.
10824 3. It then calls MAKE-PLAN with the operation and system as arguments.
10825 4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system.
10827 The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code.
10828 If a VERSION argument is supplied, then operate also ensures that the system found satisfies it
10829 using the VERSION-SATISFIES method.
10830 If a PLAN-CLASS argument is supplied, that class is used for the plan.
10831 If a PLAN-OPTIONS argument is supplied, the options are passed to the plan.
10833 The :FORCE or :FORCE-NOT argument to OPERATE can be:
10834 T to force the inside of the specified system to be rebuilt (resp. not),
10835 without recursively forcing the other systems we depend on.
10836 :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
10837 (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
10838 :FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.
10840 For backward compatibility, all keyword arguments are passed to MAKE-OPERATION
10841 when instantiating a new operation, that will in turn be inherited by new operations.
10842 But do NOT depend on it, for this is deprecated behavior."))
10844 (define-convenience-action-methods operate (operation component &key)
10845 :if-no-component (error 'missing-component :requires component))
10847 ;; This method ensures that an ASDF upgrade is attempted as the very first thing,
10848 ;; with suitable state preservation in case in case it actually happens,
10849 ;; and that a few suitable dynamic bindings are established.
10850 (defmethod operate :around (operation component &rest keys
10852 (on-warnings *compile-file-warnings-behaviour*)
10853 (on-failure *compile-file-failure-behaviour*))
10855 (with-asdf-session ())
10856 (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
10857 (etypecase operation
10858 (operation (let ((name (type-of operation)))
10859 #'(lambda () (make-operation name))))
10860 ((or symbol string) (constantly operation))))
10861 (component-path (typecase component ;; to remake the component after ASDF upgrade
10862 (component (component-find-path component))
10864 (system-name (labels ((first-name (x)
10866 ((or string symbol) x) ; NB: includes the NIL case.
10867 (cons (or (first-name (car x)) (first-name (cdr x)))))))
10868 (coerce-name (first-name component-path)))))
10869 (apply 'make-forcing :performable-p t :system system-name keys)
10870 ;; Before we operate on any system, make sure ASDF is up-to-date,
10871 ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
10872 (unless (asdf-upgraded-p (toplevel-asdf-session))
10873 (setf (asdf-upgraded-p (toplevel-asdf-session)) t)
10874 (when (upgrade-asdf)
10875 ;; If we were upgraded, restart OPERATE the hardest of ways, for
10876 ;; its function may have been redefined.
10877 (return-from operate
10878 (with-asdf-session (:override t :override-cache t)
10879 (apply 'operate (funcall operation-remaker) component-path keys))))))
10880 ;; Setup proper bindings around any operate call.
10881 (let* ((*verbose-out* (and verbose *standard-output*))
10882 (*compile-file-warnings-behaviour* on-warnings)
10883 (*compile-file-failure-behaviour* on-failure)))
10886 (incf (operate-level))
10887 (call-next-method))
10888 (decf (operate-level)))))
10890 (defmethod operate :before ((operation operation) (component component)
10892 (unless (version-satisfies component version)
10893 (error 'missing-component-of-version :requires component :version version))
10894 (record-dependency nil operation component))
10896 (defmethod operate ((operation operation) (component component)
10897 &key plan-class plan-options)
10898 (let ((plan (apply 'make-plan plan-class operation component
10899 :forcing (forcing *asdf-session*) plan-options)))
10900 (perform-plan plan)
10901 (values operation plan)))
10903 (defun oos (operation component &rest args &key &allow-other-keys)
10904 (apply 'operate operation component args))
10906 (setf (documentation 'oos 'function)
10907 (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
10908 (documentation 'operate 'function)))
10910 (define-condition recursive-operate (warning)
10911 ((operation :initarg :operation :reader condition-operation)
10912 (component :initarg :component :reader condition-component)
10913 (action :initarg :action :reader condition-action))
10914 (:report (lambda (c s)
10915 (format s (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
10916 - please use proper dependencies instead~@:>")
10918 (type-of (condition-operation c))
10919 (component-find-path (condition-component c))
10920 (action-path (condition-action c)))))))
10922 ;;;; Common operations
10924 (defmethod component-depends-on ((o prepare-op) (s system))
10925 (call-next-method)))
10926 (with-upgradability ()
10927 (defclass build-op (non-propagating-operation) ()
10928 (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
10929 to operate by default on a system or component, via the function BUILD.
10930 Its meaning is configurable via the :BUILD-OPERATION option of a component.
10931 which typically specifies the name of a specific operation to which to delegate the build,
10932 as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
10933 if NIL is specified (the default), BUILD-OP falls back to LOAD-OP,
10934 that will load the system in the current image."))
10935 (defmethod component-depends-on ((o build-op) (c component))
10936 `((,(or (component-build-operation c) 'load-op) ,c)
10937 ,@(call-next-method)))
10939 (defun make (system &rest keys)
10940 "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
10941 It will build system FOO using the operation BUILD-OP,
10942 the meaning of which is configurable by the system, and
10943 defaults to LOAD-OP, to load it in current image."
10944 (apply 'operate 'build-op system keys)
10947 (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
10948 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
10949 (declare (ignore force force-not verbose version))
10950 (apply 'operate 'load-op system keys)
10953 (defun load-systems* (systems &rest keys)
10954 "Loading multiple systems at once."
10955 (dolist (s systems) (apply 'load-system s keys)))
10957 (defun load-systems (&rest systems)
10958 "Loading multiple systems at once."
10959 (load-systems* systems))
10961 (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
10962 "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
10963 (declare (ignore force force-not verbose version))
10964 (apply 'operate 'compile-op system args)
10967 (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
10968 "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
10969 (declare (ignore force force-not verbose version))
10970 (apply 'operate 'test-op system args)
10973 ;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
10974 ;; only tries to load its specified target if it's not loaded yet.
10975 (with-upgradability ()
10976 (defun component-loaded-p (component)
10977 "Has the given COMPONENT been successfully loaded in the current image (yet)?
10978 Note that this returns true even if the component is not up to date."
10979 (if-let ((component (find-component component () :registered t)))
10980 (nth-value 1 (component-operation-time (make-operation 'load-op) component))))
10982 (defun already-loaded-systems ()
10983 "return a list of the names of the systems that have been successfully loaded so far"
10984 (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*)))))
10987 ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
10988 ;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
10989 ;; Note that despite the two being homonyms, the _function_ require-system
10990 ;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes.
10991 (with-upgradability ()
10992 (defvar *modules-being-required* nil)
10994 (defclass require-system (system)
10995 ((module :initarg :module :initform nil :accessor required-module))
10996 (:documentation "A SYSTEM subclass whose processing is handled by
10997 the implementation's REQUIRE rather than by internal ASDF mechanisms."))
10999 (defmethod perform ((o compile-op) (c require-system))
11002 (defmethod perform ((o load-op) (s require-system))
11003 (let* ((module (or (required-module s) (coerce-name s)))
11004 (*modules-being-required* (cons module *modules-being-required*)))
11005 (assert (null (component-children s)))
11008 (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
11009 (unless (and (length=n-p arguments 1)
11010 (typep (car arguments) '(or string (and symbol (not null)))))
11011 (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
11012 'resolve-dependency-combination
11013 (cons combinator arguments) component combinator))
11014 ;; :require must be prepared for some implementations providing modules using ASDF,
11015 ;; as SBCL used to do, and others may might do. Thus, the system provided in the end
11016 ;; would be a downcased name as per module-provide-asdf above. For the same reason,
11017 ;; we cannot assume that the system in the end will be of type require-system,
11018 ;; but must check whether we can use find-system and short-circuit cl:require.
11019 ;; Otherwise, calling cl:require could result in nasty reentrant calls between
11020 ;; cl:require and asdf:operate that could potentially blow up the stack,
11021 ;; all the while defeating the consistency of the dependency graph.
11022 (let* ((module (car arguments)) ;; NB: we already checked that it was not null
11023 ;; CMUCL, MKCL, SBCL like their module names to be all upcase.
11024 (module-name (string module))
11025 (system-name (string-downcase module))
11026 (system (find-system system-name nil)))
11027 (or system (let ((system (make-instance 'require-system :name system-name :module module-name)))
11028 (register-system system)
11031 (defun module-provide-asdf (name)
11032 ;; We must use string-downcase, because modules are traditionally specified as symbols,
11033 ;; that implementations traditionally normalize as uppercase, for which we seek a system
11034 ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine.
11035 ;; We could make complex, non-portable rules to try to preserve case, and just documenting
11036 ;; them would be a hell that it would be a disservice to inflict on users.
11037 (let ((module-name (string name))
11038 (system-name (string-downcase name)))
11039 (unless (member module-name *modules-being-required* :test 'equal)
11040 (let ((*modules-being-required* (cons module-name *modules-being-required*))
11041 #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal)))
11043 (((or style-warning recursive-operate) #'muffle-warning)
11044 (missing-component (constantly nil))
11047 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
11049 (let ((*verbose-out* (make-broadcast-stream)))
11050 (let ((system (find-system system-name nil)))
11052 ;; Do not use require-system after all, use load-system:
11053 ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice,
11054 ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with
11055 ;; the toplevel session forcing settings.
11056 (load-system system :verbose nil)
11060 ;;;; Some upgrade magic
11061 (with-upgradability ()
11062 (defun restart-upgraded-asdf ()
11063 ;; If we're in the middle of something, restart it.
11064 (let ((systems-being-defined
11065 (when *asdf-session*
11067 (loop :for k :being :the hash-keys :of (asdf-cache)
11068 :when (eq (first k) 'find-system) :collect (second k))
11069 (clrhash (asdf-cache))))))
11070 ;; Regardless, clear defined systems, since they might be invalid
11071 ;; after an incompatible ASDF upgrade.
11072 (clear-registered-systems)
11073 ;; The configuration also may have to be upgraded.
11074 (upgrade-configuration)
11075 ;; If we were in the middle of an operation, be sure to restore the system being defined.
11076 (dolist (s systems-being-defined) (find-system s nil))))
11077 (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf))
11078 ;;;; -------------------------------------------------------------------------
11079 ;;;; Finding systems
11081 (uiop/package:define-package :asdf/find-system
11082 (:recycle :asdf/find-system :asdf)
11083 (:use :uiop/common-lisp :uiop :asdf/upgrade
11084 :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action
11085 :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate)
11086 (:import-from #:asdf/component #:%additional-input-files)
11088 #:find-system #:locate-system #:load-asd #:define-op
11089 #:load-system-definition-error #:error-name #:error-pathname #:error-condition))
11090 (in-package :asdf/find-system)
11092 (with-upgradability ()
11093 (define-condition load-system-definition-error (system-definition-error)
11094 ((name :initarg :name :reader error-name)
11095 (pathname :initarg :pathname :reader error-pathname)
11096 (condition :initarg :condition :reader error-condition))
11097 (:report (lambda (c s)
11098 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
11099 (error-name c) (error-pathname c) (error-condition c)))))
11102 ;;; Methods for find-system
11104 ;; Reject NIL as a system designator.
11105 (defmethod find-system ((name null) &optional (error-p t))
11107 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
11109 ;; Default method for find-system: resolve the argument using COERCE-NAME.
11110 (defmethod find-system (name &optional (error-p t))
11111 (find-system (coerce-name name) error-p))
11113 (defun find-system-if-being-defined (name)
11114 ;; This function finds systems being defined *in the current ASDF session*, as embodied by
11115 ;; its session cache, even before they are fully defined and registered in *registered-systems*.
11116 ;; The purpose of this function is to prevent races between two files that might otherwise
11117 ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow.
11118 ;; This function explicitly MUST NOT find definitions merely registered in previous sessions.
11119 ;; NB: this function depends on a corresponding side-effect in parse-defsystem;
11120 ;; the precise protocol between the two functions may change in the future (or not).
11121 (first (gethash `(find-system ,(coerce-name name)) (asdf-cache))))
11123 (defclass define-op (non-propagating-operation) ()
11124 (:documentation "An operation to record dependencies on loading a .asd file."))
11126 (defmethod record-dependency ((plan null) (operation t) (component t))
11127 (unless (or (typep operation 'define-op)
11128 (and (typep operation 'load-op)
11129 (typep component 'system)
11130 (equal "asdf" (coerce-name component))))
11131 (if-let ((action (first (visiting-action-list *asdf-session*))))
11132 (let ((parent-operation (action-operation action))
11133 (parent-component (action-component action)))
11135 ((and (typep parent-operation 'define-op)
11136 (typep parent-component 'system))
11137 (let ((action (cons operation component)))
11138 (unless (gethash action (definition-dependency-set parent-component))
11139 (push (cons operation component) (definition-dependency-list parent-component))
11140 (setf (gethash action (definition-dependency-set parent-component)) t))))
11142 (warn 'recursive-operate
11143 :operation operation :component component :action action)))))))
11145 (defmethod component-depends-on ((o define-op) (s system))
11146 `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below.
11147 ;; 2- We don't call-next-method to avoid other methods
11148 ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c))))
11150 (defmethod component-depends-on ((o operation) (s system))
11151 `(,@(when (and (not (typep o 'define-op))
11152 (or (system-source-file s) (definition-dependency-list s)))
11153 `((define-op ,(primary-system-name s))))
11154 ,@(call-next-method)))
11156 (defmethod perform ((o operation) (c undefined-system))
11157 (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c)))
11159 ;; TODO: could this file be refactored so that locate-system is merely
11160 ;; the cache-priming call to input-files here?
11161 (defmethod input-files ((o define-op) (s system))
11162 (if-let ((asd (system-source-file s))) (list asd)))
11164 (defmethod perform ((o define-op) (s system))
11166 (if-let ((pathname (first (input-files o s)))))
11167 (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control
11168 (print-pprint-dispatch *print-pprint-dispatch*)))
11169 (with-standard-io-syntax)
11170 (let ((*print-readably* nil)
11171 ;; Note that our backward-compatible *readtable* is
11172 ;; a global readtable that gets globally side-effected. Ouch.
11173 ;; Same for the *print-pprint-dispatch* table.
11174 ;; We should do something about that for ASDF3 if possible, or else ASDF4.
11175 (*readtable* readtable) ;; restore inside syntax table
11176 (*print-pprint-dispatch* print-pprint-dispatch)
11177 (*package* (find-package :asdf-user))
11178 (*default-pathname-defaults*
11179 ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
11180 (pathname-directory-pathname (physicalize-pathname pathname)))))
11182 (((and error (not missing-component))
11183 #'(lambda (condition)
11184 (error 'load-system-definition-error
11185 :name (coerce-name s) :pathname pathname :condition condition))))
11186 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%")
11187 (coerce-name s) pathname)
11188 ;; dependencies will depend on what's loaded via definition-dependency-list
11189 (unset-asdf-cache-entry `(component-depends-on ,o ,s))
11190 (unset-asdf-cache-entry `(input-files ,o ,s)))
11191 (load* pathname :external-format (encoding-external-format (detect-encoding pathname)))))
11193 (defun load-asd (pathname &key name)
11194 "Load system definitions from PATHNAME.
11195 NAME if supplied is the name of a system expected to be defined in that file.
11197 Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD."
11198 (with-asdf-session ()
11199 ;; TODO: use OPERATE, so we consult the cache and only load once per session.
11200 (flet ((do-it (o c) (operate o c)))
11201 (let ((primary-name (primary-system-name (or name (pathname-name pathname))))
11202 (operation (make-operation 'define-op)))
11203 (if-let (system (registered-system primary-name))
11205 ;; We already determine this to be obsolete ---
11206 ;; or should we move some tests from find-system to check for up-to-date-ness here?
11207 (setf (component-operation-time operation system) t
11208 (definition-dependency-list system) nil
11209 (definition-dependency-set system) (list-to-hash-set nil))
11210 (do-it operation system))
11211 (let ((system (make-instance 'undefined-system
11212 :name primary-name :source-file pathname)))
11213 (register-system system)
11214 (unwind-protect (do-it operation system)
11215 (when (typep system 'undefined-system)
11216 (clear-system system)))))))))
11218 (defvar *old-asdf-systems* (make-hash-table :test 'equal))
11220 ;; (Private) function to check that a system that was found isn't an asdf downgrade.
11221 ;; Returns T if everything went right, NIL if the system was an ASDF at an older version,
11222 ;; or UIOP of the same or older version, that shall not be loaded.
11223 ;; Also issue a warning if it was a strictly older version of ASDF.
11224 (defun check-not-old-asdf-system (name pathname)
11225 (or (not (member name '("asdf" "uiop") :test 'equal))
11227 (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop
11229 (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp")))
11230 (version (and (probe-file* version-pathname :truename nil)
11231 (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2)))))
11232 (old-version (asdf-version)))
11234 ;; Same version is OK for ASDF, to allow loading from modified source.
11235 ;; However, do *not* load UIOP of the exact same version:
11236 ;; it was already loaded it as part of ASDF and would only be double-loading.
11237 ;; Be quiet about it, though, since it's a normal situation.
11238 ((equal old-version version) asdfp)
11239 ((version< old-version version) t) ;; newer version: Good!
11240 (t ;; old version: bad
11242 (list (namestring pathname) version) *old-asdf-systems*
11244 (let ((old-pathname (system-source-file (registered-system "asdf"))))
11247 You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
11248 or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
11249 ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
11250 Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
11251 and having an old version registered is a configuration error. ~
11252 ASDF will ignore this configured system rather than downgrade itself. ~
11253 In the future, you may want to either: ~
11254 (a) upgrade this configured ASDF to a newer version, ~
11255 (b) install a newer ASDF and register it in front of the former in your configuration, or ~
11256 (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
11257 Note that the older ASDF might be registered implicitly through configuration inherited ~
11258 from your system installation, in which case you might have to specify ~
11259 :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
11260 or other source-registry configuration file, environment variable or lisp parameter. ~
11261 Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
11262 that you might want to upgrade (if a recent enough version is available) ~
11263 or else remove altogether (since most implementations ship with a recent asdf); ~
11264 if you lack the system administration rights to upgrade or remove this package, ~
11265 then you might indeed want to either install and register a more recent version, ~
11266 or use :ignore-inherited-configuration to avoid registering the old one. ~
11267 Please consult ASDF documentation and/or experts.~@:>~%"
11268 old-version old-pathname version pathname)
11269 ;; NB: for UIOP, don't warn, just ignore.
11270 (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)"
11271 old-version old-pathname version pathname)
11273 nil))))) ;; only issue the warning the first time, but always return nil
11275 (defun locate-system (name)
11276 "Given a system NAME designator, try to locate where to load the system from.
11277 Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY
11278 FOUNDP is true when a system was found,
11279 either a new unregistered one or a previously registered one.
11280 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed.
11281 PATHNAME when not null is a path from which to load the system,
11282 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
11283 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
11284 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
11285 PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system."
11286 (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful,
11287 ;; and keeping a negative cache was a bug (see lp#1335323), which required
11288 ;; explicit invalidation in clear-system and find-system (when unsucccessful).
11289 (let* ((name (coerce-name name))
11290 (previous (registered-system name)) ; load from disk if absent or newer on disk
11291 (previous-primary-name (and previous (primary-system-name previous)))
11292 (previous-primary-system (and previous-primary-name
11293 (registered-system previous-primary-name)))
11294 (previous-time (and previous-primary-system
11295 (component-operation-time 'define-op previous-primary-system)))
11296 (found (search-for-system-definition name))
11297 (found-system (and (typep found 'system) found))
11298 (pathname (ensure-pathname
11299 (or (and (typep found '(or pathname string)) (pathname found))
11300 (system-source-file found-system)
11301 (system-source-file previous))
11302 :want-absolute t :resolve-symlinks *resolve-symlinks*))
11303 (foundp (and (or found-system pathname previous) t)))
11304 (check-type found (or null pathname system))
11305 (unless (check-not-old-asdf-system name pathname)
11306 (check-type previous system) ;; asdf is preloaded, so there should be a previous one.
11307 (setf found-system nil pathname nil))
11308 (values foundp found-system pathname previous previous-time previous-primary-system))))
11310 ;; TODO: make a prepare-define-op node for this
11311 ;; so we can properly cache the answer rather than recompute it.
11312 (defun definition-dependencies-up-to-date-p (system)
11313 (check-type system system)
11314 (or (not (primary-system-p system))
11316 (loop :with plan = (make-instance *plan-class*)
11317 :for action :in (definition-dependency-list system)
11318 :always (action-up-to-date-p
11319 plan (action-operation action) (action-component action))
11321 (let ((o (make-operation 'define-op)))
11322 (multiple-value-bind (stamp done-p)
11323 (compute-action-stamp plan o system)
11324 (return (and (timestamp<= stamp (component-operation-time o system))
11326 (system-out-of-date () nil))))
11328 ;; Main method for find-system: first, make sure the computation is memoized in a session cache.
11329 ;; Unless the system is immutable, use locate-system to find the primary system;
11330 ;; reconcile the finding (if any) with any previous definition (in a previous session,
11331 ;; preloaded, with a previous configuration, or before filesystem changes), and
11332 ;; load a found .asd if appropriate. Finally, update registration table and return results.
11333 (defmethod find-system ((name string) &optional (error-p t))
11335 (with-asdf-session (:key `(find-system ,name)))
11336 (let ((name-primary-p (primary-system-p name)))
11337 (unless name-primary-p (find-system (primary-system-name name) nil)))
11338 (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name)))
11339 (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary)
11340 (locate-system name)
11341 (assert (eq foundp (and (or found-system pathname previous) t))))
11342 (let ((previous-pathname (system-source-file previous))
11343 (system (or previous found-system)))
11344 (when (and found-system (not previous))
11345 (register-system found-system))
11346 (when (and system pathname)
11347 (setf (system-source-file system) pathname))
11348 (if-let ((stamp (get-file-stamp pathname)))
11349 (let ((up-to-date-p
11350 (and previous previous-primary
11351 (or (pathname-equal pathname previous-pathname)
11352 (and pathname previous-pathname
11354 (physicalize-pathname pathname)
11355 (physicalize-pathname previous-pathname))))
11356 (timestamp<= stamp previous-time)
11357 ;; Check that all previous definition-dependencies are up-to-date,
11358 ;; traversing them without triggering the adding of nodes to the plan.
11359 ;; TODO: actually have a prepare-define-op, extract its timestamp,
11360 ;; and check that it is less than the stamp of the previous define-op ?
11361 (definition-dependencies-up-to-date-p previous-primary))))
11362 (unless up-to-date-p
11364 (signal 'system-out-of-date :name name)
11365 (continue () :report "continue"))
11366 (load-asd pathname :name name)))))
11367 ;; Try again after having loaded from disk if needed
11368 (or (registered-system name)
11369 (when error-p (error 'missing-component :requires name)))))
11371 ;; Resolved forward reference for asdf/system-registry.
11372 (defun mark-component-preloaded (component)
11373 "Mark a component as preloaded."
11374 (let ((component (find-component component nil :registered t)))
11375 ;; Recurse to children, so asdf/plan will hopefully be happy.
11376 (map () 'mark-component-preloaded (component-children component))
11377 ;; Mark the timestamps of the common lisp-action operations as 0.
11378 (let ((cot (component-operation-times component)))
11379 (dolist (o `(,@(when (primary-system-p component) '(define-op))
11380 prepare-op compile-op load-op))
11381 (setf (gethash (make-operation o) cot) 0))))))
11382 ;;;; -------------------------------------------------------------------------
11385 (uiop/package:define-package :asdf/parse-defsystem
11386 (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf)
11387 (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares
11388 (:use :uiop/common-lisp :asdf/driver :asdf/upgrade
11389 :asdf/session :asdf/component :asdf/system :asdf/system-registry
11390 :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate)
11391 (:import-from :asdf/system #:depends-on #:weakly-depends-on)
11392 ;; these needed for record-additional-system-input-file
11393 (:import-from :asdf/operation #:make-operation)
11394 (:import-from :asdf/component #:%additional-input-files)
11395 (:import-from :asdf/find-system #:define-op)
11397 #:defsystem #:register-system-definition
11398 #:*default-component-class*
11399 #:determine-system-directory #:parse-component-form
11400 #:non-toplevel-system #:non-system-system #:bad-system-name
11401 #:*known-systems-with-bad-secondary-system-names*
11402 #:known-system-with-bad-secondary-system-names-p
11403 #:sysdef-error-component #:check-component-input
11405 ;; for extending the component types
11406 #:compute-component-children
11408 (in-package :asdf/parse-defsystem)
11411 (with-upgradability ()
11412 (defun determine-system-directory (pathname)
11413 ;; The defsystem macro calls this function to determine the pathname of a system as follows:
11414 ;; 1. If the pathname argument is an pathname object (NOT a namestring),
11415 ;; that is already an absolute pathname, return it.
11416 ;; 2. Otherwise, the directory containing the LOAD-PATHNAME
11417 ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and
11418 ;; if it is indeed available and an absolute pathname, then
11419 ;; the PATHNAME argument is normalized to a relative pathname
11420 ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T)
11421 ;; and merged into that DIRECTORY as per SUBPATHNAME.
11422 ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source,
11423 ;; but may be from within the EVAL-WHEN of a file compilation.
11424 ;; If no absolute pathname was found, we return NIL.
11425 (check-type pathname (or null string pathname))
11426 (pathname-directory-pathname
11428 (ensure-absolute-pathname
11429 (parse-unix-namestring pathname :type :directory)
11430 #'(lambda () (ensure-absolute-pathname
11431 (load-pathname) 'get-pathname-defaults nil))
11435 (when-upgrading (:version "3.3.4.17")
11436 ;; This turned into a generic function in 3.3.4.17
11437 (fmakunbound 'class-for-type))
11439 ;;; Component class
11440 (with-upgradability ()
11441 ;; What :file gets interpreted as, unless overridden by a :default-component-class
11442 (defvar *default-component-class* 'cl-source-file)
11444 (defgeneric class-for-type (parent type-designator)
11446 "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT."))
11448 (defmethod class-for-type ((parent null) type)
11449 "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM."
11450 (or (coerce-class type :package :asdf/interface :super 'system :error nil)
11451 (sysdef-error "don't recognize component type ~S in the context of no parent" type)))
11453 (defmethod class-for-type ((parent parent-component) type)
11454 (or (coerce-class type :package :asdf/interface :super 'component :error nil)
11455 (and (eq type :file)
11457 (or (loop :for p = parent :then (component-parent p) :while p
11458 :thereis (module-default-component-class p))
11459 *default-component-class*)
11460 :package :asdf/interface :super 'component :error nil))
11461 (sysdef-error "don't recognize component type ~S" type))))
11465 (with-upgradability ()
11466 (define-condition non-system-system (system-definition-error)
11467 ((name :initarg :name :reader non-system-system-name)
11468 (class-name :initarg :class-name :reader non-system-system-class-name))
11469 (:report (lambda (c s)
11470 (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
11471 (non-system-system-name c) (non-system-system-class-name c) 'system))))
11473 (define-condition non-toplevel-system (system-definition-error)
11474 ((parent :initarg :parent :reader non-toplevel-system-parent)
11475 (name :initarg :name :reader non-toplevel-system-name))
11476 (:report (lambda (c s)
11477 (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
11478 (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
11480 (define-condition bad-system-name (warning)
11481 ((name :initarg :name :reader component-name)
11482 (source-file :initarg :source-file :reader system-source-file))
11483 (:report (lambda (c s)
11484 (let* ((file (system-source-file c))
11485 (name (component-name c))
11486 (asd (pathname-name file)))
11487 (format s (compatfmt "~@<System definition file ~S contains definition for system ~S. ~
11488 Please only define ~S and secondary systems with a name starting with ~S (e.g. ~S) in that file.~@:>")
11489 file name asd (strcat asd "/") (strcat asd "/test"))))))
11491 (defun sysdef-error-component (msg type name value)
11492 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
11495 (defun check-component-input (type name weakly-depends-on
11496 depends-on components)
11497 "A partial test of the values of a component."
11498 (unless (listp depends-on)
11499 (sysdef-error-component ":depends-on must be a list."
11500 type name depends-on))
11501 (unless (listp weakly-depends-on)
11502 (sysdef-error-component ":weakly-depends-on must be a list."
11503 type name weakly-depends-on))
11504 (unless (listp components)
11505 (sysdef-error-component ":components must be NIL or a list of components."
11506 type name components)))
11509 (defun record-additional-system-input-file (pathname component parent)
11510 (let* ((record-on (if parent
11512 :for par = parent :then (component-parent par)
11514 :do (setf retval par)
11515 :finally (return retval))
11517 (comp (if (typep record-on 'component)
11519 ;; at this point there will be no parent for RECORD-ON
11520 (find-component record-on nil)))
11521 (op (make-operation 'define-op))
11522 (cell (or (assoc op (%additional-input-files comp))
11523 (let ((new-cell (list op)))
11524 (push new-cell (%additional-input-files comp))
11526 (pushnew pathname (cdr cell) :test 'pathname-equal)
11529 ;; Given a form used as :version specification, in the context of a system definition
11530 ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form
11531 ;; to an acceptable ASDF-format version.
11532 (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31
11533 (defun normalize-version (form &key pathname component parent)
11534 (labels ((invalid (&optional (continuation "using NIL instead"))
11535 (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
11536 form component parent pathname continuation))
11537 (invalid-parse (control &rest args)
11538 (unless (if-let (target (find-component parent component)) (builtin-system-p target))
11539 (apply 'warn control args)
11541 (if-let (v (typecase form
11542 ((or string null) form)
11544 (invalid "Substituting a string")
11545 (format nil "~D" form)) ;; 1.0 becomes "1.0"
11549 (destructuring-bind (subpath &key (at 0)) (rest form)
11550 (let ((path (subpathname pathname subpath)))
11551 (record-additional-system-input-file path component parent)
11552 (safe-read-file-form path
11553 :at at :package :asdf-user))))
11555 (destructuring-bind (subpath &key (at 0)) (rest form)
11556 (let ((path (subpathname pathname subpath)))
11557 (record-additional-system-input-file path component parent)
11558 (safe-read-file-line (subpathname pathname subpath)
11564 (if-let (pv (parse-version v #'invalid-parse))
11565 (unparse-version pv)
11569 ;;; "inline methods"
11570 (with-upgradability ()
11571 (defparameter* +asdf-methods+
11572 '(perform-with-restarts perform explain output-files operation-done-p))
11574 (defun %remove-component-inline-methods (component)
11575 (dolist (name +asdf-methods+)
11577 ;; this is inefficient as most of the stored
11578 ;; methods will not be for this particular gf
11579 ;; But this is hardly performance-critical
11581 (remove-method (symbol-function name) m))
11582 (component-inline-methods component)))
11583 (component-inline-methods component) nil)
11585 (defparameter *standard-method-combination-qualifiers*
11586 '(:around :before :after))
11588 ;;; Find inline method definitions of the form
11590 ;;; :perform (test-op :before (operation component) ...)
11592 ;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods.
11593 (defun %define-component-inline-methods (ret rest)
11594 ;; find key-value pairs that look like inline method definitions in REST. For each identified
11595 ;; definition, parse it and, if it is well-formed, define the method.
11596 (loop :for (key value) :on rest :by #'cddr
11597 :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
11599 ;; parse VALUE as an inline method definition of the form
11601 ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY)
11602 (destructuring-bind (operation-name &rest rest) value
11603 (let ((qualifiers '()))
11604 ;; ensure that OPERATION-NAME is a symbol.
11605 (unless (and (symbolp operation-name) (not (null operation-name)))
11606 (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~
11607 designating an operation but ~S."
11608 value operation-name))
11609 ;; ensure that REST starts with either a cons (potential lambda list, further checked
11610 ;; below) or a qualifier accepted by the standard method combination. Everything else
11611 ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely
11612 ;; has to start with the lambda list.
11614 ((consp (car rest)))
11615 ((not (member (car rest)
11616 *standard-method-combination-qualifiers*))
11617 (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~
11618 qualifiers ~{~S~^ ~} is allowed, not ~S."
11619 value *standard-method-combination-qualifiers* (car rest)))
11621 (setf qualifiers (list (pop rest)))))
11622 ;; REST must start with a two-element lambda list.
11623 (unless (and (listp (car rest))
11624 (length=n-p (car rest) 2)
11625 (null (cddar rest)))
11626 (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~
11627 a lambda-list of the form (OPERATION COMPONENT) and a method body."
11628 value operation-name))
11629 ;; define the method.
11630 (destructuring-bind ((o c) &rest body) rest
11632 (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body))
11633 (component-inline-methods ret)))))))
11635 (defun %refresh-component-inline-methods (component rest)
11636 ;; clear methods, then add the new ones
11637 (%remove-component-inline-methods component)
11638 (%define-component-inline-methods component rest)))
11641 ;;; Main parsing function
11642 (with-upgradability ()
11643 (defun parse-dependency-def (dd)
11647 (unless (= (length dd) 3)
11648 (sysdef-error "Ill-formed feature dependency: ~s" dd))
11649 (let ((embedded (parse-dependency-def (third dd))))
11650 `(:feature ,(second dd) ,embedded)))
11652 (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd))
11654 (unless (= (length dd) 2)
11655 (sysdef-error "Ill-formed require dependency: ~s" dd))
11658 (unless (= (length dd) 3)
11659 (sysdef-error "Ill-formed version dependency: ~s" dd))
11660 `(:version ,(coerce-name (second dd)) ,(third dd)))
11661 (otherwise (sysdef-error "Ill-formed dependency: ~s" dd)))
11664 (defun parse-dependency-defs (dd-list)
11665 "Parse the dependency defs in DD-LIST into canonical form by translating all
11666 system names contained using COERCE-NAME. Return the result."
11667 (mapcar 'parse-dependency-def dd-list))
11669 (defgeneric compute-component-children (component components serial-p)
11671 "Return a list of children for COMPONENT.
11673 COMPONENTS is a list of the explicitly defined children descriptions.
11675 SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous
11678 (defun stable-union (s1 s2 &key (test #'eql) (key 'identity))
11680 (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2)))
11682 (defun parse-component-form (parent options &key previous-serial-components)
11683 (destructuring-bind
11684 (type name &rest rest &key
11685 (builtin-system-p () bspp)
11686 ;; the following list of keywords is reproduced below in the
11687 ;; remove-plist-keys form. important to keep them in sync
11688 components pathname perform explain output-files operation-done-p
11689 weakly-depends-on depends-on serial
11690 do-first if-component-dep-fails version
11692 &allow-other-keys) options
11693 (declare (ignore perform explain output-files operation-done-p builtin-system-p))
11694 (check-component-input type name weakly-depends-on depends-on components)
11696 (find-component parent name)
11697 (not ;; ignore the same object when rereading the defsystem
11698 (typep (find-component parent name)
11699 (class-for-type parent type))))
11700 (error 'duplicate-names :name name))
11701 (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
11702 (let* ((name (coerce-name name))
11703 (args `(:name ,name
11704 :pathname ,pathname
11705 ,@(when parent `(:parent ,parent))
11706 ,@(remove-plist-keys
11707 '(:components :pathname :if-component-dep-fails :version
11708 :perform :explain :output-files :operation-done-p
11709 :weakly-depends-on :depends-on :serial)
11711 (component (find-component parent name))
11712 (class (class-for-type parent type)))
11713 (when (and parent (subtypep class 'system))
11714 (error 'non-toplevel-system :parent parent :name name))
11715 (if component ; preserve identity
11716 (apply 'reinitialize-instance component args)
11717 (setf component (apply 'make-instance class args)))
11718 (component-pathname component) ; eagerly compute the absolute pathname
11719 (when (typep component 'system)
11720 ;; cache information for introspection
11721 (setf (slot-value component 'depends-on)
11722 (parse-dependency-defs depends-on)
11723 (slot-value component 'weakly-depends-on)
11724 ;; these must be a list of systems, cannot be features or versioned systems
11725 (mapcar 'coerce-name weakly-depends-on)))
11726 (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
11727 (when (and (typep component 'system) (not bspp))
11728 (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
11729 (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
11730 ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
11731 ;; A better fix is required.
11732 (setf (slot-value component 'version) version)
11733 (when (typep component 'parent-component)
11734 (setf (component-children component) (compute-component-children component components serial))
11735 (compute-children-by-name component))
11736 (when previous-serial-components
11737 (setf depends-on (stable-union depends-on previous-serial-components :test #'equal)))
11738 (when weakly-depends-on
11739 ;; ASDF4: deprecate this feature and remove it.
11740 (appendf depends-on
11741 (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
11742 ;; Used by POIU. ASDF4: rename to component-depends-on?
11743 (setf (component-sideway-dependencies component) depends-on)
11744 (%refresh-component-inline-methods component rest)
11745 (when if-component-dep-fails
11746 (error "The system definition for ~S uses deprecated ~
11747 ASDF option :IF-COMPONENT-DEP-FAILS. ~
11748 Starting with ASDF 3, please use :IF-FEATURE instead"
11749 (coerce-name (component-system component))))
11752 (defmethod compute-component-children ((component parent-component) components serial-p)
11754 :with previous-components = nil ; list of strings
11755 :for c-form :in components
11756 :for c = (parse-component-form component c-form
11757 :previous-serial-components previous-components)
11758 :for name :of-type string = (component-name c)
11760 ;; if this is an if-feature component, we need to make a serial link
11761 ;; from previous components to following components -- otherwise should
11762 ;; the IF-FEATURE component drop out, the chain of serial dependencies will be
11764 :unless (component-if-feature c)
11765 :do (setf previous-components nil)
11768 :do (push name previous-components)
11772 ;; the following are all systems that Stas Boukarev maintains and refuses to fix,
11773 ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them.
11774 (defparameter* *known-systems-with-bad-secondary-system-names*
11775 (list-to-hash-set '("cl-ppcre" "cl-interpol")))
11776 (defun known-system-with-bad-secondary-system-names-p (asd-name)
11777 ;; Does .asd file with name ASD-NAME contain known exceptions
11778 ;; that should be screened out of checking for BAD-SYSTEM-NAME?
11779 (gethash asd-name *known-systems-with-bad-secondary-system-names*))
11781 (defun register-system-definition
11782 (name &rest options &key pathname (class 'system) (source-file () sfp)
11783 defsystem-depends-on &allow-other-keys)
11784 ;; The system must be registered before we parse the body,
11785 ;; otherwise we recur when trying to find an existing system
11786 ;; of the same name to reuse options (e.g. pathname) from.
11787 ;; To avoid infinite recursion in cases where you defsystem a system
11788 ;; that is registered to a different location to find-system,
11789 ;; we also need to remember it in the asdf-cache.
11791 (with-asdf-session ())
11792 (let* ((name (coerce-name name))
11793 (source-file (if sfp source-file (resolve-symlinks* (load-pathname))))))
11794 (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x))))
11795 (let* ((asd-name (and source-file
11796 (equal "asd" (fix-case (pathname-type source-file)))
11797 (fix-case (pathname-name source-file))))
11798 ;; note that PRIMARY-NAME is a *syntactically* primary name
11799 (primary-name (primary-system-name name)))
11800 (when (and asd-name
11801 (not (equal asd-name primary-name))
11802 (not (known-system-with-bad-secondary-system-names-p asd-name)))
11803 (warn (make-condition 'bad-system-name :source-file source-file :name name))))
11804 (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object,
11805 ;; so that in case it fails, there is no incomplete object polluting the build.
11806 (checked-defsystem-depends-on
11807 (let* ((dep-forms (parse-dependency-defs defsystem-depends-on))
11808 (deps (loop :for spec :in dep-forms
11809 :when (resolve-dependency-spec nil spec)
11811 (load-systems* deps)
11813 (system (or (find-system-if-being-defined name)
11814 (if-let (registered (registered-system name))
11815 (reset-system-class registered 'undefined-system
11816 :name name :source-file source-file)
11817 (register-system (make-instance 'undefined-system
11818 :name name :source-file source-file)))))
11821 (remove-plist-keys '(:defsystem-depends-on :class) options)
11822 ;; cache defsystem-depends-on in canonical form
11823 (when checked-defsystem-depends-on
11824 `(:defsystem-depends-on ,checked-defsystem-depends-on))))
11825 (directory (determine-system-directory pathname)))
11826 ;; This works hand in hand with asdf/find-system:find-system-if-being-defined:
11827 (set-asdf-cache-entry `(find-system ,name) (list system)))
11828 ;; We change-class AFTER we loaded the defsystem-depends-on
11829 ;; since the class might be defined as part of those.
11830 (let ((class (class-for-type nil class)))
11831 (unless (subtypep class 'system)
11832 (error 'non-system-system :name name :class-name (class-name class)))
11833 (unless (eq (type-of system) class)
11834 (reset-system-class system class)))
11835 (parse-component-form nil (list* :system name :pathname directory component-options))))
11837 (defmacro defsystem (name &body options)
11838 `(apply 'register-system-definition ',name ',options)))
11839 ;;;; -------------------------------------------------------------------------
11842 (uiop/package:define-package :asdf/bundle
11843 (:recycle :asdf/bundle :asdf)
11844 (:use :uiop/common-lisp :uiop :asdf/upgrade
11845 :asdf/component :asdf/system :asdf/operation
11846 :asdf/find-component ;; used by ECL
11847 :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
11849 #:bundle-op #:bundle-type #:program-system
11850 #:bundle-system #:bundle-pathname-type #:direct-dependency-files
11851 #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
11852 #:basic-compile-bundle-op #:prepare-bundle-op
11853 #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
11854 #:lib-op #:monolithic-lib-op
11855 #:dll-op #:monolithic-dll-op
11856 #:deliver-asd-op #:monolithic-deliver-asd-op
11857 #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
11858 #:user-system-p #:user-system #:trivial-system-p
11859 #:prologue-code #:epilogue-code #:static-library))
11860 (in-package :asdf/bundle)
11862 (with-upgradability ()
11863 (defclass bundle-op (operation) ()
11864 (:documentation "base class for operations that bundle outputs from multiple components"))
11865 (defgeneric bundle-type (bundle-op))
11867 (defclass monolithic-op (operation) ()
11868 (:documentation "A MONOLITHIC operation operates on a system *and all of its
11869 dependencies*. So, for example, a monolithic concatenate operation will
11870 concatenate together a system's components and all of its dependencies, but a
11871 simple concatenate operation will concatenate only the components of the system
11874 (defclass monolithic-bundle-op (bundle-op monolithic-op)
11875 ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
11876 ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
11877 ((prologue-code :initform nil :accessor prologue-code)
11878 (epilogue-code :initform nil :accessor epilogue-code))
11879 (:documentation "operations that are both monolithic-op and bundle-op"))
11881 (defclass program-system (system)
11882 ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
11883 ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
11884 (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
11885 (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
11886 (prefix-lisp-object-files :initarg :prefix-lisp-object-files
11887 :initform nil :accessor prefix-lisp-object-files)
11888 (postfix-lisp-object-files :initarg :postfix-lisp-object-files
11889 :initform nil :accessor postfix-lisp-object-files)
11890 (extra-object-files :initarg :extra-object-files
11891 :initform nil :accessor extra-object-files)
11892 (extra-build-args :initarg :extra-build-args
11893 :initform nil :accessor extra-build-args)))
11895 (defmethod prologue-code ((x system)) nil)
11896 (defmethod epilogue-code ((x system)) nil)
11897 (defmethod no-uiop ((x system)) nil)
11898 (defmethod prefix-lisp-object-files ((x system)) nil)
11899 (defmethod postfix-lisp-object-files ((x system)) nil)
11900 (defmethod extra-object-files ((x system)) nil)
11901 (defmethod extra-build-args ((x system)) nil)
11903 (defclass link-op (bundle-op) ()
11904 (:documentation "Abstract operation for linking files together"))
11906 (defclass gather-operation (bundle-op) ()
11907 (:documentation "Abstract operation for gathering many input files from a system"))
11908 (defgeneric gather-operation (gather-operation))
11909 (defmethod gather-operation ((o gather-operation)) nil)
11910 (defgeneric gather-type (gather-operation))
11912 (defun operation-monolithic-p (op)
11913 (typep op 'monolithic-op))
11915 ;; Dependencies of a gather-op are the actions of the dependent operation
11916 ;; for all the (sorted) required components for loading the system.
11917 ;; Monolithic operations typically use lib-op as the dependent operation,
11918 ;; and all system-level dependencies as required components.
11919 ;; Non-monolithic operations typically use compile-op as the dependent operation,
11920 ;; and all transitive sub-components as required components (excluding other systems).
11921 (defmethod component-depends-on ((o gather-operation) (s system))
11922 (let* ((mono (operation-monolithic-p o))
11923 (go (make-operation (or (gather-operation o) 'compile-op)))
11924 (bundle-p (typep go 'bundle-op))
11925 ;; In a non-mono operation, don't recurse to other systems.
11926 ;; In a mono operation gathering bundles, don't recurse inside systems.
11927 (component-type (if mono (if bundle-p 'system t) '(not system)))
11928 ;; In the end, only keep system bundles or non-system bundles, depending.
11929 (keep-component (if bundle-p 'system '(not system)))
11931 ;; Required-components only looks at the dependencies of an action, excluding the action
11932 ;; itself, so it may be safely used by an action recursing on its dependencies (which
11933 ;; may or may not be an overdesigned API, since in practice we never use it that way).
11934 ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
11935 ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
11936 ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
11937 ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
11938 ;; for our needs of gathering all the files we want to include in a bundle.
11939 ;; Note that we use basic-compile-op rather than compile-op so it will still work on
11940 ;; systems that would somehow load dependencies with load-bundle-op.
11941 (required-components
11942 s :other-systems mono :component-type component-type :keep-component keep-component
11943 :goal-operation 'load-op :keep-operation 'basic-compile-op)))
11944 `((,go ,@deps) ,@(call-next-method))))
11946 ;; Create a single fasl for the entire library
11947 (defclass basic-compile-bundle-op (bundle-op basic-compile-op) ()
11948 (:documentation "Base class for compiling into a bundle"))
11949 (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb)
11950 (defmethod gather-type ((o basic-compile-bundle-op))
11951 #-(or clasp ecl mkcl) :fasl
11952 #+(or clasp ecl mkcl) :object)
11954 ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
11955 (defclass prepare-bundle-op (sideway-operation)
11956 ((sideway-operation
11957 :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
11958 :allocation :class))
11959 (:documentation "Operation class for loading the bundles of a system's dependencies"))
11961 (defclass lib-op (link-op gather-operation non-propagating-operation) ()
11962 (:documentation "Compile the system and produce a linkable static library (.a/.lib)
11963 for all the linkable object files associated with the system. Compare with DLL-OP.
11965 On most implementations, these object files only include extensions to the runtime
11966 written in C or another language with a compiler producing linkable object files.
11967 On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
11968 themselves. In any case, this operation will produce what you need to further build
11969 a static runtime for your system, or a dynamic library to load in an existing runtime."))
11970 (defmethod bundle-type ((o lib-op)) :lib)
11971 (defmethod gather-type ((o lib-op)) :object)
11973 ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
11974 ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
11975 (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
11976 #+(or clasp ecl mkcl) link-op)
11977 ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
11978 (:documentation "This operator is an alternative to COMPILE-OP. Build a system
11979 and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
11980 of one per source file, which may be more resource efficient. That monolithic
11981 FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
11983 (defclass load-bundle-op (basic-load-op selfward-operation)
11984 ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
11985 (:documentation "This operator is an alternative to LOAD-OP. Build a system
11986 and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
11987 respect to LOAD-OP is that it builds only a single FASL, which may be
11988 faster and more resource efficient."))
11990 ;; NB: since the monolithic-op's can't be sideway-operation's,
11991 ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
11992 ;; we'd have to have the monolithic-op not inherit from the main op,
11993 ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
11995 (defclass dll-op (link-op gather-operation non-propagating-operation) ()
11996 (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
11997 for all the linkable object files associated with the system. Compare with LIB-OP."))
11998 (defmethod bundle-type ((o dll-op)) :dll)
11999 (defmethod gather-type ((o dll-op)) :object)
12001 (defclass deliver-asd-op (basic-compile-op selfward-operation)
12002 ((selfward-operation
12003 ;; TODO: implement link-op on all implementations, and make that
12004 ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
12005 :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
12006 :allocation :class))
12007 (:documentation "produce an asd file for delivering the system as a single fasl"))
12010 (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
12011 ((selfward-operation
12012 ;; TODO: implement link-op on all implementations, and make that
12013 ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
12014 :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
12015 :allocation :class))
12016 (:documentation "produce fasl and asd files for combined system and dependencies."))
12018 (defclass monolithic-compile-bundle-op
12019 (basic-compile-bundle-op monolithic-bundle-op
12020 #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
12022 (:documentation "Create a single fasl for the system and its dependencies."))
12024 (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
12025 ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
12026 (:documentation "Load a single fasl for the system and its dependencies."))
12028 (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ()
12029 (:documentation "Compile the system and produce a linkable static library (.a/.lib)
12030 for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
12032 (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ()
12033 (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
12034 for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
12036 (defclass image-op (monolithic-bundle-op selfward-operation
12037 #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
12038 ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
12039 (:documentation "create an image file from the system and its dependencies"))
12040 (defmethod bundle-type ((o image-op)) :image)
12041 #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op)
12042 #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library)
12044 (defclass program-op (image-op) ()
12045 (:documentation "create an executable file from the system and its dependencies"))
12046 (defmethod bundle-type ((o program-op)) :program)
12048 ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
12049 (defun bundle-pathname-type (bundle-type)
12050 (etypecase bundle-type
12051 ((or null string) ;; pass through nil or string literal
12053 ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
12054 (error "No output file, therefore no pathname type"))
12055 ((eql :fasl) ;; the type of a fasl
12056 (compile-file-type)) ; on image-based platforms, used as input and output
12057 ((eql :fasb) ;; the type of a fasl
12058 #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
12059 #+(or ecl mkcl) "fasb"
12060 #+clasp "fasp") ; on C-linking platforms, only used as output for system bundles
12063 #+(and clisp os-windows) "exe"
12064 #-(or allegro (and clisp os-windows)) "image")
12065 ;; NB: on CLASP and ECL these implementations, we better agree with
12066 ;; (compile-file-type :type bundle-type))
12067 ((eql :object) ;; the type of a linkable object file
12068 (os-cond ((os-unix-p)
12069 #+clasp "fasp" ;(core:build-extension cmp:*default-object-type*)
12071 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
12072 ((member :lib :static-library) ;; the type of a linkable library
12073 (os-cond ((os-unix-p) "a")
12074 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
12075 ((member :dll :shared-library) ;; the type of a shared library
12076 (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
12077 ((eql :program) ;; the type of an executable program
12078 (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
12080 ;; Compute the output-files for a given bundle action
12081 (defun bundle-output-files (o c)
12082 (let ((bundle-type (bundle-type o)))
12083 (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
12084 (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
12085 (let ((name (or (component-build-pathname c)
12087 (unless (typep o 'program-op)
12088 ;; "." is no good separator for Logical Pathnames, so we use "--"
12089 (if (operation-monolithic-p o)
12091 ;; These use a different type .fasb or .a instead of .fasl
12092 #-(or clasp ecl mkcl) "--system"))))
12093 (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix))))
12094 (type (bundle-pathname-type bundle-type)))
12095 (values (list (subpathname (component-pathname c) name :type type))
12096 (eq (class-of o) (coerce-class (component-build-operation c)
12097 :package :asdf/interface
12101 (defmethod output-files ((o bundle-op) (c system))
12102 (bundle-output-files o c))
12104 #-(or clasp ecl mkcl)
12106 (defmethod perform ((o image-op) (c system))
12107 (dump-image (output-file o c) :executable (typep o 'program-op)))
12108 (defmethod perform :before ((o program-op) (c system))
12109 (setf *image-entry-point* (ensure-function (component-entry-point c)))))
12111 (defclass compiled-file (file-component)
12112 ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
12113 (:documentation "Class for a file that is already compiled,
12114 e.g. as part of the implementation, of an outer build system that calls into ASDF,
12115 or of opaque libraries shipped along the source code."))
12117 (defclass precompiled-system (system)
12118 ((build-pathname :initarg :fasb :initarg :fasl))
12119 (:documentation "Class For a system that is delivered as a precompiled fasl"))
12121 (defclass prebuilt-system (system)
12122 ((build-pathname :initarg :static-library :initarg :lib
12123 :accessor prebuilt-system-static-library))
12124 (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
12130 ;;; This operation takes all components from one or more systems and
12131 ;;; creates a single output file, which may be
12132 ;;; a FASL, a statically linked library, a shared library, etc.
12133 ;;; The different targets are defined by specialization.
12135 (when-upgrading (:version "3.2.0")
12136 ;; Cancel any previously defined method
12137 (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
12138 (declare (ignore initargs))))
12140 (with-upgradability ()
12141 (defgeneric trivial-system-p (component))
12143 (defun user-system-p (s)
12144 (and (typep s 'system)
12145 (not (builtin-system-p s))
12146 (not (trivial-system-p s)))))
12148 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
12149 (deftype user-system () '(and system (satisfies user-system-p))))
12152 ;;; First we handle monolithic bundles.
12153 ;;; These are standalone systems which contain everything,
12154 ;;; including other ASDF systems required by the current one.
12155 ;;; A PROGRAM is always monolithic.
12157 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
12159 (with-upgradability ()
12160 (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
12161 ;; This function selects output files from direct dependencies;
12162 ;; your component-depends-on method must gather the correct dependencies in the correct order.
12163 (while-collecting (collect)
12164 (map-direct-dependencies
12165 o c #'(lambda (sub-o sub-c)
12166 (loop :for f :in (funcall key sub-o sub-c)
12167 :when (funcall test f) :do (collect f))))))
12169 (defun pathname-type-equal-function (type)
12170 #'(lambda (p) (equalp (pathname-type p) type)))
12172 (defmethod input-files ((o gather-operation) (c system))
12173 (unless (eq (bundle-type o) :no-output-file)
12174 (direct-dependency-files
12175 o c :key 'output-files
12176 :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
12178 ;; Find the operation that produces a given bundle-type
12179 (defun select-bundle-operation (type &optional monolithic)
12181 ((:dll :shared-library)
12182 (if monolithic 'monolithic-dll-op 'dll-op))
12183 ((:lib :static-library)
12184 (if monolithic 'monolithic-lib-op 'lib-op))
12186 (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
12195 ;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
12197 (with-upgradability ()
12198 (defmethod component-depends-on ((o load-bundle-op) (c system))
12199 `((,o ,@(component-sideway-dependencies c))
12200 (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
12201 ,@(call-next-method)))
12203 (defmethod input-files ((o load-bundle-op) (c system))
12204 (when (user-system-p c)
12205 (output-files (find-operation o 'compile-bundle-op) c)))
12207 (defmethod perform ((o load-bundle-op) (c system))
12208 (when (input-files o c)
12209 (perform-lisp-load-fasl o c)))
12211 (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
12212 (mark-operation-done (find-operation o 'load-op) c)))
12215 ;;; PRECOMPILED FILES
12217 ;;; This component can be used to distribute ASDF systems in precompiled form.
12218 ;;; Only useful when the dependencies have also been precompiled.
12220 (with-upgradability ()
12221 (defmethod trivial-system-p ((s system))
12222 (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
12224 (defmethod input-files ((o operation) (c compiled-file))
12225 (list (component-pathname c)))
12226 (defmethod perform ((o load-op) (c compiled-file))
12227 (perform-lisp-load-fasl o c))
12228 (defmethod perform ((o load-source-op) (c compiled-file))
12229 (perform (find-operation o 'load-op) c))
12230 (defmethod perform ((o operation) (c compiled-file))
12234 ;;; Pre-built systems
12236 (with-upgradability ()
12237 (defmethod trivial-system-p ((s prebuilt-system))
12240 (defmethod perform ((o link-op) (c prebuilt-system))
12243 (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
12246 (defmethod perform ((o lib-op) (c prebuilt-system))
12249 (defmethod perform ((o dll-op) (c prebuilt-system))
12252 (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
12255 (defmethod output-files ((o lib-op) (c prebuilt-system))
12256 (values (list (prebuilt-system-static-library c)) t)))
12260 ;;; PREBUILT SYSTEM CREATOR
12262 (with-upgradability ()
12263 (defmethod output-files ((o deliver-asd-op) (s system))
12264 (list (make-pathname :name (coerce-filename (component-name s)) :type "asd"
12265 :defaults (component-pathname s))))
12267 ;; because of name collisions between the output files of different
12268 ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to
12269 ;; tell us if the output file is up-to-date, so just treat the
12270 ;; operation as never being done.
12271 (defmethod operation-done-p ((o deliver-asd-op) (s system))
12272 (declare (ignorable o s))
12275 (defun space-for-crlf (s)
12276 (substitute-if #\space #'(lambda (x) (find x +crlf+)) s))
12278 (defmethod perform ((o deliver-asd-op) (s system))
12279 "Write an ASDF system definition for loading S as a delivered system."
12280 (let* ((inputs (input-files o s))
12281 (fasl (first inputs))
12282 (library (second inputs))
12283 (asd (output-file o s))
12284 (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
12285 (version (component-version s))
12287 (if (operation-monolithic-p o)
12288 ;; We want only dependencies, and we use basic-load-op rather than load-op so that
12289 ;; this will keep working on systems that load dependencies with load-bundle-op
12290 (remove-if-not 'builtin-system-p
12291 (required-components s :component-type 'system
12292 :keep-operation 'basic-load-op))
12293 (while-collecting (x) ;; resolve the sideway-dependencies of s
12294 (map-direct-dependencies
12297 (when (and (typep o 'load-op) (typep c 'system))
12299 (depends-on (mapcar 'coerce-name dependencies)))
12300 (when (pathname-equal asd (system-source-file s))
12301 (cerror "overwrite the asd file"
12302 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
12303 which is probably not what you want; you probably need to tweak your output translations."
12305 (with-open-file (s asd :direction :output :if-exists :supersede
12306 :if-does-not-exist :create)
12307 (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
12308 (operation-monolithic-p o) name)
12309 ;; this can cause bugs in cases where one of the functions returns a multi-line
12311 (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A"
12312 (lisp-implementation-type)
12313 (lisp-implementation-version)
12316 (software-version))))
12317 ;; ensure the whole thing is on one line
12318 (println (space-for-crlf description-string) s))
12319 (let ((*package* (find-package :asdf-user)))
12320 (pprint `(defsystem ,name
12321 :class prebuilt-system
12323 :depends-on ,depends-on
12324 :components ((:compiled-file ,(pathname-name fasl)))
12325 ,@(when library `(:lib ,(file-namestring library))))
12329 #-(or clasp ecl mkcl)
12330 (defmethod perform ((o basic-compile-bundle-op) (c system))
12331 (let* ((input-files (input-files o c))
12332 (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
12333 (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
12334 (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL
12335 (output-file (first output-files)))
12336 (assert (eq (not input-files) (not output-files)))
12338 (when non-fasl-files
12339 (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
12340 (implementation-type) non-fasl-files))
12341 (when (or (prologue-code c) (epilogue-code c))
12342 (error "prologue-code and epilogue-code are not supported on ~A"
12343 (implementation-type)))
12344 (with-staging-pathname (output-file)
12345 (combine-fasls fasl-files output-file)))))
12347 (defmethod input-files ((o load-op) (s precompiled-system))
12348 (bundle-output-files (find-operation o 'compile-bundle-op) s))
12350 (defmethod perform ((o load-op) (s precompiled-system))
12351 (perform-lisp-load-fasl o s))
12353 (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
12354 `((load-op ,s) ,@(call-next-method))))
12357 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
12358 (asdf:load-system :precompiled-asdf-utils)
12361 #+(or clasp ecl mkcl)
12362 (with-upgradability ()
12363 (defun system-module-pathname (module)
12364 (let ((name (coerce-name module)))
12368 #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
12369 #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
12370 #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib)
12371 #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
12372 #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
12373 #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
12375 (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
12376 "Creates a prebuilt-system if PATHNAME isn't NIL."
12378 (make-instance 'prebuilt-system
12379 :name (coerce-name name)
12380 :static-library (resolve-symlinks* pathname))))
12382 (defun linkable-system (x)
12383 (or ;; If the system is available as source, use it.
12384 (if-let (s (find-system x))
12385 (and (output-files 'lib-op s) s))
12386 ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
12387 ;; then use the asdf/driver system instead of
12388 ;; the UIOP that was disabled by check-not-old-asdf-system.
12389 (if-let (s (and (equal (coerce-name x) "uiop")
12390 (output-files 'lib-op "asdf")
12391 (find-system "asdf/driver")))
12392 (and (output-files 'lib-op s) s))
12393 ;; If there was no source upgrade, look for modules provided by the implementation.
12394 (if-let (p (system-module-pathname (coerce-name x)))
12395 (make-prebuilt-system x p))))
12397 (defmethod component-depends-on :around ((o image-op) (c system))
12398 (let* ((next (call-next-method))
12399 (deps (make-hash-table :test 'equal))
12400 (linkable (loop :for (do . dcs) :in next :collect
12402 (loop :for dc :in dcs
12403 :for dep = (and dc (resolve-dependency-spec c dc))
12405 :do (setf (gethash (coerce-name (component-system dep)) deps) t)
12406 :collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
12408 ,@(unless (no-uiop c)
12409 (list (linkable-system "cmp")
12410 (unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
12411 (and (gethash "asdf" deps) (linkable-system "asdf")))
12412 (or (linkable-system "uiop")
12413 (linkable-system "asdf")
12417 (defmethod perform ((o link-op) (c system))
12418 (let* ((object-files (input-files o c))
12419 (output (output-files o c))
12420 (bundle (first output))
12421 (programp (typep o 'program-op))
12422 (kind (bundle-type o)))
12424 (apply 'create-image
12426 (when programp (prefix-lisp-object-files c))
12428 (when programp (postfix-lisp-object-files c)))
12430 :prologue-code (when programp (prologue-code c))
12431 :epilogue-code (when programp (epilogue-code c))
12432 :build-args (when programp (extra-build-args c))
12433 :extra-object-files (when programp (extra-object-files c))
12434 :no-uiop (no-uiop c)
12435 (when programp `(:entry-point ,(component-entry-point c))))))))
12436 ;;;; -------------------------------------------------------------------------
12437 ;;;; Concatenate-source
12439 (uiop/package:define-package :asdf/concatenate-source
12440 (:recycle :asdf/concatenate-source :asdf)
12441 (:use :uiop/common-lisp :uiop :asdf/upgrade
12442 :asdf/component :asdf/operation
12444 :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle)
12446 #:concatenate-source-op
12447 #:load-concatenated-source-op
12448 #:compile-concatenated-source-op
12449 #:load-compiled-concatenated-source-op
12450 #:monolithic-concatenate-source-op
12451 #:monolithic-load-concatenated-source-op
12452 #:monolithic-compile-concatenated-source-op
12453 #:monolithic-load-compiled-concatenated-source-op))
12454 (in-package :asdf/concatenate-source)
12457 ;;; Concatenate sources
12459 (with-upgradability ()
12460 ;; Base classes for both regular and monolithic concatenate-source operations
12461 (defclass basic-concatenate-source-op (bundle-op) ())
12462 (defmethod bundle-type ((o basic-concatenate-source-op)) "lisp")
12463 (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
12464 (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
12465 (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
12467 ;; Regular concatenate-source operations
12468 (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()
12469 (:documentation "Operation to concatenate all sources in a system into a single file"))
12470 (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
12471 ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
12472 (:documentation "Operation to load the result of concatenate-source-op as source"))
12473 (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
12474 ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))
12475 (:documentation "Operation to compile the result of concatenate-source-op"))
12476 (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
12477 ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))
12478 (:documentation "Operation to load the result of compile-concatenated-source-op"))
12480 (defclass monolithic-concatenate-source-op
12481 (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()
12482 (:documentation "Operation to concatenate all sources in a system and its dependencies
12483 into a single file"))
12484 (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
12485 ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
12486 (:documentation "Operation to load the result of monolithic-concatenate-source-op as source"))
12487 (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
12488 ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))
12489 (:documentation "Operation to compile the result of monolithic-concatenate-source-op"))
12490 (defclass monolithic-load-compiled-concatenated-source-op
12491 (basic-load-compiled-concatenated-source-op)
12492 ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))
12493 (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op"))
12495 (defmethod input-files ((operation basic-concatenate-source-op) (s system))
12496 (loop :with encoding = (or (component-encoding s) *default-encoding*)
12497 :with other-encodings = '()
12498 :with around-compile = (around-compile-hook s)
12499 :with other-around-compile = '()
12500 :for c :in (required-components ;; see note about similar call to required-components
12501 s :goal-operation 'load-op ;; in bundle.lisp
12502 :keep-operation 'basic-compile-op
12503 :other-systems (operation-monolithic-p operation))
12505 (when (typep c 'cl-source-file)
12506 (let ((e (component-encoding c)))
12507 (unless (or (equal e encoding)
12508 (and (equal e :ASCII) (equal encoding :UTF-8)))
12509 (let ((a (assoc e other-encodings)))
12510 (if a (push (component-find-path c) (cdr a))
12511 (push (list e (component-find-path c)) other-encodings)))))
12512 (unless (equal around-compile (around-compile-hook c))
12513 (push (component-find-path c) other-around-compile))
12514 (input-files (make-operation 'compile-op) c)) :into inputs
12516 (when other-encodings
12517 (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}"
12519 (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x)))))
12521 (when other-around-compile
12522 (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
12523 operation around-compile other-around-compile))
12525 (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
12526 (lisp-compilation-output-files o s))
12528 (defmethod perform ((o basic-concatenate-source-op) (s system))
12529 (let* ((ins (input-files o s))
12530 (out (output-file o s))
12531 (tmp (tmpize-pathname out)))
12532 (concatenate-files ins tmp)
12533 (rename-file-overwriting-target tmp out)))
12534 (defmethod perform ((o basic-load-concatenated-source-op) (s system))
12535 (perform-lisp-load-source o s))
12536 (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
12537 (perform-lisp-compilation o s))
12538 (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
12539 (perform-lisp-load-fasl o s)))
12541 ;;;; -------------------------------------------------------------------------
12542 ;;;; Package systems in the style of quick-build or faslpath
12544 (uiop:define-package :asdf/package-inferred-system
12545 (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
12546 (:use :uiop/common-lisp :uiop
12547 :asdf/upgrade :asdf/session
12548 :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action
12549 :asdf/parse-defsystem)
12551 #:package-inferred-system #:sysdef-package-inferred-system-search
12552 #:package-system ;; backward compatibility only. To be removed.
12553 #:register-system-packages
12554 #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
12555 (in-package :asdf/package-inferred-system)
12557 (with-upgradability ()
12558 ;; The names of the recognized defpackage forms.
12559 (defparameter *defpackage-forms* '(defpackage define-package))
12561 (defun initial-package-inferred-systems-table ()
12562 ;; Mark all existing packages are preloaded.
12563 (let ((h (make-hash-table :test 'equal)))
12564 (dolist (p (list-all-packages))
12565 (dolist (n (package-names p))
12566 (setf (gethash n h) t)))
12569 ;; Mapping from package names to systems that provide them.
12570 (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
12572 (defclass package-inferred-system (system)
12574 (:documentation "Class for primary systems for which secondary systems are automatically
12575 in the one-file, one-file, one-system style: system names are mapped to files under the primary
12576 system's system-source-directory, dependencies are inferred from the first defpackage form in
12579 ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release:
12580 (defclass package-system (package-inferred-system) ())
12582 ;; Is a given form recognizable as a defpackage form?
12583 (defun defpackage-form-p (form)
12585 (member (car form) *defpackage-forms*)))
12587 ;; Find the first defpackage form in a stream, if any
12588 (defun stream-defpackage-form (stream)
12589 (loop :for form = (read stream nil nil) :while form
12590 :when (defpackage-form-p form) :return form))
12592 (defun file-defpackage-form (file)
12593 "Return the first DEFPACKAGE form in FILE."
12594 (with-input-file (f file)
12595 (stream-defpackage-form f)))
12597 (define-condition package-inferred-system-missing-package-error (system-definition-error)
12598 ((system :initarg :system :reader error-system)
12599 (pathname :initarg :pathname :reader error-pathname))
12600 (:report (lambda (c s)
12601 (format s (compatfmt "~@<No package form found while ~
12602 trying to define package-inferred-system ~A from file ~A~>")
12603 (error-system c) (error-pathname c)))))
12605 (defun package-dependencies (defpackage-form)
12606 "Return a list of packages depended on by the package
12607 defined in DEFPACKAGE-FORM. A package is depended upon if
12608 the DEFPACKAGE-FORM uses it or imports a symbol from it."
12609 (assert (defpackage-form-p defpackage-form))
12611 (while-collecting (dep)
12612 (loop :for (option . arguments) :in (cddr defpackage-form) :do
12614 ((:use :mix :reexport :use-reexport :mix-reexport)
12615 (dolist (p arguments) (dep (string p))))
12616 ((:import-from :shadowing-import-from)
12617 (dep (string (first arguments))))
12618 #+package-local-nicknames
12619 ((:local-nicknames)
12620 (loop :for (nil actual-package-name) :in arguments :do
12621 (dep (string actual-package-name))))
12622 ((:nicknames :documentation :shadow :export :intern :unintern :recycle)))))
12623 :from-end t :test 'equal))
12625 (defun package-designator-name (package)
12626 "Normalize a package designator to a string"
12628 (package (package-name package))
12630 (symbol (string package))))
12632 (defun register-system-packages (system packages)
12633 "Register SYSTEM as providing PACKAGES."
12634 (let ((name (or (eq system t) (coerce-name system))))
12635 (dolist (p (ensure-list packages))
12636 (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
12638 (defun package-name-system (package-name)
12639 "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists,
12640 otherwise return a default system name computed from PACKAGE-NAME."
12641 (check-type package-name string)
12642 (or (gethash package-name *package-inferred-systems*)
12643 (string-downcase package-name)))
12645 ;; Given a file in package-inferred-system style, find its dependencies
12646 (defun package-inferred-system-file-dependencies (file &optional system)
12647 (if-let (defpackage-form (file-defpackage-form file))
12648 (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
12649 (error 'package-inferred-system-missing-package-error :system system :pathname file)))
12651 ;; Given package-inferred-system object, check whether its specification matches
12652 ;; the provided parameters
12653 (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies)
12654 (and (eq (type-of system) 'package-inferred-system)
12655 (equal (component-name system) name)
12656 (pathname-equal directory (component-pathname system))
12657 (equal dependencies (component-sideway-dependencies system))
12658 (equal around-compile (around-compile-hook system))
12659 (let ((children (component-children system)))
12660 (and (length=n-p children 1)
12661 (let ((child (first children)))
12662 (and (eq (type-of child) 'cl-source-file)
12663 (equal (component-name child) "lisp")
12664 (and (slot-boundp child 'relative-pathname)
12665 (equal (slot-value child 'relative-pathname) subpath))))))))
12667 ;; sysdef search function to push into *system-definition-search-functions*
12668 (defun sysdef-package-inferred-system-search (system-name)
12669 "Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to
12670 *SYSTEM-DEFINITION-SEARCH-FUNCTIONS*."
12671 (let ((primary (primary-system-name system-name)))
12672 ;; this function ONLY does something if the primary system name is NOT the same as
12673 ;; SYSTEM-NAME. It is used to find the systems with names that are relative to
12674 ;; the primary system's name, and that are not explicitly specified in the system
12676 (unless (equal primary system-name)
12677 (let ((top (find-system primary nil)))
12678 (when (typep top 'package-inferred-system)
12679 (if-let (dir (component-pathname top))
12680 (let* ((sub (subseq system-name (1+ (length primary))))
12681 (component-type (class-for-type top :file))
12682 (file-type (file-type (make-instance component-type)))
12683 (f (probe-file* (subpathname dir sub :type file-type)
12684 :truename *resolve-symlinks*)))
12685 (when (file-pathname-p f)
12686 (let ((dependencies (package-inferred-system-file-dependencies f system-name))
12687 (previous (registered-system system-name))
12688 (around-compile (around-compile-hook top)))
12689 (if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies)
12691 (eval `(defsystem ,system-name
12692 :class package-inferred-system
12693 :default-component-class ,component-type
12694 :source-file ,(system-source-file top)
12696 :depends-on ,dependencies
12697 :around-compile ,around-compile
12698 :components ((,component-type file-type :pathname ,sub)))))))))))))))
12700 (with-upgradability ()
12701 (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
12702 (setf *system-definition-search-functions*
12703 (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
12704 *system-definition-search-functions*)))
12705 ;;;; ---------------------------------------------------------------------------
12706 ;;;; asdf-output-translations
12708 (uiop/package:define-package :asdf/output-translations
12709 (:recycle :asdf/output-translations :asdf)
12710 (:use :uiop/common-lisp :uiop :asdf/upgrade)
12712 #:*output-translations* #:*output-translations-parameter*
12713 #:invalid-output-translation
12714 #:output-translations #:output-translations-initialized-p
12715 #:initialize-output-translations #:clear-output-translations
12716 #:disable-output-translations #:ensure-output-translations
12717 #:apply-output-translations
12718 #:validate-output-translations-directive #:validate-output-translations-form
12719 #:validate-output-translations-file #:validate-output-translations-directory
12720 #:parse-output-translations-string #:wrapping-output-translations
12721 #:user-output-translations-pathname #:system-output-translations-pathname
12722 #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
12723 #:environment-output-translations #:process-output-translations
12724 #:compute-output-translations
12725 #+abcl #:translate-jar-pathname
12727 (in-package :asdf/output-translations)
12729 ;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro
12730 ;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us.
12731 (when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations)))
12733 (with-upgradability ()
12734 (define-condition invalid-output-translation (invalid-configuration warning)
12735 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
12737 (defvar *output-translations* ()
12738 "Either NIL (for uninitialized), or a list of one element,
12739 said element itself being a sorted list of mappings.
12740 Each mapping is a pair of a source pathname and destination pathname,
12741 and the order is by decreasing length of namestring of the source pathname.")
12743 (defun output-translations ()
12744 "Return the configured output-translations, if any"
12745 (car *output-translations*))
12747 ;; Set the output-translations, by sorting the provided new-value.
12748 (defun set-output-translations (new-value)
12749 (setf *output-translations*
12751 (stable-sort (copy-list new-value) #'>
12757 (normalize-pathname-directory-component
12758 (pathname-directory (car x)))))
12759 (if (listp directory) (length directory) 0))))))))
12761 (defun (setf output-translations) (new-value) (set-output-translations new-value))
12763 (defun output-translations-initialized-p ()
12764 "Have the output-translations been initialized yet?"
12765 (and *output-translations* t))
12767 (defun clear-output-translations ()
12768 "Undoes any initialization of the output translations."
12769 (setf *output-translations* '())
12771 (register-clear-configuration-hook 'clear-output-translations)
12774 ;;; Validation of the configuration directives...
12776 (defun validate-output-translations-directive (directive)
12777 (or (member directive '(:enable-user-cache :disable-cache nil))
12778 (and (consp directive)
12779 (or (and (length=n-p directive 2)
12780 (or (and (eq (first directive) :include)
12781 (typep (second directive) '(or string pathname null)))
12782 (and (location-designator-p (first directive))
12783 (or (location-designator-p (second directive))
12784 (location-function-p (second directive))))))
12785 (and (length=n-p directive 1)
12786 (location-designator-p (first directive)))))))
12788 (defun validate-output-translations-form (form &key location)
12789 (validate-configuration-form
12791 :output-translations
12792 'validate-output-translations-directive
12793 :location location :invalid-form-reporter 'invalid-output-translation))
12795 (defun validate-output-translations-file (file)
12796 (validate-configuration-file
12797 file 'validate-output-translations-form :description "output translations"))
12799 (defun validate-output-translations-directory (directory)
12800 (validate-configuration-directory
12801 directory :output-translations 'validate-output-translations-directive
12802 :invalid-form-reporter 'invalid-output-translation))
12805 ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents
12806 (defun parse-output-translations-string (string &key location)
12808 ((or (null string) (equal string ""))
12809 '(:output-translations :inherit-configuration))
12810 ((not (stringp string))
12811 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
12812 ((eql (char string 0) #\")
12813 (parse-output-translations-string (read-from-string string) :location location))
12814 ((eql (char string 0) #\()
12815 (validate-output-translations-form (read-from-string string) :location location))
12818 :with inherit = nil
12819 :with directives = ()
12821 :with end = (length string)
12823 :with separator = (inter-directory-separator)
12824 :for i = (or (position separator string :start start) end) :do
12825 (let ((s (subseq string start i)))
12828 (push (list source (if (equal "" s) nil s)) directives)
12832 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
12835 (push :inherit-configuration directives))
12838 (setf start (1+ i))
12839 (when (> start end)
12841 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
12844 (push :ignore-inherited-configuration directives))
12845 (return `(:output-translations ,@(nreverse directives)))))))))
12848 ;; The default sources of configuration for output-translations
12849 (defparameter* *default-output-translations*
12850 '(environment-output-translations
12851 user-output-translations-pathname
12852 user-output-translations-directory-pathname
12853 system-output-translations-pathname
12854 system-output-translations-directory-pathname))
12856 ;; Compulsory implementation-dependent wrapping for the translations:
12857 ;; handle implementation-provided systems.
12858 (defun wrapping-output-translations ()
12859 `(:output-translations
12860 ;; Some implementations have precompiled ASDF systems,
12861 ;; so we must disable translations for implementation paths.
12862 #+(or clasp #|clozure|# ecl mkcl sbcl)
12863 ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
12864 (when h `(((,h ,*wild-path*) ()))))
12865 #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
12866 ;; All-import, here is where we want user stuff to be:
12867 :inherit-configuration
12868 ;; These are for convenience, and can be overridden by the user:
12869 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
12870 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
12871 ;; We enable the user cache by default, and here is the place we do:
12872 :enable-user-cache))
12874 ;; Relative pathnames of output-translations configuration to XDG configuration directory
12875 (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf"))
12876 (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/"))
12878 ;; Locating various configuration pathnames, depending on input or output intent.
12879 (defun user-output-translations-pathname (&key (direction :input))
12880 (xdg-config-pathname *output-translations-file* direction))
12881 (defun system-output-translations-pathname (&key (direction :input))
12882 (find-preferred-file (system-config-pathnames *output-translations-file*)
12883 :direction direction))
12884 (defun user-output-translations-directory-pathname (&key (direction :input))
12885 (xdg-config-pathname *output-translations-directory* direction))
12886 (defun system-output-translations-directory-pathname (&key (direction :input))
12887 (find-preferred-file (system-config-pathnames *output-translations-directory*)
12888 :direction direction))
12889 (defun environment-output-translations ()
12890 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
12893 ;;; Processing the configuration.
12895 (defgeneric process-output-translations (spec &key inherit collect))
12897 (defun inherit-output-translations (inherit &key collect)
12899 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
12901 (defun process-output-translations-directive (directive &key inherit collect)
12902 (if (atom directive)
12904 ((:enable-user-cache)
12905 (process-output-translations-directive '(t :user-cache) :collect collect))
12907 (process-output-translations-directive '(t t) :collect collect))
12908 ((:inherit-configuration)
12909 (inherit-output-translations inherit :collect collect))
12910 ((:ignore-inherited-configuration :ignore-invalid-entries nil)
12912 (let ((src (first directive))
12913 (dst (second directive)))
12914 (if (eq src :include)
12916 (process-output-translations (pathname dst) :inherit nil :collect collect))
12918 (let ((trusrc (or (eql src t)
12919 (let ((loc (resolve-location src :ensure-directory t :wilden t)))
12920 (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
12922 ((location-function-p dst)
12924 (list trusrc (ensure-function (second dst)))))
12925 ((typep dst 'boolean)
12926 (funcall collect (list trusrc t)))
12928 (let* ((trudst (resolve-location dst :ensure-directory t :wilden t)))
12929 (funcall collect (list trudst t))
12930 (funcall collect (list trusrc trudst)))))))))))
12932 (defmethod process-output-translations ((x symbol) &key
12933 (inherit *default-output-translations*)
12935 (process-output-translations (funcall x) :inherit inherit :collect collect))
12936 (defmethod process-output-translations ((pathname pathname) &key inherit collect)
12938 ((directory-pathname-p pathname)
12939 (process-output-translations (validate-output-translations-directory pathname)
12940 :inherit inherit :collect collect))
12941 ((probe-file* pathname :truename *resolve-symlinks*)
12942 (process-output-translations (validate-output-translations-file pathname)
12943 :inherit inherit :collect collect))
12945 (inherit-output-translations inherit :collect collect))))
12946 (defmethod process-output-translations ((string string) &key inherit collect)
12947 (process-output-translations (parse-output-translations-string string)
12948 :inherit inherit :collect collect))
12949 (defmethod process-output-translations ((x null) &key inherit collect)
12950 (inherit-output-translations inherit :collect collect))
12951 (defmethod process-output-translations ((form cons) &key inherit collect)
12952 (dolist (directive (cdr (validate-output-translations-form form)))
12953 (process-output-translations-directive directive :inherit inherit :collect collect)))
12956 ;;; Top-level entry-points to configure output-translations
12958 (defun compute-output-translations (&optional parameter)
12959 "read the configuration, return it"
12961 (while-collecting (c)
12962 (inherit-output-translations
12963 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
12964 :test 'equal :from-end t))
12966 ;; Saving the user-provided parameter to output-translations, if any,
12967 ;; so we can recompute the translations after code upgrade.
12968 (defvar *output-translations-parameter* nil)
12970 ;; Main entry-point for users.
12971 (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
12972 "read the configuration, initialize the internal configuration variable,
12973 return the configuration"
12974 (setf *output-translations-parameter* parameter
12975 (output-translations) (compute-output-translations parameter)))
12977 (defun disable-output-translations ()
12978 "Initialize output translations in a way that maps every file to itself,
12979 effectively disabling the output translation facility."
12980 (initialize-output-translations
12981 '(:output-translations :disable-cache :ignore-inherited-configuration)))
12983 ;; checks an initial variable to see whether the state is initialized
12984 ;; or cleared. In the former case, return current configuration; in
12985 ;; the latter, initialize. ASDF will call this function at the start
12986 ;; of (asdf:find-system).
12987 (defun ensure-output-translations ()
12988 (if (output-translations-initialized-p)
12989 (output-translations)
12990 (initialize-output-translations)))
12993 ;; Top-level entry-point to _use_ output-translations
12994 (defun apply-output-translations (path)
12998 ((or pathname string)
12999 (ensure-output-translations)
13000 (loop :with p = (resolve-symlinks* path)
13001 :for (source destination) :in (car *output-translations*)
13002 :for root = (when (or (eq source t)
13003 (and (pathnamep source)
13004 (not (absolute-pathname-p source))))
13006 :for absolute-source = (cond
13007 ((eq source t) (wilden root))
13008 (root (merge-pathnames* source root))
13010 :when (or (eq source t) (pathname-match-p p absolute-source))
13011 :return (translate-pathname* p absolute-source destination root source)
13012 :finally (return p)))))
13015 ;; Hook into uiop's output-translation mechanism
13017 (setf *output-translation-function* 'apply-output-translations)
13020 ;;; Implementation-dependent hacks
13021 #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar.
13022 (defun translate-jar-pathname (source wildcard)
13023 (declare (ignore wildcard))
13024 (flet ((normalize-device (pathname)
13025 (if (find :windows *features*)
13027 (make-pathname :defaults pathname :device :unspecific))))
13029 (pathname (first (pathname-device source))))
13030 (target-root-directory-namestring
13031 (format nil "/___jar___file___root___/~@[~A/~]"
13032 (and (find :windows *features*)
13033 (pathname-device jar))))
13035 (relativize-pathname-directory source))
13037 (relativize-pathname-directory (ensure-directory-pathname jar)))
13038 (target-root-directory
13040 (pathname-directory-pathname
13041 (parse-namestring target-root-directory-namestring))))
13043 (merge-pathnames* relative-jar target-root-directory))
13045 (merge-pathnames* relative-source target-root)))
13046 (normalize-device (apply-output-translations target))))))
13048 ;;;; -----------------------------------------------------------------
13049 ;;;; Source Registry Configuration, by Francois-Rene Rideau
13050 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
13052 (uiop/package:define-package :asdf/source-registry
13053 ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there
13054 (:recycle :asdf/source-registry :asdf/find-system :asdf)
13055 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry)
13057 #:*source-registry-parameter* #:*default-source-registries*
13058 #:invalid-source-registry
13059 #:source-registry-initialized-p
13060 #:initialize-source-registry #:clear-source-registry #:*source-registry*
13061 #:ensure-source-registry #:*source-registry-parameter*
13062 #:*default-source-registry-exclusions* #:*source-registry-exclusions*
13063 #:*wild-asd* #:directory-asd-files #:register-asd-directory
13064 #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files
13065 #:validate-source-registry-directive #:validate-source-registry-form
13066 #:validate-source-registry-file #:validate-source-registry-directory
13067 #:parse-source-registry-string #:wrapping-source-registry
13068 #:default-user-source-registry #:default-system-source-registry
13069 #:user-source-registry #:system-source-registry
13070 #:user-source-registry-directory #:system-source-registry-directory
13071 #:environment-source-registry #:process-source-registry #:inherit-source-registry
13072 #:compute-source-registry #:flatten-source-registry
13073 #:sysdef-source-registry-search))
13074 (in-package :asdf/source-registry)
13076 (with-upgradability ()
13077 (define-condition invalid-source-registry (invalid-configuration warning)
13078 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
13080 ;; Default list of directories under which the source-registry tree search won't recurse
13081 (defvar *default-source-registry-exclusions*
13082 '(;;-- Using ack 1.2 exclusions
13084 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
13085 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
13086 "_sgbak" "autom4te.cache" "cover_db" "_build"
13087 ;;-- debian often builds stuff under the debian directory... BAD.
13090 ;; Actual list of directories under which the source-registry tree search won't recurse
13091 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
13093 ;; The state of the source-registry after search in configured locations
13094 (defvar *source-registry* nil
13095 "Either NIL (for uninitialized), or an equal hash-table, mapping
13096 system names to pathnames of .asd files")
13098 ;; Saving the user-provided parameter to the source-registry, if any,
13099 ;; so we can recompute the source-registry after code upgrade.
13100 (defvar *source-registry-parameter* nil)
13102 (defun source-registry-initialized-p ()
13103 (typep *source-registry* 'hash-table))
13105 (defun clear-source-registry ()
13106 "Undoes any initialization of the source registry."
13107 (setf *source-registry* nil)
13109 (register-clear-configuration-hook 'clear-source-registry)
13111 (defparameter *wild-asd*
13112 (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
13114 (defun directory-asd-files (directory)
13115 (directory-files directory *wild-asd*))
13117 (defun collect-asds-in-directory (directory collect)
13118 (let ((asds (directory-asd-files directory)))
13119 (map () collect asds)
13122 (defvar *recurse-beyond-asds* t
13123 "Should :tree entries of the source-registry recurse in subdirectories
13124 after having found a .asd file? True by default.")
13126 ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache,
13127 ;; read its contents instead of further recursively querying the filesystem.
13128 (defun process-source-registry-cache (directory collect)
13129 (let ((cache (ignore-errors
13130 (safe-read-file-form (subpathname directory ".cl-source-registry.cache")))))
13131 (when (and (listp cache) (eq :source-registry-cache (first cache)))
13132 (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s)))
13135 (defun collect-sub*directories-asd-files
13136 (directory &key (exclude *default-source-registry-exclusions*) collect
13137 (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache)
13138 (let ((visited (make-hash-table :test 'equalp)))
13139 (flet ((collectp (dir)
13140 (unless (and (not ignore-cache) (process-source-registry-cache dir collect))
13141 (let ((asds (collect-asds-in-directory dir collect)))
13142 (or recurse-beyond-asds (not asds)))))
13143 (recursep (x) ; x will be a directory pathname
13145 (not (member (car (last (pathname-directory x))) exclude :test #'equal))
13146 (flet ((pathname-key (x)
13147 (namestring (truename* x))))
13148 (let ((visitedp (gethash (pathname-key x) visited)))
13150 (setf (gethash (pathname-key x) visited) t)))))))
13151 (collect-sub*directories directory #'collectp #'recursep (constantly nil)))))
13154 ;;; Validate the configuration forms
13156 (defun validate-source-registry-directive (directive)
13157 (or (member directive '(:default-registry))
13158 (and (consp directive)
13159 (let ((rest (rest directive)))
13160 (case (first directive)
13161 ((:include :directory :tree)
13162 (and (length=n-p rest 1)
13163 (location-designator-p (first rest))))
13164 ((:exclude :also-exclude)
13165 (every #'stringp rest))
13166 ((:default-registry)
13169 (defun validate-source-registry-form (form &key location)
13170 (validate-configuration-form
13171 form :source-registry 'validate-source-registry-directive
13172 :location location :invalid-form-reporter 'invalid-source-registry))
13174 (defun validate-source-registry-file (file)
13175 (validate-configuration-file
13176 file 'validate-source-registry-form :description "a source registry"))
13178 (defun validate-source-registry-directory (directory)
13179 (validate-configuration-directory
13180 directory :source-registry 'validate-source-registry-directive
13181 :invalid-form-reporter 'invalid-source-registry))
13184 ;;; Parse the configuration string
13186 (defun parse-source-registry-string (string &key location)
13188 ((or (null string) (equal string ""))
13189 '(:source-registry :inherit-configuration))
13190 ((not (stringp string))
13191 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
13192 ((find (char string 0) "\"(")
13193 (validate-source-registry-form (read-from-string string) :location location))
13196 :with inherit = nil
13197 :with directives = ()
13199 :with end = (length string)
13200 :with separator = (inter-directory-separator)
13201 :for pos = (position separator string :start start) :do
13202 (let ((s (subseq string start (or pos end))))
13203 (flet ((check (dir)
13204 (unless (absolute-pathname-p dir)
13205 (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
13208 ((equal "" s) ; empty element: inherit
13210 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
13213 (push ':inherit-configuration directives))
13214 ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
13215 (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
13217 (push `(:directory ,(check s)) directives))))
13220 (setf start (1+ pos)))
13223 (push '(:ignore-inherited-configuration) directives))
13224 (return `(:source-registry ,@(nreverse directives))))))))))
13226 (defun register-asd-directory (directory &key recurse exclude collect)
13228 (collect-asds-in-directory directory collect)
13229 (collect-sub*directories-asd-files
13230 directory :exclude exclude :collect collect)))
13232 (defparameter* *default-source-registries*
13233 '(environment-source-registry
13234 user-source-registry
13235 user-source-registry-directory
13236 default-user-source-registry
13237 system-source-registry
13238 system-source-registry-directory
13239 default-system-source-registry)
13240 "List of default source registries" "3.1.0.102")
13242 (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf"))
13243 (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/"))
13245 (defun wrapping-source-registry ()
13247 #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
13248 :inherit-configuration
13249 #+mkcl (:tree ,(translate-logical-pathname "SYS:"))
13250 #+cmucl (:tree #p"modules:")
13251 #+scl (:tree #p"file://modules/")))
13252 (defun default-user-source-registry ()
13254 (:tree (:home "common-lisp/"))
13255 #+sbcl (:directory (:home ".sbcl/systems/"))
13256 (:directory ,(xdg-data-home "common-lisp/systems/"))
13257 (:tree ,(xdg-data-home "common-lisp/source/"))
13258 :inherit-configuration))
13259 (defun default-system-source-registry ()
13261 ,@(loop :for dir :in (xdg-data-dirs "common-lisp/")
13262 :collect `(:directory (,dir "systems/"))
13263 :collect `(:tree (,dir "source/")))
13264 :inherit-configuration))
13265 (defun user-source-registry (&key (direction :input))
13266 (xdg-config-pathname *source-registry-file* direction))
13267 (defun system-source-registry (&key (direction :input))
13268 (find-preferred-file (system-config-pathnames *source-registry-file*)
13269 :direction direction))
13270 (defun user-source-registry-directory (&key (direction :input))
13271 (xdg-config-pathname *source-registry-directory* direction))
13272 (defun system-source-registry-directory (&key (direction :input))
13273 (find-preferred-file (system-config-pathnames *source-registry-directory*)
13274 :direction direction))
13275 (defun environment-source-registry ()
13276 (getenv "CL_SOURCE_REGISTRY"))
13279 ;;; Process the source-registry configuration
13281 (defgeneric process-source-registry (spec &key inherit register))
13283 (defun inherit-source-registry (inherit &key register)
13285 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
13287 (defun process-source-registry-directive (directive &key inherit register)
13288 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
13291 (destructuring-bind (pathname) rest
13292 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
13294 (destructuring-bind (pathname) rest
13296 (funcall register (resolve-location pathname :ensure-directory t)))))
13298 (destructuring-bind (pathname) rest
13300 (funcall register (resolve-location pathname :ensure-directory t)
13301 :recurse t :exclude *source-registry-exclusions*))))
13303 (setf *source-registry-exclusions* rest))
13305 (appendf *source-registry-exclusions* rest))
13306 ((:default-registry)
13307 (inherit-source-registry
13308 '(default-user-source-registry default-system-source-registry) :register register))
13309 ((:inherit-configuration)
13310 (inherit-source-registry inherit :register register))
13311 ((:ignore-inherited-configuration)
13315 (defmethod process-source-registry ((x symbol) &key inherit register)
13316 (process-source-registry (funcall x) :inherit inherit :register register))
13317 (defmethod process-source-registry ((pathname pathname) &key inherit register)
13319 ((directory-pathname-p pathname)
13320 (let ((*here-directory* (resolve-symlinks* pathname)))
13321 (process-source-registry (validate-source-registry-directory pathname)
13322 :inherit inherit :register register)))
13323 ((probe-file* pathname :truename *resolve-symlinks*)
13324 (let ((*here-directory* (pathname-directory-pathname pathname)))
13325 (process-source-registry (validate-source-registry-file pathname)
13326 :inherit inherit :register register)))
13328 (inherit-source-registry inherit :register register))))
13329 (defmethod process-source-registry ((string string) &key inherit register)
13330 (process-source-registry (parse-source-registry-string string)
13331 :inherit inherit :register register))
13332 (defmethod process-source-registry ((x null) &key inherit register)
13333 (inherit-source-registry inherit :register register))
13334 (defmethod process-source-registry ((form cons) &key inherit register)
13335 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
13336 (dolist (directive (cdr (validate-source-registry-form form)))
13337 (process-source-registry-directive directive :inherit inherit :register register))))
13340 ;; Flatten the user-provided configuration into an ordered list of directories and trees
13341 (defun flatten-source-registry (&optional (parameter *source-registry-parameter*))
13343 (while-collecting (collect)
13344 (with-pathname-defaults () ;; be location-independent
13345 (inherit-source-registry
13346 `(wrapping-source-registry
13348 ,@*default-source-registries*)
13349 :register #'(lambda (directory &key recurse exclude)
13350 (collect (list directory :recurse recurse :exclude exclude))))))
13351 :test 'equal :from-end t))
13353 ;; MAYBE: move this utility function to uiop/pathname and export it?
13354 (defun pathname-directory-depth (p)
13355 (length (normalize-pathname-directory-component (pathname-directory p))))
13357 (defun preferred-source-path-p (x y)
13358 "Return T iff X is to be preferred over Y as a source path"
13359 (let ((lx (pathname-directory-depth x))
13360 (ly (pathname-directory-depth y)))
13363 (string< (namestring x)
13364 (namestring y))))))
13366 ;; Will read the configuration and initialize all internal variables.
13367 (defun compute-source-registry (&optional (parameter *source-registry-parameter*)
13368 (registry *source-registry*))
13369 (dolist (entry (flatten-source-registry parameter))
13370 (destructuring-bind (directory &key recurse exclude) entry
13371 (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
13372 (register-asd-directory
13373 directory :recurse recurse :exclude exclude :collect
13375 (let* ((name (pathname-name asd))
13376 (name (if (typep asd 'logical-pathname)
13377 ;; logical pathnames are upper-case,
13378 ;; at least in the CLHS and on SBCL,
13379 ;; yet (coerce-name :foo) is lower-case.
13380 ;; won't work well with (load-system "Foo")
13381 ;; instead of (load-system 'foo)
13382 (string-downcase name)
13384 (unless (gethash name registry) ; already shadowed by something else
13385 (if-let (old (gethash name h))
13386 ;; If the name appears multiple times,
13387 ;; prefer the one with the shallowest directory,
13388 ;; or if they have same depth, compare unix-namestring with string<
13389 (multiple-value-bind (better worse)
13390 (if (preferred-source-path-p asd old)
13391 (progn (setf (gethash name h) asd) (values asd old))
13393 (when *verbose-out*
13394 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
13395 found several entries for ~A - picking ~S over ~S~:>")
13396 directory recurse name better worse)))
13397 (setf (gethash name h) asd))))))
13398 (maphash #'(lambda (k v) (setf (gethash k registry) v)) h))))
13401 (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
13402 ;; Record the parameter used to configure the registry
13403 (setf *source-registry-parameter* parameter)
13404 ;; Clear the previous registry database:
13405 (setf *source-registry* (make-hash-table :test 'equal))
13407 (compute-source-registry parameter))
13409 ;; Checks an initial variable to see whether the state is initialized
13410 ;; or cleared. In the former case, return current configuration; in
13411 ;; the latter, initialize. ASDF will call this function at the start
13412 ;; of (asdf:find-system) to make sure the source registry is initialized.
13413 ;; However, it will do so *without* a parameter, at which point it
13414 ;; will be too late to provide a parameter to this function, though
13415 ;; you may override the configuration explicitly by calling
13416 ;; initialize-source-registry directly with your parameter.
13417 (defun ensure-source-registry (&optional parameter)
13418 (unless (source-registry-initialized-p)
13419 (initialize-source-registry parameter))
13422 (defun sysdef-source-registry-search (system)
13423 (ensure-source-registry)
13424 (values (gethash (primary-system-name system) *source-registry*))))
13427 ;;;; -------------------------------------------------------------------------
13428 ;;; Internal hacks for backward-compatibility
13430 (uiop/package:define-package :asdf/backward-internals
13431 (:recycle :asdf/backward-internals :asdf)
13432 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system)
13433 (:export #:load-sysdef))
13434 (in-package :asdf/backward-internals)
13436 (with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
13437 (defun load-sysdef (name pathname)
13438 (declare (ignore name pathname))
13439 ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older.
13440 (error "Use asdf:load-asd instead of asdf::load-sysdef")))
13441 ;;;; -------------------------------------------------------------------------
13442 ;;; Backward-compatible interfaces
13444 (uiop/package:define-package :asdf/backward-interface
13445 (:recycle :asdf/backward-interface :asdf)
13446 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
13447 :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action
13448 :asdf/lisp-action :asdf/plan :asdf/operate
13449 :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle)
13452 #:operation-error #:compile-error #:compile-failed #:compile-warned
13453 #:error-component #:error-operation #:traverse
13454 #:component-load-dependencies
13455 #:enable-asdf-binary-locations-compatibility
13456 #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
13457 #:component-property
13458 #:run-shell-command
13459 #:system-definition-pathname #:system-registered-p #:require-system
13461 #+ecl #:make-build))
13462 (in-package :asdf/backward-interface)
13464 ;; NB: the warning status of these functions may have to be distinguished later,
13465 ;; as some get removed faster than the others in client code.
13466 (with-asdf-deprecation (:style-warning "3.2" :warning "3.4")
13468 ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp;
13469 ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition
13470 ;; that do not involve ASDF actions.
13471 ;; TODO: find the offenders and stop them.
13473 (define-condition operation-error (error) ;; Bad, backward-compatible name
13474 ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
13475 ((component :reader error-component :initarg :component)
13476 (operation :reader error-operation :initarg :operation))
13477 (:report (lambda (c s)
13478 (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
13479 (type-of c) (error-operation c) (error-component c)))))
13480 (define-condition compile-error (operation-error) ())
13481 (define-condition compile-failed (compile-error) ())
13482 (define-condition compile-warned (compile-error) ()))
13484 ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi
13485 (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26
13486 "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better,
13487 define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION,
13488 or define methods on PREPARE-OP, etc."
13489 ;; Old deprecated name for the same thing. Please update your software.
13490 (component-sideway-dependencies component))
13492 ;; These old interfaces from ASDF1 have never been very meaningful
13493 ;; but are still used in obscure places.
13494 ;; In Quicklisp 2015-05, still used by cl-protobufs and clx.
13495 (defgeneric operation-on-warnings (operation)
13496 (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
13497 (defgeneric operation-on-failure (operation)
13498 (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
13499 (defgeneric (setf operation-on-warnings) (x operation)
13500 (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead."))
13501 (defgeneric (setf operation-on-failure) (x operation)
13502 (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead."))
13504 (defmethod operation-on-warnings ((o operation))
13505 *compile-file-warnings-behaviour*)
13506 (defmethod operation-on-failure ((o operation))
13507 *compile-file-failure-behaviour*)
13508 (defmethod (setf operation-on-warnings) (x (o operation))
13509 (setf *compile-file-warnings-behaviour* x))
13510 (defmethod (setf operation-on-failure) (x (o operation))
13511 (setf *compile-file-failure-behaviour* x)))
13513 ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat,
13514 ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject,
13515 ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel,
13516 ;; cl-glfw, cffi, jwacs, montezuma
13517 (defun system-definition-pathname (x)
13518 ;; As of 2.014.8, we mean to make this function obsolete,
13519 ;; but that won't happen until all clients have been updated.
13520 "DEPRECATED. This function used to expose ASDF internals with subtle
13521 differences with respect to user expectations, that have been refactored
13522 away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a
13523 mostly compatible replacement that we're supporting, or even
13524 ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
13525 if that's whay you mean." ;;)
13526 (system-source-file x))
13528 ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2.
13529 ;; It was never officially exposed but some people still used it.
13530 (defgeneric traverse (operation component &key &allow-other-keys)
13532 "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS,
13533 or some other supported interface instead.
13535 Generate and return a plan for performing OPERATION on COMPONENT.
13537 The plan returned is a list of dotted-pairs. Each pair is the CONS
13538 of ASDF operation object and a COMPONENT object. The pairs will be
13539 processed in order by OPERATE."))
13541 (define-convenience-action-methods traverse (operation component &key)))
13542 (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
13543 (plan-actions (apply 'make-plan plan-class o c keys)))
13546 ;; ASDF-Binary-Locations compatibility
13547 ;; This remains supported for legacy user, but not recommended for new users.
13548 ;; We suspect there are no more legacy users in 2016.
13549 (defun enable-asdf-binary-locations-compatibility
13551 (centralize-lisp-binaries nil)
13552 (default-toplevel-directory
13553 ;; Use ".cache/common-lisp/" instead ???
13554 (subpathname (user-homedir-pathname) ".fasls/"))
13555 (include-per-user-information nil)
13556 (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil))
13557 (source-to-target-mappings nil)
13558 (file-types `(,(compile-file-type)
13560 #+clasp (compile-file-type :output-type :object)
13561 #+ecl (compile-file-type :type :object)
13562 #+mkcl (compile-file-type :fasl-p nil)
13563 #+clisp "lib" #+sbcl "cfasl"
13564 #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
13565 "DEPRECATED. Use asdf-output-translations instead."
13566 #+(or clasp clisp ecl mkcl)
13567 (when (null map-all-source-files)
13568 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
13569 (let* ((patterns (if map-all-source-files (list *wild-file*)
13570 (loop :for type :in file-types
13571 :collect (make-pathname :type type :defaults *wild-file*))))
13572 (destination-directory
13573 (if centralize-lisp-binaries
13574 `(,default-toplevel-directory
13575 ,@(when include-per-user-information
13576 (cdr (pathname-directory (user-homedir-pathname))))
13577 :implementation ,*wild-inferiors*)
13578 `(:root ,*wild-inferiors* :implementation))))
13579 (initialize-output-translations
13580 `(:output-translations
13581 ,@source-to-target-mappings
13582 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
13583 #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
13584 ,@(loop :for pattern :in patterns
13585 :collect `((:root ,*wild-inferiors* ,pattern)
13586 (,@destination-directory ,pattern)))
13588 :ignore-inherited-configuration))))
13590 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
13591 (declare (ignore operation-class system args))
13592 (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
13593 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
13594 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
13595 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
13596 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
13597 In case you insist on preserving your previous A-B-L configuration, but
13598 do not know how to achieve the same effect with A-O-T, you may use function
13599 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
13600 call that function where you would otherwise have loaded and configured A-B-L."))))
13603 ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die!
13604 (defun run-shell-command (control-string &rest args)
13605 "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional.
13606 Please use UIOP:RUN-PROGRAM instead."
13607 #-(and ecl os-windows)
13608 (let ((command (apply 'format nil control-string args)))
13609 (asdf-message "; $ ~A~%" command)
13612 (nth-value 2 (run-program command :force-shell t :ignore-error-status t
13613 :output *verbose-out*)))))
13614 (typecase exit-code
13615 ((integer 0 255) exit-code)
13617 #+(and ecl os-windows)
13618 (not-implemented-error "run-shell-command" "for ECL on Windows."))
13620 ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning?
13621 ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version.
13623 (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
13625 ;; Do NOT use in new code. NOT SUPPORTED.
13626 ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT.
13627 ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy.
13628 ;; See TODO for further cleanups required before to get rid of it.
13629 (defgeneric component-property (component property))
13630 (defgeneric (setf component-property) (new-value component property))
13632 (defmethod component-property ((c component) property)
13633 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
13635 (defmethod (setf component-property) (new-value (c component) property)
13636 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
13638 (setf (cdr a) new-value)
13639 (setf (slot-value c 'properties)
13640 (acons property new-value (slot-value c 'properties)))))
13644 ;; This method survives from ASDF 1, but really it is superseded by action-description.
13645 (defgeneric explain (operation component)
13646 (:documentation "Display a message describing an action.
13648 DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead."))
13650 (define-convenience-action-methods explain (operation component)))
13651 (defmethod explain ((o operation) (c component))
13652 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c))))
13654 (with-asdf-deprecation (:style-warning "3.3")
13655 (defun system-registered-p (name)
13656 "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already.
13657 NAME is a system designator, to be normalized by COERCE-NAME.
13658 The value returned if true is a pair of a timestamp and a system object."
13659 (if-let (system (registered-system name))
13660 (cons (if-let (primary-system (registered-system (primary-system-name name)))
13661 (component-operation-time 'define-op primary-system))
13664 (defun require-system (system &rest keys &key &allow-other-keys)
13665 "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
13666 system or its dependencies if it has already been loaded."
13667 (declare (ignore keys))
13668 (unless (component-loaded-p system)
13669 (load-system system))))
13671 ;;; This function is for backward compatibility with ECL only.
13673 (with-asdf-deprecation (:style-warning "3.2" :warning "9999")
13674 (defun make-build (system &rest args
13675 &key (monolithic nil) (type :fasl) (move-here nil move-here-p)
13676 prologue-code epilogue-code no-uiop
13677 prefix-lisp-object-files postfix-lisp-object-files extra-object-files
13679 (let* ((operation (asdf/bundle::select-bundle-operation type monolithic))
13680 (move-here-path (if (and move-here
13681 (typep move-here '(or pathname string)))
13682 (ensure-pathname move-here :namestring :lisp :ensure-directory t)
13683 (system-relative-pathname system "asdf-output/")))
13684 (extra-build-args (remove-plist-keys
13685 '(:monolithic :type :move-here
13686 :prologue-code :epilogue-code :no-uiop
13687 :prefix-lisp-object-files :postfix-lisp-object-files
13688 :extra-object-files)
13690 (build-system (if (subtypep operation 'image-op)
13691 (eval `(defsystem "asdf.make-build"
13692 :class program-system
13694 :pathname ,(system-source-directory system)
13695 :build-operation ,operation
13696 :build-pathname ,(subpathname move-here-path
13697 (file-namestring (first (output-files operation system))))
13698 :depends-on (,(coerce-name system))
13699 :prologue-code ,prologue-code
13700 :epilogue-code ,epilogue-code
13702 :prefix-lisp-object-files ,prefix-lisp-object-files
13703 :postfix-lisp-object-files ,postfix-lisp-object-files
13704 :extra-object-files ,extra-object-files
13705 :extra-build-args ,extra-build-args))
13707 (files (output-files operation build-system)))
13708 (operate operation build-system)
13710 (and (null move-here-p) (member operation '(program-op image-op))))
13711 (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
13713 :for new-f = (make-pathname :name (pathname-name f)
13714 :type (pathname-type f)
13715 :defaults dest-path)
13716 :do (rename-file-overwriting-target f new-f)
13719 ;;;; ---------------------------------------------------------------------------
13720 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
13722 (uiop/package:define-package :asdf/interface
13723 (:nicknames :asdf :asdf-utilities)
13724 (:recycle :asdf/interface :asdf)
13726 #:loaded-systems ; makes for annoying SLIME completion
13727 #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL
13728 (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
13729 :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
13730 :asdf/operation :asdf/action :asdf/lisp-action
13731 :asdf/output-translations :asdf/source-registry
13732 :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem
13733 :asdf/bundle :asdf/concatenate-source
13734 :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
13735 ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
13736 ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
13738 #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name
13739 #:primary-system-name #:primary-system-p
13740 #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
13741 #:system-definition-pathname
13742 #:search-for-system-definition #:find-component #:component-find-path
13743 #:compile-system #:load-system #:load-systems #:load-systems*
13744 #:require-system #:test-system #:clear-system
13745 #:operation #:make-operation #:find-operation
13746 #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
13747 #:non-propagating-operation
13749 #:load-op #:prepare-op #:compile-op
13750 #:prepare-source-op #:load-source-op #:test-op #:define-op
13751 #:feature #:version #:version-satisfies #:upgrade-asdf
13752 #:implementation-identifier #:implementation-type #:hostname
13753 #:component-depends-on ; backward-compatible name rather than action-depends-on
13754 #:input-files #:additional-input-files
13755 #:output-files #:output-file #:perform #:perform-with-restarts
13756 #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
13757 #:needed-in-image-p
13758 #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
13760 #:basic-compile-bundle-op #:prepare-bundle-op
13761 #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
13762 #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op
13763 #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op
13764 #:concatenate-source-op
13765 #:load-concatenated-source-op
13766 #:compile-concatenated-source-op
13767 #:load-compiled-concatenated-source-op
13768 #:monolithic-concatenate-source-op
13769 #:monolithic-load-concatenated-source-op
13770 #:monolithic-compile-concatenated-source-op
13771 #:monolithic-load-compiled-concatenated-source-op
13772 #:operation-monolithic-p
13773 #:required-components
13774 #:component-loaded-p
13775 #:component #:parent-component #:child-component #:system #:module
13776 #:file-component #:source-file #:c-source-file #:java-source-file
13777 #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
13778 #:static-file #:doc-file #:html-file
13779 #:file-type #:source-file-type
13780 #:register-preloaded-system #:sysdef-preloaded-system-search
13781 #:register-immutable-system #:sysdef-immutable-system-search
13782 #:package-inferred-system #:register-system-packages
13783 #:component-children
13784 #:component-children-by-name
13785 #:component-pathname
13786 #:component-relative-pathname
13788 #:component-version
13791 #:component-encoding
13792 #:component-external-format
13793 #:system-description
13794 #:system-long-description
13796 #:system-maintainer
13800 #:system-source-file
13801 #:system-source-directory
13802 #:system-relative-pathname
13805 #:system-bug-tracker
13807 #:system-source-control
13809 #:system-defsystem-depends-on
13810 #:system-depends-on
13811 #:system-weakly-depends-on
13812 #:*system-definition-search-functions* ; variables
13813 #:*central-registry*
13814 #:*compile-file-warnings-behaviour*
13815 #:*compile-file-failure-behaviour*
13816 #:*resolve-symlinks*
13819 #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
13820 #:compile-warned-warning #:compile-failed-warning
13823 #:load-system-definition-error
13824 #:error-component #:error-operation
13825 #:system-definition-error
13826 #:missing-component
13827 #:missing-component-of-version
13828 #:missing-dependency
13829 #:missing-dependency-of-version
13830 #:circular-dependency ; errors
13831 #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date
13832 #:package-inferred-system-missing-package-error
13833 #:operation-definition-warning #:operation-definition-error
13834 #:try-recompiling ; restarts
13837 #:coerce-entry-to-directory
13838 #:remove-entry-from-registry
13839 #:clear-configuration-and-retry
13840 #:*encoding-detection-hook*
13841 #:*encoding-external-format-hook*
13842 #:*default-encoding*
13843 #:*utf-8-external-format*
13844 #:clear-configuration
13845 #:*output-translations-parameter*
13846 #:initialize-output-translations
13847 #:disable-output-translations
13848 #:clear-output-translations
13849 #:ensure-output-translations
13850 #:apply-output-translations
13852 #:compile-file-pathname*
13853 #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
13854 #:enable-asdf-binary-locations-compatibility
13855 #:*default-source-registries*
13856 #:*source-registry-parameter*
13857 #:initialize-source-registry
13858 #:compute-source-registry
13859 #:clear-source-registry
13860 #:ensure-source-registry
13861 #:process-source-registry
13862 #:registered-system #:registered-systems #:already-loaded-systems
13866 #:user-output-translations-pathname
13867 #:system-output-translations-pathname
13868 #:user-output-translations-directory-pathname
13869 #:system-output-translations-directory-pathname
13870 #:user-source-registry
13871 #:system-source-registry
13872 #:user-source-registry-directory
13873 #:system-source-registry-directory
13875 ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release.
13876 #:*asdf-verbose* #:run-shell-command
13877 #:component-load-dependencies #:system-registered-p #:package-system
13879 #:operation-on-warnings #:operation-on-failure #:operation-error
13880 #:compile-failed #:compile-warned #:compile-error
13881 #:module-components #:component-property #:traverse))
13882 ;;;; ---------------------------------------------------------------------------
13883 ;;;; ASDF-USER, where the action happens.
13885 (uiop/package:define-package :asdf/user
13886 (:nicknames :asdf-user)
13887 ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
13888 ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
13889 ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.
13890 ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package
13891 ;; that only :use's :cl and :asdf
13892 (:use :uiop/common-lisp :uiop :asdf/interface))
13893 ;;;; -----------------------------------------------------------------------
13894 ;;;; ASDF Footer: last words and cleanup
13896 (uiop/package:define-package :asdf/footer
13897 (:recycle :asdf/footer :asdf)
13898 (:use :uiop/common-lisp :uiop
13899 :asdf/system ;; used by ECL
13900 :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle)
13901 ;; Happily, all those implementations all have the same module-provider hook interface.
13902 #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl)
13903 (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int
13904 #:*module-provider-functions*
13905 #+ecl #:*load-hooks*)
13906 #+(or clasp mkcl) (:import-from :si #:*load-hooks*))
13908 (in-package :asdf/footer)
13910 ;;;; Register ASDF itself and all its subsystems as preloaded.
13911 (with-upgradability ()
13912 (dolist (s '("asdf" "asdf-package-system"))
13913 ;; Don't bother with these system names, no one relies on them anymore:
13914 ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem"
13915 (register-preloaded-system s :version *asdf-version*))
13916 (register-preloaded-system "uiop" :version *uiop-version*))
13918 ;;;; Ensure that the version slot on the registered preloaded systems are
13919 ;;;; correct, by CLEARing the system. However, we do not CLEAR-SYSTEM
13920 ;;;; unconditionally. This is because it's possible the user has upgraded the
13921 ;;;; systems using ASDF itself, meaning that the registered systems have real
13922 ;;;; data from the file system that we want to preserve instead of blasting
13923 ;;;; away and replacing with a blank preloaded system.
13924 (with-upgradability ()
13925 (unless (equal (system-version (registered-system "asdf")) (asdf-version))
13926 (clear-system "asdf"))
13927 ;; 3.1.2 is the last version where asdf-package-system was a separate system.
13928 (when (version< "3.1.2" (system-version (registered-system "asdf-package-system")))
13929 (clear-system "asdf-package-system"))
13930 (unless (equal (system-version (registered-system "uiop")) *uiop-version*)
13931 (clear-system "uiop")))
13933 ;;;; Hook ASDF into the implementation's REQUIRE and other entry points.
13934 #+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl)
13935 (with-upgradability ()
13936 ;; Hook into CL:REQUIRE.
13937 #-clisp (pushnew 'module-provide-asdf *module-provider-functions*)
13938 #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil))
13939 (eval `(pushnew 'module-provide-asdf ,x)))
13941 #+(or clasp ecl mkcl)
13943 (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car)
13946 (unless (assoc "asd" *load-hooks* :test 'equal)
13947 (appendf *load-hooks* '(("asd" . si::load-source))))
13949 ;; Wrap module provider functions in an idempotent, upgrade friendly way
13950 (defvar *wrapped-module-provider* (make-hash-table))
13951 (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf)
13952 (defun wrap-module-provider (provider name)
13953 (let ((results (multiple-value-list (funcall provider name))))
13954 (when (first results) (register-preloaded-system (coerce-name name)))
13955 (values-list results)))
13956 (defun wrap-module-provider-function (provider)
13957 (ensure-gethash provider *wrapped-module-provider*
13959 #'(lambda (module-name)
13960 (wrap-module-provider provider module-name)))))
13961 (setf *module-provider-functions*
13962 (mapcar #'wrap-module-provider-function *module-provider-functions*))))
13964 #+cmucl ;; Hook into the CMUCL herald.
13965 (with-upgradability ()
13966 (defun herald-asdf (stream)
13967 (format stream " ASDF ~A" (asdf-version)))
13968 (setf (getf ext:*herald-items* :asdf) '(herald-asdf)))
13972 (with-upgradability ()
13973 #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp
13974 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
13975 (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*))
13977 ;; Advertise the features we provide.
13978 (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*))
13980 ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users.
13981 (provide "asdf") (provide "ASDF")
13983 ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF.
13984 (cleanup-upgraded-asdf))
13986 (when *load-verbose*
13987 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
