1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
2 ;;; This is ASDF 2.23: Another System Definition Facility.
4 ;;; Feedback, bug reports, and patches are all welcome:
5 ;;; please mail to <asdf-devel@common-lisp.net>.
6 ;;; Note first that the canonical source for ASDF is presently
7 ;;; <URL:http://common-lisp.net/project/asdf/>.
9 ;;; If you obtained this copy from anywhere else, and you experience
10 ;;; trouble using it, or find bugs, you may want to check at the
11 ;;; location above for a more recent version (and for documentation
12 ;;; and test files, if your copy came without them) before reporting
13 ;;; bugs. There are usually two "supported" revisions - the git master
14 ;;; branch is the latest development version, whereas the git release
15 ;;; branch may be slightly older but is considered `stable'
18 ;;; (This is the MIT / X Consortium license as taken from
19 ;;; http://www.opensource.org/licenses/mit-license.html on or about
20 ;;; Monday; July 13, 2009)
22 ;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
24 ;;; Permission is hereby granted, free of charge, to any person obtaining
25 ;;; a copy of this software and associated documentation files (the
26 ;;; "Software"), to deal in the Software without restriction, including
27 ;;; without limitation the rights to use, copy, modify, merge, publish,
28 ;;; distribute, sublicense, and/or sell copies of the Software, and to
29 ;;; permit persons to whom the Software is furnished to do so, subject to
30 ;;; the following conditions:
32 ;;; The above copyright notice and this permission notice shall be
33 ;;; included in all copies or substantial portions of the Software.
35 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
36 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
37 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
38 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
39 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
40 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
41 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
45 ;;; The problem with writing a defsystem replacement is bootstrapping:
46 ;;; we can't use defsystem to compile it. Hence, all in one file.
50 (cl:in-package :common-lisp-user)
51 #+genera (in-package :future-common-lisp-user)
53 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
54 (error "ASDF is not supported on your implementation. Please help us port it.")
56 ;;;; Create and setup packages in a way that is compatible with hot-upgrade.
57 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
58 ;;;; See these two eval-when forms, and more near the end of the file.
60 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
62 (eval-when (:load-toplevel :compile-toplevel :execute)
63 ;;; Before we do anything, some implementation-dependent tweaks
64 ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
66 (setf excl::*autoload-package-name-alist*
67 (remove "asdf" excl::*autoload-package-name-alist*
68 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
69 #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
70 (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
71 (and (= system::*gcl-major-version* 2)
72 (< system::*gcl-minor-version* 7)))
73 (pushnew :gcl-pre2.7 *features*))
74 #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode)
75 (and ecl unicode) lispworks (and sbcl sb-unicode) scl)
76 (pushnew :asdf-unicode *features*)
77 ;;; make package if it doesn't exist yet.
78 ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
79 (unless (find-package :asdf)
80 (make-package :asdf :use '(:common-lisp))))
84 (eval-when (:load-toplevel :compile-toplevel :execute)
85 ;;; This would belong amongst implementation-dependent tweaks above,
86 ;;; except that the defun has to be in package asdf.
87 #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
88 #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
90 ;;; Package setup, step 2.
91 (defvar *asdf-version* nil)
92 (defvar *upgraded-p* nil)
93 (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
94 (defun find-symbol* (s p)
95 (find-symbol (string s) p))
96 ;; Strip out formatting that is not supported on Genera.
97 ;; Has to be inside the eval-when to make Lispworks happy (!)
98 (defun strcat (&rest strings)
99 (apply 'concatenate 'string strings))
100 (defmacro compatfmt (format)
101 #-(or gcl genera) format
103 (loop :for (unsupported . replacement) :in
106 #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
107 (loop :for found = (search unsupported format) :while found :do
108 (setf format (strcat (subseq format 0 found) replacement
109 (subseq format (+ found (length unsupported)))))))
111 (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
112 ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
113 ;; can help you do these changes in synch (look at the source for documentation).
114 ;; Relying on its automation, the version is now redundantly present on top of this file.
115 ;; "2.345" would be an official release
116 ;; "2.345.6" would be a development version in the official upstream
117 ;; "2.345.0.7" would be your seventh local modification of official release 2.345
118 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
119 (asdf-version "2.23")
120 (existing-asdf (find-class 'component nil))
121 (existing-version *asdf-version*)
122 (already-there (equal asdf-version existing-version)))
123 (unless (and existing-asdf already-there)
124 (when (and existing-asdf *asdf-verbose*)
125 (format *trace-output*
126 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
127 existing-version asdf-version))
129 ((present-symbol-p (symbol package)
130 (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
131 (present-symbols (package)
132 ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
134 (do-symbols (s package)
135 (when (present-symbol-p s package) (push s l)))
137 (unlink-package (package)
138 (let ((u (find-package package)))
140 (ensure-unintern u (present-symbols u))
141 (loop :for p :in (package-used-by-list u) :do
143 (delete-package u))))
144 (ensure-exists (name nicknames use)
147 (mapcar #'find-package (cons name nicknames))
149 ;; do away with packages with conflicting (nick)names
150 (map () #'unlink-package (cdr previous))
151 ;; reuse previous package with same name
152 (let ((p (car previous)))
155 (rename-package p name nicknames)
159 (make-package name :nicknames nicknames :use use))))))
160 (intern* (symbol package)
161 (intern (string symbol) package))
162 (remove-symbol (symbol package)
163 (let ((sym (find-symbol* symbol package)))
165 #-cormanlisp (unexport sym package)
166 (unintern sym package)
168 (ensure-unintern (package symbols)
169 (loop :with packages = (list-all-packages)
171 :for removed = (remove-symbol sym package)
173 (loop :for p :in packages :do
174 (when (eq removed (find-symbol* sym p))
175 (unintern removed p)))))
176 (ensure-shadow (package symbols)
177 (shadow symbols package))
178 (ensure-use (package use)
179 (dolist (used (package-use-list package))
180 (unless (member (package-name used) use :test 'string=)
182 (do-external-symbols (sym used)
183 (when (eq sym (find-symbol* sym package))
184 (remove-symbol sym package)))))
185 (dolist (used (reverse use))
186 (do-external-symbols (sym used)
187 (unless (eq sym (find-symbol* sym package))
188 (remove-symbol sym package)))
189 (use-package used package)))
190 (ensure-fmakunbound (package symbols)
191 (loop :for name :in symbols
192 :for sym = (find-symbol* name package)
193 :when sym :do (fmakunbound sym)))
194 (ensure-export (package export)
195 (let ((formerly-exported-symbols nil)
196 (bothly-exported-symbols nil)
197 (newly-exported-symbols nil))
198 (do-external-symbols (sym package)
199 (if (member sym export :test 'string-equal)
200 (push sym bothly-exported-symbols)
201 (push sym formerly-exported-symbols)))
202 (loop :for sym :in export :do
203 (unless (member sym bothly-exported-symbols :test 'equal)
204 (push sym newly-exported-symbols)))
205 (loop :for user :in (package-used-by-list package)
206 :for shadowing = (package-shadowing-symbols user) :do
207 (loop :for new :in newly-exported-symbols
208 :for old = (find-symbol* new user)
209 :when (and old (not (member old shadowing)))
210 :do (unintern old user)))
211 (loop :for x :in newly-exported-symbols :do
212 (export (intern* x package)))))
213 (ensure-package (name &key nicknames use unintern
214 shadow export redefined-functions)
215 (let* ((p (ensure-exists name nicknames use)))
216 (ensure-unintern p (append unintern #+cmu redefined-functions))
217 (ensure-shadow p shadow)
218 (ensure-export p export)
219 #-cmu (ensure-fmakunbound p redefined-functions)
222 ((pkgdcl (name &key nicknames use export
223 redefined-functions unintern shadow)
225 ',name :nicknames ',nicknames :use ',use :export ',export
228 :redefined-functions ',redefined-functions)))
231 :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
234 (#:perform #:explain #:output-files #:operation-done-p
235 #:perform-with-restarts #:component-relative-pathname
236 #:system-source-file #:operate #:find-component #:find-system
237 #:apply-output-translations #:translate-pathname* #:resolve-location
238 #:system-relative-pathname
239 #:inherit-source-registry #:process-source-registry
240 #:process-source-registry-directive
241 #:compile-file* #:source-file-type)
243 (#:*asdf-revision* #:around #:asdf-method-combination
244 #:split #:make-collector #:do-dep #:do-one-dep
245 #:resolve-relative-location-component #:resolve-absolute-location-component
246 #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
248 (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
249 #:system-definition-pathname #:with-system-definitions
250 #:search-for-system-definition #:find-component #:component-find-path
251 #:compile-system #:load-system #:load-systems
252 #:require-system #:test-system #:clear-system
253 #:operation #:compile-op #:load-op #:load-source-op #:test-op
254 #:feature #:version #:version-satisfies
256 #:implementation-identifier #:implementation-type #:hostname
257 #:input-files #:output-files #:output-file #:perform
258 #:operation-done-p #:explain
260 #:component #:source-file
261 #:c-source-file #:cl-source-file #:java-source-file
262 #:cl-source-file.cl #:cl-source-file.lsp
268 #:module ; components
272 #:module-components ; component accessors
273 #:module-components-by-name
275 #:component-relative-pathname
281 #:component-depends-on
283 #:component-external-format
286 #:system-long-description
292 #:system-source-directory
293 #:system-relative-pathname
296 #:operation-description
297 #:operation-on-warnings
298 #:operation-on-failure
299 #:component-visited-p
301 #:*system-definition-search-functions* ; variables
303 #:*compile-file-warnings-behaviour*
304 #:*compile-file-failure-behaviour*
306 #:*require-asdf-operator*
312 #:operation-error #:compile-failed #:compile-warned #:compile-error
315 #:load-system-definition-error
316 #:error-component #:error-operation
317 #:system-definition-error
319 #:missing-component-of-version
321 #:missing-dependency-of-version
322 #:circular-dependency ; errors
328 #:coerce-entry-to-directory
329 #:remove-entry-from-registry
331 #:*encoding-detection-hook*
332 #:*encoding-external-format-hook*
334 #:*utf-8-external-format*
336 #:clear-configuration
337 #:*output-translations-parameter*
338 #:initialize-output-translations
339 #:disable-output-translations
340 #:clear-output-translations
341 #:ensure-output-translations
342 #:apply-output-translations
344 #:compile-file-pathname*
345 #:enable-asdf-binary-locations-compatibility
346 #:*default-source-registries*
347 #:*source-registry-parameter*
348 #:initialize-source-registry
349 #:compute-source-registry
350 #:clear-source-registry
351 #:ensure-source-registry
352 #:process-source-registry
353 #:system-registered-p #:registered-systems #:loaded-systems
356 #:user-output-translations-pathname
357 #:system-output-translations-pathname
358 #:user-output-translations-directory-pathname
359 #:system-output-translations-directory-pathname
360 #:user-source-registry
361 #:system-source-registry
362 #:user-source-registry-directory
363 #:system-source-registry-directory
369 #:remove-keys #:remove-keyword
370 #:first-char #:last-char #:ends-with
372 #:directory-pathname-p #:ensure-directory-pathname
373 #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
374 #:getenv #:getenv-pathname #:getenv-pathname
375 #:getenv-absolute-directory #:getenv-absolute-directories
377 #:find-symbol* #:strcat
378 #:make-pathname-component-logical #:make-pathname-logical
379 #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
380 #:pathname-directory-pathname #:pathname-parent-directory-pathname
382 #:resolve-symlinks #:truenamize
384 #:component-name-to-pathname-components
386 #:subdirectories #:directory-files
388 #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
389 #:*wild-path* #:wilden
390 #:directorize-pathname-host-device
392 #+genera (import 'scl:boolean :asdf)
393 (setf *asdf-version* asdf-version
394 *upgraded-p* (if existing-version
395 (cons existing-version *upgraded-p*)
398 ;;;; -------------------------------------------------------------------------
399 ;;;; User-visible parameters
401 (defvar *resolve-symlinks* t
402 "Determine whether or not ASDF resolves symlinks when defining systems.
406 (defvar *compile-file-warnings-behaviour*
407 (or #+clisp :ignore :warn)
408 "How should ASDF react if it encounters a warning when compiling a file?
409 Valid values are :error, :warn, and :ignore.")
411 (defvar *compile-file-failure-behaviour*
412 (or #+sbcl :error #+clisp :ignore :warn)
413 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
414 when compiling a file? Valid values are :error, :warn, and :ignore.
415 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
417 (defvar *verbose-out* nil)
419 (defparameter +asdf-methods+
420 '(perform-with-restarts perform explain output-files operation-done-p))
423 (eval-when (:compile-toplevel :execute)
424 (defparameter *acl-warn-save*
425 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
426 excl:*warn-on-nested-reader-conditionals*))
427 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
428 (setf excl:*warn-on-nested-reader-conditionals* nil)))
430 ;;;; -------------------------------------------------------------------------
431 ;;;; Resolve forward references
433 (declaim (ftype (function (t) t)
434 format-arguments format-control
435 error-name error-pathname error-condition
437 error-component error-operation
438 module-components module-components-by-name
439 circular-dependency-components
440 condition-arguments condition-form
441 condition-format condition-location
443 (ftype (function (&optional t) (values)) initialize-source-registry)
444 #-(or cormanlisp gcl-pre2.7)
445 (ftype (function (t t) t) (setf module-components-by-name)))
447 ;;;; -------------------------------------------------------------------------
448 ;;;; Compatibility various implementations
451 (deftype logical-pathname () nil)
452 (defun make-broadcast-stream () *error-output*)
453 (defun file-namestring (p)
454 (setf p (pathname p))
455 (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
457 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
459 "(eval-when (:compile-toplevel :load-toplevel :execute)
460 (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
461 (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
462 ;; Note: ASDF may expect user-homedir-pathname to provide
463 ;; the pathname of the current user's home directory, whereas
464 ;; MCL by default provides the directory from which MCL was started.
465 ;; See http://code.google.com/p/mcl/wiki/Portability
466 (defun current-user-homedir-pathname ()
467 (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
468 (defun probe-posix (posix-namestring)
469 \"If a file exists for the posix namestring, return the pathname\"
470 (ccl::with-cstrs ((cpath posix-namestring))
471 (ccl::rlet ((is-dir :boolean)
473 (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
474 (ccl::%path-from-fsref fsref is-dir))))))"))
476 ;;;; -------------------------------------------------------------------------
477 ;;;; General Purpose Utilities
481 `(defmacro ,def* (name formals &rest rest)
483 #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
484 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
485 ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
486 `(declaim (notinline ,name)))
487 (,',def ,name ,formals ,@rest)))))
488 (defdef defgeneric* defgeneric)
489 (defdef defun* defun))
491 (defmacro while-collecting ((&rest collectors) &body body)
492 "COLLECTORS should be a list of names for collections. A collector
493 defines a function that, when applied to an argument inside BODY, will
494 add its argument to the corresponding collection. Returns multiple values,
495 a list for each collection, in order.
497 \(while-collecting \(foo bar\)
498 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
500 \(bar \(second x\)\)\)\)
501 Returns two values: \(A B C\) and \(1 2 3\)."
502 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
503 (initial-values (mapcar (constantly nil) collectors)))
504 `(let ,(mapcar #'list vars initial-values)
505 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
507 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
509 (defmacro aif (test then &optional else)
510 "Anaphoric version of IF, On Lisp style"
511 `(let ((it ,test)) (if it ,then ,else)))
513 (defun* pathname-directory-pathname (pathname)
514 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
515 and NIL NAME, TYPE and VERSION components"
517 (make-pathname :name nil :type nil :version nil :defaults pathname)))
519 (defun* normalize-pathname-directory-component (directory)
520 "Given a pathname directory component, return an equivalent form that is a list"
522 #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
523 ((stringp directory) `(:absolute ,directory) directory)
525 ((and (consp directory) (stringp (first directory)))
526 `(:absolute ,@directory))
527 ((or (null directory)
528 (and (consp directory) (member (first directory) '(:absolute :relative))))
531 (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
533 (defun* merge-pathname-directory-components (specified defaults)
534 ;; Helper for merge-pathnames* that handles directory components.
535 (let ((directory (normalize-pathname-directory-component specified)))
536 (ecase (first directory)
538 (:absolute specified)
540 (let ((defdir (normalize-pathname-directory-component defaults))
541 (reldir (cdr directory)))
545 ((not (eq :back (first reldir)))
546 (append defdir reldir))
548 (loop :with defabs = (first defdir)
549 :with defrev = (reverse (rest defdir))
550 :while (and (eq :back (car reldir))
551 (or (and (eq :absolute defabs) (null defrev))
552 (stringp (car defrev))))
553 :do (pop reldir) (pop defrev)
554 :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
556 (defun* make-pathname-component-logical (x)
557 "Make a pathname component suitable for use in a logical-pathname"
559 ((eql :unspecific) nil)
560 #+clisp (string (string-upcase x))
561 #+clisp (cons (mapcar 'make-pathname-component-logical x))
564 (defun* make-pathname-logical (pathname host)
565 "Take a PATHNAME's directory, name, type and version components,
566 and make a new pathname with corresponding components and specified logical HOST"
569 :directory (make-pathname-component-logical (pathname-directory pathname))
570 :name (make-pathname-component-logical (pathname-name pathname))
571 :type (make-pathname-component-logical (pathname-type pathname))
572 :version (make-pathname-component-logical (pathname-version pathname))))
574 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
575 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
576 if the SPECIFIED pathname does not have an absolute directory,
577 then the HOST and DEVICE both come from the DEFAULTS, whereas
578 if the SPECIFIED pathname does have an absolute directory,
579 then the HOST and DEVICE both come from the SPECIFIED.
580 Also, if either argument is NIL, then the other argument is returned unmodified."
581 (when (null specified) (return-from merge-pathnames* defaults))
582 (when (null defaults) (return-from merge-pathnames* specified))
584 (ext:resolve-pathname specified defaults)
586 (let* ((specified (pathname specified))
587 (defaults (pathname defaults))
588 (directory (normalize-pathname-directory-component (pathname-directory specified)))
589 (name (or (pathname-name specified) (pathname-name defaults)))
590 (type (or (pathname-type specified) (pathname-type defaults)))
591 (version (or (pathname-version specified) (pathname-version defaults))))
592 (labels ((unspecific-handler (p)
593 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
594 (multiple-value-bind (host device directory unspecific-handler)
595 (ecase (first directory)
597 (values (pathname-host specified)
598 (pathname-device specified)
600 (unspecific-handler specified)))
602 (values (pathname-host defaults)
603 (pathname-device defaults)
604 (merge-pathname-directory-components directory (pathname-directory defaults))
605 (unspecific-handler defaults))))
606 (make-pathname :host host :device device :directory directory
607 :name (funcall unspecific-handler name)
608 :type (funcall unspecific-handler type)
609 :version (funcall unspecific-handler version))))))
611 (defun* pathname-parent-directory-pathname (pathname)
612 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
613 and NIL NAME, TYPE and VERSION components"
615 (make-pathname :name nil :type nil :version nil
616 :directory (merge-pathname-directory-components
617 '(:relative :back) (pathname-directory pathname))
618 :defaults pathname)))
620 (define-modify-macro appendf (&rest args)
621 append "Append onto list") ;; only to be used on short lists.
623 (define-modify-macro orf (&rest args)
626 (defun* first-char (s)
627 (and (stringp s) (plusp (length s)) (char s 0)))
629 (defun* last-char (s)
630 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
633 (defun* asdf-message (format-string &rest format-args)
634 (declare (dynamic-extent format-args))
635 (apply 'format *verbose-out* format-string format-args))
637 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
638 "Split STRING into a list of components separated by
639 any of the characters in the sequence SEPARATOR.
640 If MAX is specified, then no more than max(1,MAX) components will be returned,
641 starting the separation from the end, e.g. when called with arguments
642 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
644 (let ((list nil) (words 0) (end (length string)))
645 (flet ((separatorp (char) (find char separator))
646 (done () (throw nil (cons (subseq string 0 end) list))))
648 :for start = (if (and max (>= words (1- max)))
650 (position-if #'separatorp string :end end :from-end t)) :do
653 (push (subseq string (1+ start) end) list)
655 (setf end start))))))
657 (defun* split-name-type (filename)
659 ;; Giving :unspecific as argument to make-pathname is not portable.
660 ;; See CLHS make-pathname and 19.2.2.2.3.
661 ;; We only use it on implementations that support it,
662 #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific
663 #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
664 (destructuring-bind (name &optional (type unspecific))
665 (split-string filename :max 2 :separator ".")
667 (values filename unspecific)
668 (values name type)))))
670 (defun* component-name-to-pathname-components (s &key force-directory force-relative)
671 "Splits the path string S, returning three values:
672 A flag that is either :absolute or :relative, indicating
673 how the rest of the values are to be interpreted.
674 A directory path --- a list of strings, suitable for
675 use with MAKE-PATHNAME when prepended with the flag
677 A filename with type extension, possibly NIL in the
678 case of a directory pathname.
679 FORCE-DIRECTORY forces S to be interpreted as a directory
680 pathname \(third return value will be NIL, final component
681 of S will be treated as part of the directory path.
683 The intention of this function is to support structured component names,
684 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
686 (check-type s string)
688 (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
689 (let* ((components (split-string s :separator "/"))
690 (last-comp (car (last components))))
691 (multiple-value-bind (relative components)
692 (if (equal (first components) "")
693 (if (equal (first-char s) #\/)
696 (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
697 (values :absolute (cdr components)))
698 (values :relative nil))
699 (values :relative components))
700 (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
701 (setf components (substitute :back ".." components :test #'equal))
703 ((equal last-comp "")
704 (values relative components nil)) ; "" already removed
706 (values relative components nil))
708 (values relative (butlast components) last-comp))))))
710 (defun* remove-keys (key-names args)
711 (loop :for (name val) :on args :by #'cddr
712 :unless (member (symbol-name name) key-names
713 :key #'symbol-name :test 'equal)
714 :append (list name val)))
716 (defun* remove-keyword (key args)
717 (loop :for (k v) :on args :by #'cddr
722 (declare (ignorable x))
723 #+(or abcl clisp ecl xcl) (ext:getenv x)
724 #+allegro (sys:getenv x)
725 #+clozure (ccl:getenv x)
726 #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
728 (let* ((buffer (ct:malloc 1))
729 (cname (ct:lisp-string-to-c-string x))
730 (needed-size (win:getenvironmentvariable cname buffer 0))
731 (buffer1 (ct:malloc (1+ needed-size))))
732 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
734 (ct:c-string-to-lisp-string buffer1))
737 #+gcl (system:getenv x)
739 #+lispworks (lispworks:environment-variable x)
740 #+mcl (ccl:with-cstrs ((name x))
741 (let ((value (_getenv name)))
742 (unless (ccl:%null-ptr-p value)
743 (ccl:%get-cstring value))))
744 #+sbcl (sb-ext:posix-getenv x)
745 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
746 (error "~S is not supported on your implementation" 'getenv))
748 (defun* directory-pathname-p (pathname)
749 "Does PATHNAME represent a directory?
751 A directory-pathname is a pathname _without_ a filename. The three
752 ways that the filename components can be missing are for it to be NIL,
753 :UNSPECIFIC or the empty string.
755 Note that this does _not_ check to see that PATHNAME points to an
756 actually-existing directory."
758 (let ((pathname (pathname pathname)))
759 (flet ((check-one (x)
760 (member x '(nil :unspecific "") :test 'equal)))
761 (and (not (wild-pathname-p pathname))
762 (check-one (pathname-name pathname))
763 (check-one (pathname-type pathname))
766 (defun* ensure-directory-pathname (pathspec)
767 "Converts the non-wild pathname designator PATHSPEC to directory form."
770 (ensure-directory-pathname (pathname pathspec)))
771 ((not (pathnamep pathspec))
772 (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
773 ((wild-pathname-p pathspec)
774 (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
775 ((directory-pathname-p pathspec)
778 (make-pathname :directory (append (or (pathname-directory pathspec)
780 (list (file-namestring pathspec)))
781 :name nil :type nil :version nil
782 :defaults pathspec))))
785 (unless (fboundp 'ensure-directories-exist)
786 (defun* ensure-directories-exist (path)
787 (fs:create-directories-recursively (pathname path))))
789 (defun* absolute-pathname-p (pathspec)
790 (and (typep pathspec '(or pathname string))
791 (eq :absolute (car (pathname-directory (pathname pathspec))))))
793 (defun* coerce-pathname (name &key type defaults)
794 "coerce NAME into a PATHNAME.
795 When given a string, portably decompose it into a relative pathname:
796 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
797 if TYPE is NIL, its last #\\. if any separates name and type from from type;
798 if TYPE is a string, it is the type, and the whole string is the name;
799 if TYPE is :DIRECTORY, the string is a directory component;
800 if the string is empty, it's a directory.
801 Any directory named .. is read as :BACK.
802 Host, device and version components are taken from DEFAULTS."
803 ;; The defaults are required notably because they provide the default host
804 ;; to the below make-pathname, which may crucially matter to people using
805 ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
806 ;; NOTE that the host and device slots will be taken from the defaults,
807 ;; but that should only matter if you later merge relative pathnames with
808 ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
813 (coerce-pathname (string-downcase name) :type type :defaults defaults))
815 (multiple-value-bind (relative path filename)
816 (component-name-to-pathname-components name :force-directory (eq type :directory)
818 (multiple-value-bind (name type)
820 ((or (eq type :directory) (null filename))
823 (values filename type))
825 (split-name-type filename)))
826 (apply 'make-pathname :directory (cons relative path) :name name :type type
827 (when defaults `(:defaults ,defaults))))))))
829 (defun* merge-component-name-type (name &key type defaults)
830 ;; For backwards compatibility only, for people using internals.
831 ;; Will be removed in a future release, e.g. 2.016.
832 (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
833 (coerce-pathname name :type type :defaults defaults))
835 (defun* subpathname (pathname subpath &key type)
836 (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
837 (pathname-directory-pathname pathname))))
839 (defun subpathname* (pathname subpath &key type)
841 (subpathname (ensure-directory-pathname pathname) subpath :type type)))
843 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
844 (check-type n (integer 0 *))
846 :for l = x :then (cdr l)
847 :for i :downfrom n :do
849 ((zerop i) (return (null l)))
850 ((not (consp l)) (return nil)))))
852 (defun* ends-with (s suffix)
853 (check-type s string)
854 (check-type suffix string)
855 (let ((start (- (length s) (length suffix))))
857 (string-equal s suffix :start1 start))))
859 (defun* read-file-forms (file)
860 (with-open-file (in file)
861 (loop :with eof = (list nil)
862 :for form = (read in nil eof)
866 (defun* pathname-root (pathname)
867 (make-pathname :directory '(:absolute)
868 :name nil :type nil :version nil
869 :defaults pathname ;; host device, and on scl, *some*
870 ;; scheme-specific parts: port username password, not others:
871 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
873 (defun* probe-file* (p)
874 "when given a pathname P, probes the filesystem for a file or directory
875 with given pathname and if it exists return its truename."
878 (string (probe-file* (parse-namestring p)))
879 (pathname (unless (wild-pathname-p p)
880 #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
882 #+clisp (aif (find-symbol* '#:probe-pathname :ext)
883 `(ignore-errors (,it p)))
884 '(ignore-errors (truename p)))))))
886 (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
887 "Resolve as much of a pathname as possible"
889 (when (typep pathname '(or null logical-pathname)) (return pathname))
890 (let ((p (merge-pathnames* pathname defaults)))
891 (when (typep p 'logical-pathname) (return p))
892 (let ((found (probe-file* p)))
893 (when found (return found)))
894 (unless (absolute-pathname-p p)
895 (let ((true-defaults (ignore-errors (truename defaults))))
897 (setf p (merge-pathnames pathname true-defaults)))))
898 (unless (absolute-pathname-p p) (return p))
899 (let ((sofar (probe-file* (pathname-root p))))
900 (unless sofar (return p))
901 (flet ((solution (directories)
903 (make-pathname :host nil :device nil
904 :directory `(:relative ,@directories)
905 :name (pathname-name p)
906 :type (pathname-type p)
907 :version (pathname-version p))
909 (loop :with directory = (normalize-pathname-directory-component
910 (pathname-directory p))
911 :for component :in (cdr directory)
912 :for rest :on (cdr directory)
913 :for more = (probe-file*
915 (make-pathname :directory `(:relative ,component))
919 (return (solution rest)))
921 (return (solution nil))))))))
923 (defun* resolve-symlinks (path)
924 #-allegro (truenamize path)
925 #+allegro (if (typep path 'logical-pathname)
927 (excl:pathname-resolve-symbolic-links path)))
929 (defun* resolve-symlinks* (path)
930 (if *resolve-symlinks*
931 (and path (resolve-symlinks path))
934 (defun* ensure-pathname-absolute (path)
936 ((absolute-pathname-p path) path)
937 ((stringp path) (ensure-pathname-absolute (pathname path)))
938 ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
939 (t (let ((resolved (resolve-symlinks path)))
940 (assert (absolute-pathname-p resolved))
943 (defun* default-directory ()
944 (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
946 (defun* lispize-pathname (input-file)
947 (make-pathname :type "lisp" :defaults input-file))
949 (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
950 (defparameter *wild-file*
951 (make-pathname :name *wild* :type *wild*
952 :version (or #-(or abcl xcl) *wild*) :directory nil))
953 (defparameter *wild-directory*
954 (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
955 (defparameter *wild-inferiors*
956 (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
957 (defparameter *wild-path*
958 (merge-pathnames *wild-file* *wild-inferiors*))
960 (defun* wilden (path)
961 (merge-pathnames* *wild-path* path))
964 (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
965 (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
966 (last-char (namestring foo))))
969 (defun* directorize-pathname-host-device (pathname)
970 (let* ((root (pathname-root pathname))
971 (wild-root (wilden root))
972 (absolute-pathname (merge-pathnames* pathname root))
973 (separator (directory-separator-for-host root))
974 (root-namestring (namestring root))
977 #'(lambda (x) (or (eql x #\:)
980 (multiple-value-bind (relative path filename)
981 (component-name-to-pathname-components root-string :force-directory t)
982 (declare (ignore relative filename))
984 (make-pathname :defaults root
985 :directory `(:absolute ,@path))))
986 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
989 (defun* directorize-pathname-host-device (pathname)
990 (let ((scheme (ext:pathname-scheme pathname))
991 (host (pathname-host pathname))
992 (port (ext:pathname-port pathname))
993 (directory (pathname-directory pathname)))
994 (flet ((specificp (x) (and x (not (eq x :unspecific)))))
995 (if (or (specificp port)
996 (and (specificp host) (plusp (length host)))
999 (when (specificp port)
1000 (setf prefix (format nil ":~D" port)))
1001 (when (and (specificp host) (plusp (length host)))
1002 (setf prefix (strcat host prefix)))
1003 (setf prefix (strcat ":" prefix))
1004 (when (specificp scheme)
1005 (setf prefix (strcat scheme prefix)))
1006 (assert (and directory (eq (first directory) :absolute)))
1007 (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
1008 :defaults pathname)))
1011 ;;;; -------------------------------------------------------------------------
1012 ;;;; ASDF Interface, in terms of generic functions.
1013 (defgeneric* find-system (system &optional error-p))
1014 (defgeneric* perform-with-restarts (operation component))
1015 (defgeneric* perform (operation component))
1016 (defgeneric* operation-done-p (operation component))
1017 (defgeneric* mark-operation-done (operation component))
1018 (defgeneric* explain (operation component))
1019 (defgeneric* output-files (operation component))
1020 (defgeneric* input-files (operation component))
1021 (defgeneric* component-operation-time (operation component))
1022 (defgeneric* operation-description (operation component)
1023 (:documentation "returns a phrase that describes performing this operation
1024 on this component, e.g. \"loading /a/b/c\".
1025 You can put together sentences using this phrase."))
1027 (defgeneric* system-source-file (system)
1028 (:documentation "Return the source file in which system is defined."))
1030 (defgeneric* component-system (component)
1031 (:documentation "Find the top-level system containing COMPONENT"))
1033 (defgeneric* component-pathname (component)
1034 (:documentation "Extracts the pathname applicable for a particular component."))
1036 (defgeneric* component-relative-pathname (component)
1037 (:documentation "Returns a pathname for the component argument intended to be
1038 interpreted relative to the pathname of that component's parent.
1039 Despite the function's name, the return value may be an absolute
1040 pathname, because an absolute pathname may be interpreted relative to
1041 another pathname in a degenerate way."))
1043 (defgeneric* component-property (component property))
1045 (defgeneric* (setf component-property) (new-value component property))
1047 (defgeneric* component-external-format (component))
1049 (defgeneric* component-encoding (component))
1051 (eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
1052 (defgeneric* (setf module-components-by-name) (new-value module)))
1054 (defgeneric* version-satisfies (component version))
1056 (defgeneric* find-component (base path)
1057 (:documentation "Finds the component with PATH starting from BASE module;
1058 if BASE is nil, then the component is assumed to be a system."))
1060 (defgeneric* source-file-type (component system))
1062 (defgeneric* operation-ancestor (operation)
1064 "Recursively chase the operation's parent pointer until we get to
1065 the head of the tree"))
1067 (defgeneric* component-visited-p (operation component)
1068 (:documentation "Returns the value stored by a call to
1069 VISIT-COMPONENT, if that has been called, otherwise NIL.
1070 This value stored will be a cons cell, the first element
1071 of which is a computed key, so not interesting. The
1072 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
1073 it as (cdr (component-visited-p op c)).
1074 In the current form of ASDF, the DATA value retrieved is
1075 effectively a boolean, indicating whether some operations are
1076 to be performed in order to do OPERATION X COMPONENT. If the
1077 data value is NIL, the combination had been explored, but no
1078 operations needed to be performed."))
1080 (defgeneric* visit-component (operation component data)
1081 (:documentation "Record DATA as being associated with OPERATION
1082 and COMPONENT. This is a side-effecting function: the association
1083 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
1085 No evidence that DATA is ever interesting, beyond just being
1086 non-NIL. Using the data field is probably very risky; if there is
1087 already a record for OPERATION X COMPONENT, DATA will be quietly
1088 discarded instead of recorded.
1089 Starting with 2.006, TRAVERSE will store an integer in data,
1090 so that nodes can be sorted in decreasing order of traversal."))
1093 (defgeneric* (setf visiting-component) (new-value operation component))
1095 (defgeneric* component-visiting-p (operation component))
1097 (defgeneric* component-depends-on (operation component)
1099 "Returns a list of dependencies needed by the component to perform
1100 the operation. A dependency has one of the following forms:
1102 (<operation> <component>*), where <operation> is a class
1103 designator and each <component> is a component
1104 designator, which means that the component depends on
1105 <operation> having been performed on each <component>; or
1107 (FEATURE <feature>), which means that the component depends
1108 on <feature>'s presence in *FEATURES*.
1110 Methods specialized on subclasses of existing component types
1111 should usually append the results of CALL-NEXT-METHOD to the
1114 (defgeneric* component-self-dependencies (operation component))
1116 (defgeneric* traverse (operation component)
1118 "Generate and return a plan for performing OPERATION on COMPONENT.
1120 The plan returned is a list of dotted-pairs. Each pair is the CONS
1121 of ASDF operation object and a COMPONENT object. The pairs will be
1122 processed in order by OPERATE."))
1125 ;;;; -------------------------------------------------------------------------
1126 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
1128 (when (find-class 'module nil)
1130 '(defmethod update-instance-for-redefined-class :after
1131 ((m module) added deleted plist &key)
1132 (declare (ignorable deleted plist))
1133 (when *asdf-verbose*
1134 (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
1136 (when (member 'components-by-name added)
1137 (compute-module-components-by-name m))
1138 (when (typep m 'system)
1139 (when (member 'source-file added)
1140 (%set-system-source-file
1141 (probe-asd (component-name m) (component-pathname m)) m)
1142 (when (equal (component-name m) "asdf")
1143 (setf (component-version m) *asdf-version*))))))))
1145 ;;;; -------------------------------------------------------------------------
1146 ;;;; Classes, Conditions
1148 (define-condition system-definition-error (error) ()
1149 ;; [this use of :report should be redundant, but unfortunately it's not.
1150 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
1151 ;; over print-object; this is always conditions::%print-condition for
1152 ;; condition objects, which in turn does inheritance of :report options at
1153 ;; run-time. fortunately, inheritance means we only need this kludge here in
1154 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
1155 #+cmu (:report print-object))
1157 (define-condition formatted-system-definition-error (system-definition-error)
1158 ((format-control :initarg :format-control :reader format-control)
1159 (format-arguments :initarg :format-arguments :reader format-arguments))
1160 (:report (lambda (c s)
1161 (apply 'format s (format-control c) (format-arguments c)))))
1163 (define-condition load-system-definition-error (system-definition-error)
1164 ((name :initarg :name :reader error-name)
1165 (pathname :initarg :pathname :reader error-pathname)
1166 (condition :initarg :condition :reader error-condition))
1167 (:report (lambda (c s)
1168 (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
1169 (error-name c) (error-pathname c) (error-condition c)))))
1171 (define-condition circular-dependency (system-definition-error)
1172 ((components :initarg :components :reader circular-dependency-components))
1173 (:report (lambda (c s)
1174 (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
1175 (circular-dependency-components c)))))
1177 (define-condition duplicate-names (system-definition-error)
1178 ((name :initarg :name :reader duplicate-names-name))
1179 (:report (lambda (c s)
1180 (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
1181 (duplicate-names-name c)))))
1183 (define-condition missing-component (system-definition-error)
1184 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
1185 (parent :initform nil :reader missing-parent :initarg :parent)))
1187 (define-condition missing-component-of-version (missing-component)
1188 ((version :initform nil :reader missing-version :initarg :version)))
1190 (define-condition missing-dependency (missing-component)
1191 ((required-by :initarg :required-by :reader missing-required-by)))
1193 (define-condition missing-dependency-of-version (missing-dependency
1194 missing-component-of-version)
1197 (define-condition operation-error (error)
1198 ((component :reader error-component :initarg :component)
1199 (operation :reader error-operation :initarg :operation))
1200 (:report (lambda (c s)
1201 (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
1202 (error-operation c) (error-component c)))))
1203 (define-condition compile-error (operation-error) ())
1204 (define-condition compile-failed (compile-error) ())
1205 (define-condition compile-warned (compile-error) ())
1207 (define-condition invalid-configuration ()
1208 ((form :reader condition-form :initarg :form)
1209 (location :reader condition-location :initarg :location)
1210 (format :reader condition-format :initarg :format)
1211 (arguments :reader condition-arguments :initarg :arguments :initform nil))
1212 (:report (lambda (c s)
1213 (format s (compatfmt "~@<~? (will be skipped)~@:>")
1214 (condition-format c)
1215 (list* (condition-form c) (condition-location c)
1216 (condition-arguments c))))))
1217 (define-condition invalid-source-registry (invalid-configuration warning)
1218 ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1219 (define-condition invalid-output-translation (invalid-configuration warning)
1220 ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
1222 (defclass component ()
1223 ((name :accessor component-name :initarg :name :type string :documentation
1224 "Component name: designator for a string composed of portable pathname characters")
1225 ;; We might want to constrain version with
1226 ;; :type (and string (satisfies parse-version))
1227 ;; but we cannot until we fix all systems that don't use it correctly!
1228 (version :accessor component-version :initarg :version)
1229 (description :accessor component-description :initarg :description)
1230 (long-description :accessor component-long-description :initarg :long-description)
1231 ;; This one below is used by POIU - http://www.cliki.net/poiu
1232 ;; a parallelizing extension of ASDF that compiles in multiple parallel
1233 ;; slave processes (forked on demand) and loads in the master process.
1234 ;; Maybe in the future ASDF may use it internally instead of in-order-to.
1235 (load-dependencies :accessor component-load-dependencies :initform nil)
1236 ;; In the ASDF object model, dependencies exist between *actions*
1237 ;; (an action is a pair of operation and component). They are represented
1238 ;; alists of operations to dependencies (other actions) in each component.
1239 ;; There are two kinds of dependencies, each stored in its own slot:
1240 ;; in-order-to and do-first dependencies. These two kinds are related to
1241 ;; the fact that some actions modify the filesystem,
1242 ;; whereas other actions modify the current image, and
1243 ;; this implies a difference in how to interpret timestamps.
1244 ;; in-order-to dependencies will trigger re-performing the action
1245 ;; when the timestamp of some dependency
1246 ;; makes the timestamp of current action out-of-date;
1247 ;; do-first dependencies do not trigger such re-performing.
1248 ;; Therefore, a FASL must be recompiled if it is obsoleted
1249 ;; by any of its FASL dependencies (in-order-to); but
1250 ;; it needn't be recompiled just because one of these dependencies
1251 ;; hasn't yet been loaded in the current image (do-first).
1252 ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
1253 ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
1254 ;; Maybe rename the slots in ASDF? But that's not very backwards compatible.
1255 ;; See our ASDF 2 paper for more complete explanations.
1256 (in-order-to :initform nil :initarg :in-order-to
1257 :accessor component-in-order-to)
1258 (do-first :initform nil :initarg :do-first
1259 :accessor component-do-first)
1260 ;; methods defined using the "inline" style inside a defsystem form:
1261 ;; need to store them somewhere so we can delete them when the system
1263 (inline-methods :accessor component-inline-methods :initform nil)
1264 (parent :initarg :parent :initform nil :reader component-parent)
1265 ;; no direct accessor for pathname, we do this as a method to allow
1266 ;; it to default in funky ways if not supplied
1267 (relative-pathname :initarg :pathname)
1268 ;; the absolute-pathname is computed based on relative-pathname...
1270 (operation-times :initform (make-hash-table)
1271 :accessor component-operation-times)
1272 (around-compile :initarg :around-compile)
1273 (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
1274 ;; XXX we should provide some atomic interface for updating the
1275 ;; component properties
1276 (properties :accessor component-properties :initarg :properties
1279 (defun* component-find-path (component)
1281 (loop :for c = component :then (component-parent c)
1282 :while c :collect (component-name c))))
1284 (defmethod print-object ((c component) stream)
1285 (print-unreadable-object (c stream :type t :identity nil)
1286 (format stream "~{~S~^ ~}" (component-find-path c))))
1289 ;;;; methods: conditions
1291 (defmethod print-object ((c missing-dependency) s)
1292 (format s (compatfmt "~@<~A, required by ~A~@:>")
1293 (call-next-method c nil) (missing-required-by c)))
1295 (defun* sysdef-error (format &rest arguments)
1296 (error 'formatted-system-definition-error :format-control
1297 format :format-arguments arguments))
1299 ;;;; methods: components
1301 (defmethod print-object ((c missing-component) s)
1302 (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
1303 (missing-requires c)
1304 (when (missing-parent c)
1305 (coerce-name (missing-parent c)))))
1307 (defmethod print-object ((c missing-component-of-version) s)
1308 (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
1309 (missing-requires c)
1311 (when (missing-parent c)
1312 (coerce-name (missing-parent c)))))
1314 (defmethod component-system ((component component))
1315 (aif (component-parent component)
1316 (component-system it)
1319 (defvar *default-component-class* 'cl-source-file)
1321 (defun* compute-module-components-by-name (module)
1322 (let ((hash (make-hash-table :test 'equal)))
1323 (setf (module-components-by-name module) hash)
1324 (loop :for c :in (module-components module)
1325 :for name = (component-name c)
1326 :for previous = (gethash name (module-components-by-name module))
1329 (error 'duplicate-names :name name))
1330 :do (setf (gethash name (module-components-by-name module)) c))
1333 (defclass module (component)
1336 :initarg :components
1337 :accessor module-components)
1339 :accessor module-components-by-name)
1340 ;; What to do if we can't satisfy a dependency of one of this module's
1341 ;; components. This allows a limited form of conditional processing.
1342 (if-component-dep-fails
1344 :initarg :if-component-dep-fails
1345 :accessor module-if-component-dep-fails)
1346 (default-component-class
1348 :initarg :default-component-class
1349 :accessor module-default-component-class)))
1351 (defun* component-parent-pathname (component)
1352 ;; No default anymore (in particular, no *default-pathname-defaults*).
1353 ;; If you force component to have a NULL pathname, you better arrange
1354 ;; for any of its children to explicitly provide a proper absolute pathname
1355 ;; wherever a pathname is actually wanted.
1356 (let ((parent (component-parent component)))
1358 (component-pathname parent))))
1360 (defmethod component-pathname ((component component))
1361 (if (slot-boundp component 'absolute-pathname)
1362 (slot-value component 'absolute-pathname)
1365 (component-relative-pathname component)
1366 (pathname-directory-pathname (component-parent-pathname component)))))
1367 (unless (or (null pathname) (absolute-pathname-p pathname))
1368 (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
1369 pathname (component-find-path component)))
1370 (setf (slot-value component 'absolute-pathname) pathname)
1373 (defmethod component-property ((c component) property)
1374 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1376 (defmethod (setf component-property) (new-value (c component) property)
1377 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1379 (setf (cdr a) new-value)
1380 (setf (slot-value c 'properties)
1381 (acons property new-value (slot-value c 'properties)))))
1384 (defvar *default-encoding* :default
1385 "Default encoding for source files.
1386 The default value :default preserves the legacy behavior.
1387 A future default might be :utf-8 or :autodetect
1388 reading emacs-style -*- coding: utf-8 -*- specifications,
1389 and falling back to utf-8 or latin1 if nothing is specified.")
1391 (defparameter *utf-8-external-format*
1392 #+(and asdf-unicode (not clisp)) :utf-8
1393 #+(and asdf-unicode clisp) charset:utf-8
1394 #-asdf-unicode :default
1395 "Default :external-format argument to pass to CL:OPEN and also
1396 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
1397 On modern implementations, this will decode UTF-8 code points as CL characters.
1398 On legacy implementations, it may fall back on some 8-bit encoding,
1399 with non-ASCII code points being read as several CL characters;
1400 hopefully, if done consistently, that won't affect program behavior too much.")
1402 (defun* always-default-encoding (pathname)
1403 (declare (ignore pathname))
1406 (defvar *encoding-detection-hook* #'always-default-encoding
1407 "Hook for an extension to define a function to automatically detect a file's encoding")
1409 (defun* detect-encoding (pathname)
1410 (funcall *encoding-detection-hook* pathname))
1412 (defmethod component-encoding ((c component))
1413 (or (loop :for x = c :then (component-parent x)
1414 :while x :thereis (%component-encoding x))
1415 (detect-encoding (component-pathname c))))
1417 (defun* default-encoding-external-format (encoding)
1419 (:default :default) ;; for backwards compatibility only. Explicit usage discouraged.
1420 (:utf-8 *utf-8-external-format*)
1422 (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)
1425 (defvar *encoding-external-format-hook*
1426 #'default-encoding-external-format
1427 "Hook for an extension to define a mapping between non-default encodings
1428 and implementation-defined external-format's")
1430 (defun encoding-external-format (encoding)
1431 (funcall *encoding-external-format-hook* encoding))
1433 (defmethod component-external-format ((c component))
1434 (encoding-external-format (component-encoding c)))
1436 (defclass proto-system () ; slots to keep when resetting a system
1437 ;; To preserve identity for all objects, we'd need keep the components slots
1438 ;; but also to modify parse-component-form to reset the recycled objects.
1439 ((name) #|(components) (components-by-names)|#))
1441 (defclass system (module proto-system)
1442 (;; description and long-description are now available for all component's,
1443 ;; but now also inherited from component, but we add the legacy accessor
1444 (description :accessor system-description :initarg :description)
1445 (long-description :accessor system-long-description :initarg :long-description)
1446 (author :accessor system-author :initarg :author)
1447 (maintainer :accessor system-maintainer :initarg :maintainer)
1448 (licence :accessor system-licence :initarg :licence
1449 :accessor system-license :initarg :license)
1450 (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
1451 :writer %set-system-source-file)
1452 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1454 ;;;; -------------------------------------------------------------------------
1455 ;;;; version-satisfies
1457 (defmethod version-satisfies ((c component) version)
1458 (unless (and version (slot-boundp c 'version))
1460 (warn "Requested version ~S but component ~S has no version" version c))
1461 (return-from version-satisfies t))
1462 (version-satisfies (component-version c) version))
1464 (defun* asdf-version ()
1465 "Exported interface to the version of ASDF currently installed. A string.
1466 You can compare this string with e.g.:
1467 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
1470 (defun* parse-version (string &optional on-error)
1471 "Parse a version string as a series of natural integers separated by dots.
1472 Return a (non-null) list of integers if the string is valid, NIL otherwise.
1473 If on-error is error, warn, or designates a function of compatible signature,
1474 the function is called with an explanation of what is wrong with the argument.
1475 NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
1477 (or (stringp string)
1479 (funcall on-error "~S: ~S is not a string"
1480 'parse-version string)) nil)
1481 (or (loop :for prev = nil :then c :for c :across string
1482 :always (or (digit-char-p c)
1483 (and (eql c #\.) prev (not (eql prev #\.))))
1484 :finally (return (and c (digit-char-p c))))
1486 (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
1487 'parse-version string)) nil)
1488 (mapcar #'parse-integer (split-string string :separator "."))))
1490 (defmethod version-satisfies ((cver string) version)
1491 (let ((x (parse-version cver 'warn))
1492 (y (parse-version version 'warn)))
1493 (labels ((bigger (x y)
1496 ((> (car x) (car y)) t)
1497 ((= (car x) (car y))
1498 (bigger (cdr x) (cdr y))))))
1499 (and x y (= (car x) (car y))
1500 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1502 ;;;; -----------------------------------------------------------------
1503 ;;;; Windows shortcut support. Based on:
1505 ;;;; Jesse Hager: The Windows Shortcut File Format.
1506 ;;;; http://www.wotsit.org/list.asp?fc=13
1508 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
1510 (defparameter *link-initial-dword* 76)
1511 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
1513 (defun* read-null-terminated-string (s)
1514 (with-output-to-string (out)
1515 (loop :for code = (read-byte s)
1517 :do (write-char (code-char code) out))))
1519 (defun* read-little-endian (s &optional (bytes 4))
1520 (loop :for i :from 0 :below bytes
1521 :sum (ash (read-byte s) (* 8 i))))
1523 (defun* parse-file-location-info (s)
1524 (let ((start (file-position s))
1525 (total-length (read-little-endian s))
1526 (end-of-header (read-little-endian s))
1527 (fli-flags (read-little-endian s))
1528 (local-volume-offset (read-little-endian s))
1529 (local-offset (read-little-endian s))
1530 (network-volume-offset (read-little-endian s))
1531 (remaining-offset (read-little-endian s)))
1532 (declare (ignore total-length end-of-header local-volume-offset))
1533 (unless (zerop fli-flags)
1535 ((logbitp 0 fli-flags)
1536 (file-position s (+ start local-offset)))
1537 ((logbitp 1 fli-flags)
1538 (file-position s (+ start
1539 network-volume-offset
1541 (strcat (read-null-terminated-string s)
1543 (file-position s (+ start remaining-offset))
1544 (read-null-terminated-string s))))))
1546 (defun* parse-windows-shortcut (pathname)
1547 (with-open-file (s pathname :element-type '(unsigned-byte 8))
1549 (when (and (= (read-little-endian s) *link-initial-dword*)
1550 (let ((header (make-array (length *link-guid*))))
1551 (read-sequence header s)
1552 (equalp header *link-guid*)))
1553 (let ((flags (read-little-endian s)))
1554 (file-position s 76) ;skip rest of header
1555 (when (logbitp 0 flags)
1556 ;; skip shell item id list
1557 (let ((length (read-little-endian s 2)))
1558 (file-position s (+ length (file-position s)))))
1561 (parse-file-location-info s))
1563 (when (logbitp 2 flags)
1564 ;; skip description string
1565 (let ((length (read-little-endian s 2)))
1566 (file-position s (+ length (file-position s)))))
1567 (when (logbitp 3 flags)
1568 ;; finally, our pathname
1569 (let* ((length (read-little-endian s 2))
1570 (buffer (make-array length)))
1571 (read-sequence buffer s)
1572 (map 'string #'code-char buffer)))))))
1576 ;;;; -------------------------------------------------------------------------
1577 ;;;; Finding systems
1579 (defun* make-defined-systems-table ()
1580 (make-hash-table :test 'equal))
1582 (defvar *defined-systems* (make-defined-systems-table)
1583 "This is a hash table whose keys are strings, being the
1584 names of the systems, and whose values are pairs, the first
1585 element of which is a universal-time indicating when the
1586 system definition was last updated, and the second element
1587 of which is a system object.")
1589 (defun* coerce-name (name)
1591 (component (component-name name))
1592 (symbol (string-downcase (symbol-name name)))
1594 (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
1596 (defun* system-registered-p (name)
1597 (gethash (coerce-name name) *defined-systems*))
1599 (defun* registered-systems ()
1600 (loop :for (() . system) :being :the :hash-values :of *defined-systems*
1601 :collect (coerce-name system)))
1603 (defun* register-system (system)
1604 (check-type system system)
1605 (let ((name (component-name system)))
1606 (check-type name string)
1607 (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
1608 (unless (eq system (cdr (gethash name *defined-systems*)))
1609 (setf (gethash name *defined-systems*)
1610 (cons (get-universal-time) system)))))
1612 (defun* clear-system (name)
1613 "Clear the entry for a system in the database of systems previously loaded.
1614 Note that this does NOT in any way cause the code of the system to be unloaded."
1615 ;; There is no "unload" operation in Common Lisp, and
1616 ;; a general such operation cannot be portably written,
1617 ;; considering how much CL relies on side-effects to global data structures.
1618 (remhash (coerce-name name) *defined-systems*))
1620 (defun* map-systems (fn)
1621 "Apply FN to each defined system.
1623 FN should be a function of one argument. It will be
1624 called with an object of type asdf:system."
1625 (maphash #'(lambda (_ datum)
1626 (declare (ignore _))
1627 (destructuring-bind (_ . def) datum
1628 (declare (ignore _))
1632 ;;; for the sake of keeping things reasonably neat, we adopt a
1633 ;;; convention that functions in this list are prefixed SYSDEF-
1635 (defvar *system-definition-search-functions* '())
1637 (setf *system-definition-search-functions*
1639 ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
1640 (remove 'contrib-sysdef-search *system-definition-search-functions*)
1641 ;; Tuck our defaults at the end of the list if they were absent.
1642 ;; This is imperfect, in case they were removed on purpose,
1643 ;; but then it will be the responsibility of whoever does that
1644 ;; to upgrade asdf before he does such a thing rather than after.
1645 (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
1646 '(sysdef-central-registry-search
1647 sysdef-source-registry-search
1648 sysdef-find-asdf))))
1650 (defun* search-for-system-definition (system)
1651 (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
1652 (cons 'find-system-if-being-defined
1653 *system-definition-search-functions*)))
1655 (defvar *central-registry* nil
1656 "A list of 'system directory designators' ASDF uses to find systems.
1658 A 'system directory designator' is a pathname or an expression
1659 which evaluates to a pathname. For example:
1661 (setf asdf:*central-registry*
1662 (list '*default-pathname-defaults*
1663 #p\"/home/me/cl/systems/\"
1664 #p\"/usr/share/common-lisp/systems/\"))
1666 This is for backward compatibilily.
1667 Going forward, we recommend new users should be using the source-registry.
1670 (defun* featurep (x &optional (features *features*))
1673 (and (member x features) t))
1675 (assert (null (cddr x)))
1676 (not (featurep (cadr x) features)))
1678 (some #'(lambda (x) (featurep x features)) (cdr x)))
1680 (every #'(lambda (x) (featurep x features)) (cdr x)))
1682 (error "Malformed feature specification ~S" x))))
1684 (defun* os-unix-p ()
1685 (featurep '(:or :unix :cygwin :darwin)))
1687 (defun* os-windows-p ()
1688 (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
1690 (defun* probe-asd (name defaults)
1692 (when (directory-pathname-p defaults)
1693 (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
1696 #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
1697 (when (os-windows-p)
1700 :defaults defaults :version :newest :case :local
1701 :name (strcat name ".asd")
1703 (when (probe-file* shortcut)
1704 (let ((target (parse-windows-shortcut shortcut)))
1706 (return (pathname target))))))))))
1708 (defun* sysdef-central-registry-search (system)
1709 (let ((name (coerce-name system))
1714 (dolist (dir *central-registry*)
1715 (let ((defaults (eval dir)))
1717 (cond ((directory-pathname-p defaults)
1718 (let ((file (probe-asd name defaults)))
1723 (let* ((*print-circle* nil)
1726 (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
1727 system dir defaults)))
1729 (remove-entry-from-registry ()
1730 :report "Remove entry from *central-registry* and continue"
1731 (push dir to-remove))
1732 (coerce-entry-to-directory ()
1734 (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
1735 (ensure-directory-pathname defaults) dir))
1736 (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1738 (dolist (dir to-remove)
1739 (setf *central-registry* (remove dir *central-registry*)))
1740 (dolist (pair to-replace)
1741 (let* ((current (car pair))
1743 (position (position current *central-registry*)))
1744 (setf *central-registry*
1745 (append (subseq *central-registry* 0 position)
1747 (subseq *central-registry* (1+ position))))))))))
1749 (defun* make-temporary-package ()
1750 (flet ((try (counter)
1752 (make-package (format nil "~A~D" :asdf counter)
1753 :use '(:cl :asdf)))))
1754 (do* ((counter 0 (+ counter 1))
1755 (package (try counter) (try counter)))
1756 (package package))))
1758 (defun* safe-file-write-date (pathname)
1759 ;; If FILE-WRITE-DATE returns NIL, it's possible that
1760 ;; the user or some other agent has deleted an input file.
1761 ;; Also, generated files will not exist at the time planning is done
1762 ;; and calls operation-done-p which calls safe-file-write-date.
1763 ;; So it is very possible that we can't get a valid file-write-date,
1764 ;; and we can survive and we will continue the planning
1765 ;; as if the file were very old.
1766 ;; (or should we treat the case in a different, special way?)
1767 (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
1769 (when (and pathname *asdf-verbose*)
1770 (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
1774 (defmethod find-system ((name null) &optional (error-p t))
1775 (declare (ignorable name))
1777 (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
1779 (defmethod find-system (name &optional (error-p t))
1780 (find-system (coerce-name name) error-p))
1782 (defvar *systems-being-defined* nil
1783 "A hash-table of systems currently being defined keyed by name, or NIL")
1785 (defun* find-system-if-being-defined (name)
1786 (when *systems-being-defined*
1787 (gethash (coerce-name name) *systems-being-defined*)))
1789 (defun* call-with-system-definitions (thunk)
1790 (if *systems-being-defined*
1792 (let ((*systems-being-defined* (make-hash-table :test 'equal)))
1795 (defmacro with-system-definitions ((&optional) &body body)
1796 `(call-with-system-definitions #'(lambda () ,@body)))
1798 (defun* load-sysdef (name pathname)
1799 ;; Tries to load system definition with canonical NAME from PATHNAME.
1800 (with-system-definitions ()
1801 (let ((package (make-temporary-package)))
1804 ((error #'(lambda (condition)
1805 (error 'load-system-definition-error
1806 :name name :pathname pathname
1807 :condition condition))))
1808 (let ((*package* package)
1809 (*default-pathname-defaults*
1810 ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
1811 (pathname-directory-pathname (translate-logical-pathname pathname)))
1812 (external-format (encoding-external-format (detect-encoding pathname))))
1813 (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
1815 (load pathname :external-format external-format)))
1816 (delete-package package)))))
1818 (defun* locate-system (name)
1819 "Given a system NAME designator, try to locate where to load the system from.
1820 Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
1821 FOUNDP is true when a system was found,
1822 either a new unregistered one or a previously registered one.
1823 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
1824 PATHNAME when not null is a path from where to load the system,
1825 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
1826 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
1827 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
1828 (let* ((name (coerce-name name))
1829 (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
1830 (previous (cdr in-memory))
1831 (previous (and (typep previous 'system) previous))
1832 (previous-time (car in-memory))
1833 (found (search-for-system-definition name))
1834 (found-system (and (typep found 'system) found))
1835 (pathname (or (and (typep found '(or pathname string)) (pathname found))
1836 (and found-system (system-source-file found-system))
1837 (and previous (system-source-file previous))))
1838 (foundp (and (or found-system pathname previous) t)))
1839 (check-type found (or null pathname system))
1841 (setf pathname (resolve-symlinks* pathname))
1842 (when (and pathname (not (absolute-pathname-p pathname)))
1843 (setf pathname (ensure-pathname-absolute pathname))
1845 (%set-system-source-file pathname found-system)))
1846 (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
1847 (system-source-file previous) pathname)))
1848 (%set-system-source-file pathname previous)
1849 (setf previous-time nil))
1850 (values foundp found-system pathname previous previous-time))))
1852 (defmethod find-system ((name string) &optional (error-p t))
1853 (with-system-definitions ()
1856 (multiple-value-bind (foundp found-system pathname previous previous-time)
1857 (locate-system name)
1858 (declare (ignore foundp))
1859 (when (and found-system (not previous))
1860 (register-system found-system))
1862 (or (not previous-time)
1863 ;; don't reload if it's already been loaded,
1864 ;; or its filestamp is in the future which means some clock is skewed
1865 ;; and trying to load might cause an infinite loop.
1866 (< previous-time (safe-file-write-date pathname) (get-universal-time))))
1867 (load-sysdef name pathname))
1868 (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
1873 (setf (car in-memory) (safe-file-write-date pathname)))
1876 (error 'missing-component :requires name))))))
1877 (reinitialize-source-registry-and-retry ()
1879 (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
1880 (initialize-source-registry))))))
1882 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1883 (setf fallback (coerce-name fallback)
1884 requested (coerce-name requested))
1885 (when (equal requested fallback)
1886 (let ((registered (cdr (gethash fallback *defined-systems*))))
1888 (apply 'make-instance 'system
1889 :name fallback :source-file source-file keys)))))
1891 (defun* sysdef-find-asdf (name)
1892 ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
1893 (find-system-fallback name "asdf" :version *asdf-version*))
1896 ;;;; -------------------------------------------------------------------------
1897 ;;;; Finding components
1899 (defmethod find-component ((base string) path)
1900 (let ((s (find-system base nil)))
1901 (and s (find-component s path))))
1903 (defmethod find-component ((base symbol) path)
1905 (base (find-component (coerce-name base) path))
1906 (path (find-component path nil))
1909 (defmethod find-component ((base cons) path)
1910 (find-component (car base) (cons (cdr base) path)))
1912 (defmethod find-component ((module module) (name string))
1913 (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1914 (compute-module-components-by-name module))
1915 (values (gethash name (module-components-by-name module))))
1917 (defmethod find-component ((component component) (name symbol))
1919 (find-component component (coerce-name name))
1922 (defmethod find-component ((module module) (name cons))
1923 (find-component (find-component module (car name)) (cdr name)))
1926 ;;; component subclasses
1928 (defclass source-file (component)
1929 ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1931 (defclass cl-source-file (source-file)
1932 ((type :initform "lisp")))
1933 (defclass cl-source-file.cl (cl-source-file)
1934 ((type :initform "cl")))
1935 (defclass cl-source-file.lsp (cl-source-file)
1936 ((type :initform "lsp")))
1937 (defclass c-source-file (source-file)
1938 ((type :initform "c")))
1939 (defclass java-source-file (source-file)
1940 ((type :initform "java")))
1941 (defclass static-file (source-file) ())
1942 (defclass doc-file (static-file) ())
1943 (defclass html-file (doc-file)
1944 ((type :initform "html")))
1946 (defmethod source-file-type ((component module) (s module))
1947 (declare (ignorable component s))
1949 (defmethod source-file-type ((component source-file) (s module))
1950 (declare (ignorable s))
1951 (source-file-explicit-type component))
1953 (defmethod component-relative-pathname ((component component))
1955 (or (slot-value component 'relative-pathname)
1956 (component-name component))
1957 :type (source-file-type component (component-system component))
1958 :defaults (component-parent-pathname component)))
1960 ;;;; -------------------------------------------------------------------------
1963 ;;; one of these is instantiated whenever #'operate is called
1965 (defclass operation ()
1966 (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1967 ;; T to force the inside of the specified system,
1968 ;; but not recurse to other systems we depend on.
1969 ;; :ALL (or any other atom) to force all systems
1970 ;; including other systems we depend on.
1971 ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1972 ;; to force systems named in a given list
1973 ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
1974 (forced :initform nil :initarg :force :accessor operation-forced)
1975 (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
1976 (original-initargs :initform nil :initarg :original-initargs
1977 :accessor operation-original-initargs)
1978 (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1979 (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1980 (parent :initform nil :initarg :parent :accessor operation-parent)))
1982 (defmethod print-object ((o operation) stream)
1983 (print-unreadable-object (o stream :type t :identity t)
1985 (prin1 (operation-original-initargs o) stream))))
1987 (defmethod shared-initialize :after ((operation operation) slot-names
1988 &key force force-not
1990 ;; the &allow-other-keys disables initarg validity checking
1991 (declare (ignorable operation slot-names force force-not))
1992 (macrolet ((frob (x) ;; normalize forced and forced-not slots
1993 `(when (consp (,x operation))
1994 (setf (,x operation)
1995 (mapcar #'coerce-name (,x operation))))))
1996 (frob operation-forced) (frob operation-forced-not))
1999 (defun* node-for (o c)
2000 (cons (class-name (class-of o)) c))
2002 (defmethod operation-ancestor ((operation operation))
2003 (aif (operation-parent operation)
2004 (operation-ancestor it)
2008 (defun* make-sub-operation (c o dep-c dep-o)
2009 "C is a component, O is an operation, DEP-C is another
2010 component, and DEP-O, confusingly enough, is an operation
2011 class specifier, not an operation."
2012 (let* ((args (copy-list (operation-original-initargs o)))
2013 (force-p (getf args :force)))
2014 ;; note explicit comparison with T: any other non-NIL force value
2015 ;; (e.g. :recursive) will pass through
2016 (cond ((and (null (component-parent c))
2017 (null (component-parent dep-c))
2018 (not (eql c dep-c)))
2019 (when (eql force-p t)
2020 (setf (getf args :force) nil))
2021 (apply 'make-instance dep-o
2023 :original-initargs args args))
2024 ((subtypep (type-of o) dep-o)
2027 (apply 'make-instance dep-o
2028 :parent o :original-initargs args args)))))
2031 (defmethod visit-component ((o operation) (c component) data)
2032 (unless (component-visited-p o c)
2033 (setf (gethash (node-for o c)
2034 (operation-visited-nodes (operation-ancestor o)))
2037 (defmethod component-visited-p ((o operation) (c component))
2038 (gethash (node-for o c)
2039 (operation-visited-nodes (operation-ancestor o))))
2041 (defmethod (setf visiting-component) (new-value operation component)
2042 ;; MCL complains about unused lexical variables
2043 (declare (ignorable operation component))
2046 (defmethod (setf visiting-component) (new-value (o operation) (c component))
2047 (let ((node (node-for o c))
2048 (a (operation-ancestor o)))
2050 (setf (gethash node (operation-visiting-nodes a)) t)
2051 (remhash node (operation-visiting-nodes a)))
2054 (defmethod component-visiting-p ((o operation) (c component))
2055 (let ((node (node-for o c)))
2056 (gethash node (operation-visiting-nodes (operation-ancestor o)))))
2058 (defmethod component-depends-on ((op-spec symbol) (c component))
2059 ;; Note: we go from op-spec to operation via make-instance
2060 ;; to allow for specialization through defmethod's, even though
2061 ;; it's a detour in the default case below.
2062 (component-depends-on (make-instance op-spec) c))
2064 (defmethod component-depends-on ((o operation) (c component))
2065 (cdr (assoc (type-of o) (component-in-order-to c))))
2067 (defmethod component-self-dependencies ((o operation) (c component))
2069 #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
2070 (component-depends-on o c)))
2072 (defmethod input-files ((operation operation) (c component))
2073 (let ((parent (component-parent c))
2074 (self-deps (component-self-dependencies operation c)))
2076 (mapcan #'(lambda (dep)
2077 (destructuring-bind (op name) dep
2078 (output-files (make-instance op)
2079 (find-component parent name))))
2081 ;; no previous operations needed? I guess we work with the
2082 ;; original source file, then
2083 (list (component-pathname c)))))
2085 (defmethod input-files ((operation operation) (c module))
2086 (declare (ignorable operation c))
2089 (defmethod component-operation-time (o c)
2090 (gethash (type-of o) (component-operation-times c)))
2092 (defmethod operation-done-p ((o operation) (c component))
2093 (let ((out-files (output-files o c))
2094 (in-files (input-files o c))
2095 (op-time (component-operation-time o c)))
2096 (flet ((earliest-out ()
2097 (reduce #'min (mapcar #'safe-file-write-date out-files)))
2099 (reduce #'max (mapcar #'safe-file-write-date in-files))))
2101 ((and (not in-files) (not out-files))
2102 ;; arbitrary decision: an operation that uses nothing to
2103 ;; produce nothing probably isn't doing much.
2104 ;; e.g. operations on systems, modules that have no immediate action,
2105 ;; but are only meaningful through traversed dependencies
2108 ;; an operation without output-files is probably meant
2109 ;; for its side-effects in the current image,
2110 ;; assumed to be idem-potent,
2111 ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
2112 (and op-time (>= op-time (latest-in))))
2114 ;; an operation with output-files and no input-files
2115 ;; is probably meant for its side-effects on the file-system,
2116 ;; assumed to have to be done everytime.
2117 ;; (I don't think there is any such case in ASDF unless extended)
2120 ;; an operation with both input and output files is assumed
2121 ;; as computing the latter from the former,
2122 ;; assumed to have been done if the latter are all older
2124 ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
2125 ;; We use >= instead of > to play nice with generated files.
2126 ;; This opens a race condition if an input file is changed
2127 ;; after the output is created but within the same second
2128 ;; of filesystem time; but the same race condition exists
2129 ;; whenever the computation from input to output takes more
2130 ;; than one second of filesystem time (or just crosses the
2131 ;; second). So that's cool.
2133 (every #'probe-file* in-files)
2134 (every #'probe-file* out-files)
2135 (>= (earliest-out) (latest-in))))))))
2139 ;;; For 1.700 I've done my best to refactor TRAVERSE
2140 ;;; by splitting it up in a bunch of functions,
2141 ;;; so as to improve the collection and use-detection algorithm. --fare
2142 ;;; The protocol is as follows: we pass around operation, dependency,
2143 ;;; bunch of other stuff, and a force argument. Return a force flag.
2144 ;;; The returned flag is T if anything has changed that requires a rebuild.
2145 ;;; The force argument is a list of components that will require a rebuild
2146 ;;; if the flag is T, at which point whoever returns the flag has to
2147 ;;; mark them all as forced, and whoever recurses again can use a NIL list
2148 ;;; as a further argument.
2150 (defvar *forcing* nil
2151 "This dynamically-bound variable is used to force operations in
2152 recursive calls to traverse.")
2154 (defgeneric* do-traverse (operation component collect))
2156 (defun* resolve-dependency-name (component name &optional version)
2160 (let ((comp (find-component (component-parent component) name)))
2162 (error 'missing-dependency
2163 :required-by component
2166 (unless (version-satisfies comp version)
2167 (error 'missing-dependency-of-version
2168 :required-by component
2174 (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
2178 (and (typep c 'missing-dependency)
2179 (eq (missing-required-by c) component)
2180 (equal (missing-requires c) name))))))))
2182 (defun* resolve-dependency-spec (component dep-spec)
2185 (resolve-dependency-name component dep-spec))
2186 ;; Structured dependencies --- this parses keywords.
2187 ;; The keywords could conceivably be broken out and cleanly (extensibly)
2188 ;; processed by EQL methods. But for now, here's what we've got.
2189 ((eq :version (first dep-spec))
2190 ;; https://bugs.launchpad.net/asdf/+bug/527788
2191 (resolve-dependency-name component (second dep-spec) (third dep-spec)))
2192 ((eq :feature (first dep-spec))
2193 ;; This particular subform is not documented and
2194 ;; has always been broken in the past.
2195 ;; Therefore no one uses it, and I'm cerroring it out,
2197 ;; See https://bugs.launchpad.net/asdf/+bug/518467
2198 (cerror "Continue nonetheless."
2199 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
2200 (when (find (second dep-spec) *features* :test 'string-equal)
2201 (resolve-dependency-name component (third dep-spec))))
2203 (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
2205 (defun* do-one-dep (op c collect dep-op dep-c)
2206 ;; Collects a partial plan for performing dep-op on dep-c
2207 ;; as dependencies of a larger plan involving op and c.
2208 ;; Returns t if this should force recompilation of those who depend on us.
2209 ;; dep-op is an operation class name (not an operation object),
2210 ;; whereas dep-c is a component object.n
2211 (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
2213 (defun* do-dep (op c collect dep-op-spec dep-c-specs)
2214 ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
2215 ;; as dependencies of a larger plan involving op and c.
2216 ;; Returns t if this should force recompilation of those who depend on us.
2217 ;; dep-op-spec is either an operation class name (not an operation object),
2218 ;; or the magic symbol asdf:feature.
2219 ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
2220 ;; and the plan will succeed if that keyword is present in *feature*,
2221 ;; or fail if it isn't
2222 ;; (at which point c's :if-component-dep-fails will kick in).
2223 ;; If dep-op-spec is an operation class name,
2224 ;; then dep-c-specs specifies a list of sibling component of c,
2225 ;; as per resolve-dependency-spec, such that operating op on c
2226 ;; depends on operating dep-op-spec on each of them.
2227 (cond ((eq dep-op-spec 'feature)
2228 (if (member (car dep-c-specs) *features*)
2230 (error 'missing-dependency
2232 :requires (list :feature (car dep-c-specs)))))
2235 (dolist (d dep-c-specs)
2236 (when (do-one-dep op c collect dep-op-spec
2237 (resolve-dependency-spec c d))
2241 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
2243 (defun* do-collect (collect x)
2244 (funcall collect x))
2246 (defmethod do-traverse ((operation operation) (c component) collect)
2247 (let ((*forcing* *forcing*)
2248 (flag nil)) ;; return value: must we rebuild this and its dependencies?
2253 (update-flag (do-dep operation c collect op comp))))
2254 ;; Have we been visited yet? If so, just process the result.
2255 (aif (component-visited-p operation c)
2257 (update-flag (cdr it))
2258 (return-from do-traverse flag)))
2260 (when (component-visiting-p operation c)
2261 (error 'circular-dependency :components (list c)))
2262 (setf (visiting-component operation c) t)
2265 (when (typep c 'system) ;; systems can be forced or forced-not
2266 (let ((ancestor (operation-ancestor operation)))
2268 (and f (or (not (consp f)) ;; T or :ALL
2269 (member (component-name c) f :test #'equal)))))
2271 ((match? (operation-forced ancestor))
2273 ((match? (operation-forced-not ancestor))
2275 ;; first we check and do all the dependencies for the module.
2276 ;; Operations planned in this loop will show up
2277 ;; in the results, and are consumed below.
2278 (let ((*forcing* nil))
2279 ;; upstream dependencies are never forced to happen just because
2280 ;; the things that depend on them are....
2282 :for (required-op . deps) :in (component-depends-on operation c)
2283 :do (dep required-op deps)))
2286 (when (typep c 'module)
2287 (let ((at-least-one nil)
2288 ;; This is set based on the results of the
2289 ;; dependencies and whether we are in the
2290 ;; context of a *forcing* call...
2291 ;; inter-system dependencies do NOT trigger
2292 ;; building components
2295 (and flag (not (typep c 'system)))))
2297 (while-collecting (internal-collect)
2298 (dolist (kid (module-components c))
2301 (do-traverse operation kid #'internal-collect))
2303 (missing-dependency (condition)
2304 (when (eq (module-if-component-dep-fails c)
2307 (setf error condition))
2309 (declare (ignore c))
2310 (setf at-least-one t))))
2311 (when (and (eq (module-if-component-dep-fails c)
2315 (update-flag (or *forcing* (not (operation-done-p operation c))))
2316 ;; For sub-operations, check whether
2317 ;; the original ancestor operation was forced,
2318 ;; or names us amongst an explicit list of things to force...
2319 ;; except that this check doesn't distinguish
2320 ;; between all the things with a given name. Sigh.
2323 (let ((do-first (cdr (assoc (class-name (class-of operation))
2324 (component-do-first c)))))
2325 (loop :for (required-op . deps) :in do-first
2326 :do (do-dep operation c collect required-op deps)))
2327 (do-collect collect (vector module-ops))
2328 (do-collect collect (cons operation c)))))
2329 (setf (visiting-component operation c) nil)))
2330 (visit-component operation c (when flag (incf *visit-count*)))
2333 (defun* flatten-tree (l)
2334 ;; You collected things into a list.
2335 ;; Most elements are just things to collect again.
2336 ;; A (simple-vector 1) indicate that you should recurse into its contents.
2337 ;; This way, in two passes (rather than N being the depth of the tree),
2338 ;; you can collect things with marginally constant-time append,
2339 ;; achieving linear time collection instead of quadratic time.
2340 (while-collecting (c)
2342 (if (typep x '(simple-vector 1))
2346 (dolist (x l) (r x))))
2349 (defmethod traverse ((operation operation) (c component))
2351 (while-collecting (collect)
2352 (let ((*visit-count* 0))
2353 (do-traverse operation c #'collect)))))
2355 (defmethod perform ((operation operation) (c source-file))
2357 (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
2358 (class-of operation) (class-of c)))
2360 (defmethod perform ((operation operation) (c module))
2361 (declare (ignorable operation c))
2364 (defmethod mark-operation-done ((operation operation) (c component))
2365 (setf (gethash (type-of operation) (component-operation-times c))
2367 (cons (get-universal-time)
2368 (mapcar #'safe-file-write-date (input-files operation c))))))
2370 (defmethod perform-with-restarts (operation component)
2371 ;; TOO verbose, especially as the default. Add your own :before method
2372 ;; to perform-with-restart or perform if you want that:
2373 #|(when *asdf-verbose* (explain operation component))|#
2374 (perform operation component))
2376 (defmethod perform-with-restarts :around (operation component)
2379 (return (call-next-method))
2383 (format s (compatfmt "~@<Retry ~A.~@:>")
2384 (operation-description operation component))))
2388 (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
2389 (operation-description operation component)))
2390 (mark-operation-done operation component)
2393 (defmethod explain ((operation operation) (component component))
2394 (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
2395 (operation-description operation component)))
2397 (defmethod operation-description (operation component)
2398 (format nil (compatfmt "~@<~A on ~A~@:>")
2399 (class-of operation) component))
2401 ;;;; -------------------------------------------------------------------------
2404 (defclass compile-op (operation)
2405 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
2406 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
2407 :initform *compile-file-warnings-behaviour*)
2408 (on-failure :initarg :on-failure :accessor operation-on-failure
2409 :initform *compile-file-failure-behaviour*)
2410 (flags :initarg :flags :accessor compile-op-flags
2413 (defun* output-file (operation component)
2414 "The unique output file of performing OPERATION on COMPONENT"
2415 (let ((files (output-files operation component)))
2416 (assert (length=n-p files 1))
2419 (defun* ensure-all-directories-exist (pathnames)
2420 (dolist (pathname pathnames)
2421 (ensure-directories-exist (translate-logical-pathname pathname))))
2423 (defmethod perform :before ((operation compile-op) (c source-file))
2424 (ensure-all-directories-exist (output-files operation c)))
2426 (defmethod perform :after ((operation operation) (c component))
2427 (mark-operation-done operation c))
2429 (defgeneric* around-compile-hook (component))
2430 (defgeneric* call-with-around-compile-hook (component thunk))
2432 (defmethod around-compile-hook ((c component))
2434 ((slot-boundp c 'around-compile)
2435 (slot-value c 'around-compile))
2436 ((component-parent c)
2437 (around-compile-hook (component-parent c)))))
2439 (defun ensure-function (fun &key (package :asdf))
2441 ((or symbol function) fun)
2442 (cons (eval `(function ,fun)))
2443 (string (eval `(function ,(with-standard-io-syntax
2444 (let ((*package* (find-package package)))
2445 (read-from-string fun))))))))
2447 (defmethod call-with-around-compile-hook ((c component) thunk)
2448 (let ((hook (around-compile-hook c)))
2450 (funcall (ensure-function hook) thunk)
2453 (defvar *compile-op-compile-file-function* 'compile-file*
2454 "Function used to compile lisp files.")
2456 ;;; perform is required to check output-files to find out where to put
2457 ;;; its answers, in case it has been overridden for site policy
2458 (defmethod perform ((operation compile-op) (c cl-source-file))
2459 #-:broken-fasl-loader
2460 (let ((source-file (component-pathname c))
2461 ;; on some implementations, there are more than one output-file,
2462 ;; but the first one should always be the primary fasl that gets loaded.
2463 (output-file (first (output-files operation c)))
2464 (*compile-file-warnings-behaviour* (operation-on-warnings operation))
2465 (*compile-file-failure-behaviour* (operation-on-failure operation)))
2466 (multiple-value-bind (output warnings-p failure-p)
2467 (call-with-around-compile-hook
2468 c #'(lambda (&rest flags)
2469 (apply *compile-op-compile-file-function* source-file
2470 :output-file output-file
2471 :external-format (component-external-format c)
2472 (append flags (compile-op-flags operation)))))
2474 (error 'compile-error :component c :operation operation))
2476 (case (operation-on-failure operation)
2478 (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
2480 (:error (error 'compile-failed :component c :operation operation))
2483 (case (operation-on-warnings operation)
2485 (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
2487 (:error (error 'compile-warned :component c :operation operation))
2490 (defmethod output-files ((operation compile-op) (c cl-source-file))
2491 (declare (ignorable operation))
2492 (let ((p (lispize-pathname (component-pathname c))))
2493 #-broken-fasl-loader (list (compile-file-pathname p))
2494 #+broken-fasl-loader (list p)))
2496 (defmethod perform ((operation compile-op) (c static-file))
2497 (declare (ignorable operation c))
2500 (defmethod output-files ((operation compile-op) (c static-file))
2501 (declare (ignorable operation c))
2504 (defmethod input-files ((operation compile-op) (c static-file))
2505 (declare (ignorable operation c))
2508 (defmethod operation-description ((operation compile-op) component)
2509 (declare (ignorable operation))
2510 (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
2512 (defmethod operation-description ((operation compile-op) (component module))
2513 (declare (ignorable operation))
2514 (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
2517 ;;;; -------------------------------------------------------------------------
2520 (defclass basic-load-op (operation) ())
2522 (defclass load-op (basic-load-op) ())
2524 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
2527 (return (call-next-method))
2530 (format s "Recompile ~a and try loading it again"
2531 (component-name c)))
2532 (perform (make-sub-operation c o c 'compile-op) c)))))
2534 (defmethod perform ((o load-op) (c cl-source-file))
2535 (map () #'load (input-files o c)))
2537 (defmethod perform ((operation load-op) (c static-file))
2538 (declare (ignorable operation c))
2541 (defmethod operation-done-p ((operation load-op) (c static-file))
2542 (declare (ignorable operation c))
2545 (defmethod output-files ((operation operation) (c component))
2546 (declare (ignorable operation c))
2549 (defmethod component-depends-on ((operation load-op) (c component))
2550 (declare (ignorable operation))
2551 (cons (list 'compile-op (component-name c))
2552 (call-next-method)))
2554 (defmethod operation-description ((operation load-op) component)
2555 (declare (ignorable operation))
2556 (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
2559 (defmethod operation-description ((operation load-op) (component cl-source-file))
2560 (declare (ignorable operation))
2561 (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
2564 (defmethod operation-description ((operation load-op) (component module))
2565 (declare (ignorable operation))
2566 (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
2569 ;;;; -------------------------------------------------------------------------
2572 (defclass load-source-op (basic-load-op) ())
2574 (defmethod perform ((o load-source-op) (c cl-source-file))
2575 (declare (ignorable o))
2576 (let ((source (component-pathname c)))
2577 (setf (component-property c 'last-loaded-as-source)
2578 (and (call-with-around-compile-hook
2579 c #'(lambda () (load source :external-format (component-external-format c))))
2580 (get-universal-time)))))
2582 (defmethod perform ((operation load-source-op) (c static-file))
2583 (declare (ignorable operation c))
2586 (defmethod output-files ((operation load-source-op) (c component))
2587 (declare (ignorable operation c))
2590 ;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right.
2591 (defmethod component-depends-on ((o load-source-op) (c component))
2592 (declare (ignorable o))
2593 (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
2594 :for (op . co) :in what-would-load-op-do
2595 :when (eq op 'load-op) :collect (cons 'load-source-op co)))
2597 (defmethod operation-done-p ((o load-source-op) (c source-file))
2598 (declare (ignorable o))
2599 (if (or (not (component-property c 'last-loaded-as-source))
2600 (> (safe-file-write-date (component-pathname c))
2601 (component-property c 'last-loaded-as-source)))
2604 (defmethod operation-description ((operation load-source-op) component)
2605 (declare (ignorable operation))
2606 (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
2609 (defmethod operation-description ((operation load-source-op) (component module))
2610 (declare (ignorable operation))
2611 (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
2614 ;;;; -------------------------------------------------------------------------
2617 (defclass test-op (operation) ())
2619 (defmethod perform ((operation test-op) (c component))
2620 (declare (ignorable operation c))
2623 (defmethod operation-done-p ((operation test-op) (c system))
2624 "Testing a system is _never_ done."
2625 (declare (ignorable operation c))
2628 (defmethod component-depends-on :around ((o test-op) (c system))
2629 (declare (ignorable o))
2630 (cons `(load-op ,(component-name c)) (call-next-method)))
2633 ;;;; -------------------------------------------------------------------------
2634 ;;;; Invoking Operations
2636 (defgeneric* operate (operation-class system &key &allow-other-keys))
2637 (defgeneric* perform-plan (plan &key))
2639 ;;;; Separating this into a different function makes it more forward-compatible
2640 (defun* cleanup-upgraded-asdf (old-version)
2641 (let ((new-version (asdf-version)))
2642 (unless (equal old-version new-version)
2644 ((version-satisfies new-version old-version)
2645 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
2646 old-version new-version))
2647 ((version-satisfies old-version new-version)
2648 (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
2649 old-version new-version))
2651 (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
2652 old-version new-version)))
2653 (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
2654 ;; Invalidate all systems but ASDF itself.
2655 (setf *defined-systems* (make-defined-systems-table))
2656 (register-system asdf)
2657 ;; If we're in the middle of something, restart it.
2658 (when *systems-being-defined*
2659 (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
2660 (clrhash *systems-being-defined*)
2661 (dolist (s l) (find-system s nil))))
2664 ;;;; Try to upgrade of ASDF. If a different version was used, return T.
2665 ;;;; We need do that before we operate on anything that depends on ASDF.
2666 (defun* upgrade-asdf ()
2667 (let ((version (asdf-version)))
2668 (handler-bind (((or style-warning warning) #'muffle-warning))
2669 (operate 'load-op :asdf :verbose nil))
2670 (cleanup-upgraded-asdf version)))
2672 (defmethod perform-plan ((steps list) &key)
2673 (let ((*package* *package*)
2674 (*readtable* *readtable*))
2675 (with-compilation-unit ()
2676 (loop :for (op . component) :in steps :do
2677 (perform-with-restarts op component)))))
2679 (defmethod operate (operation-class system &rest args
2680 &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2682 (declare (ignore force))
2683 (with-system-definitions ()
2684 (let* ((op (apply 'make-instance operation-class
2685 :original-initargs args
2687 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2688 (system (etypecase system
2690 ((or string symbol) (find-system system)))))
2691 (unless (version-satisfies system version)
2692 (error 'missing-component-of-version :requires system :version version))
2693 (let ((steps (traverse op system)))
2694 (when (and (not (equal '("asdf") (component-find-path system)))
2695 (find '("asdf") (mapcar 'cdr steps)
2696 :test 'equal :key 'component-find-path)
2698 ;; If we needed to upgrade ASDF to achieve our goal,
2699 ;; then do it specially as the first thing, then
2700 ;; invalidate all existing system
2701 ;; retry the whole thing with the new OPERATE function,
2702 ;; which on some implementations
2703 ;; has a new symbol shadowing the current one.
2704 (return-from operate
2705 (apply (find-symbol* 'operate :asdf) operation-class system args)))
2706 (perform-plan steps)
2707 (values op steps)))))
2709 (defun* oos (operation-class system &rest args &key force verbose version
2711 (declare (ignore force verbose version))
2712 (apply 'operate operation-class system args))
2714 (let ((operate-docstring
2715 "Operate does three things:
2717 1. It creates an instance of OPERATION-CLASS using any keyword parameters
2719 2. It finds the asdf-system specified by SYSTEM (possibly loading
2721 3. It then calls TRAVERSE with the operation and system as arguments
2723 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2724 handling code. If a VERSION argument is supplied, then operate also
2725 ensures that the system found satisfies it using the VERSION-SATISFIES
2728 Note that dependencies may cause the operation to invoke other
2729 operations on the system or its components: the new operations will be
2730 created with the same initargs as the original one.
2732 (setf (documentation 'oos 'function)
2734 "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
2736 (setf (documentation 'operate 'function)
2739 (defun* load-system (system &rest args &key force verbose version &allow-other-keys)
2740 "Shorthand for `(operate 'asdf:load-op system)`.
2741 See OPERATE for details."
2742 (declare (ignore force verbose version))
2743 (apply 'operate 'load-op system args)
2746 (defun* load-systems (&rest systems)
2747 (map () 'load-system systems))
2749 (defun component-loaded-p (c)
2750 (and (gethash 'load-op (component-operation-times (find-component c nil))) t))
2752 (defun loaded-systems ()
2753 (remove-if-not 'component-loaded-p (registered-systems)))
2755 (defun require-system (s)
2756 (load-system s :force-not (loaded-systems)))
2758 (defun* compile-system (system &rest args &key force verbose version
2760 "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
2762 (declare (ignore force verbose version))
2763 (apply 'operate 'compile-op system args)
2766 (defun* test-system (system &rest args &key force verbose version
2768 "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
2770 (declare (ignore force verbose version))
2771 (apply 'operate 'test-op system args)
2774 ;;;; -------------------------------------------------------------------------
2777 (defun* load-pathname ()
2778 (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
2780 (defun* determine-system-pathname (pathname)
2781 ;; The defsystem macro calls us to determine
2782 ;; the pathname of a system as follows:
2783 ;; 1. the one supplied,
2784 ;; 2. derived from *load-pathname* via load-pathname
2785 ;; 3. taken from the *default-pathname-defaults* via default-directory
2786 (let* ((file-pathname (load-pathname))
2787 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2788 (or (and pathname (subpathname directory-pathname pathname :type :directory))
2790 (default-directory))))
2792 (defun* find-class* (x &optional (errorp t) environment)
2794 ((or standard-class built-in-class) x)
2795 (symbol (find-class x errorp environment))))
2797 (defun* class-for-type (parent type)
2798 (or (loop :for symbol :in (list
2800 (find-symbol* type *package*)
2801 (find-symbol* type :asdf))
2802 :for class = (and symbol (find-class symbol nil))
2804 (#-cormanlisp subtypep #+cormanlisp cl::subclassp
2805 class (find-class 'component)))
2807 (and (eq type :file)
2809 (or (loop :for module = parent :then (component-parent module) :while module
2810 :thereis (module-default-component-class module))
2811 *default-component-class*) nil))
2812 (sysdef-error "don't recognize component type ~A" type)))
2814 (defun* maybe-add-tree (tree op1 op2 c)
2815 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2816 Returns the new tree (which probably shares structure with the old one)"
2817 (let ((first-op-tree (assoc op1 tree)))
2820 (aif (assoc op2 (cdr first-op-tree))
2821 (if (find c (cdr it) :test #'equal)
2823 (setf (cdr it) (cons c (cdr it))))
2824 (setf (cdr first-op-tree)
2825 (acons op2 (list c) (cdr first-op-tree))))
2827 (acons op1 (list (list op2 c)) tree))))
2829 (defun* union-of-dependencies (&rest deps)
2830 (let ((new-tree nil))
2832 (dolist (op-tree dep)
2833 (dolist (op (cdr op-tree))
2834 (dolist (c (cdr op))
2836 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2840 (defvar *serial-depends-on* nil)
2842 (defun* sysdef-error-component (msg type name value)
2843 (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
2846 (defun* check-component-input (type name weakly-depends-on
2847 depends-on components in-order-to)
2848 "A partial test of the values of a component."
2849 (unless (listp depends-on)
2850 (sysdef-error-component ":depends-on must be a list."
2851 type name depends-on))
2852 (unless (listp weakly-depends-on)
2853 (sysdef-error-component ":weakly-depends-on must be a list."
2854 type name weakly-depends-on))
2855 (unless (listp components)
2856 (sysdef-error-component ":components must be NIL or a list of components."
2857 type name components))
2858 (unless (and (listp in-order-to) (listp (car in-order-to)))
2859 (sysdef-error-component ":in-order-to must be NIL or a list of components."
2860 type name in-order-to)))
2862 (defun* %remove-component-inline-methods (component)
2863 (dolist (name +asdf-methods+)
2865 ;; this is inefficient as most of the stored
2866 ;; methods will not be for this particular gf
2867 ;; But this is hardly performance-critical
2869 (remove-method (symbol-function name) m))
2870 (component-inline-methods component)))
2871 ;; clear methods, then add the new ones
2872 (setf (component-inline-methods component) nil))
2874 (defun* %define-component-inline-methods (ret rest)
2875 (dolist (name +asdf-methods+)
2876 (let ((keyword (intern (symbol-name name) :keyword)))
2877 (loop :for data = rest :then (cddr data)
2878 :for key = (first data)
2879 :for value = (second data)
2881 :when (eq key keyword) :do
2882 (destructuring-bind (op qual (o c) &body body) value
2884 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2886 (component-inline-methods ret)))))))
2888 (defun* %refresh-component-inline-methods (component rest)
2889 (%remove-component-inline-methods component)
2890 (%define-component-inline-methods component rest))
2892 (defun* parse-component-form (parent options)
2894 (type name &rest rest &key
2895 ;; the following list of keywords is reproduced below in the
2896 ;; remove-keys form. important to keep them in sync
2898 perform explain output-files operation-done-p
2899 weakly-depends-on depends-on serial in-order-to
2901 (version nil versionp)
2903 &allow-other-keys) options
2904 (declare (ignorable perform explain output-files operation-done-p))
2905 (check-component-input type name weakly-depends-on depends-on components in-order-to)
2908 (find-component parent name)
2909 ;; ignore the same object when rereading the defsystem
2911 (typep (find-component parent name)
2912 (class-for-type parent type))))
2913 (error 'duplicate-names :name name))
2916 (unless (parse-version version nil)
2917 (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
2918 version name parent)))
2920 (let* ((args (list* :name (coerce-name name)
2924 '(components pathname
2925 perform explain output-files operation-done-p
2926 weakly-depends-on depends-on serial in-order-to)
2928 (ret (find-component parent name)))
2929 (when weakly-depends-on
2930 (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
2931 (when *serial-depends-on*
2932 (push *serial-depends-on* depends-on))
2933 (if ret ; preserve identity
2934 (apply 'reinitialize-instance ret args)
2935 (setf ret (apply 'make-instance (class-for-type parent type) args)))
2936 (component-pathname ret) ; eagerly compute the absolute pathname
2937 (when (typep ret 'module)
2938 (let ((*serial-depends-on* nil))
2939 (setf (module-components ret)
2941 :for c-form :in components
2942 :for c = (parse-component-form ret c-form)
2943 :for name = (component-name c)
2945 :when serial :do (setf *serial-depends-on* name))))
2946 (compute-module-components-by-name ret))
2948 (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2950 (setf (component-in-order-to ret)
2951 (union-of-dependencies
2953 `((compile-op (compile-op ,@depends-on))
2954 (load-op (load-op ,@depends-on)))))
2955 (setf (component-do-first ret)
2956 (union-of-dependencies
2958 `((compile-op (load-op ,@depends-on)))))
2960 (%refresh-component-inline-methods ret rest)
2963 (defun* reset-system (system &rest keys &key &allow-other-keys)
2964 (change-class (change-class system 'proto-system) 'system)
2965 (apply 'reinitialize-instance system keys))
2967 (defun* do-defsystem (name &rest options
2968 &key pathname (class 'system)
2969 defsystem-depends-on &allow-other-keys)
2970 ;; The system must be registered before we parse the body,
2971 ;; otherwise we recur when trying to find an existing system
2972 ;; of the same name to reuse options (e.g. pathname) from.
2973 ;; To avoid infinite recursion in cases where you defsystem a system
2974 ;; that is registered to a different location to find-system,
2975 ;; we also need to remember it in a special variable *systems-being-defined*.
2976 (with-system-definitions ()
2977 (let* ((name (coerce-name name))
2978 (registered (system-registered-p name))
2979 (registered! (if registered
2980 (rplaca registered (get-universal-time))
2981 (register-system (make-instance 'system :name name))))
2982 (system (reset-system (cdr registered!)
2983 :name name :source-file (load-pathname)))
2984 (component-options (remove-keys '(:class) options)))
2985 (setf (gethash name *systems-being-defined*) system)
2986 (apply 'load-systems defsystem-depends-on)
2987 ;; We change-class (when necessary) AFTER we load the defsystem-dep's
2988 ;; since the class might not be defined as part of those.
2989 (let ((class (class-for-type nil class)))
2990 (unless (eq (type-of system) class)
2991 (change-class system class)))
2992 (parse-component-form
2995 :pathname (determine-system-pathname pathname)
2996 component-options)))))
2998 (defmacro defsystem (name &body options)
2999 `(apply 'do-defsystem ',name ',options))
3001 ;;;; ---------------------------------------------------------------------------
3002 ;;;; run-shell-command
3004 ;;;; run-shell-command functions for other lisp implementations will be
3005 ;;;; gratefully accepted, if they do the same thing.
3006 ;;;; If the docstring is ambiguous, send a bug report.
3008 ;;;; WARNING! The function below is mostly dysfunctional.
3009 ;;;; For instance, it will probably run fine on most implementations on Unix,
3010 ;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
3011 ;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
3012 ;;;; But behavior on Windows may vary wildly between implementations,
3013 ;;;; either relying on your having installed a POSIX sh, or going through
3014 ;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
3015 ;;;; what is easily expressible in said implementation.
3017 ;;;; We probably should move this functionality to its own system and deprecate
3018 ;;;; use of it from the asdf package. However, this would break unspecified
3019 ;;;; existing software, so until a clear alternative exists, we can't deprecate
3020 ;;;; it, and even after it's been deprecated, we will support it for a few
3021 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
3023 ;;;; As a suggested replacement which is portable to all ASDF-supported
3024 ;;;; implementations and operating systems except Genera, I recommend
3025 ;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
3027 (defun* run-shell-command (control-string &rest args)
3028 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
3029 synchronously execute the result using a Bourne-compatible shell, with
3030 output to *VERBOSE-OUT*. Returns the shell's exit code."
3031 (let ((command (apply 'format nil control-string args)))
3032 (asdf-message "; $ ~A~%" command)
3035 (ext:run-shell-command command :output *verbose-out*)
3038 ;; will this fail if command has embedded quotes - it seems to work
3039 (multiple-value-bind (stdout stderr exit-code)
3040 (excl.osi:command-output
3041 #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
3042 #+mswindows command ; BEWARE!
3043 :input nil :whole nil
3044 #+mswindows :show-window #+mswindows :hide)
3045 (asdf-message "~{~&~a~%~}~%" stderr)
3046 (asdf-message "~{~&~a~%~}~%" stdout)
3050 ;; CLISP returns NIL for exit status zero.
3052 (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
3054 (outstream (ext:run-shell-command new-command :output :stream :wait t)))
3055 (multiple-value-bind (retval out-lines)
3057 (parse-clisp-shell-output outstream)
3058 (ignore-errors (close outstream)))
3059 (asdf-message "~{~&~a~%~}~%" out-lines)
3061 ;; there will be no output, just grab up the exit status
3062 (or (ext:run-shell-command command :output nil :wait t) 0))
3066 (ccl:external-process-status
3069 ((os-unix-p) "/bin/sh")
3070 ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
3071 (t (error "Unsupported OS")))
3072 (if (os-unix-p) (list "-c" command) '())
3073 :input nil :output *verbose-out* :wait t)))
3076 (ext:process-exit-code
3080 :input nil :output *verbose-out*))
3083 (win32:system command)
3085 #+ecl ;; courtesy of Juan Jose Garcia Ripoll
3086 (ext:system command)
3089 (lisp:system command)
3092 (apply 'system:call-system-showing-output command
3093 :show-cmd nil :prefix "" :output-stream *verbose-out*
3094 (when (os-unix-p) '(:shell-type "/bin/sh")))
3097 (ccl::with-cstrs ((%command command)) (_system %command))
3100 (sb-ext:process-exit-code
3101 (apply 'sb-ext:run-program
3102 #+win32 "sh" #-win32 "/bin/sh"
3104 :input nil :output *verbose-out*
3105 #+win32 '(:search t) #-win32 nil))
3108 (ext:run-shell-command command)
3110 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
3111 (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
3114 (defun* parse-clisp-shell-output (stream)
3115 "Helper function for running shell commands under clisp. Parses a specially-
3116 crafted output string to recover the exit status of the shell command and a
3117 list of lines of output."
3118 (loop :with status-prefix = "ASDF-EXIT-STATUS "
3119 :with prefix-length = (length status-prefix)
3120 :with exit-status = -1 :with lines = ()
3121 :for line = (read-line stream nil nil)
3122 :while line :do (push line lines) :finally
3123 (let* ((last (car lines))
3124 (status (and last (>= (length last) prefix-length)
3125 (string-equal last status-prefix :end1 prefix-length)
3126 (parse-integer last :start prefix-length :junk-allowed t))))
3128 (setf exit-status status)
3129 (pop lines) (when (equal "" (car lines)) (pop lines)))
3130 (return (values exit-status (reverse lines))))))
3132 ;;;; ---------------------------------------------------------------------------
3133 ;;;; system-relative-pathname
3135 (defun* system-definition-pathname (x)
3136 ;; As of 2.014.8, we mean to make this function obsolete,
3137 ;; but that won't happen until all clients have been updated.
3138 ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
3139 "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
3140 It used to expose ASDF internals with subtle differences with respect to
3141 user expectations, that have been refactored away since.
3142 We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
3143 for a mostly compatible replacement that we're supporting,
3144 or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
3145 if that's whay you mean." ;;)
3146 (system-source-file x))
3148 (defmethod system-source-file ((system system))
3149 ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
3150 (unless (slot-boundp system 'source-file)
3151 (%set-system-source-file
3152 (probe-asd (component-name system) (component-pathname system)) system))
3153 (%system-source-file system))
3154 (defmethod system-source-file ((system-name string))
3155 (%system-source-file (find-system system-name)))
3156 (defmethod system-source-file ((system-name symbol))
3157 (%system-source-file (find-system system-name)))
3159 (defun* system-source-directory (system-designator)
3160 "Return a pathname object corresponding to the
3161 directory in which the system specification (.asd file) is
3163 (pathname-directory-pathname (system-source-file system-designator)))
3165 (defun* relativize-directory (directory)
3167 ((stringp directory)
3168 (list :relative directory))
3169 ((eq (car directory) :absolute)
3170 (cons :relative (cdr directory)))
3174 (defun* relativize-pathname-directory (pathspec)
3175 (let ((p (pathname pathspec)))
3177 :directory (relativize-directory (pathname-directory p))
3180 (defun* system-relative-pathname (system name &key type)
3181 (subpathname (system-source-directory system) name :type type))
3184 ;;; ---------------------------------------------------------------------------
3185 ;;; implementation-identifier
3187 ;;; produce a string to identify current implementation.
3188 ;;; Initially stolen from SLIME's SWANK, rewritten since.
3189 ;;; We're back to runtime checking, for the sake of e.g. ABCL.
3191 (defun* first-feature (features)
3192 (dolist (x features)
3193 (multiple-value-bind (val feature)
3194 (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
3195 (when (featurep feature) (return val)))))
3197 (defun implementation-type ()
3199 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
3200 :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
3202 (defun operating-system ()
3204 '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
3205 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
3206 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
3207 (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
3210 (defun architecture ()
3212 '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
3213 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
3214 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
3215 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
3216 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
3217 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
3218 ;; we may have to segregate the code still by architecture.
3219 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
3222 (defun* ccl-fasl-version ()
3223 ;; the fasl version is target-dependent from CCL 1.8 on.
3224 (or (let ((s 'ccl::target-fasl-version))
3225 (and (fboundp s) (funcall s)))
3226 (and (boundp 'ccl::fasl-version)
3227 (symbol-value 'ccl::fasl-version))
3228 (error "Can't determine fasl version.")))
3230 (defun lisp-version-string ()
3231 (let ((s (lisp-implementation-version)))
3232 (car ; as opposed to OR, this idiom prevents some unreachable code warning
3235 (format nil "~A~A~@[~A~]"
3236 excl::*common-lisp-version-number*
3237 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
3238 (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
3239 ;; Note if not using International ACL
3240 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
3241 (excl:ics-target-case (:-ics "8")))
3242 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
3244 (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
3246 (format nil "~d.~d-f~d" ; shorten for windows
3247 ccl::*openmcl-major-version*
3248 ccl::*openmcl-minor-version*
3249 (logand (ccl-fasl-version) #xFF))
3250 #+cmu (substitute #\- #\/ s)
3251 #+scl (format nil "~A~A" s
3252 ;; ANSI upper case vs lower case.
3253 (ecase ext:*case-mode* (:upper "") (:lower "l")))
3254 #+ecl (format nil "~A~@[-~A~]" s
3255 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
3256 (subseq vcs-id 0 (min (length vcs-id) 8))))
3257 #+gcl (subseq s (1+ (position #\space s)))
3259 (multiple-value-bind (major minor) (sct:get-system-version "System")
3260 (format nil "~D.~D" major minor))
3261 #+mcl (subseq s 8) ; strip the leading "Version "
3264 (defun* implementation-identifier ()
3266 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
3267 (format nil "~(~a~@{~@[-~a~]~}~)"
3268 (or (implementation-type) (lisp-implementation-type))
3269 (or (lisp-version-string) (lisp-implementation-version))
3270 (or (operating-system) (software-type))
3271 (or (architecture) (machine-type)))))
3274 ;; Note: untested on RMCL
3275 #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance)
3276 #+cormanlisp "localhost" ;; is there a better way? Does it matter?
3277 #+allegro (excl.osi:gethostname)
3278 #+clisp (first (split-string (machine-instance) :separator " "))
3279 #+gcl (system:gethostname))
3282 ;;; ---------------------------------------------------------------------------
3283 ;;; Generic support for configuration files
3285 (defun inter-directory-separator ()
3286 (if (os-unix-p) #\: #\;))
3288 (defun* user-homedir ()
3290 (pathname-directory-pathname
3291 #+mcl (current-user-homedir-pathname)
3292 #-mcl (user-homedir-pathname))))
3294 (defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
3295 (when (plusp (length x))
3296 (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
3298 (unless (absolute-pathname-p p)
3299 (cerror "ignore relative pathname"
3300 "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
3301 (return-from ensure-pathname* nil)))
3303 (defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
3304 (loop :for dir :in (split-string
3305 x :separator (string (inter-directory-separator)))
3306 :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
3307 (defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
3308 (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
3309 (defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
3310 (and (plusp (length s))
3311 (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
3312 (defun getenv-absolute-directory (x)
3313 (getenv-pathname x :want-absolute t :want-directory t))
3314 (defun getenv-absolute-directories (x)
3315 (getenv-pathnames x :want-absolute t :want-directory t))
3318 (defun* user-configuration-directories ()
3320 `(,@(when (os-unix-p)
3322 (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
3323 (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
3324 :collect (subpathname* dir "common-lisp/"))))
3325 ,@(when (os-windows-p)
3326 `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
3327 (getenv-absolute-directory "LOCALAPPDATA"))
3328 "common-lisp/config/")
3329 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
3330 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
3331 (getenv-absolute-directory "APPDATA"))
3332 "common-lisp/config/")))
3333 ,(subpathname (user-homedir) ".config/common-lisp/"))))
3334 (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
3335 :from-end t :test 'equal)))
3337 (defun* system-configuration-directories ()
3339 ((os-unix-p) '(#p"/etc/common-lisp/"))
3342 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
3343 (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
3344 (getenv-absolute-directory "ALLUSERSAPPDATA")
3345 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))
3346 "common-lisp/config/")
3349 (defun* in-first-directory (dirs x &key (direction :input))
3350 (loop :with fun = (ecase direction
3351 ((nil :input :probe) 'probe-file*)
3352 ((:output :io) 'identity))
3354 :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
3356 (defun* in-user-configuration-directory (x &key (direction :input))
3357 (in-first-directory (user-configuration-directories) x :direction direction))
3358 (defun* in-system-configuration-directory (x &key (direction :input))
3359 (in-first-directory (system-configuration-directories) x :direction direction))
3361 (defun* configuration-inheritance-directive-p (x)
3362 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
3364 (and (length=n-p x 1) (member (car x) kw)))))
3366 (defun* report-invalid-form (reporter &rest args)
3369 (apply 'error 'invalid-configuration args))
3371 (apply reporter args))
3373 (apply 'error reporter args))
3375 (apply 'apply (append reporter args)))))
3377 (defvar *ignored-configuration-form* nil)
3379 (defun* validate-configuration-form (form tag directive-validator
3380 &key location invalid-form-reporter)
3381 (unless (and (consp form) (eq (car form) tag))
3382 (setf *ignored-configuration-form* t)
3383 (report-invalid-form invalid-form-reporter :form form :location location)
3384 (return-from validate-configuration-form nil))
3385 (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
3386 :for directive :in (cdr form)
3388 ((configuration-inheritance-directive-p directive)
3390 ((eq directive :ignore-invalid-entries)
3391 (setf ignore-invalid-p t) t)
3392 ((funcall directive-validator directive)
3397 (setf *ignored-configuration-form* t)
3398 (report-invalid-form invalid-form-reporter :form directive :location location)
3400 :do (push directive x)
3402 (unless (= inherit 1)
3403 (report-invalid-form invalid-form-reporter
3404 :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
3405 :inherit-configuration :ignore-inherited-configuration)))
3406 (return (nreverse x))))
3408 (defun* validate-configuration-file (file validator &key description)
3409 (let ((forms (read-file-forms file)))
3410 (unless (length=n-p forms 1)
3411 (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
3413 (funcall validator (car forms) :location file)))
3415 (defun* hidden-file-p (pathname)
3416 (equal (first-char (pathname-name pathname)) #\.))
3418 (defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
3419 (apply 'directory pathname-spec
3420 (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3421 #+clozure '(:follow-links nil)
3422 #+clisp '(:circle t :if-does-not-exist :ignore)
3423 #+(or cmu scl) '(:follow-links nil :truenamep nil)
3424 #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
3425 '(:resolve-symlinks nil))))))
3427 (defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
3428 "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
3429 be applied to the results to yield a configuration form. Current
3430 values of TAG include :source-registry and :output-translations."
3431 (let ((files (sort (ignore-errors
3434 (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
3435 #'string< :key #'namestring)))
3437 ,@(loop :for file :in files :append
3438 (loop :with ignore-invalid-p = nil
3439 :for form :in (read-file-forms file)
3440 :when (eq form :ignore-invalid-entries)
3441 :do (setf ignore-invalid-p t)
3443 :when (funcall validator form)
3446 :when ignore-invalid-p
3447 :do (setf *ignored-configuration-form* t)
3449 :do (report-invalid-form invalid-form-reporter :form form :location file)))
3450 :inherit-configuration)))
3453 ;;; ---------------------------------------------------------------------------
3454 ;;; asdf-output-translations
3456 ;;; this code is heavily inspired from
3457 ;;; asdf-binary-translations, common-lisp-controller and cl-launch.
3458 ;;; ---------------------------------------------------------------------------
3460 (defvar *output-translations* ()
3461 "Either NIL (for uninitialized), or a list of one element,
3462 said element itself being a sorted list of mappings.
3463 Each mapping is a pair of a source pathname and destination pathname,
3464 and the order is by decreasing length of namestring of the source pathname.")
3466 (defvar *user-cache*
3467 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
3469 (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
3470 (when (os-windows-p)
3471 (try (or #+lispworks (sys:get-folder-path :local-appdata)
3472 (getenv-absolute-directory "LOCALAPPDATA")
3473 #+lispworks (sys:get-folder-path :appdata)
3474 (getenv-absolute-directory "APPDATA"))
3475 "common-lisp" "cache" :implementation))
3476 '(:home ".cache" "common-lisp" :implementation))))
3478 (defun* output-translations ()
3479 (car *output-translations*))
3481 (defun* (setf output-translations) (new-value)
3482 (setf *output-translations*
3484 (stable-sort (copy-list new-value) #'>
3489 (let ((directory (pathname-directory (car x))))
3490 (if (listp directory) (length directory) 0))))))))
3493 (defun* output-translations-initialized-p ()
3494 (and *output-translations* t))
3496 (defun* clear-output-translations ()
3497 "Undoes any initialization of the output translations.
3498 You might want to call that before you dump an image that would be resumed
3499 with a different configuration, so the configuration would be re-read then."
3500 (setf *output-translations* '())
3503 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
3504 (values (or null pathname) &optional))
3507 (defun* resolve-relative-location-component (x &key directory wilden)
3508 (let ((r (etypecase x
3510 (string (coerce-pathname x :type (when directory :directory)))
3513 (resolve-relative-location-component
3514 (car x) :directory directory :wilden wilden)
3515 (let* ((car (resolve-relative-location-component
3516 (car x) :directory t :wilden nil)))
3518 (resolve-relative-location-component
3519 (cdr x) :directory directory :wilden wilden)
3521 ((eql :default-directory)
3522 (relativize-pathname-directory (default-directory)))
3523 ((eql :*/) *wild-directory*)
3524 ((eql :**/) *wild-inferiors*)
3525 ((eql :*.*.*) *wild-file*)
3526 ((eql :implementation)
3527 (coerce-pathname (implementation-identifier) :type :directory))
3528 ((eql :implementation-type)
3529 (coerce-pathname (string-downcase (implementation-type)) :type :directory))
3531 (coerce-pathname (hostname) :type :directory)))))
3532 (when (absolute-pathname-p r)
3533 (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
3534 (if (or (pathnamep x) (not wilden)) r (wilden r))))
3536 (defvar *here-directory* nil
3537 "This special variable is bound to the currect directory during calls to
3538 PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
3541 (defun* resolve-absolute-location-component (x &key directory wilden)
3545 (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
3546 #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
3547 (if directory (ensure-directory-pathname p) p)))
3549 (return-from resolve-absolute-location-component
3551 (resolve-absolute-location-component
3552 (car x) :directory directory :wilden wilden)
3554 (resolve-relative-location-component
3555 (cdr x) :directory directory :wilden wilden)
3556 (resolve-absolute-location-component
3557 (car x) :directory t :wilden nil)))))
3559 ;; special magic! we encode such paths as relative pathnames,
3560 ;; but it means "relative to the root of the source pathname's host and device".
3561 (return-from resolve-absolute-location-component
3562 (let ((p (make-pathname :directory '(:relative))))
3563 (if wilden (wilden p) p))))
3564 ((eql :home) (user-homedir))
3566 (resolve-location (or *here-directory*
3567 ;; give semantics in the case of use interactively
3569 :directory t :wilden nil))
3570 ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
3571 ((eql :system-cache)
3572 (error "Using the :system-cache is deprecated. ~%~
3573 Please remove it from your ASDF configuration"))
3574 ((eql :default-directory) (default-directory))))
3575 (s (if (and wilden (not (pathnamep x)))
3578 (unless (absolute-pathname-p s)
3579 (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
3582 (defun* resolve-location (x &key directory wilden)
3584 (resolve-absolute-location-component x :directory directory :wilden wilden)
3585 (loop :with path = (resolve-absolute-location-component
3586 (car x) :directory (and (or directory (cdr x)) t)
3587 :wilden (and wilden (null (cdr x))))
3588 :for (component . morep) :on (cdr x)
3589 :for dir = (and (or morep directory) t)
3590 :for wild = (and wilden (not morep))
3591 :do (setf path (merge-pathnames*
3592 (resolve-relative-location-component
3593 component :directory dir :wilden wild)
3595 :finally (return path))))
3597 (defun* location-designator-p (x)
3598 (flet ((absolute-component-p (c)
3599 (typep c '(or string pathname
3600 (member :root :home :here :user-cache :system-cache :default-directory))))
3601 (relative-component-p (c)
3602 (typep c '(or string pathname
3603 (member :default-directory :*/ :**/ :*.*.*
3604 :implementation :implementation-type)))))
3605 (or (typep x 'boolean)
3606 (absolute-component-p x)
3607 (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
3609 (defun* location-function-p (x)
3612 (eq (car x) :function)
3613 (or (symbolp (cadr x))
3614 (and (consp (cadr x))
3615 (eq (caadr x) 'lambda)
3616 (length=n-p (cadadr x) 2)))))
3618 (defun* validate-output-translations-directive (directive)
3619 (or (member directive '(:enable-user-cache :disable-cache nil))
3620 (and (consp directive)
3621 (or (and (length=n-p directive 2)
3622 (or (and (eq (first directive) :include)
3623 (typep (second directive) '(or string pathname null)))
3624 (and (location-designator-p (first directive))
3625 (or (location-designator-p (second directive))
3626 (location-function-p (second directive))))))
3627 (and (length=n-p directive 1)
3628 (location-designator-p (first directive)))))))
3630 (defun* validate-output-translations-form (form &key location)
3631 (validate-configuration-form
3633 :output-translations
3634 'validate-output-translations-directive
3635 :location location :invalid-form-reporter 'invalid-output-translation))
3637 (defun* validate-output-translations-file (file)
3638 (validate-configuration-file
3639 file 'validate-output-translations-form :description "output translations"))
3641 (defun* validate-output-translations-directory (directory)
3642 (validate-configuration-directory
3643 directory :output-translations 'validate-output-translations-directive
3644 :invalid-form-reporter 'invalid-output-translation))
3646 (defun* parse-output-translations-string (string &key location)
3648 ((or (null string) (equal string ""))
3649 '(:output-translations :inherit-configuration))
3650 ((not (stringp string))
3651 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
3652 ((eql (char string 0) #\")
3653 (parse-output-translations-string (read-from-string string) :location location))
3654 ((eql (char string 0) #\()
3655 (validate-output-translations-form (read-from-string string) :location location))
3659 :with directives = ()
3661 :with end = (length string)
3663 :with separator = (inter-directory-separator)
3664 :for i = (or (position separator string :start start) end) :do
3665 (let ((s (subseq string start i)))
3668 (push (list source (if (equal "" s) nil s)) directives)
3672 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
3675 (push :inherit-configuration directives))
3681 (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
3684 (push :ignore-inherited-configuration directives))
3685 (return `(:output-translations ,@(nreverse directives)))))))))
3687 (defparameter *default-output-translations*
3688 '(environment-output-translations
3689 user-output-translations-pathname
3690 user-output-translations-directory-pathname
3691 system-output-translations-pathname
3692 system-output-translations-directory-pathname))
3694 (defun* wrapping-output-translations ()
3695 `(:output-translations
3696 ;; Some implementations have precompiled ASDF systems,
3697 ;; so we must disable translations for implementation paths.
3698 #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
3699 (when h `((,(truenamize h) ,*wild-inferiors*) ())))
3700 ;; The below two are not needed: no precompiled ASDF system there
3701 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
3702 ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
3703 ;; All-import, here is where we want user stuff to be:
3704 :inherit-configuration
3705 ;; These are for convenience, and can be overridden by the user:
3706 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
3707 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
3708 ;; We enable the user cache by default, and here is the place we do:
3709 :enable-user-cache))
3711 (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
3712 (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
3714 (defun* user-output-translations-pathname (&key (direction :input))
3715 (in-user-configuration-directory *output-translations-file* :direction direction))
3716 (defun* system-output-translations-pathname (&key (direction :input))
3717 (in-system-configuration-directory *output-translations-file* :direction direction))
3718 (defun* user-output-translations-directory-pathname (&key (direction :input))
3719 (in-user-configuration-directory *output-translations-directory* :direction direction))
3720 (defun* system-output-translations-directory-pathname (&key (direction :input))
3721 (in-system-configuration-directory *output-translations-directory* :direction direction))
3722 (defun* environment-output-translations ()
3723 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
3725 (defgeneric* process-output-translations (spec &key inherit collect))
3726 (declaim (ftype (function (t &key (:collect (or symbol function))) t)
3727 inherit-output-translations))
3728 (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
3729 process-output-translations-directive))
3731 (defmethod process-output-translations ((x symbol) &key
3732 (inherit *default-output-translations*)
3734 (process-output-translations (funcall x) :inherit inherit :collect collect))
3735 (defmethod process-output-translations ((pathname pathname) &key inherit collect)
3737 ((directory-pathname-p pathname)
3738 (process-output-translations (validate-output-translations-directory pathname)
3739 :inherit inherit :collect collect))
3740 ((probe-file* pathname)
3741 (process-output-translations (validate-output-translations-file pathname)
3742 :inherit inherit :collect collect))
3744 (inherit-output-translations inherit :collect collect))))
3745 (defmethod process-output-translations ((string string) &key inherit collect)
3746 (process-output-translations (parse-output-translations-string string)
3747 :inherit inherit :collect collect))
3748 (defmethod process-output-translations ((x null) &key inherit collect)
3749 (declare (ignorable x))
3750 (inherit-output-translations inherit :collect collect))
3751 (defmethod process-output-translations ((form cons) &key inherit collect)
3752 (dolist (directive (cdr (validate-output-translations-form form)))
3753 (process-output-translations-directive directive :inherit inherit :collect collect)))
3755 (defun* inherit-output-translations (inherit &key collect)
3757 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
3759 (defun* process-output-translations-directive (directive &key inherit collect)
3760 (if (atom directive)
3762 ((:enable-user-cache)
3763 (process-output-translations-directive '(t :user-cache) :collect collect))
3765 (process-output-translations-directive '(t t) :collect collect))
3766 ((:inherit-configuration)
3767 (inherit-output-translations inherit :collect collect))
3768 ((:ignore-inherited-configuration :ignore-invalid-entries nil)
3770 (let ((src (first directive))
3771 (dst (second directive)))
3772 (if (eq src :include)
3774 (process-output-translations (pathname dst) :inherit nil :collect collect))
3776 (let ((trusrc (or (eql src t)
3777 (let ((loc (resolve-location src :directory t :wilden t)))
3778 (if (absolute-pathname-p loc) (truenamize loc) loc)))))
3780 ((location-function-p dst)
3783 (if (symbolp (second dst))
3784 (fdefinition (second dst))
3785 (eval (second dst))))))
3787 (funcall collect (list trusrc t)))
3789 (let* ((trudst (if dst
3790 (resolve-location dst :directory t :wilden t)
3792 (wilddst (merge-pathnames* *wild-file* trudst)))
3793 (funcall collect (list wilddst t))
3794 (funcall collect (list trusrc trudst)))))))))))
3796 (defun* compute-output-translations (&optional parameter)
3797 "read the configuration, return it"
3799 (while-collecting (c)
3800 (inherit-output-translations
3801 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
3802 :test 'equal :from-end t))
3804 (defvar *output-translations-parameter* nil)
3806 (defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
3807 "read the configuration, initialize the internal configuration variable,
3808 return the configuration"
3809 (setf *output-translations-parameter* parameter
3810 (output-translations) (compute-output-translations parameter)))
3812 (defun* disable-output-translations ()
3813 "Initialize output translations in a way that maps every file to itself,
3814 effectively disabling the output translation facility."
3815 (initialize-output-translations
3816 '(:output-translations :disable-cache :ignore-inherited-configuration)))
3818 ;; checks an initial variable to see whether the state is initialized
3819 ;; or cleared. In the former case, return current configuration; in
3820 ;; the latter, initialize. ASDF will call this function at the start
3821 ;; of (asdf:find-system).
3822 (defun* ensure-output-translations ()
3823 (if (output-translations-initialized-p)
3824 (output-translations)
3825 (initialize-output-translations)))
3827 (defun* translate-pathname* (path absolute-source destination &optional root source)
3828 (declare (ignore source))
3830 ((functionp destination)
3831 (funcall destination path absolute-source))
3834 ((not (pathnamep destination))
3835 (error "Invalid destination"))
3836 ((not (absolute-pathname-p destination))
3837 (translate-pathname path absolute-source (merge-pathnames* destination root)))
3839 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3841 (translate-pathname path absolute-source destination))))
3843 (defun* apply-output-translations (path)
3844 #+cormanlisp (truenamize path) #-cormanlisp
3848 ((or pathname string)
3849 (ensure-output-translations)
3850 (loop :with p = (truenamize path)
3851 :for (source destination) :in (car *output-translations*)
3852 :for root = (when (or (eq source t)
3853 (and (pathnamep source)
3854 (not (absolute-pathname-p source))))
3856 :for absolute-source = (cond
3857 ((eq source t) (wilden root))
3858 (root (merge-pathnames* source root))
3860 :when (or (eq source t) (pathname-match-p p absolute-source))
3861 :return (translate-pathname* p absolute-source destination root source)
3862 :finally (return p)))))
3864 (defmethod output-files :around (operation component)
3865 "Translate output files, unless asked not to"
3866 operation component ;; hush genera, not convinced by declare ignorable(!)
3868 (multiple-value-bind (files fixedp) (call-next-method)
3871 (mapcar #'apply-output-translations files)))
3874 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3875 (if (absolute-pathname-p output-file)
3876 ;; what cfp should be doing, w/ mp* instead of mp
3877 (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
3878 (defaults (make-pathname
3879 :type type :defaults (merge-pathnames* input-file))))
3880 (merge-pathnames* output-file defaults))
3881 (apply-output-translations
3882 (apply 'compile-file-pathname input-file keys))))
3884 (defun* tmpize-pathname (x)
3886 :name (strcat "ASDF-TMP-" (pathname-name x))
3889 (defun* delete-file-if-exists (x)
3890 (when (and x (probe-file* x))
3893 (defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
3894 (let* ((keywords (remove-keyword :compile-check keys))
3895 (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
3896 (tmp-file (tmpize-pathname output-file))
3898 (multiple-value-bind (output-truename warnings-p failure-p)
3899 (apply 'compile-file input-file :output-file tmp-file keywords)
3902 (setf status *compile-file-failure-behaviour*))
3904 (setf status *compile-file-warnings-behaviour*))
3906 (setf status :success)))
3909 ((:success :warn :ignore) t)
3911 (or (not compile-check)
3912 (apply compile-check input-file :output-file tmp-file keywords)))
3913 (delete-file-if-exists output-file)
3914 (when output-truename
3915 (rename-file output-truename output-file)
3916 (setf output-truename output-file)))
3917 (t ;; error or failed check
3918 (delete-file-if-exists output-truename)
3919 (setf output-truename nil failure-p t)))
3920 (values output-truename warnings-p failure-p))))
3923 (defun* translate-jar-pathname (source wildcard)
3924 (declare (ignore wildcard))
3925 (let* ((p (pathname (first (pathname-device source))))
3926 (root (format nil "/___jar___file___root___/~@[~A/~]"
3927 (and (find :windows *features*)
3928 (pathname-device p)))))
3929 (apply-output-translations
3931 (relativize-pathname-directory source)
3933 (relativize-pathname-directory (ensure-directory-pathname p))
3936 ;;;; -----------------------------------------------------------------
3937 ;;;; Compatibility mode for ASDF-Binary-Locations
3939 (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
3940 (declare (ignorable operation-class system args))
3941 (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
3942 (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
3943 ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
3944 which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
3945 and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
3946 In case you insist on preserving your previous A-B-L configuration, but
3947 do not know how to achieve the same effect with A-O-T, you may use function
3948 ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
3949 call that function where you would otherwise have loaded and configured A-B-L.")))
3951 (defun* enable-asdf-binary-locations-compatibility
3953 (centralize-lisp-binaries nil)
3954 (default-toplevel-directory
3955 (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
3956 (include-per-user-information nil)
3957 (map-all-source-files (or #+(or ecl clisp) t nil))
3958 (source-to-target-mappings nil))
3960 (when (null map-all-source-files)
3961 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3962 (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3963 (mapped-files (if map-all-source-files *wild-file*
3964 (make-pathname :type fasl-type :defaults *wild-file*)))
3965 (destination-directory
3966 (if centralize-lisp-binaries
3967 `(,default-toplevel-directory
3968 ,@(when include-per-user-information
3969 (cdr (pathname-directory (user-homedir))))
3970 :implementation ,*wild-inferiors*)
3971 `(:root ,*wild-inferiors* :implementation))))
3972 (initialize-output-translations
3973 `(:output-translations
3974 ,@source-to-target-mappings
3975 ((:root ,*wild-inferiors* ,mapped-files)
3976 (,@destination-directory ,mapped-files))
3978 :ignore-inherited-configuration))))
3980 ;;;; -----------------------------------------------------------------
3981 ;;;; Source Registry Configuration, by Francois-Rene Rideau
3982 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3984 ;; Using ack 1.2 exclusions
3985 (defvar *default-source-registry-exclusions*
3987 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3988 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3989 "_sgbak" "autom4te.cache" "cover_db" "_build"
3990 "debian")) ;; debian often builds stuff under the debian directory... BAD.
3992 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3994 (defvar *source-registry* nil
3995 "Either NIL (for uninitialized), or an equal hash-table, mapping
3996 system names to pathnames of .asd files")
3998 (defun* source-registry-initialized-p ()
3999 (typep *source-registry* 'hash-table))
4001 (defun* clear-source-registry ()
4002 "Undoes any initialization of the source registry.
4003 You might want to call that before you dump an image that would be resumed
4004 with a different configuration, so the configuration would be re-read then."
4005 (setf *source-registry* nil)
4008 (defparameter *wild-asd*
4009 (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
4011 (defun* filter-logical-directory-results (directory entries merger)
4012 (if (typep directory 'logical-pathname)
4013 ;; Try hard to not resolve logical-pathname into physical pathnames;
4014 ;; otherwise logical-pathname users/lovers will be disappointed.
4015 ;; If directory* could use some implementation-dependent magic,
4016 ;; we will have logical pathnames already; otherwise,
4017 ;; we only keep pathnames for which specifying the name and
4018 ;; translating the LPN commute.
4019 (loop :for f :in entries
4020 :for p = (or (and (typep f 'logical-pathname) f)
4021 (let* ((u (ignore-errors (funcall merger f))))
4022 ;; The first u avoids a cumbersome (truename u) error.
4023 ;; At this point f should already be a truename,
4024 ;; but isn't quite in CLISP, for doesn't have :version :newest
4025 (and u (equal (ignore-errors (truename u)) (truename f)) u)))
4029 (defun* directory-files (directory &optional (pattern *wild-file*))
4030 (let ((dir (pathname directory)))
4031 (when (typep dir 'logical-pathname)
4032 ;; Because of the filtering we do below,
4033 ;; logical pathnames have restrictions on wild patterns.
4034 ;; Not that the results are very portable when you use these patterns on physical pathnames.
4035 (when (wild-pathname-p dir)
4036 (error "Invalid wild pattern in logical directory ~S" directory))
4037 (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
4038 (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
4039 (setf pattern (make-pathname-logical pattern (pathname-host dir))))
4040 (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
4041 (filter-logical-directory-results
4044 (make-pathname :defaults dir
4045 :name (make-pathname-component-logical (pathname-name f))
4046 :type (make-pathname-component-logical (pathname-type f))
4047 :version (make-pathname-component-logical (pathname-version f))))))))
4049 (defun* directory-asd-files (directory)
4050 (directory-files directory *wild-asd*))
4052 (defun* subdirectories (directory)
4053 (let* ((directory (ensure-directory-pathname directory))
4054 #-(or abcl cormanlisp genera xcl)
4055 (wild (merge-pathnames*
4056 #-(or abcl allegro cmu lispworks sbcl scl xcl)
4058 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
4061 #-(or abcl cormanlisp genera xcl)
4063 (directory* wild . #.(or #+clozure '(:directories t :files nil)
4064 #+mcl '(:directories t))))
4065 #+(or abcl xcl) (system:list-directory directory)
4066 #+cormanlisp (cl::directory-subdirs directory)
4067 #+genera (fs:directory-list directory))
4068 #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
4069 (dirs (loop :for x :in dirs
4070 :for d = #+(or abcl xcl) (extensions:probe-directory x)
4071 #+allegro (excl:probe-directory x)
4072 #+(or cmu sbcl scl) (directory-pathname-p x)
4073 #+genera (getf (cdr x) :directory)
4074 #+lispworks (lw:file-directory-p x)
4075 :when d :collect #+(or abcl allegro xcl) d
4076 #+genera (ensure-directory-pathname (first x))
4077 #+(or cmu lispworks sbcl scl) x)))
4078 (filter-logical-directory-results
4080 (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
4081 '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
4083 (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
4084 (and (consp dir) (consp (cdr dir))
4086 :defaults directory :name nil :type nil :version nil
4087 :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
4089 (defun* collect-asds-in-directory (directory collect)
4090 (map () collect (directory-asd-files directory)))
4092 (defun* collect-sub*directories (directory collectp recursep collector)
4093 (when (funcall collectp directory)
4094 (funcall collector directory))
4095 (dolist (subdir (subdirectories directory))
4096 (when (funcall recursep subdir)
4097 (collect-sub*directories subdir collectp recursep collector))))
4099 (defun* collect-sub*directories-asd-files
4101 (exclude *default-source-registry-exclusions*)
4103 (collect-sub*directories
4106 #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
4107 #'(lambda (dir) (collect-asds-in-directory dir collect))))
4109 (defun* validate-source-registry-directive (directive)
4110 (or (member directive '(:default-registry))
4111 (and (consp directive)
4112 (let ((rest (rest directive)))
4113 (case (first directive)
4114 ((:include :directory :tree)
4115 (and (length=n-p rest 1)
4116 (location-designator-p (first rest))))
4117 ((:exclude :also-exclude)
4118 (every #'stringp rest))
4119 ((:default-registry)
4122 (defun* validate-source-registry-form (form &key location)
4123 (validate-configuration-form
4124 form :source-registry 'validate-source-registry-directive
4125 :location location :invalid-form-reporter 'invalid-source-registry))
4127 (defun* validate-source-registry-file (file)
4128 (validate-configuration-file
4129 file 'validate-source-registry-form :description "a source registry"))
4131 (defun* validate-source-registry-directory (directory)
4132 (validate-configuration-directory
4133 directory :source-registry 'validate-source-registry-directive
4134 :invalid-form-reporter 'invalid-source-registry))
4136 (defun* parse-source-registry-string (string &key location)
4138 ((or (null string) (equal string ""))
4139 '(:source-registry :inherit-configuration))
4140 ((not (stringp string))
4141 (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
4142 ((find (char string 0) "\"(")
4143 (validate-source-registry-form (read-from-string string) :location location))
4147 :with directives = ()
4149 :with end = (length string)
4150 :with separator = (inter-directory-separator)
4151 :for pos = (position separator string :start start) :do
4152 (let ((s (subseq string start (or pos end))))
4154 (unless (absolute-pathname-p dir)
4155 (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
4158 ((equal "" s) ; empty element: inherit
4160 (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
4163 (push ':inherit-configuration directives))
4164 ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
4165 (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
4167 (push `(:directory ,(check s)) directives))))
4170 (setf start (1+ pos)))
4173 (push '(:ignore-inherited-configuration) directives))
4174 (return `(:source-registry ,@(nreverse directives))))))))))
4176 (defun* register-asd-directory (directory &key recurse exclude collect)
4178 (collect-asds-in-directory directory collect)
4179 (collect-sub*directories-asd-files
4180 directory :exclude exclude :collect collect)))
4182 (defparameter *default-source-registries*
4183 '(environment-source-registry
4184 user-source-registry
4185 user-source-registry-directory
4186 system-source-registry
4187 system-source-registry-directory
4188 default-source-registry))
4190 (defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
4191 (defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
4193 (defun* wrapping-source-registry ()
4195 #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
4196 :inherit-configuration
4197 #+cmu (:tree #p"modules:")
4198 #+scl (:tree #p"file://modules/")))
4199 (defun* default-source-registry ()
4201 #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
4202 (:directory ,(default-directory))
4203 ,@(loop :for dir :in
4204 `(,@(when (os-unix-p)
4205 `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
4206 (subpathname (user-homedir) ".local/share/"))
4207 ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
4208 '("/usr/local/share" "/usr/share"))))
4209 ,@(when (os-windows-p)
4210 `(,(or #+lispworks (sys:get-folder-path :local-appdata)
4211 (getenv-absolute-directory "LOCALAPPDATA"))
4212 ,(or #+lispworks (sys:get-folder-path :appdata)
4213 (getenv-absolute-directory "APPDATA"))
4214 ,(or #+lispworks (sys:get-folder-path :common-appdata)
4215 (getenv-absolute-directory "ALLUSERSAPPDATA")
4216 (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))
4217 :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
4218 :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
4219 :inherit-configuration))
4220 (defun* user-source-registry (&key (direction :input))
4221 (in-user-configuration-directory *source-registry-file* :direction direction))
4222 (defun* system-source-registry (&key (direction :input))
4223 (in-system-configuration-directory *source-registry-file* :direction direction))
4224 (defun* user-source-registry-directory (&key (direction :input))
4225 (in-user-configuration-directory *source-registry-directory* :direction direction))
4226 (defun* system-source-registry-directory (&key (direction :input))
4227 (in-system-configuration-directory *source-registry-directory* :direction direction))
4228 (defun* environment-source-registry ()
4229 (getenv "CL_SOURCE_REGISTRY"))
4231 (defgeneric* process-source-registry (spec &key inherit register))
4232 (declaim (ftype (function (t &key (:register (or symbol function))) t)
4233 inherit-source-registry))
4234 (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
4235 process-source-registry-directive))
4237 (defmethod process-source-registry ((x symbol) &key inherit register)
4238 (process-source-registry (funcall x) :inherit inherit :register register))
4239 (defmethod process-source-registry ((pathname pathname) &key inherit register)
4241 ((directory-pathname-p pathname)
4242 (let ((*here-directory* (truenamize pathname)))
4243 (process-source-registry (validate-source-registry-directory pathname)
4244 :inherit inherit :register register)))
4245 ((probe-file* pathname)
4246 (let ((*here-directory* (pathname-directory-pathname pathname)))
4247 (process-source-registry (validate-source-registry-file pathname)
4248 :inherit inherit :register register)))
4250 (inherit-source-registry inherit :register register))))
4251 (defmethod process-source-registry ((string string) &key inherit register)
4252 (process-source-registry (parse-source-registry-string string)
4253 :inherit inherit :register register))
4254 (defmethod process-source-registry ((x null) &key inherit register)
4255 (declare (ignorable x))
4256 (inherit-source-registry inherit :register register))
4257 (defmethod process-source-registry ((form cons) &key inherit register)
4258 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
4259 (dolist (directive (cdr (validate-source-registry-form form)))
4260 (process-source-registry-directive directive :inherit inherit :register register))))
4262 (defun* inherit-source-registry (inherit &key register)
4264 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
4266 (defun* process-source-registry-directive (directive &key inherit register)
4267 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
4270 (destructuring-bind (pathname) rest
4271 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
4273 (destructuring-bind (pathname) rest
4275 (funcall register (resolve-location pathname :directory t)))))
4277 (destructuring-bind (pathname) rest
4279 (funcall register (resolve-location pathname :directory t)
4280 :recurse t :exclude *source-registry-exclusions*))))
4282 (setf *source-registry-exclusions* rest))
4284 (appendf *source-registry-exclusions* rest))
4285 ((:default-registry)
4286 (inherit-source-registry '(default-source-registry) :register register))
4287 ((:inherit-configuration)
4288 (inherit-source-registry inherit :register register))
4289 ((:ignore-inherited-configuration)
4293 (defun* flatten-source-registry (&optional parameter)
4295 (while-collecting (collect)
4296 (let ((*default-pathname-defaults* (default-directory)))
4297 (inherit-source-registry
4298 `(wrapping-source-registry
4300 ,@*default-source-registries*)
4301 :register #'(lambda (directory &key recurse exclude)
4302 (collect (list directory :recurse recurse :exclude exclude))))))
4303 :test 'equal :from-end t))
4305 ;; Will read the configuration and initialize all internal variables.
4306 (defun* compute-source-registry (&optional parameter (registry *source-registry*))
4307 (dolist (entry (flatten-source-registry parameter))
4308 (destructuring-bind (directory &key recurse exclude) entry
4309 (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
4310 (register-asd-directory
4311 directory :recurse recurse :exclude exclude :collect
4313 (let* ((name (pathname-name asd))
4314 (name (if (typep asd 'logical-pathname)
4315 ;; logical pathnames are upper-case,
4316 ;; at least in the CLHS and on SBCL,
4317 ;; yet (coerce-name :foo) is lower-case.
4318 ;; won't work well with (load-system "Foo")
4319 ;; instead of (load-system 'foo)
4320 (string-downcase name)
4323 ((gethash name registry) ; already shadowed by something else
4325 ((gethash name h) ; conflict at current level
4326 (when *asdf-verbose*
4327 (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
4328 found several entries for ~A - picking ~S over ~S~:>")
4329 directory recurse name (gethash name h) asd)))
4331 (setf (gethash name registry) asd)
4332 (setf (gethash name h) asd))))))
4336 (defvar *source-registry-parameter* nil)
4338 (defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
4339 (setf *source-registry-parameter* parameter)
4340 (setf *source-registry* (make-hash-table :test 'equal))
4341 (compute-source-registry parameter))
4343 ;; Checks an initial variable to see whether the state is initialized
4344 ;; or cleared. In the former case, return current configuration; in
4345 ;; the latter, initialize. ASDF will call this function at the start
4346 ;; of (asdf:find-system) to make sure the source registry is initialized.
4347 ;; However, it will do so *without* a parameter, at which point it
4348 ;; will be too late to provide a parameter to this function, though
4349 ;; you may override the configuration explicitly by calling
4350 ;; initialize-source-registry directly with your parameter.
4351 (defun* ensure-source-registry (&optional parameter)
4352 (unless (source-registry-initialized-p)
4353 (initialize-source-registry parameter))
4356 (defun* sysdef-source-registry-search (system)
4357 (ensure-source-registry)
4358 (values (gethash (coerce-name system) *source-registry*)))
4360 (defun* clear-configuration ()
4361 (clear-source-registry)
4362 (clear-output-translations))
4365 ;;; ECL support for COMPILE-OP / LOAD-OP
4367 ;;; In ECL, these operations produce both FASL files and the
4368 ;;; object files that they are built from. Having both of them allows
4369 ;;; us to later on reuse the object files for bundles, libraries,
4370 ;;; standalone executables, etc.
4372 ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
4373 ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
4377 (setf *compile-op-compile-file-function* 'ecl-compile-file)
4379 (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
4380 (if (use-ecl-byte-compiler-p)
4381 (apply 'compile-file* input-file keys)
4382 (multiple-value-bind (object-file flags1 flags2)
4383 (apply 'compile-file* input-file :system-p t keys)
4384 (values (and object-file
4385 (c::build-fasl (compile-file-pathname object-file :type :fasl)
4386 :lisp-files (list object-file))
4391 (defmethod output-files ((operation compile-op) (c cl-source-file))
4392 (declare (ignorable operation))
4393 (let* ((p (lispize-pathname (component-pathname c)))
4394 (f (compile-file-pathname p :type :fasl)))
4395 (if (use-ecl-byte-compiler-p)
4397 (list (compile-file-pathname p :type :object) f))))
4399 (defmethod perform ((o load-op) (c cl-source-file))
4401 (loop :for i :in (input-files o c)
4402 :unless (string= (pathname-type i) "fas")
4403 :collect (compile-file-pathname (lispize-pathname i))))))
4405 ;;;; -----------------------------------------------------------------
4406 ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
4408 (defvar *require-asdf-operator* 'load-op)
4410 (defun* module-provide-asdf (name)
4412 ((style-warning #'muffle-warning)
4414 (missing-component (constantly nil))
4415 (error #'(lambda (e)
4416 (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
4418 (let ((*verbose-out* (make-broadcast-stream))
4419 (system (find-system (string-downcase name) nil)))
4421 (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
4424 #+(or abcl clisp clozure cmu ecl sbcl)
4425 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
4427 (eval `(pushnew 'module-provide-asdf
4428 #+abcl sys::*module-provider-functions*
4430 #+clozure ccl:*module-provider-functions*
4431 #+(or cmu ecl) ext:*module-provider-functions*
4432 #+sbcl sb-ext:*module-provider-functions*))))
4435 ;;;; -------------------------------------------------------------------------
4436 ;;;; Cleanups after hot-upgrade.
4437 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
4438 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
4441 ;;; If a previous version of ASDF failed to read some configuration, try again.
4442 (when *ignored-configuration-form*
4443 (clear-configuration)
4444 (setf *ignored-configuration-form* nil))
4446 ;;;; -----------------------------------------------------------------
4448 (when *load-verbose*
4449 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
4452 (eval-when (:compile-toplevel :execute)
4453 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
4454 (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
4456 (pushnew :asdf *features*)
4457 (pushnew :asdf2 *features*)
4461 ;;; Local Variables: