1 ;;; -*- mode: common-lisp; package: asdf; -*-
2 ;;; This is ASDF: 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 HEAD
14 ;;; is the latest development version, whereas the revision tagged
15 ;;; RELEASE 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-2010 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 :cl-user)
52 (eval-when (:compile-toplevel :load-toplevel :execute)
53 ;;; make package if it doesn't exist yet.
54 ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
55 (unless (find-package :asdf)
56 (make-package :asdf :use '(:cl)))
57 ;;; Implementation-dependent tweaks
58 ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
60 (setf excl::*autoload-package-name-alist*
61 (remove "asdf" excl::*autoload-package-name-alist*
62 :test 'equalp :key 'car))
67 ;;;; Create packages in a way that is compatible with hot-upgrade.
68 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
69 ;;;; See more at the end of the file.
71 (eval-when (:load-toplevel :compile-toplevel :execute)
72 (defvar *asdf-version* nil)
73 (defvar *upgraded-p* nil)
74 (let* ((asdf-version "2.010") ;; same as 2.146
75 (existing-asdf (fboundp 'find-system))
76 (existing-version *asdf-version*)
77 (already-there (equal asdf-version existing-version)))
78 (unless (and existing-asdf already-there)
80 (format *error-output*
81 "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
82 existing-version asdf-version))
84 ((unlink-package (package)
85 (let ((u (find-package package)))
88 (loop :for s :being :each :present-symbol :in u :collect s))
89 (loop :for p :in (package-used-by-list u) :do
92 (ensure-exists (name nicknames use)
95 (mapcar #'find-package (cons name nicknames))
97 ;; do away with packages with conflicting (nick)names
98 (map () #'unlink-package (cdr previous))
99 ;; reuse previous package with same name
100 (let ((p (car previous)))
103 (rename-package p name nicknames)
107 (make-package name :nicknames nicknames :use use))))))
108 (find-sym (symbol package)
109 (find-symbol (string symbol) package))
110 (intern* (symbol package)
111 (intern (string symbol) package))
112 (remove-symbol (symbol package)
113 (let ((sym (find-sym symbol package)))
115 (unexport sym package)
116 (unintern sym package)
118 (ensure-unintern (package symbols)
119 (loop :with packages = (list-all-packages)
121 :for removed = (remove-symbol sym package)
123 (loop :for p :in packages :do
124 (when (eq removed (find-sym sym p))
125 (unintern removed p)))))
126 (ensure-shadow (package symbols)
127 (shadow symbols package))
128 (ensure-use (package use)
129 (dolist (used (reverse use))
130 (do-external-symbols (sym used)
131 (unless (eq sym (find-sym sym package))
132 (remove-symbol sym package)))
133 (use-package used package)))
134 (ensure-fmakunbound (package symbols)
135 (loop :for name :in symbols
136 :for sym = (find-sym name package)
137 :when sym :do (fmakunbound sym)))
138 (ensure-export (package export)
139 (let ((formerly-exported-symbols nil)
140 (bothly-exported-symbols nil)
141 (newly-exported-symbols nil))
142 (loop :for sym :being :each :external-symbol :in package :do
143 (if (member sym export :test 'string-equal)
144 (push sym bothly-exported-symbols)
145 (push sym formerly-exported-symbols)))
146 (loop :for sym :in export :do
147 (unless (member sym bothly-exported-symbols :test 'string-equal)
148 (push sym newly-exported-symbols)))
149 (loop :for user :in (package-used-by-list package)
150 :for shadowing = (package-shadowing-symbols user) :do
151 (loop :for new :in newly-exported-symbols
152 :for old = (find-sym new user)
153 :when (and old (not (member old shadowing)))
154 :do (unintern old user)))
155 (loop :for x :in newly-exported-symbols :do
156 (export (intern* x package)))))
157 (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
158 (let* ((p (ensure-exists name nicknames use)))
159 (ensure-unintern p unintern)
160 (ensure-shadow p shadow)
161 (ensure-export p export)
162 (ensure-fmakunbound p fmakunbound)
165 ((pkgdcl (name &key nicknames use export
166 redefined-functions unintern fmakunbound shadow)
168 ',name :nicknames ',nicknames :use ',use :export ',export
170 :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
171 :fmakunbound ',(append fmakunbound))))
174 :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
177 (#:perform #:explain #:output-files #:operation-done-p
178 #:perform-with-restarts #:component-relative-pathname
179 #:system-source-file #:operate #:find-component #:find-system
180 #:apply-output-translations #:translate-pathname* #:resolve-location)
182 (#:*asdf-revision* #:around #:asdf-method-combination
183 #:split #:make-collector)
185 (#:system-source-file
186 #:component-relative-pathname #:system-relative-pathname
187 #:process-source-registry
188 #:inherit-source-registry #:process-source-registry-directive)
190 (#:defsystem #:oos #:operate #:find-system #:run-shell-command
191 #:system-definition-pathname #:find-component ; miscellaneous
192 #:compile-system #:load-system #:test-system #:clear-system
193 #:compile-op #:load-op #:load-source-op
195 #:operation ; operations
196 #:feature ; sort-of operation
197 #:version ; metaphorically sort-of an operation
200 #:input-files #:output-files #:output-file #:perform ; operation methods
201 #:operation-done-p #:explain
203 #:component #:source-file
204 #:c-source-file #:cl-source-file #:java-source-file
210 #:module ; components
214 #:module-components ; component accessors
215 #:module-components-by-name ; component accessors
217 #:component-relative-pathname
224 #:component-depends-on
227 #:system-long-description
233 #:system-source-directory
234 #:system-relative-pathname
237 #:operation-on-warnings
238 #:operation-on-failure
239 #:component-visited-p
240 ;;#:*component-parent-pathname*
241 #:*system-definition-search-functions*
242 #:*central-registry* ; variables
243 #:*compile-file-warnings-behaviour*
244 #:*compile-file-failure-behaviour*
250 #:operation-error #:compile-failed #:compile-warned #:compile-error
253 #:load-system-definition-error
254 #:error-component #:error-operation
255 #:system-definition-error
257 #:missing-component-of-version
259 #:missing-dependency-of-version
260 #:circular-dependency ; errors
266 #:coerce-entry-to-directory
267 #:remove-entry-from-registry
269 #:clear-configuration
270 #:initialize-output-translations
271 #:disable-output-translations
272 #:clear-output-translations
273 #:ensure-output-translations
274 #:apply-output-translations
276 #:compile-file-pathname*
277 #:enable-asdf-binary-locations-compatibility
278 #:*default-source-registries*
279 #:initialize-source-registry
280 #:compute-source-registry
281 #:clear-source-registry
282 #:ensure-source-registry
283 #:process-source-registry
284 #:system-registered-p
288 #:absolute-pathname-p
292 #:directory-pathname-p
294 #:ensure-directory-pathname
299 #:pathname-directory-pathname
305 #:component-name-to-pathname-components
309 #:while-collecting)))
310 (setf *asdf-version* asdf-version
311 *upgraded-p* (if existing-version
312 (cons existing-version *upgraded-p*)
315 ;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
318 (when (find-class 'compile-op nil)
319 (defmethod update-instance-for-redefined-class :after
320 ((c compile-op) added deleted plist &key)
321 (declare (ignore added deleted))
322 (let ((system-p (getf plist 'system-p)))
323 (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
324 (when (find-class 'module nil)
327 (defmethod update-instance-for-redefined-class :after
328 ((m module) added deleted plist &key)
329 (declare (ignorable deleted plist))
330 (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
331 (when (member 'components-by-name added)
332 (compute-module-components-by-name m)))
333 (defmethod update-instance-for-redefined-class :after
334 ((s system) added deleted plist &key)
335 (declare (ignorable deleted plist))
336 (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s))
337 (when (member 'source-file added)
338 (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s)))))))
340 ;;;; -------------------------------------------------------------------------
341 ;;;; User-visible parameters
343 (defun asdf-version ()
344 "Exported interface to the version of ASDF currently installed. A string.
345 You can compare this string with e.g.:
346 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
349 (defvar *resolve-symlinks* t
350 "Determine whether or not ASDF resolves symlinks when defining systems.
354 (defvar *compile-file-warnings-behaviour*
355 (or #+clisp :ignore :warn)
356 "How should ASDF react if it encounters a warning when compiling a file?
357 Valid values are :error, :warn, and :ignore.")
359 (defvar *compile-file-failure-behaviour*
360 (or #+sbcl :error #+clisp :ignore :warn)
361 "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
362 when compiling a file? Valid values are :error, :warn, and :ignore.
363 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
365 (defvar *verbose-out* nil)
367 (defvar *asdf-verbose* t)
369 (defparameter +asdf-methods+
370 '(perform-with-restarts perform explain output-files operation-done-p))
373 (eval-when (:compile-toplevel :execute)
374 (defparameter *acl-warn-save*
375 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
376 excl:*warn-on-nested-reader-conditionals*))
377 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
378 (setf excl:*warn-on-nested-reader-conditionals* nil)))
380 ;;;; -------------------------------------------------------------------------
381 ;;;; ASDF Interface, in terms of generic functions.
384 `(defmacro ,def* (name formals &rest rest)
386 #+(or ecl gcl) (fmakunbound ',name)
387 ,(when (and #+ecl (symbolp name))
388 `(declaim (notinline ,name))) ; fails for setf functions on ecl
389 (,',def ,name ,formals ,@rest)))))
390 (defdef defgeneric* defgeneric)
391 (defdef defun* defun))
393 (defgeneric* find-system (system &optional error-p))
394 (defgeneric* perform-with-restarts (operation component))
395 (defgeneric* perform (operation component))
396 (defgeneric* operation-done-p (operation component))
397 (defgeneric* explain (operation component))
398 (defgeneric* output-files (operation component))
399 (defgeneric* input-files (operation component))
400 (defgeneric* component-operation-time (operation component))
401 (defgeneric* operation-description (operation component)
402 (:documentation "returns a phrase that describes performing this operation
403 on this component, e.g. \"loading /a/b/c\".
404 You can put together sentences using this phrase."))
406 (defgeneric* system-source-file (system)
407 (:documentation "Return the source file in which system is defined."))
409 (defgeneric* component-system (component)
410 (:documentation "Find the top-level system containing COMPONENT"))
412 (defgeneric* component-pathname (component)
413 (:documentation "Extracts the pathname applicable for a particular component."))
415 (defgeneric* component-relative-pathname (component)
416 (:documentation "Returns a pathname for the component argument intended to be
417 interpreted relative to the pathname of that component's parent.
418 Despite the function's name, the return value may be an absolute
419 pathname, because an absolute pathname may be interpreted relative to
420 another pathname in a degenerate way."))
422 (defgeneric* component-property (component property))
424 (defgeneric* (setf component-property) (new-value component property))
426 (defgeneric* version-satisfies (component version))
428 (defgeneric* find-component (base path)
429 (:documentation "Finds the component with PATH starting from BASE module;
430 if BASE is nil, then the component is assumed to be a system."))
432 (defgeneric* source-file-type (component system))
434 (defgeneric* operation-ancestor (operation)
436 "Recursively chase the operation's parent pointer until we get to
437 the head of the tree"))
439 (defgeneric* component-visited-p (operation component)
440 (:documentation "Returns the value stored by a call to
441 VISIT-COMPONENT, if that has been called, otherwise NIL.
442 This value stored will be a cons cell, the first element
443 of which is a computed key, so not interesting. The
444 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
445 it as (cdr (component-visited-p op c)).
446 In the current form of ASDF, the DATA value retrieved is
447 effectively a boolean, indicating whether some operations are
448 to be performed in order to do OPERATION X COMPONENT. If the
449 data value is NIL, the combination had been explored, but no
450 operations needed to be performed."))
452 (defgeneric* visit-component (operation component data)
453 (:documentation "Record DATA as being associated with OPERATION
454 and COMPONENT. This is a side-effecting function: the association
455 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
457 No evidence that DATA is ever interesting, beyond just being
458 non-NIL. Using the data field is probably very risky; if there is
459 already a record for OPERATION X COMPONENT, DATA will be quietly
460 discarded instead of recorded.
461 Starting with 2.006, TRAVERSE will store an integer in data,
462 so that nodes can be sorted in decreasing order of traversal."))
465 (defgeneric* (setf visiting-component) (new-value operation component))
467 (defgeneric* component-visiting-p (operation component))
469 (defgeneric* component-depends-on (operation component)
471 "Returns a list of dependencies needed by the component to perform
472 the operation. A dependency has one of the following forms:
474 (<operation> <component>*), where <operation> is a class
475 designator and each <component> is a component
476 designator, which means that the component depends on
477 <operation> having been performed on each <component>; or
479 (FEATURE <feature>), which means that the component depends
480 on <feature>'s presence in *FEATURES*.
482 Methods specialized on subclasses of existing component types
483 should usually append the results of CALL-NEXT-METHOD to the
486 (defgeneric* component-self-dependencies (operation component))
488 (defgeneric* traverse (operation component)
490 "Generate and return a plan for performing OPERATION on COMPONENT.
492 The plan returned is a list of dotted-pairs. Each pair is the CONS
493 of ASDF operation object and a COMPONENT object. The pairs will be
494 processed in order by OPERATE."))
497 ;;;; -------------------------------------------------------------------------
498 ;;;; General Purpose Utilities
500 (defmacro while-collecting ((&rest collectors) &body body)
501 "COLLECTORS should be a list of names for collections. A collector
502 defines a function that, when applied to an argument inside BODY, will
503 add its argument to the corresponding collection. Returns multiple values,
504 a list for each collection, in order.
506 \(while-collecting \(foo bar\)
507 \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
509 \(bar \(second x\)\)\)\)
510 Returns two values: \(A B C\) and \(1 2 3\)."
511 (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
512 (initial-values (mapcar (constantly nil) collectors)))
513 `(let ,(mapcar #'list vars initial-values)
514 (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
516 (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
518 (defmacro aif (test then &optional else)
519 `(let ((it ,test)) (if it ,then ,else)))
521 (defun* pathname-directory-pathname (pathname)
522 "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
523 and NIL NAME, TYPE and VERSION components"
525 (make-pathname :name nil :type nil :version nil :defaults pathname)))
527 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
528 "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
529 does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
530 Also, if either argument is NIL, then the other argument is returned unmodified."
531 (when (null specified) (return-from merge-pathnames* defaults))
532 (when (null defaults) (return-from merge-pathnames* specified))
533 (let* ((specified (pathname specified))
534 (defaults (pathname defaults))
535 (directory (pathname-directory specified))
539 ((stringp directory) `(:absolute ,directory) directory)
541 ((and (consp directory) (stringp (first directory)))
542 `(:absolute ,@directory))
543 ((or (null directory)
544 (and (consp directory) (member (first directory) '(:absolute :relative))))
547 (error "Unrecognized directory component ~S in pathname ~S" directory specified))))
548 (name (or (pathname-name specified) (pathname-name defaults)))
549 (type (or (pathname-type specified) (pathname-type defaults)))
550 (version (or (pathname-version specified) (pathname-version defaults))))
551 (labels ((ununspecific (x)
552 (if (eq x :unspecific) nil x))
553 (unspecific-handler (p)
554 (if (typep p 'logical-pathname) #'ununspecific #'identity)))
555 (multiple-value-bind (host device directory unspecific-handler)
556 (ecase (first directory)
558 (values (pathname-host defaults)
559 (pathname-device defaults)
560 (pathname-directory defaults)
561 (unspecific-handler defaults)))
563 (values (pathname-host specified)
564 (pathname-device specified)
566 (unspecific-handler specified)))
568 (values (pathname-host defaults)
569 (pathname-device defaults)
570 (if (pathname-directory defaults)
571 (append (pathname-directory defaults) (cdr directory))
573 (unspecific-handler defaults))))
574 (make-pathname :host host :device device :directory directory
575 :name (funcall unspecific-handler name)
576 :type (funcall unspecific-handler type)
577 :version (funcall unspecific-handler version))))))
579 (define-modify-macro appendf (&rest args)
580 append "Append onto list") ;; only to be used on short lists.
582 (define-modify-macro orf (&rest args)
585 (defun* first-char (s)
586 (and (stringp s) (plusp (length s)) (char s 0)))
588 (defun* last-char (s)
589 (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
591 (defun* asdf-message (format-string &rest format-args)
592 (declare (dynamic-extent format-args))
593 (apply #'format *verbose-out* format-string format-args))
595 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
596 "Split STRING into a list of components separated by
597 any of the characters in the sequence SEPARATOR.
598 If MAX is specified, then no more than max(1,MAX) components will be returned,
599 starting the separation from the end, e.g. when called with arguments
600 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
602 (let ((list nil) (words 0) (end (length string)))
603 (flet ((separatorp (char) (find char separator))
604 (done () (return (cons (subseq string 0 end) list))))
606 :for start = (if (and max (>= words (1- max)))
608 (position-if #'separatorp string :end end :from-end t)) :do
611 (push (subseq string (1+ start) end) list)
613 (setf end start))))))
615 (defun* split-name-type (filename)
617 ;; Giving :unspecific as argument to make-pathname is not portable.
618 ;; See CLHS make-pathname and 19.2.2.2.3.
619 ;; We only use it on implementations that support it.
620 (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
621 (destructuring-bind (name &optional (type unspecific))
622 (split-string filename :max 2 :separator ".")
624 (values filename unspecific)
625 (values name type)))))
627 (defun* component-name-to-pathname-components (s &key force-directory force-relative)
628 "Splits the path string S, returning three values:
629 A flag that is either :absolute or :relative, indicating
630 how the rest of the values are to be interpreted.
631 A directory path --- a list of strings, suitable for
632 use with MAKE-PATHNAME when prepended with the flag
634 A filename with type extension, possibly NIL in the
635 case of a directory pathname.
636 FORCE-DIRECTORY forces S to be interpreted as a directory
637 pathname \(third return value will be NIL, final component
638 of S will be treated as part of the directory path.
640 The intention of this function is to support structured component names,
641 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
643 (check-type s string)
645 (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s))
646 (let* ((components (split-string s :separator "/"))
647 (last-comp (car (last components))))
648 (multiple-value-bind (relative components)
649 (if (equal (first components) "")
650 (if (equal (first-char s) #\/)
653 (error "absolute pathname designator not allowed: ~S" s))
654 (values :absolute (cdr components)))
655 (values :relative nil))
656 (values :relative components))
657 (setf components (remove "" components :test #'equal))
659 ((equal last-comp "")
660 (values relative components nil)) ; "" already removed
662 (values relative components nil))
664 (values relative (butlast components) last-comp))))))
666 (defun* remove-keys (key-names args)
667 (loop :for (name val) :on args :by #'cddr
668 :unless (member (symbol-name name) key-names
669 :key #'symbol-name :test 'equal)
670 :append (list name val)))
672 (defun* remove-keyword (key args)
673 (loop :for (k v) :on args :by #'cddr
682 #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
685 #+lispworks lispworks:environment-variable
686 #+sbcl sb-ext:posix-getenv
689 (defun* directory-pathname-p (pathname)
690 "Does PATHNAME represent a directory?
692 A directory-pathname is a pathname _without_ a filename. The three
693 ways that the filename components can be missing are for it to be NIL,
694 :UNSPECIFIC or the empty string.
696 Note that this does _not_ check to see that PATHNAME points to an
697 actually-existing directory."
699 (let ((pathname (pathname pathname)))
700 (flet ((check-one (x)
701 (member x '(nil :unspecific "") :test 'equal)))
702 (and (not (wild-pathname-p pathname))
703 (check-one (pathname-name pathname))
704 (check-one (pathname-type pathname))
707 (defun* ensure-directory-pathname (pathspec)
708 "Converts the non-wild pathname designator PATHSPEC to directory form."
711 (ensure-directory-pathname (pathname pathspec)))
712 ((not (pathnamep pathspec))
713 (error "Invalid pathname designator ~S" pathspec))
714 ((wild-pathname-p pathspec)
715 (error "Can't reliably convert wild pathname ~S" pathspec))
716 ((directory-pathname-p pathspec)
719 (make-pathname :directory (append (or (pathname-directory pathspec)
721 (list (file-namestring pathspec)))
722 :name nil :type nil :version nil
723 :defaults pathspec))))
725 (defun* absolute-pathname-p (pathspec)
726 (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
728 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
729 (check-type n (integer 0 *))
731 :for l = x :then (cdr l)
732 :for i :downfrom n :do
734 ((zerop i) (return (null l)))
735 ((not (consp l)) (return nil)))))
737 (defun* ends-with (s suffix)
738 (check-type s string)
739 (check-type suffix string)
740 (let ((start (- (length s) (length suffix))))
742 (string-equal s suffix :start1 start))))
744 (defun* read-file-forms (file)
745 (with-open-file (in file)
746 (loop :with eof = (list nil)
747 :for form = (read in nil eof)
751 #-(and (or win32 windows mswindows mingw32) (not cygwin))
753 #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
754 '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
756 #+allegro (excl.osi:getuid)
757 #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
758 :for f = (ignore-errors (read-from-string s))
759 :when f :return (funcall f))
760 #+(or cmu scl) (unix:unix-getuid)
761 #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
762 '(ffi:c-inline () () :int "getuid()" :one-liner t)
764 #+sbcl (sb-unix:unix-getuid)
765 #-(or allegro clisp cmu ecl sbcl scl)
767 (with-output-to-string (*verbose-out*)
768 (run-shell-command "id -ur"))))
769 (with-input-from-string (stream uid-string)
771 (handler-case (parse-integer (read-line stream))
772 (error () (error "Unable to find out user ID")))))))
774 (defun* pathname-root (pathname)
775 (make-pathname :host (pathname-host pathname)
776 :device (pathname-device pathname)
777 :directory '(:absolute)
778 :name nil :type nil :version nil))
780 (defun* probe-file* (p)
781 "when given a pathname P, probes the filesystem for a file or directory
782 with given pathname and if it exists return its truename."
785 (string (probe-file* (parse-namestring p)))
786 (pathname (unless (wild-pathname-p p)
787 #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
788 #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p)))
789 '(ignore-errors (truename p)))))))
791 (defun* truenamize (p)
792 "Resolve as much of a pathname as possible"
794 (when (typep p 'logical-pathname) (return p))
795 (let* ((p (merge-pathnames* p))
796 (directory (pathname-directory p)))
797 (when (typep p 'logical-pathname) (return p))
798 (let ((found (probe-file* p)))
799 (when found (return found)))
800 #-(or sbcl cmu) (when (stringp directory) (return p))
801 (when (not (eq :absolute (car directory))) (return p))
802 (let ((sofar (probe-file* (pathname-root p))))
803 (unless sofar (return p))
804 (flet ((solution (directories)
806 (make-pathname :host nil :device nil
807 :directory `(:relative ,@directories)
808 :name (pathname-name p)
809 :type (pathname-type p)
810 :version (pathname-version p))
812 (loop :for component :in (cdr directory)
813 :for rest :on (cdr directory)
814 :for more = (probe-file*
816 (make-pathname :directory `(:relative ,component))
820 (return (solution rest)))
822 (return (solution nil))))))))
824 (defun* resolve-symlinks (path)
825 #-allegro (truenamize path)
826 #+allegro (excl:pathname-resolve-symbolic-links path))
828 (defun* default-directory ()
829 (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
831 (defun* lispize-pathname (input-file)
832 (make-pathname :type "lisp" :defaults input-file))
834 (defparameter *wild-path*
835 (make-pathname :directory '(:relative :wild-inferiors)
836 :name :wild :type :wild :version :wild))
838 (defun* wilden (path)
839 (merge-pathnames* *wild-path* path))
841 (defun* directorize-pathname-host-device (pathname)
842 (let* ((root (pathname-root pathname))
843 (wild-root (wilden root))
844 (absolute-pathname (merge-pathnames* pathname root))
845 (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
846 (separator (last-char (namestring foo)))
847 (root-namestring (namestring root))
850 (lambda (x) (or (eql x #\:)
853 (multiple-value-bind (relative path filename)
854 (component-name-to-pathname-components root-string :force-directory t)
855 (declare (ignore relative filename))
857 (make-pathname :defaults root
858 :directory `(:absolute ,@path))))
859 (translate-pathname absolute-pathname wild-root (wilden new-base))))))
861 ;;;; -------------------------------------------------------------------------
862 ;;;; Classes, Conditions
864 (define-condition system-definition-error (error) ()
865 ;; [this use of :report should be redundant, but unfortunately it's not.
866 ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
867 ;; over print-object; this is always conditions::%print-condition for
868 ;; condition objects, which in turn does inheritance of :report options at
869 ;; run-time. fortunately, inheritance means we only need this kludge here in
870 ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.]
871 #+cmu (:report print-object))
873 (declaim (ftype (function (t) t)
874 format-arguments format-control
875 error-name error-pathname error-condition
877 error-component error-operation
878 module-components module-components-by-name
879 circular-dependency-components)
880 (ftype (function (t t) t) (setf module-components-by-name)))
883 (define-condition formatted-system-definition-error (system-definition-error)
884 ((format-control :initarg :format-control :reader format-control)
885 (format-arguments :initarg :format-arguments :reader format-arguments))
886 (:report (lambda (c s)
887 (apply #'format s (format-control c) (format-arguments c)))))
889 (define-condition load-system-definition-error (system-definition-error)
890 ((name :initarg :name :reader error-name)
891 (pathname :initarg :pathname :reader error-pathname)
892 (condition :initarg :condition :reader error-condition))
893 (:report (lambda (c s)
894 (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
895 (error-name c) (error-pathname c) (error-condition c)))))
897 (define-condition circular-dependency (system-definition-error)
898 ((components :initarg :components :reader circular-dependency-components))
899 (:report (lambda (c s)
900 (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
902 (define-condition duplicate-names (system-definition-error)
903 ((name :initarg :name :reader duplicate-names-name))
904 (:report (lambda (c s)
905 (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
906 (duplicate-names-name c)))))
908 (define-condition missing-component (system-definition-error)
909 ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
910 (parent :initform nil :reader missing-parent :initarg :parent)))
912 (define-condition missing-component-of-version (missing-component)
913 ((version :initform nil :reader missing-version :initarg :version)))
915 (define-condition missing-dependency (missing-component)
916 ((required-by :initarg :required-by :reader missing-required-by)))
918 (define-condition missing-dependency-of-version (missing-dependency
919 missing-component-of-version)
922 (define-condition operation-error (error)
923 ((component :reader error-component :initarg :component)
924 (operation :reader error-operation :initarg :operation))
925 (:report (lambda (c s)
926 (format s "~@<erred while invoking ~A on ~A~@:>"
927 (error-operation c) (error-component c)))))
928 (define-condition compile-error (operation-error) ())
929 (define-condition compile-failed (compile-error) ())
930 (define-condition compile-warned (compile-error) ())
932 (defclass component ()
933 ((name :accessor component-name :initarg :name :documentation
934 "Component name: designator for a string composed of portable pathname characters")
935 (version :accessor component-version :initarg :version)
936 ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
937 ;; POIU is a parallel (multi-process build) extension of ASDF. See
938 ;; http://www.cliki.net/poiu
939 (load-dependencies :accessor component-load-dependencies :initform nil)
940 ;; In the ASDF object model, dependencies exist between *actions*
941 ;; (an action is a pair of operation and component). They are represented
942 ;; alists of operations to dependencies (other actions) in each component.
943 ;; There are two kinds of dependencies, each stored in its own slot:
944 ;; in-order-to and do-first dependencies. These two kinds are related to
945 ;; the fact that some actions modify the filesystem,
946 ;; whereas other actions modify the current image, and
947 ;; this implies a difference in how to interpret timestamps.
948 ;; in-order-to dependencies will trigger re-performing the action
949 ;; when the timestamp of some dependency
950 ;; makes the timestamp of current action out-of-date;
951 ;; do-first dependencies do not trigger such re-performing.
952 ;; Therefore, a FASL must be recompiled if it is obsoleted
953 ;; by any of its FASL dependencies (in-order-to); but
954 ;; it needn't be recompiled just because one of these dependencies
955 ;; hasn't yet been loaded in the current image (do-first).
956 ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
957 (in-order-to :initform nil :initarg :in-order-to
958 :accessor component-in-order-to)
959 (do-first :initform nil :initarg :do-first
960 :accessor component-do-first)
961 ;; methods defined using the "inline" style inside a defsystem form:
962 ;; need to store them somewhere so we can delete them when the system
964 (inline-methods :accessor component-inline-methods :initform nil)
965 (parent :initarg :parent :initform nil :reader component-parent)
966 ;; no direct accessor for pathname, we do this as a method to allow
967 ;; it to default in funky ways if not supplied
968 (relative-pathname :initarg :pathname)
970 (operation-times :initform (make-hash-table)
971 :accessor component-operation-times)
972 ;; XXX we should provide some atomic interface for updating the
973 ;; component properties
974 (properties :accessor component-properties :initarg :properties
977 (defun* component-find-path (component)
979 (loop :for c = component :then (component-parent c)
980 :while c :collect (component-name c))))
982 (defmethod print-object ((c component) stream)
983 (print-unreadable-object (c stream :type t :identity nil)
984 (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
987 ;;;; methods: conditions
989 (defmethod print-object ((c missing-dependency) s)
990 (format s "~@<~A, required by ~A~@:>"
991 (call-next-method c nil) (missing-required-by c)))
993 (defun* sysdef-error (format &rest arguments)
994 (error 'formatted-system-definition-error :format-control
995 format :format-arguments arguments))
997 ;;;; methods: components
999 (defmethod print-object ((c missing-component) s)
1000 (format s "~@<component ~S not found~@[ in ~A~]~@:>"
1001 (missing-requires c)
1002 (when (missing-parent c)
1003 (component-name (missing-parent c)))))
1005 (defmethod print-object ((c missing-component-of-version) s)
1006 (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
1007 (missing-requires c)
1009 (when (missing-parent c)
1010 (component-name (missing-parent c)))))
1012 (defmethod component-system ((component component))
1013 (aif (component-parent component)
1014 (component-system it)
1017 (defvar *default-component-class* 'cl-source-file)
1019 (defun* compute-module-components-by-name (module)
1020 (let ((hash (make-hash-table :test 'equal)))
1021 (setf (module-components-by-name module) hash)
1022 (loop :for c :in (module-components module)
1023 :for name = (component-name c)
1024 :for previous = (gethash name (module-components-by-name module))
1027 (error 'duplicate-names :name name))
1028 :do (setf (gethash name (module-components-by-name module)) c))
1031 (defclass module (component)
1034 :initarg :components
1035 :accessor module-components)
1037 :accessor module-components-by-name)
1038 ;; What to do if we can't satisfy a dependency of one of this module's
1039 ;; components. This allows a limited form of conditional processing.
1040 (if-component-dep-fails
1042 :initarg :if-component-dep-fails
1043 :accessor module-if-component-dep-fails)
1044 (default-component-class
1045 :initform *default-component-class*
1046 :initarg :default-component-class
1047 :accessor module-default-component-class)))
1049 (defun* component-parent-pathname (component)
1050 ;; No default anymore (in particular, no *default-pathname-defaults*).
1051 ;; If you force component to have a NULL pathname, you better arrange
1052 ;; for any of its children to explicitly provide a proper absolute pathname
1053 ;; wherever a pathname is actually wanted.
1054 (let ((parent (component-parent component)))
1056 (component-pathname parent))))
1058 (defmethod component-pathname ((component component))
1059 (if (slot-boundp component 'absolute-pathname)
1060 (slot-value component 'absolute-pathname)
1063 (component-relative-pathname component)
1064 (pathname-directory-pathname (component-parent-pathname component)))))
1065 (unless (or (null pathname) (absolute-pathname-p pathname))
1066 (error "Invalid relative pathname ~S for component ~S"
1067 pathname (component-find-path component)))
1068 (setf (slot-value component 'absolute-pathname) pathname)
1071 (defmethod component-property ((c component) property)
1072 (cdr (assoc property (slot-value c 'properties) :test #'equal)))
1074 (defmethod (setf component-property) (new-value (c component) property)
1075 (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
1077 (setf (cdr a) new-value)
1078 (setf (slot-value c 'properties)
1079 (acons property new-value (slot-value c 'properties)))))
1082 (defclass system (module)
1083 ((description :accessor system-description :initarg :description)
1085 :accessor system-long-description :initarg :long-description)
1086 (author :accessor system-author :initarg :author)
1087 (maintainer :accessor system-maintainer :initarg :maintainer)
1088 (licence :accessor system-licence :initarg :licence
1089 :accessor system-license :initarg :license)
1090 (source-file :reader system-source-file :initarg :source-file
1091 :writer %set-system-source-file)
1092 (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
1094 ;;;; -------------------------------------------------------------------------
1095 ;;;; version-satisfies
1097 (defmethod version-satisfies ((c component) version)
1098 (unless (and version (slot-boundp c 'version))
1099 (return-from version-satisfies t))
1100 (version-satisfies (component-version c) version))
1102 (defmethod version-satisfies ((cver string) version)
1103 (let ((x (mapcar #'parse-integer
1104 (split-string cver :separator ".")))
1105 (y (mapcar #'parse-integer
1106 (split-string version :separator "."))))
1107 (labels ((bigger (x y)
1110 ((> (car x) (car y)) t)
1111 ((= (car x) (car y))
1112 (bigger (cdr x) (cdr y))))))
1113 (and (= (car x) (car y))
1114 (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
1116 ;;;; -------------------------------------------------------------------------
1117 ;;;; Finding systems
1119 (defun* make-defined-systems-table ()
1120 (make-hash-table :test 'equal))
1122 (defvar *defined-systems* (make-defined-systems-table)
1123 "This is a hash table whose keys are strings, being the
1124 names of the systems, and whose values are pairs, the first
1125 element of which is a universal-time indicating when the
1126 system definition was last updated, and the second element
1127 of which is a system object.")
1129 (defun* coerce-name (name)
1131 (component (component-name name))
1132 (symbol (string-downcase (symbol-name name)))
1134 (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
1136 (defun* system-registered-p (name)
1137 (gethash (coerce-name name) *defined-systems*))
1139 (defun* clear-system (name)
1140 "Clear the entry for a system in the database of systems previously loaded.
1141 Note that this does NOT in any way cause the code of the system to be unloaded."
1142 ;; There is no "unload" operation in Common Lisp, and a general such operation
1143 ;; cannot be portably written, considering how much CL relies on side-effects
1144 ;; of global data structures.
1145 ;; Note that this does a setf gethash instead of a remhash
1146 ;; this way there remains a hint in the *defined-systems* table
1147 ;; that the system was loaded at some point.
1148 (setf (gethash (coerce-name name) *defined-systems*) nil))
1150 (defun* map-systems (fn)
1151 "Apply FN to each defined system.
1153 FN should be a function of one argument. It will be
1154 called with an object of type asdf:system."
1155 (maphash (lambda (_ datum)
1156 (declare (ignore _))
1157 (destructuring-bind (_ . def) datum
1158 (declare (ignore _))
1162 ;;; for the sake of keeping things reasonably neat, we adopt a
1163 ;;; convention that functions in this list are prefixed SYSDEF-
1165 (defparameter *system-definition-search-functions*
1166 '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
1168 (defun* system-definition-pathname (system)
1169 (let ((system-name (coerce-name system)))
1171 (some (lambda (x) (funcall x system-name))
1172 *system-definition-search-functions*)
1173 (let ((system-pair (system-registered-p system-name)))
1175 (system-source-file (cdr system-pair)))))))
1177 (defvar *central-registry* nil
1178 "A list of 'system directory designators' ASDF uses to find systems.
1180 A 'system directory designator' is a pathname or an expression
1181 which evaluates to a pathname. For example:
1183 (setf asdf:*central-registry*
1184 (list '*default-pathname-defaults*
1185 #p\"/home/me/cl/systems/\"
1186 #p\"/usr/share/common-lisp/systems/\"))
1188 This is for backward compatibilily.
1189 Going forward, we recommend new users should be using the source-registry.
1192 (defun* probe-asd (name defaults)
1194 (when (directory-pathname-p defaults)
1197 :defaults defaults :version :newest :case :local
1200 (when (probe-file file)
1202 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
1205 :defaults defaults :version :newest :case :local
1206 :name (concatenate 'string name ".asd")
1208 (when (probe-file shortcut)
1209 (let ((target (parse-windows-shortcut shortcut)))
1211 (return (pathname target)))))))))
1213 (defun* sysdef-central-registry-search (system)
1214 (let ((name (coerce-name system))
1219 (dolist (dir *central-registry*)
1220 (let ((defaults (eval dir)))
1222 (cond ((directory-pathname-p defaults)
1223 (let ((file (probe-asd name defaults)))
1228 (let* ((*print-circle* nil)
1231 "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
1232 system dir defaults)))
1234 (remove-entry-from-registry ()
1235 :report "Remove entry from *central-registry* and continue"
1236 (push dir to-remove))
1237 (coerce-entry-to-directory ()
1239 (format s "Coerce entry to ~a, replace ~a and continue."
1240 (ensure-directory-pathname defaults) dir))
1241 (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
1243 (dolist (dir to-remove)
1244 (setf *central-registry* (remove dir *central-registry*)))
1245 (dolist (pair to-replace)
1246 (let* ((current (car pair))
1248 (position (position current *central-registry*)))
1249 (setf *central-registry*
1250 (append (subseq *central-registry* 0 position)
1252 (subseq *central-registry* (1+ position))))))))))
1254 (defun* make-temporary-package ()
1255 (flet ((try (counter)
1257 (make-package (format nil "~A~D" :asdf counter)
1258 :use '(:cl :asdf)))))
1259 (do* ((counter 0 (+ counter 1))
1260 (package (try counter) (try counter)))
1261 (package package))))
1263 (defun* safe-file-write-date (pathname)
1264 ;; If FILE-WRITE-DATE returns NIL, it's possible that
1265 ;; the user or some other agent has deleted an input file.
1266 ;; Also, generated files will not exist at the time planning is done
1267 ;; and calls operation-done-p which calls safe-file-write-date.
1268 ;; So it is very possible that we can't get a valid file-write-date,
1269 ;; and we can survive and we will continue the planning
1270 ;; as if the file were very old.
1271 ;; (or should we treat the case in a different, special way?)
1272 (or (and pathname (probe-file pathname) (file-write-date pathname))
1274 (when (and pathname *asdf-verbose*)
1275 (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
1279 (defmethod find-system (name &optional (error-p t))
1280 (find-system (coerce-name name) error-p))
1282 (defmethod find-system ((name string) &optional (error-p t))
1284 (let* ((in-memory (system-registered-p name))
1285 (on-disk (system-definition-pathname name)))
1288 (< (car in-memory) (safe-file-write-date on-disk))))
1289 (let ((package (make-temporary-package)))
1292 ((error (lambda (condition)
1293 (error 'load-system-definition-error
1294 :name name :pathname on-disk
1295 :condition condition))))
1296 (let ((*package* package))
1298 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
1301 (delete-package package))))
1302 (let ((in-memory (system-registered-p name)))
1306 (setf (car in-memory) (safe-file-write-date on-disk)))
1309 (error 'missing-component :requires name)))))))
1311 (defun* register-system (name system)
1312 (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
1313 (setf (gethash (coerce-name name) *defined-systems*)
1314 (cons (get-universal-time) system)))
1316 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
1317 (setf fallback (coerce-name fallback)
1318 source-file (or source-file *compile-file-truename* *load-truename*)
1319 requested (coerce-name requested))
1320 (when (equal requested fallback)
1321 (let* ((registered (cdr (gethash fallback *defined-systems*)))
1322 (system (or registered
1323 (apply 'make-instance 'system
1324 :name fallback :source-file source-file keys))))
1326 (register-system fallback system))
1327 (throw 'find-system system))))
1329 (defun* sysdef-find-asdf (name)
1330 (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated.
1333 ;;;; -------------------------------------------------------------------------
1334 ;;;; Finding components
1336 (defmethod find-component ((base string) path)
1337 (let ((s (find-system base nil)))
1338 (and s (find-component s path))))
1340 (defmethod find-component ((base symbol) path)
1342 (base (find-component (coerce-name base) path))
1343 (path (find-component path nil))
1346 (defmethod find-component ((base cons) path)
1347 (find-component (car base) (cons (cdr base) path)))
1349 (defmethod find-component ((module module) (name string))
1350 (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
1351 (compute-module-components-by-name module))
1352 (values (gethash name (module-components-by-name module))))
1354 (defmethod find-component ((component component) (name symbol))
1356 (find-component component (coerce-name name))
1359 (defmethod find-component ((module module) (name cons))
1360 (find-component (find-component module (car name)) (cdr name)))
1363 ;;; component subclasses
1365 (defclass source-file (component)
1366 ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
1368 (defclass cl-source-file (source-file)
1369 ((type :initform "lisp")))
1370 (defclass c-source-file (source-file)
1371 ((type :initform "c")))
1372 (defclass java-source-file (source-file)
1373 ((type :initform "java")))
1374 (defclass static-file (source-file) ())
1375 (defclass doc-file (static-file) ())
1376 (defclass html-file (doc-file)
1377 ((type :initform "html")))
1379 (defmethod source-file-type ((component module) (s module))
1380 (declare (ignorable component s))
1382 (defmethod source-file-type ((component source-file) (s module))
1383 (declare (ignorable s))
1384 (source-file-explicit-type component))
1386 (defun* merge-component-name-type (name &key type defaults)
1387 ;; The defaults are required notably because they provide the default host
1388 ;; to the below make-pathname, which may crucially matter to people using
1389 ;; merge-pathnames with non-default hosts, e.g. for logical-pathnames.
1390 ;; NOTE that the host and device slots will be taken from the defaults,
1391 ;; but that should only matter if you either (a) use absolute pathnames, or
1392 ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
1393 ;; ASDF:MERGE-PATHNAMES*
1398 (merge-component-name-type (string-downcase name) :type type :defaults defaults))
1400 (multiple-value-bind (relative path filename)
1401 (component-name-to-pathname-components name :force-directory (eq type :directory)
1403 (multiple-value-bind (name type)
1405 ((or (eq type :directory) (null filename))
1408 (values filename type))
1410 (split-name-type filename)))
1411 (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
1412 (host (pathname-host defaults))
1413 (device (pathname-device defaults)))
1414 (make-pathname :directory `(,relative ,@path)
1415 :name name :type type
1416 :host host :device device)))))))
1418 (defmethod component-relative-pathname ((component component))
1419 (merge-component-name-type
1420 (or (slot-value component 'relative-pathname)
1421 (component-name component))
1422 :type (source-file-type component (component-system component))
1423 :defaults (component-parent-pathname component)))
1425 ;;;; -------------------------------------------------------------------------
1428 ;;; one of these is instantiated whenever #'operate is called
1430 (defclass operation ()
1432 ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
1433 ;; T to force the inside of existing system,
1434 ;; but not recurse to other systems we depend on.
1435 ;; :ALL (or any other atom) to force all systems
1436 ;; including other systems we depend on.
1437 ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
1438 ;; to force systems named in a given list
1439 ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
1440 (forced :initform nil :initarg :force :accessor operation-forced)
1441 (original-initargs :initform nil :initarg :original-initargs
1442 :accessor operation-original-initargs)
1443 (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
1444 (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
1445 (parent :initform nil :initarg :parent :accessor operation-parent)))
1447 (defmethod print-object ((o operation) stream)
1448 (print-unreadable-object (o stream :type t :identity t)
1450 (prin1 (operation-original-initargs o) stream))))
1452 (defmethod shared-initialize :after ((operation operation) slot-names
1455 (declare (ignorable operation slot-names force))
1456 ;; empty method to disable initarg validity checking
1459 (defun* node-for (o c)
1460 (cons (class-name (class-of o)) c))
1462 (defmethod operation-ancestor ((operation operation))
1463 (aif (operation-parent operation)
1464 (operation-ancestor it)
1468 (defun* make-sub-operation (c o dep-c dep-o)
1469 "C is a component, O is an operation, DEP-C is another
1470 component, and DEP-O, confusingly enough, is an operation
1471 class specifier, not an operation."
1472 (let* ((args (copy-list (operation-original-initargs o)))
1473 (force-p (getf args :force)))
1474 ;; note explicit comparison with T: any other non-NIL force value
1475 ;; (e.g. :recursive) will pass through
1476 (cond ((and (null (component-parent c))
1477 (null (component-parent dep-c))
1478 (not (eql c dep-c)))
1479 (when (eql force-p t)
1480 (setf (getf args :force) nil))
1481 (apply #'make-instance dep-o
1483 :original-initargs args args))
1484 ((subtypep (type-of o) dep-o)
1487 (apply #'make-instance dep-o
1488 :parent o :original-initargs args args)))))
1491 (defmethod visit-component ((o operation) (c component) data)
1492 (unless (component-visited-p o c)
1493 (setf (gethash (node-for o c)
1494 (operation-visited-nodes (operation-ancestor o)))
1497 (defmethod component-visited-p ((o operation) (c component))
1498 (gethash (node-for o c)
1499 (operation-visited-nodes (operation-ancestor o))))
1501 (defmethod (setf visiting-component) (new-value operation component)
1502 ;; MCL complains about unused lexical variables
1503 (declare (ignorable operation component))
1506 (defmethod (setf visiting-component) (new-value (o operation) (c component))
1507 (let ((node (node-for o c))
1508 (a (operation-ancestor o)))
1510 (setf (gethash node (operation-visiting-nodes a)) t)
1511 (remhash node (operation-visiting-nodes a)))
1514 (defmethod component-visiting-p ((o operation) (c component))
1515 (let ((node (node-for o c)))
1516 (gethash node (operation-visiting-nodes (operation-ancestor o)))))
1518 (defmethod component-depends-on ((op-spec symbol) (c component))
1519 (component-depends-on (make-instance op-spec) c))
1521 (defmethod component-depends-on ((o operation) (c component))
1522 (cdr (assoc (class-name (class-of o))
1523 (component-in-order-to c))))
1525 (defmethod component-self-dependencies ((o operation) (c component))
1526 (let ((all-deps (component-depends-on o c)))
1527 (remove-if-not (lambda (x)
1528 (member (component-name c) (cdr x) :test #'string=))
1531 (defmethod input-files ((operation operation) (c component))
1532 (let ((parent (component-parent c))
1533 (self-deps (component-self-dependencies operation c)))
1535 (mapcan (lambda (dep)
1536 (destructuring-bind (op name) dep
1537 (output-files (make-instance op)
1538 (find-component parent name))))
1540 ;; no previous operations needed? I guess we work with the
1541 ;; original source file, then
1542 (list (component-pathname c)))))
1544 (defmethod input-files ((operation operation) (c module))
1545 (declare (ignorable operation c))
1548 (defmethod component-operation-time (o c)
1549 (gethash (type-of o) (component-operation-times c)))
1551 (defmethod operation-done-p ((o operation) (c component))
1552 (let ((out-files (output-files o c))
1553 (in-files (input-files o c))
1554 (op-time (component-operation-time o c)))
1555 (flet ((earliest-out ()
1556 (reduce #'min (mapcar #'safe-file-write-date out-files)))
1558 (reduce #'max (mapcar #'safe-file-write-date in-files))))
1560 ((and (not in-files) (not out-files))
1561 ;; arbitrary decision: an operation that uses nothing to
1562 ;; produce nothing probably isn't doing much.
1563 ;; e.g. operations on systems, modules that have no immediate action,
1564 ;; but are only meaningful through traversed dependencies
1567 ;; an operation without output-files is probably meant
1568 ;; for its side-effects in the current image,
1569 ;; assumed to be idem-potent,
1570 ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
1571 (and op-time (>= op-time (latest-in))))
1573 ;; an operation without output-files and no input-files
1574 ;; is probably meant for its side-effects on the file-system,
1575 ;; assumed to have to be done everytime.
1576 ;; (I don't think there is any such case in ASDF unless extended)
1579 ;; an operation with both input and output files is assumed
1580 ;; as computing the latter from the former,
1581 ;; assumed to have been done if the latter are all older
1583 ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
1584 ;; We use >= instead of > to play nice with generated files.
1585 ;; This opens a race condition if an input file is changed
1586 ;; after the output is created but within the same second
1587 ;; of filesystem time; but the same race condition exists
1588 ;; whenever the computation from input to output takes more
1589 ;; than one second of filesystem time (or just crosses the
1590 ;; second). So that's cool.
1592 (every #'probe-file in-files)
1593 (every #'probe-file out-files)
1594 (>= (earliest-out) (latest-in))))))))
1598 ;;; For 1.700 I've done my best to refactor TRAVERSE
1599 ;;; by splitting it up in a bunch of functions,
1600 ;;; so as to improve the collection and use-detection algorithm. --fare
1601 ;;; The protocol is as follows: we pass around operation, dependency,
1602 ;;; bunch of other stuff, and a force argument. Return a force flag.
1603 ;;; The returned flag is T if anything has changed that requires a rebuild.
1604 ;;; The force argument is a list of components that will require a rebuild
1605 ;;; if the flag is T, at which point whoever returns the flag has to
1606 ;;; mark them all as forced, and whoever recurses again can use a NIL list
1607 ;;; as a further argument.
1609 (defvar *forcing* nil
1610 "This dynamically-bound variable is used to force operations in
1611 recursive calls to traverse.")
1613 (defgeneric* do-traverse (operation component collect))
1615 (defun* %do-one-dep (operation c collect required-op required-c required-v)
1616 ;; collects a partial plan that results from performing required-op
1617 ;; on required-c, possibly with a required-vERSION
1618 (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
1619 (and d (version-satisfies d required-v) d))
1621 (error 'missing-dependency-of-version
1624 :requires required-c)
1625 (error 'missing-dependency
1627 :requires required-c))))
1628 (op (make-sub-operation c operation dep-c required-op)))
1629 (do-traverse op dep-c collect)))
1631 (defun* do-one-dep (operation c collect required-op required-c required-v)
1632 ;; this function is a thin, error-handling wrapper around %do-one-dep.
1633 ;; Collects a partial plan per that function.
1636 (return (%do-one-dep operation c collect
1637 required-op required-c required-v))
1640 (format s "~@<Retry loading component ~S.~@:>"
1641 (component-find-path required-c)))
1645 (and (typep c 'missing-dependency)
1646 (equalp (missing-requires c)
1649 (defun* do-dep (operation c collect op dep)
1650 ;; type of arguments uncertain:
1651 ;; op seems to at least potentially be a symbol, rather than an operation
1652 ;; dep is a list of component names
1653 (cond ((eq op 'feature)
1654 (if (member (car dep) *features*)
1656 (error 'missing-dependency
1658 :requires (car dep))))
1661 (flet ((dep (op comp ver)
1662 (when (do-one-dep operation c collect
1668 ;; structured dependencies --- this parses keywords
1669 ;; the keywords could be broken out and cleanly (extensibly)
1670 ;; processed by EQL methods
1671 (cond ((eq :version (first d))
1672 ;; https://bugs.launchpad.net/asdf/+bug/527788
1673 (dep op (second d) (third d)))
1674 ;; This particular subform is not documented and
1675 ;; has always been broken in the past.
1676 ;; Therefore no one uses it, and I'm cerroring it out,
1678 ;; See https://bugs.launchpad.net/asdf/+bug/518467
1679 ((eq :feature (first d))
1680 (cerror "Continue nonetheless."
1681 "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
1682 (when (find (second d) *features* :test 'string-equal)
1683 (dep op (third d) nil)))
1685 (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
1688 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
1690 (defun* do-collect (collect x)
1691 (funcall collect x))
1693 (defmethod do-traverse ((operation operation) (c component) collect)
1694 (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
1700 (update-flag (do-dep operation c collect op comp))))
1701 ;; Have we been visited yet? If so, just process the result.
1702 (aif (component-visited-p operation c)
1704 (update-flag (cdr it))
1705 (return-from do-traverse flag)))
1707 (when (component-visiting-p operation c)
1708 (error 'circular-dependency :components (list c)))
1709 (setf (visiting-component operation c) t)
1712 ;; first we check and do all the dependencies for the module.
1713 ;; Operations planned in this loop will show up
1714 ;; in the results, and are consumed below.
1715 (let ((*forcing* nil))
1716 ;; upstream dependencies are never forced to happen just because
1717 ;; the things that depend on them are....
1719 :for (required-op . deps) :in (component-depends-on operation c)
1720 :do (dep required-op deps)))
1723 (when (typep c 'module)
1724 (let ((at-least-one nil)
1725 ;; This is set based on the results of the
1726 ;; dependencies and whether we are in the
1727 ;; context of a *forcing* call...
1728 ;; inter-system dependencies do NOT trigger
1729 ;; building components
1732 (and flag (not (typep c 'system)))))
1734 (while-collecting (internal-collect)
1735 (dolist (kid (module-components c))
1738 (do-traverse operation kid #'internal-collect))
1739 (missing-dependency (condition)
1740 (when (eq (module-if-component-dep-fails c)
1743 (setf error condition))
1745 (declare (ignore c))
1746 (setf at-least-one t))))
1747 (when (and (eq (module-if-component-dep-fails c)
1754 (not (operation-done-p operation c))
1755 ;; For sub-operations, check whether
1756 ;; the original ancestor operation was forced,
1757 ;; or names us amongst an explicit list of things to force...
1758 ;; except that this check doesn't distinguish
1759 ;; between all the things with a given name. Sigh.
1761 (let ((f (operation-forced
1762 (operation-ancestor operation))))
1763 (and f (or (not (consp f)) ;; T or :ALL
1764 (and (typep c 'system) ;; list of names of systems to force
1765 (member (component-name c) f
1766 :test #'string=)))))))
1768 (let ((do-first (cdr (assoc (class-name (class-of operation))
1769 (component-do-first c)))))
1770 (loop :for (required-op . deps) :in do-first
1771 :do (do-dep operation c collect required-op deps)))
1772 (do-collect collect (vector module-ops))
1773 (do-collect collect (cons operation c)))))
1774 (setf (visiting-component operation c) nil)))
1775 (visit-component operation c (when flag (incf *visit-count*)))
1778 (defun* flatten-tree (l)
1779 ;; You collected things into a list.
1780 ;; Most elements are just things to collect again.
1781 ;; A (simple-vector 1) indicate that you should recurse into its contents.
1782 ;; This way, in two passes (rather than N being the depth of the tree),
1783 ;; you can collect things with marginally constant-time append,
1784 ;; achieving linear time collection instead of quadratic time.
1785 (while-collecting (c)
1787 (if (typep x '(simple-vector 1))
1791 (dolist (x l) (r x))))
1794 (defmethod traverse ((operation operation) (c component))
1795 ;; cerror'ing a feature that seems to have NEVER EVER worked
1796 ;; ever since danb created it in his 2003-03-16 commit e0d02781.
1797 ;; It was both fixed and disabled in the 1.700 rewrite.
1798 (when (consp (operation-forced operation))
1799 (cerror "Continue nonetheless."
1800 "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
1801 (setf (operation-forced operation)
1802 (mapcar #'coerce-name (operation-forced operation))))
1804 (while-collecting (collect)
1805 (let ((*visit-count* 0))
1806 (do-traverse operation c #'collect)))))
1808 (defmethod perform ((operation operation) (c source-file))
1810 "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
1811 (class-of operation) (class-of c)))
1813 (defmethod perform ((operation operation) (c module))
1814 (declare (ignorable operation c))
1817 (defmethod explain ((operation operation) (component component))
1818 (asdf-message "~&;;; ~A~%" (operation-description operation component)))
1820 (defmethod operation-description (operation component)
1821 (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
1823 ;;;; -------------------------------------------------------------------------
1826 (defclass compile-op (operation)
1827 ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
1828 (on-warnings :initarg :on-warnings :accessor operation-on-warnings
1829 :initform *compile-file-warnings-behaviour*)
1830 (on-failure :initarg :on-failure :accessor operation-on-failure
1831 :initform *compile-file-failure-behaviour*)
1832 (flags :initarg :flags :accessor compile-op-flags
1833 :initform #-ecl nil #+ecl '(:system-p t))))
1835 (defun output-file (operation component)
1836 "The unique output file of performing OPERATION on COMPONENT"
1837 (let ((files (output-files operation component)))
1838 (assert (length=n-p files 1))
1841 (defmethod perform :before ((operation compile-op) (c source-file))
1842 (map nil #'ensure-directories-exist (output-files operation c)))
1845 (defmethod perform :after ((o compile-op) (c cl-source-file))
1846 ;; Note how we use OUTPUT-FILES to find the binary locations
1847 ;; This allows the user to override the names.
1848 (let* ((files (output-files o c))
1849 (object (first files))
1850 (fasl (second files)))
1851 (c:build-fasl fasl :lisp-files (list object))))
1853 (defmethod perform :after ((operation operation) (c component))
1854 (setf (gethash (type-of operation) (component-operation-times c))
1855 (get-universal-time)))
1857 (declaim (ftype (function ((or pathname string)
1858 &rest t &key (:output-file t) &allow-other-keys)
1862 ;;; perform is required to check output-files to find out where to put
1863 ;;; its answers, in case it has been overridden for site policy
1864 (defmethod perform ((operation compile-op) (c cl-source-file))
1865 #-:broken-fasl-loader
1866 (let ((source-file (component-pathname c))
1867 ;; on some implementations, there are more than one output-file,
1868 ;; but the first one should always be the primary fasl that gets loaded.
1869 (output-file (first (output-files operation c)))
1870 (*compile-file-warnings-behaviour* (operation-on-warnings operation))
1871 (*compile-file-failure-behaviour* (operation-on-failure operation)))
1872 (multiple-value-bind (output warnings-p failure-p)
1873 (apply #'compile-file* source-file :output-file output-file
1874 (compile-op-flags operation))
1876 (case (operation-on-warnings operation)
1878 "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
1880 (:error (error 'compile-warned :component c :operation operation))
1883 (case (operation-on-failure operation)
1885 "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
1887 (:error (error 'compile-failed :component c :operation operation))
1890 (error 'compile-error :component c :operation operation)))))
1892 (defmethod output-files ((operation compile-op) (c cl-source-file))
1893 (declare (ignorable operation))
1894 (let ((p (lispize-pathname (component-pathname c))))
1895 #-:broken-fasl-loader
1896 (list (compile-file-pathname p #+ecl :type #+ecl :object)
1897 #+ecl (compile-file-pathname p :type :fasl))
1898 #+:broken-fasl-loader (list p)))
1900 (defmethod perform ((operation compile-op) (c static-file))
1901 (declare (ignorable operation c))
1904 (defmethod output-files ((operation compile-op) (c static-file))
1905 (declare (ignorable operation c))
1908 (defmethod input-files ((operation compile-op) (c static-file))
1909 (declare (ignorable operation c))
1912 (defmethod operation-description ((operation compile-op) component)
1913 (declare (ignorable operation))
1914 (format nil "compiling component ~S" (component-find-path component)))
1916 ;;;; -------------------------------------------------------------------------
1919 (defclass basic-load-op (operation) ())
1921 (defclass load-op (basic-load-op) ())
1923 (defmethod perform ((o load-op) (c cl-source-file))
1925 #-ecl (input-files o c)
1926 #+ecl (loop :for i :in (input-files o c)
1927 :unless (string= (pathname-type i) "fas")
1928 :collect (compile-file-pathname (lispize-pathname i)))))
1930 (defmethod perform-with-restarts (operation component)
1931 (perform operation component))
1933 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
1934 (declare (ignorable o))
1935 (loop :with state = :initial
1936 :until (or (eq state :success)
1937 (eq state :failure)) :do
1940 (setf state :failure)
1942 (setf state :success))
1944 (setf state :recompiled)
1945 (perform (make-instance 'compile-op) c))
1947 (with-simple-restart
1948 (try-recompiling "Recompile ~a and try loading it again"
1950 (setf state :failed-load)
1952 (setf state :success))))))
1954 (defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
1955 (loop :with state = :initial
1956 :until (or (eq state :success)
1957 (eq state :failure)) :do
1960 (setf state :failure)
1962 (setf state :success))
1964 (setf state :recompiled)
1965 (perform-with-restarts o c))
1967 (with-simple-restart
1968 (try-recompiling "Try recompiling ~a"
1970 (setf state :failed-compile)
1972 (setf state :success))))))
1974 (defmethod perform ((operation load-op) (c static-file))
1975 (declare (ignorable operation c))
1978 (defmethod operation-done-p ((operation load-op) (c static-file))
1979 (declare (ignorable operation c))
1982 (defmethod output-files ((operation operation) (c component))
1983 (declare (ignorable operation c))
1986 (defmethod component-depends-on ((operation load-op) (c component))
1987 (declare (ignorable operation))
1988 (cons (list 'compile-op (component-name c))
1989 (call-next-method)))
1991 (defmethod operation-description ((operation load-op) component)
1992 (declare (ignorable operation))
1993 (format nil "loading component ~S" (component-find-path component)))
1996 ;;;; -------------------------------------------------------------------------
1999 (defclass load-source-op (basic-load-op) ())
2001 (defmethod perform ((o load-source-op) (c cl-source-file))
2002 (declare (ignorable o))
2003 (let ((source (component-pathname c)))
2004 (setf (component-property c 'last-loaded-as-source)
2006 (get-universal-time)))))
2008 (defmethod perform ((operation load-source-op) (c static-file))
2009 (declare (ignorable operation c))
2012 (defmethod output-files ((operation load-source-op) (c component))
2013 (declare (ignorable operation c))
2016 ;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
2017 (defmethod component-depends-on ((o load-source-op) (c component))
2018 (declare (ignorable o))
2019 (let ((what-would-load-op-do (cdr (assoc 'load-op
2020 (component-in-order-to c)))))
2021 (mapcar (lambda (dep)
2022 (if (eq (car dep) 'load-op)
2023 (cons 'load-source-op (cdr dep))
2025 what-would-load-op-do)))
2027 (defmethod operation-done-p ((o load-source-op) (c source-file))
2028 (declare (ignorable o))
2029 (if (or (not (component-property c 'last-loaded-as-source))
2030 (> (safe-file-write-date (component-pathname c))
2031 (component-property c 'last-loaded-as-source)))
2034 (defmethod operation-description ((operation load-source-op) component)
2035 (declare (ignorable operation))
2036 (format nil "loading component ~S" (component-find-path component)))
2039 ;;;; -------------------------------------------------------------------------
2042 (defclass test-op (operation) ())
2044 (defmethod perform ((operation test-op) (c component))
2045 (declare (ignorable operation c))
2048 (defmethod operation-done-p ((operation test-op) (c system))
2049 "Testing a system is _never_ done."
2050 (declare (ignorable operation c))
2053 (defmethod component-depends-on :around ((o test-op) (c system))
2054 (declare (ignorable o))
2055 (cons `(load-op ,(component-name c)) (call-next-method)))
2058 ;;;; -------------------------------------------------------------------------
2059 ;;;; Invoking Operations
2061 (defgeneric* operate (operation-class system &key &allow-other-keys))
2063 (defmethod operate (operation-class system &rest args
2064 &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
2066 (declare (ignore force))
2067 (let* ((*package* *package*)
2068 (*readtable* *readtable*)
2069 (op (apply #'make-instance operation-class
2070 :original-initargs args
2072 (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
2073 (system (if (typep system 'component) system (find-system system))))
2074 (unless (version-satisfies system version)
2075 (error 'missing-component-of-version :requires system :version version))
2076 (let ((steps (traverse op system)))
2077 (with-compilation-unit ()
2078 (loop :for (op . component) :in steps :do
2082 (perform-with-restarts op component)
2087 (format s "~@<Retry ~A.~@:>" (operation-description op component))))
2091 (format s "~@<Continue, treating ~A as having been successful.~@:>"
2092 (operation-description op component)))
2093 (setf (gethash (type-of op)
2094 (component-operation-times component))
2095 (get-universal-time))
2097 (values op steps))))
2099 (defun* oos (operation-class system &rest args &key force verbose version
2101 (declare (ignore force verbose version))
2102 (apply #'operate operation-class system args))
2104 (let ((operate-docstring
2105 "Operate does three things:
2107 1. It creates an instance of OPERATION-CLASS using any keyword parameters
2109 2. It finds the asdf-system specified by SYSTEM (possibly loading
2111 3. It then calls TRAVERSE with the operation and system as arguments
2113 The traverse operation is wrapped in WITH-COMPILATION-UNIT and error
2114 handling code. If a VERSION argument is supplied, then operate also
2115 ensures that the system found satisfies it using the VERSION-SATISFIES
2118 Note that dependencies may cause the operation to invoke other
2119 operations on the system or its components: the new operations will be
2120 created with the same initargs as the original one.
2122 (setf (documentation 'oos 'function)
2124 "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
2126 (setf (documentation 'operate 'function)
2129 (defun* load-system (system &rest args &key force verbose version
2131 "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
2133 (declare (ignore force verbose version))
2134 (apply #'operate 'load-op system args)
2137 (defun* compile-system (system &rest args &key force verbose version
2139 "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
2141 (declare (ignore force verbose version))
2142 (apply #'operate 'compile-op system args)
2145 (defun* test-system (system &rest args &key force verbose version
2147 "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
2149 (declare (ignore force verbose version))
2150 (apply #'operate 'test-op system args)
2153 ;;;; -------------------------------------------------------------------------
2156 (defun* load-pathname ()
2157 (let ((pn (or *load-pathname* *compile-file-pathname*)))
2158 (if *resolve-symlinks*
2159 (and pn (resolve-symlinks pn))
2162 (defun* determine-system-pathname (pathname pathname-supplied-p)
2163 ;; The defsystem macro calls us to determine
2164 ;; the pathname of a system as follows:
2165 ;; 1. the one supplied,
2166 ;; 2. derived from *load-pathname* via load-pathname
2167 ;; 3. taken from the *default-pathname-defaults* via default-directory
2168 (let* ((file-pathname (load-pathname))
2169 (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
2170 (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
2172 (default-directory))))
2174 (defmacro defsystem (name &body options)
2175 (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
2176 defsystem-depends-on &allow-other-keys)
2178 (let ((component-options (remove-keys '(:class) options)))
2180 ;; system must be registered before we parse the body, otherwise
2181 ;; we recur when trying to find an existing system of the same name
2182 ;; to reuse options (e.g. pathname) from
2183 ,@(loop :for system :in defsystem-depends-on
2184 :collect `(load-system ,system))
2185 (let ((s (system-registered-p ',name)))
2186 (cond ((and s (eq (type-of (cdr s)) ',class))
2187 (setf (car s) (get-universal-time)))
2189 (change-class (cdr s) ',class))
2191 (register-system (quote ,name)
2192 (make-instance ',class :name ',name))))
2193 (%set-system-source-file (load-pathname)
2194 (cdr (system-registered-p ',name))))
2195 (parse-component-form
2197 :module (coerce-name ',name)
2199 ,(determine-system-pathname pathname pathname-arg-p)
2200 ',component-options))))))
2202 (defun* class-for-type (parent type)
2203 (or (loop :for symbol :in (list
2204 (unless (keywordp type) type)
2205 (find-symbol (symbol-name type) *package*)
2206 (find-symbol (symbol-name type) :asdf))
2207 :for class = (and symbol (find-class symbol nil))
2208 :when (and class (subtypep class 'component))
2210 (and (eq type :file)
2211 (or (module-default-component-class parent)
2212 (find-class *default-component-class*)))
2213 (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
2215 (defun* maybe-add-tree (tree op1 op2 c)
2216 "Add the node C at /OP1/OP2 in TREE, unless it's there already.
2217 Returns the new tree (which probably shares structure with the old one)"
2218 (let ((first-op-tree (assoc op1 tree)))
2221 (aif (assoc op2 (cdr first-op-tree))
2222 (if (find c (cdr it))
2224 (setf (cdr it) (cons c (cdr it))))
2225 (setf (cdr first-op-tree)
2226 (acons op2 (list c) (cdr first-op-tree))))
2228 (acons op1 (list (list op2 c)) tree))))
2230 (defun* union-of-dependencies (&rest deps)
2231 (let ((new-tree nil))
2233 (dolist (op-tree dep)
2234 (dolist (op (cdr op-tree))
2235 (dolist (c (cdr op))
2237 (maybe-add-tree new-tree (car op-tree) (car op) c))))))
2241 (defvar *serial-depends-on* nil)
2243 (defun* sysdef-error-component (msg type name value)
2244 (sysdef-error (concatenate 'string msg
2245 "~&The value specified for ~(~A~) ~A is ~S")
2248 (defun* check-component-input (type name weakly-depends-on
2249 depends-on components in-order-to)
2250 "A partial test of the values of a component."
2251 (unless (listp depends-on)
2252 (sysdef-error-component ":depends-on must be a list."
2253 type name depends-on))
2254 (unless (listp weakly-depends-on)
2255 (sysdef-error-component ":weakly-depends-on must be a list."
2256 type name weakly-depends-on))
2257 (unless (listp components)
2258 (sysdef-error-component ":components must be NIL or a list of components."
2259 type name components))
2260 (unless (and (listp in-order-to) (listp (car in-order-to)))
2261 (sysdef-error-component ":in-order-to must be NIL or a list of components."
2262 type name in-order-to)))
2264 (defun* %remove-component-inline-methods (component)
2265 (dolist (name +asdf-methods+)
2267 ;; this is inefficient as most of the stored
2268 ;; methods will not be for this particular gf
2269 ;; But this is hardly performance-critical
2271 (remove-method (symbol-function name) m))
2272 (component-inline-methods component)))
2273 ;; clear methods, then add the new ones
2274 (setf (component-inline-methods component) nil))
2276 (defun* %define-component-inline-methods (ret rest)
2277 (dolist (name +asdf-methods+)
2278 (let ((keyword (intern (symbol-name name) :keyword)))
2279 (loop :for data = rest :then (cddr data)
2280 :for key = (first data)
2281 :for value = (second data)
2283 :when (eq key keyword) :do
2284 (destructuring-bind (op qual (o c) &body body) value
2286 (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
2288 (component-inline-methods ret)))))))
2290 (defun* %refresh-component-inline-methods (component rest)
2291 (%remove-component-inline-methods component)
2292 (%define-component-inline-methods component rest))
2294 (defun* parse-component-form (parent options)
2296 (type name &rest rest &key
2297 ;; the following list of keywords is reproduced below in the
2298 ;; remove-keys form. important to keep them in sync
2299 components pathname default-component-class
2300 perform explain output-files operation-done-p
2302 depends-on serial in-order-to
2304 &allow-other-keys) options
2305 (declare (ignorable perform explain output-files operation-done-p))
2306 (check-component-input type name weakly-depends-on depends-on components in-order-to)
2309 (find-component parent name)
2310 ;; ignore the same object when rereading the defsystem
2312 (typep (find-component parent name)
2313 (class-for-type parent type))))
2314 (error 'duplicate-names :name name))
2316 (let* ((other-args (remove-keys
2317 '(components pathname default-component-class
2318 perform explain output-files operation-done-p
2320 depends-on serial in-order-to)
2323 (or (find-component parent name)
2324 (make-instance (class-for-type parent type)))))
2325 (when weakly-depends-on
2326 (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
2327 (when *serial-depends-on*
2328 (push *serial-depends-on* depends-on))
2329 (apply #'reinitialize-instance ret
2330 :name (coerce-name name)
2334 (component-pathname ret) ; eagerly compute the absolute pathname
2335 (when (typep ret 'module)
2336 (setf (module-default-component-class ret)
2337 (or default-component-class
2338 (and (typep parent 'module)
2339 (module-default-component-class parent))))
2340 (let ((*serial-depends-on* nil))
2341 (setf (module-components ret)
2343 :for c-form :in components
2344 :for c = (parse-component-form ret c-form)
2345 :for name = (component-name c)
2347 :when serial :do (setf *serial-depends-on* name))))
2348 (compute-module-components-by-name ret))
2350 (setf (component-load-dependencies ret) depends-on) ;; Used by POIU
2352 (setf (component-in-order-to ret)
2353 (union-of-dependencies
2355 `((compile-op (compile-op ,@depends-on))
2356 (load-op (load-op ,@depends-on)))))
2357 (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
2359 (%refresh-component-inline-methods ret rest)
2362 ;;;; ---------------------------------------------------------------------------
2363 ;;;; run-shell-command
2365 ;;;; run-shell-command functions for other lisp implementations will be
2366 ;;;; gratefully accepted, if they do the same thing.
2367 ;;;; If the docstring is ambiguous, send a bug report.
2369 ;;;; We probably should move this functionality to its own system and deprecate
2370 ;;;; use of it from the asdf package. However, this would break unspecified
2371 ;;;; existing software, so until a clear alternative exists, we can't deprecate
2372 ;;;; it, and even after it's been deprecated, we will support it for a few
2373 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
2375 (defun* run-shell-command (control-string &rest args)
2376 "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
2377 synchronously execute the result using a Bourne-compatible shell, with
2378 output to *VERBOSE-OUT*. Returns the shell's exit code."
2379 (let ((command (apply #'format nil control-string args)))
2380 (asdf-message "; $ ~A~%" command)
2383 (ext:run-shell-command command :output *verbose-out*)
2386 ;; will this fail if command has embedded quotes - it seems to work
2387 (multiple-value-bind (stdout stderr exit-code)
2388 (excl.osi:command-output
2389 (format nil "~a -c \"~a\""
2390 #+mswindows "sh" #-mswindows "/bin/sh" command)
2391 :input nil :whole nil
2392 #+mswindows :show-window #+mswindows :hide)
2393 (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
2394 (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
2397 #+clisp ;XXX not exactly *verbose-out*, I know
2398 (ext:run-shell-command command :output :terminal :wait t)
2402 (ccl:external-process-status
2403 (ccl:run-program "/bin/sh" (list "-c" command)
2404 :input nil :output *verbose-out*
2407 #+ecl ;; courtesy of Juan Jose Garcia Ripoll
2411 (lisp:system command)
2414 (system:call-system-showing-output
2416 :shell-type "/bin/sh"
2419 :output-stream *verbose-out*)
2422 (sb-ext:process-exit-code
2423 (apply #'sb-ext:run-program
2424 #+win32 "sh" #-win32 "/bin/sh"
2426 :input nil :output *verbose-out*
2427 #+win32 '(:search t) #-win32 nil))
2430 (ext:process-exit-code
2434 :input nil :output *verbose-out*))
2436 #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
2437 (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
2439 ;;;; ---------------------------------------------------------------------------
2440 ;;;; system-relative-pathname
2442 (defmethod system-source-file ((system-name string))
2443 (system-source-file (find-system system-name)))
2444 (defmethod system-source-file ((system-name symbol))
2445 (system-source-file (find-system system-name)))
2447 (defun* system-source-directory (system-designator)
2448 "Return a pathname object corresponding to the
2449 directory in which the system specification (.asd file) is
2451 (make-pathname :name nil
2453 :defaults (system-source-file system-designator)))
2455 (defun* relativize-directory (directory)
2457 ((stringp directory)
2458 (list :relative directory))
2459 ((eq (car directory) :absolute)
2460 (cons :relative (cdr directory)))
2464 (defun* relativize-pathname-directory (pathspec)
2465 (let ((p (pathname pathspec)))
2467 :directory (relativize-directory (pathname-directory p))
2470 (defun* system-relative-pathname (system name &key type)
2472 (merge-component-name-type name :type type)
2473 (system-source-directory system)))
2476 ;;; ---------------------------------------------------------------------------
2477 ;;; implementation-identifier
2479 ;;; produce a string to identify current implementation.
2480 ;;; Initially stolen from SLIME's SWANK, hacked since.
2482 (defparameter *implementation-features*
2485 (:digitool) ; before clozure, so it won't get preempted by ccl
2487 (:corman :cormanlisp)
2489 :sbcl :cmu :clisp :gcl :ecl :scl))
2491 (defparameter *os-features*
2492 '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
2494 (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
2495 (:macosx :darwin :darwin-target :apple)
2496 :freebsd :netbsd :openbsd :bsd
2499 (defparameter *architecture-features*
2500 '((:amd64 :x86-64 :x86_64 :x8664-target)
2501 (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
2504 (:ppc64 :ppc64-target)
2505 (:ppc32 :ppc32-target :ppc :powerpc)
2509 (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))
2511 (defun* lisp-version-string ()
2512 (let ((s (lisp-implementation-version)))
2513 (declare (ignorable s))
2514 #+allegro (format nil
2516 excl::*common-lisp-version-number*
2517 ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
2518 (if (eq excl:*current-case-mode*
2519 :case-sensitive-lower) "M" "A")
2520 ;; Note if not using International ACL
2521 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
2522 (excl:ics-target-case
2525 (if (member :64bit *features*) "-64bit" ""))
2526 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
2527 #+clisp (subseq s 0 (position #\space s))
2528 #+clozure (format nil "~d.~d-f~d" ; shorten for windows
2529 ccl::*openmcl-major-version*
2530 ccl::*openmcl-minor-version*
2531 (logand ccl::fasl-version #xFF))
2532 #+cmu (substitute #\- #\/ s)
2533 #+digitool (subseq s 8)
2534 #+ecl (format nil "~A~@[-~A~]" s
2535 (let ((vcs-id (ext:lisp-implementation-vcs-id)))
2536 (when (>= (length vcs-id) 8)
2537 (subseq vcs-id 0 8))))
2538 #+gcl (subseq s (1+ (position #\space s)))
2539 #+lispworks (format nil "~A~@[~A~]" s
2540 (when (member :lispworks-64bit *features*) "-64bit"))
2541 ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
2542 #+(or cormanlisp mcl sbcl scl) s
2543 #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
2544 ecl gcl lispworks mcl sbcl scl) s))
2546 (defun* first-feature (features)
2551 (let ((feature (find thing *features*)))
2552 (when feature (return-from fp feature))))
2553 ;; allows features to be lists of which the first
2554 ;; member is the "main name", the rest being aliases
2556 (dolist (subf thing)
2557 (when (find subf *features*) (return-from fp (first thing))))))
2559 (loop :for f :in features
2560 :when (fp f) :return :it)))
2562 (defun* implementation-type ()
2563 (first-feature *implementation-features*))
2565 (defun* implementation-identifier ()
2567 ((maybe-warn (value fstring &rest args)
2569 (t (apply #'warn fstring args)
2571 (let ((lisp (maybe-warn (implementation-type)
2572 "No implementation feature found in ~a."
2573 *implementation-features*))
2574 (os (maybe-warn (first-feature *os-features*)
2575 "No os feature found in ~a." *os-features*))
2576 (arch (maybe-warn (first-feature *architecture-features*)
2577 "No architecture feature found in ~a."
2578 *architecture-features*))
2579 (version (maybe-warn (lisp-version-string)
2580 "Don't know how to get Lisp implementation version.")))
2582 #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
2583 (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
2587 ;;; ---------------------------------------------------------------------------
2588 ;;; Generic support for configuration files
2590 (defparameter *inter-directory-separator*
2591 #+(or unix cygwin) #\:
2592 #-(or unix cygwin) #\;)
2594 (defun* user-homedir ()
2595 (truename (user-homedir-pathname)))
2597 (defun* try-directory-subpath (x sub &key type)
2598 (let* ((p (and x (ensure-directory-pathname x)))
2599 (tp (and p (probe-file* p)))
2600 (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
2601 (ts (and sp (probe-file* sp))))
2602 (and ts (values sp ts))))
2603 (defun* user-configuration-directories ()
2606 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2607 `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
2608 ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
2609 :for dir :in (split-string dirs :separator ":")
2610 :collect (try dir "common-lisp/"))
2611 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2612 ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
2613 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
2614 ,(try (getenv "APPDATA") "common-lisp/config/"))
2615 ,(try (user-homedir) ".config/common-lisp/")))))
2616 (defun* system-configuration-directories ()
2620 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2621 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
2622 `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
2623 ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
2624 ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
2625 (list #p"/etc/common-lisp/"))))
2626 (defun* in-first-directory (dirs x)
2627 (loop :for dir :in dirs
2628 :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
2629 (defun* in-user-configuration-directory (x)
2630 (in-first-directory (user-configuration-directories) x))
2631 (defun* in-system-configuration-directory (x)
2632 (in-first-directory (system-configuration-directories) x))
2634 (defun* configuration-inheritance-directive-p (x)
2635 (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
2637 (and (length=n-p x 1) (member (car x) kw)))))
2639 (defun* validate-configuration-form (form tag directive-validator
2640 &optional (description tag))
2641 (unless (and (consp form) (eq (car form) tag))
2642 (error "Error: Form doesn't specify ~A ~S~%" description form))
2643 (loop :with inherit = 0
2644 :for directive :in (cdr form) :do
2645 (if (configuration-inheritance-directive-p directive)
2647 (funcall directive-validator directive))
2649 (unless (= inherit 1)
2650 (error "One and only one of ~S or ~S is required"
2651 :inherit-configuration :ignore-inherited-configuration)))
2654 (defun* validate-configuration-file (file validator description)
2655 (let ((forms (read-file-forms file)))
2656 (unless (length=n-p forms 1)
2657 (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
2658 (funcall validator (car forms))))
2660 (defun* hidden-file-p (pathname)
2661 (equal (first-char (pathname-name pathname)) #\.))
2663 (defun* validate-configuration-directory (directory tag validator)
2664 (let ((files (sort (ignore-errors
2667 (directory (make-pathname :name :wild :type "conf" :defaults directory)
2668 #+sbcl :resolve-symlinks #+sbcl nil)))
2669 #'string< :key #'namestring)))
2671 ,@(loop :for file :in files :append
2672 (mapcar validator (read-file-forms file)))
2673 :inherit-configuration)))
2676 ;;; ---------------------------------------------------------------------------
2677 ;;; asdf-output-translations
2679 ;;; this code is heavily inspired from
2680 ;;; asdf-binary-translations, common-lisp-controller and cl-launch.
2681 ;;; ---------------------------------------------------------------------------
2683 (defvar *output-translations* ()
2684 "Either NIL (for uninitialized), or a list of one element,
2685 said element itself being a sorted list of mappings.
2686 Each mapping is a pair of a source pathname and destination pathname,
2687 and the order is by decreasing length of namestring of the source pathname.")
2689 (defvar *user-cache*
2690 (flet ((try (x &rest sub) (and x `(,x ,@sub))))
2692 (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
2693 #+(and (or win32 windows mswindows mingw32) (not cygwin))
2694 (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
2695 '(:home ".cache" "common-lisp" :implementation))))
2696 (defvar *system-cache*
2697 ;; No good default, plus there's a security problem
2698 ;; with other users messing with such directories.
2701 (defun* output-translations ()
2702 (car *output-translations*))
2704 (defun* (setf output-translations) (new-value)
2705 (setf *output-translations*
2707 (stable-sort (copy-list new-value) #'>
2712 (length (pathname-directory (car x)))))))))
2715 (defun* output-translations-initialized-p ()
2716 (and *output-translations* t))
2718 (defun* clear-output-translations ()
2719 "Undoes any initialization of the output translations.
2720 You might want to call that before you dump an image that would be resumed
2721 with a different configuration, so the configuration would be re-read then."
2722 (setf *output-translations* '())
2725 (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
2726 (values (or null pathname) &optional))
2729 (defun* resolve-relative-location-component (super x &key directory wilden)
2730 (let* ((r (etypecase x
2734 (return-from resolve-relative-location-component
2736 (resolve-relative-location-component
2737 super (car x) :directory directory :wilden wilden)
2738 (let* ((car (resolve-relative-location-component
2739 super (car x) :directory t :wilden nil))
2740 (cdr (resolve-relative-location-component
2741 (merge-pathnames* car super) (cdr x)
2742 :directory directory :wilden wilden)))
2743 (merge-pathnames* cdr car)))))
2744 ((eql :default-directory)
2745 (relativize-pathname-directory (default-directory)))
2746 ((eql :implementation) (implementation-identifier))
2747 ((eql :implementation-type) (string-downcase (implementation-type)))
2748 #-(and (or win32 windows mswindows mingw32) (not cygwin))
2749 ((eql :uid) (princ-to-string (get-uid)))))
2750 (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
2751 (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
2752 (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
2753 (error "pathname ~S is not relative to ~S" s super))
2754 (merge-pathnames* s super)))
2756 (defun* resolve-absolute-location-component (x &key directory wilden)
2760 (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
2762 (return-from resolve-absolute-location-component
2764 (resolve-absolute-location-component
2765 (car x) :directory directory :wilden wilden)
2766 (let* ((car (resolve-absolute-location-component
2767 (car x) :directory t :wilden nil))
2768 (cdr (resolve-relative-location-component
2769 car (cdr x) :directory directory :wilden wilden)))
2770 (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
2772 ;; special magic! we encode such paths as relative pathnames,
2773 ;; but it means "relative to the root of the source pathname's host and device".
2774 (return-from resolve-absolute-location-component
2775 (let ((p (make-pathname :directory '(:relative))))
2776 (if wilden (wilden p) p))))
2777 ((eql :home) (user-homedir))
2778 ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
2779 ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
2780 ((eql :default-directory) (default-directory))))
2781 (s (if (and wilden (not (pathnamep x)))
2784 (unless (absolute-pathname-p s)
2785 (error "Not an absolute pathname ~S" s))
2788 (defun* resolve-location (x &key directory wilden)
2790 (resolve-absolute-location-component x :directory directory :wilden wilden)
2791 (loop :with path = (resolve-absolute-location-component
2792 (car x) :directory (and (or directory (cdr x)) t)
2793 :wilden (and wilden (null (cdr x))))
2794 :for (component . morep) :on (cdr x)
2795 :for dir = (and (or morep directory) t)
2796 :for wild = (and wilden (not morep))
2797 :do (setf path (resolve-relative-location-component
2798 path component :directory dir :wilden wild))
2799 :finally (return path))))
2801 (defun* location-designator-p (x)
2802 (flet ((componentp (c) (typep c '(or string pathname keyword))))
2803 (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
2805 (defun* location-function-p (x)
2809 (or (and (equal (first x) :function)
2810 (typep (second x) 'symbol))
2811 (and (equal (first x) 'lambda)
2813 (length=n-p (second x) 2)))))
2815 (defun* validate-output-translations-directive (directive)
2817 (or (member directive '(:inherit-configuration
2818 :ignore-inherited-configuration
2819 :enable-user-cache :disable-cache nil))
2820 (and (consp directive)
2821 (or (and (length=n-p directive 2)
2822 (or (and (eq (first directive) :include)
2823 (typep (second directive) '(or string pathname null)))
2824 (and (location-designator-p (first directive))
2825 (or (location-designator-p (second directive))
2826 (location-function-p (second directive))))))
2827 (and (length=n-p directive 1)
2828 (location-designator-p (first directive))))))
2829 (error "Invalid directive ~S~%" directive))
2832 (defun* validate-output-translations-form (form)
2833 (validate-configuration-form
2835 :output-translations
2836 'validate-output-translations-directive
2837 "output translations"))
2839 (defun* validate-output-translations-file (file)
2840 (validate-configuration-file
2841 file 'validate-output-translations-form "output translations"))
2843 (defun* validate-output-translations-directory (directory)
2844 (validate-configuration-directory
2845 directory :output-translations 'validate-output-translations-directive))
2847 (defun* parse-output-translations-string (string)
2849 ((or (null string) (equal string ""))
2850 '(:output-translations :inherit-configuration))
2851 ((not (stringp string))
2852 (error "environment string isn't: ~S" string))
2853 ((eql (char string 0) #\")
2854 (parse-output-translations-string (read-from-string string)))
2855 ((eql (char string 0) #\()
2856 (validate-output-translations-form (read-from-string string)))
2860 :with directives = ()
2862 :with end = (length string)
2864 :for i = (or (position *inter-directory-separator* string :start start) end) :do
2865 (let ((s (subseq string start i)))
2868 (push (list source (if (equal "" s) nil s)) directives)
2872 (error "only one inherited configuration allowed: ~S" string))
2874 (push :inherit-configuration directives))
2880 (error "Uneven number of components in source to destination mapping ~S" string))
2882 (push :ignore-inherited-configuration directives))
2883 (return `(:output-translations ,@(nreverse directives)))))))))
2885 (defparameter *default-output-translations*
2886 '(environment-output-translations
2887 user-output-translations-pathname
2888 user-output-translations-directory-pathname
2889 system-output-translations-pathname
2890 system-output-translations-directory-pathname))
2892 (defun* wrapping-output-translations ()
2893 `(:output-translations
2894 ;; Some implementations have precompiled ASDF systems,
2895 ;; so we must disable translations for implementation paths.
2896 #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
2897 #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
2898 #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
2899 ;; All-import, here is where we want user stuff to be:
2900 :inherit-configuration
2901 ;; These are for convenience, and can be overridden by the user:
2902 #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
2903 #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
2904 ;; We enable the user cache by default, and here is the place we do:
2905 :enable-user-cache))
2907 (defparameter *output-translations-file* #p"asdf-output-translations.conf")
2908 (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
2910 (defun* user-output-translations-pathname ()
2911 (in-user-configuration-directory *output-translations-file* ))
2912 (defun* system-output-translations-pathname ()
2913 (in-system-configuration-directory *output-translations-file*))
2914 (defun* user-output-translations-directory-pathname ()
2915 (in-user-configuration-directory *output-translations-directory*))
2916 (defun* system-output-translations-directory-pathname ()
2917 (in-system-configuration-directory *output-translations-directory*))
2918 (defun* environment-output-translations ()
2919 (getenv "ASDF_OUTPUT_TRANSLATIONS"))
2921 (defgeneric* process-output-translations (spec &key inherit collect))
2922 (declaim (ftype (function (t &key (:collect (or symbol function))) t)
2923 inherit-output-translations))
2924 (declaim (ftype (function (t &key (:collect (or symbol function)) (:inherit list)) t)
2925 process-output-translations-directive))
2927 (defmethod process-output-translations ((x symbol) &key
2928 (inherit *default-output-translations*)
2930 (process-output-translations (funcall x) :inherit inherit :collect collect))
2931 (defmethod process-output-translations ((pathname pathname) &key inherit collect)
2933 ((directory-pathname-p pathname)
2934 (process-output-translations (validate-output-translations-directory pathname)
2935 :inherit inherit :collect collect))
2936 ((probe-file pathname)
2937 (process-output-translations (validate-output-translations-file pathname)
2938 :inherit inherit :collect collect))
2940 (inherit-output-translations inherit :collect collect))))
2941 (defmethod process-output-translations ((string string) &key inherit collect)
2942 (process-output-translations (parse-output-translations-string string)
2943 :inherit inherit :collect collect))
2944 (defmethod process-output-translations ((x null) &key inherit collect)
2945 (declare (ignorable x))
2946 (inherit-output-translations inherit :collect collect))
2947 (defmethod process-output-translations ((form cons) &key inherit collect)
2948 (dolist (directive (cdr (validate-output-translations-form form)))
2949 (process-output-translations-directive directive :inherit inherit :collect collect)))
2951 (defun* inherit-output-translations (inherit &key collect)
2953 (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
2955 (defun* process-output-translations-directive (directive &key inherit collect)
2956 (if (atom directive)
2958 ((:enable-user-cache)
2959 (process-output-translations-directive '(t :user-cache) :collect collect))
2961 (process-output-translations-directive '(t t) :collect collect))
2962 ((:inherit-configuration)
2963 (inherit-output-translations inherit :collect collect))
2964 ((:ignore-inherited-configuration nil)
2966 (let ((src (first directive))
2967 (dst (second directive)))
2968 (if (eq src :include)
2970 (process-output-translations (pathname dst) :inherit nil :collect collect))
2972 (let ((trusrc (or (eql src t)
2973 (let ((loc (resolve-location src :directory t :wilden t)))
2974 (if (absolute-pathname-p loc) (truenamize loc) loc)))))
2976 ((location-function-p dst)
2979 (if (symbolp (second dst))
2980 (fdefinition (second dst))
2981 (eval (second dst))))))
2983 (funcall collect (list trusrc t)))
2985 (let* ((trudst (make-pathname
2986 :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
2987 (wilddst (make-pathname
2988 :name :wild :type :wild :version :wild
2990 (funcall collect (list wilddst t))
2991 (funcall collect (list trusrc trudst)))))))))))
2993 (defun* compute-output-translations (&optional parameter)
2994 "read the configuration, return it"
2996 (while-collecting (c)
2997 (inherit-output-translations
2998 `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
2999 :test 'equal :from-end t))
3001 (defun* initialize-output-translations (&optional parameter)
3002 "read the configuration, initialize the internal configuration variable,
3003 return the configuration"
3004 (setf (output-translations) (compute-output-translations parameter)))
3006 (defun* disable-output-translations ()
3007 "Initialize output translations in a way that maps every file to itself,
3008 effectively disabling the output translation facility."
3009 (initialize-output-translations
3010 '(:output-translations :disable-cache :ignore-inherited-configuration)))
3012 ;; checks an initial variable to see whether the state is initialized
3013 ;; or cleared. In the former case, return current configuration; in
3014 ;; the latter, initialize. ASDF will call this function at the start
3015 ;; of (asdf:find-system).
3016 (defun* ensure-output-translations ()
3017 (if (output-translations-initialized-p)
3018 (output-translations)
3019 (initialize-output-translations)))
3021 (defun* translate-pathname* (path absolute-source destination &optional root source)
3022 (declare (ignore source))
3024 ((functionp destination)
3025 (funcall destination path absolute-source))
3028 ((not (pathnamep destination))
3029 (error "invalid destination"))
3030 ((not (absolute-pathname-p destination))
3031 (translate-pathname path absolute-source (merge-pathnames* destination root)))
3033 (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
3035 (translate-pathname path absolute-source destination))))
3037 (defun* apply-output-translations (path)
3041 ((or pathname string)
3042 (ensure-output-translations)
3043 (loop :with p = (truenamize path)
3044 :for (source destination) :in (car *output-translations*)
3045 :for root = (when (or (eq source t)
3046 (and (pathnamep source)
3047 (not (absolute-pathname-p source))))
3049 :for absolute-source = (cond
3050 ((eq source t) (wilden root))
3051 (root (merge-pathnames* source root))
3053 :when (or (eq source t) (pathname-match-p p absolute-source))
3054 :return (translate-pathname* p absolute-source destination root source)
3055 :finally (return p)))))
3057 (defmethod output-files :around (operation component)
3058 "Translate output files, unless asked not to"
3059 (declare (ignorable operation component))
3061 (multiple-value-bind (files fixedp) (call-next-method)
3064 (mapcar #'apply-output-translations files)))
3067 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
3069 (apply-output-translations
3070 (apply 'compile-file-pathname
3071 (truenamize (lispize-pathname input-file))
3074 (defun* tmpize-pathname (x)
3076 :name (format nil "ASDF-TMP-~A" (pathname-name x))
3079 (defun* delete-file-if-exists (x)
3080 (when (and x (probe-file x))
3083 (defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
3084 (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
3085 (tmp-file (tmpize-pathname output-file))
3087 (multiple-value-bind (output-truename warnings-p failure-p)
3088 (apply 'compile-file input-file :output-file tmp-file keys)
3091 (setf status *compile-file-failure-behaviour*))
3093 (setf status *compile-file-warnings-behaviour*))
3095 (setf status :success)))
3097 ((:success :warn :ignore)
3098 (delete-file-if-exists output-file)
3099 (when output-truename
3100 (rename-file output-truename output-file)
3101 (setf output-truename output-file)))
3103 (delete-file-if-exists output-truename)
3104 (setf output-truename nil)))
3105 (values output-truename warnings-p failure-p))))
3108 (defun* translate-jar-pathname (source wildcard)
3109 (declare (ignore wildcard))
3110 (let* ((p (pathname (first (pathname-device source))))
3111 (root (format nil "/___jar___file___root___/~@[~A/~]"
3112 (and (find :windows *features*)
3113 (pathname-device p)))))
3114 (apply-output-translations
3116 (relativize-pathname-directory source)
3118 (relativize-pathname-directory (ensure-directory-pathname p))
3121 ;;;; -----------------------------------------------------------------
3122 ;;;; Compatibility mode for ASDF-Binary-Locations
3124 (defun* enable-asdf-binary-locations-compatibility
3126 (centralize-lisp-binaries nil)
3127 (default-toplevel-directory
3128 ;; Use ".cache/common-lisp" instead ???
3129 (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
3131 (include-per-user-information nil)
3132 (map-all-source-files (or #+(or ecl clisp) t nil))
3133 (source-to-target-mappings nil))
3135 (when (null map-all-source-files)
3136 (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
3137 (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
3138 (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
3139 (mapped-files (make-pathname
3140 :name :wild :version :wild
3141 :type (if map-all-source-files :wild fasl-type)))
3142 (destination-directory
3143 (if centralize-lisp-binaries
3144 `(,default-toplevel-directory
3145 ,@(when include-per-user-information
3146 (cdr (pathname-directory (user-homedir))))
3147 :implementation ,wild-inferiors)
3148 `(:root ,wild-inferiors :implementation))))
3149 (initialize-output-translations
3150 `(:output-translations
3151 ,@source-to-target-mappings
3152 ((:root ,wild-inferiors ,mapped-files)
3153 (,@destination-directory ,mapped-files))
3155 :ignore-inherited-configuration))))
3157 ;;;; -----------------------------------------------------------------
3158 ;;;; Windows shortcut support. Based on:
3160 ;;;; Jesse Hager: The Windows Shortcut File Format.
3161 ;;;; http://www.wotsit.org/list.asp?fc=13
3163 #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
3165 (defparameter *link-initial-dword* 76)
3166 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
3168 (defun* read-null-terminated-string (s)
3169 (with-output-to-string (out)
3170 (loop :for code = (read-byte s)
3172 :do (write-char (code-char code) out))))
3174 (defun* read-little-endian (s &optional (bytes 4))
3176 :for i :from 0 :below bytes
3177 :sum (ash (read-byte s) (* 8 i))))
3179 (defun* parse-file-location-info (s)
3180 (let ((start (file-position s))
3181 (total-length (read-little-endian s))
3182 (end-of-header (read-little-endian s))
3183 (fli-flags (read-little-endian s))
3184 (local-volume-offset (read-little-endian s))
3185 (local-offset (read-little-endian s))
3186 (network-volume-offset (read-little-endian s))
3187 (remaining-offset (read-little-endian s)))
3188 (declare (ignore total-length end-of-header local-volume-offset))
3189 (unless (zerop fli-flags)
3191 ((logbitp 0 fli-flags)
3192 (file-position s (+ start local-offset)))
3193 ((logbitp 1 fli-flags)
3194 (file-position s (+ start
3195 network-volume-offset
3197 (concatenate 'string
3198 (read-null-terminated-string s)
3200 (file-position s (+ start remaining-offset))
3201 (read-null-terminated-string s))))))
3203 (defun* parse-windows-shortcut (pathname)
3204 (with-open-file (s pathname :element-type '(unsigned-byte 8))
3206 (when (and (= (read-little-endian s) *link-initial-dword*)
3207 (let ((header (make-array (length *link-guid*))))
3208 (read-sequence header s)
3209 (equalp header *link-guid*)))
3210 (let ((flags (read-little-endian s)))
3211 (file-position s 76) ;skip rest of header
3212 (when (logbitp 0 flags)
3213 ;; skip shell item id list
3214 (let ((length (read-little-endian s 2)))
3215 (file-position s (+ length (file-position s)))))
3218 (parse-file-location-info s))
3220 (when (logbitp 2 flags)
3221 ;; skip description string
3222 (let ((length (read-little-endian s 2)))
3223 (file-position s (+ length (file-position s)))))
3224 (when (logbitp 3 flags)
3225 ;; finally, our pathname
3226 (let* ((length (read-little-endian s 2))
3227 (buffer (make-array length)))
3228 (read-sequence buffer s)
3229 (map 'string #'code-char buffer)))))))
3233 ;;;; -----------------------------------------------------------------
3234 ;;;; Source Registry Configuration, by Francois-Rene Rideau
3235 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
3237 ;; Using ack 1.2 exclusions
3238 (defvar *default-source-registry-exclusions*
3240 ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
3241 ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
3242 "_sgbak" "autom4te.cache" "cover_db" "_build"
3243 "debian")) ;; debian often build stuff under the debian directory... BAD.
3245 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
3247 (defvar *source-registry* ()
3248 "Either NIL (for uninitialized), or a list of one element,
3249 said element itself being a list of directory pathnames where to look for .asd files")
3251 (defun* source-registry ()
3252 (car *source-registry*))
3254 (defun* (setf source-registry) (new-value)
3255 (setf *source-registry* (list new-value))
3258 (defun* source-registry-initialized-p ()
3259 (and *source-registry* t))
3261 (defun* clear-source-registry ()
3262 "Undoes any initialization of the source registry.
3263 You might want to call that before you dump an image that would be resumed
3264 with a different configuration, so the configuration would be re-read then."
3265 (setf *source-registry* '())
3268 (defparameter *wild-asd*
3269 (make-pathname :directory nil :name :wild :type "asd" :version :newest))
3271 (defun directory-has-asd-files-p (directory)
3273 (directory (merge-pathnames* *wild-asd* directory)
3274 #+sbcl #+sbcl :resolve-symlinks nil
3275 #+ccl #+ccl :follow-links nil
3276 #+clisp #+clisp :circle t))
3279 (defun subdirectories (directory)
3280 (let* ((directory (ensure-directory-pathname directory))
3282 (wild (merge-pathnames*
3283 #-(or abcl allegro lispworks scl)
3284 (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil)
3285 #+(or abcl allegro lispworks scl) "*.*"
3291 #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
3292 #+ccl '(:follow-links nil :directories t :files nil)
3293 #+clisp '(:circle t :if-does-not-exist :ignore)
3294 #+(or cmu scl) '(:follow-links nil :truenamep nil)
3295 #+digitool '(:directories t)
3296 #+sbcl '(:resolve-symlinks nil))))
3297 #+cormanlisp (cl::directory-subdirs directory))
3298 #+(or abcl allegro lispworks scl)
3299 (dirs (remove-if-not #+abcl #'extensions:probe-directory
3300 #+allegro #'excl:probe-directory
3301 #+lispworks #'lw:file-directory-p
3302 #-(or abcl allegro lispworks) #'directory-pathname-p
3306 (defun collect-sub*directories (directory collectp recursep collector)
3307 (when (funcall collectp directory)
3308 (funcall collector directory))
3309 (dolist (subdir (subdirectories directory))
3310 (when (funcall recursep subdir)
3311 (collect-sub*directories subdir collectp recursep collector))))
3313 (defun collect-sub*directories-with-asd
3315 (exclude *default-source-registry-exclusions*)
3317 (collect-sub*directories
3319 #'directory-has-asd-files-p
3320 #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
3323 (defun* validate-source-registry-directive (directive)
3325 (or (member directive '(:default-registry (:default-registry)) :test 'equal)
3326 (destructuring-bind (kw &rest rest) directive
3328 ((:include :directory :tree)
3329 (and (length=n-p rest 1)
3330 (location-designator-p (first rest))))
3331 ((:exclude :also-exclude)
3332 (every #'stringp rest))
3334 (error "Invalid directive ~S~%" directive))
3337 (defun* validate-source-registry-form (form)
3338 (validate-configuration-form
3339 form :source-registry 'validate-source-registry-directive "a source registry"))
3341 (defun* validate-source-registry-file (file)
3342 (validate-configuration-file
3343 file 'validate-source-registry-form "a source registry"))
3345 (defun* validate-source-registry-directory (directory)
3346 (validate-configuration-directory
3347 directory :source-registry 'validate-source-registry-directive))
3349 (defun* parse-source-registry-string (string)
3351 ((or (null string) (equal string ""))
3352 '(:source-registry :inherit-configuration))
3353 ((not (stringp string))
3354 (error "environment string isn't: ~S" string))
3355 ((find (char string 0) "\"(")
3356 (validate-source-registry-form (read-from-string string)))
3360 :with directives = ()
3362 :with end = (length string)
3363 :for pos = (position *inter-directory-separator* string :start start) :do
3364 (let ((s (subseq string start (or pos end))))
3366 ((equal "" s) ; empty element: inherit
3368 (error "only one inherited configuration allowed: ~S" string))
3370 (push ':inherit-configuration directives))
3372 (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
3374 (push `(:directory ,s) directives)))
3377 (setf start (1+ pos)))
3380 (push '(:ignore-inherited-configuration) directives))
3381 (return `(:source-registry ,@(nreverse directives))))))))))
3383 (defun* register-asd-directory (directory &key recurse exclude collect)
3385 (funcall collect directory)
3386 (collect-sub*directories-with-asd
3387 directory :exclude exclude :collect collect)))
3389 (defparameter *default-source-registries*
3390 '(environment-source-registry
3391 user-source-registry
3392 user-source-registry-directory
3393 system-source-registry
3394 system-source-registry-directory
3395 default-source-registry))
3397 (defparameter *source-registry-file* #p"source-registry.conf")
3398 (defparameter *source-registry-directory* #p"source-registry.conf.d/")
3400 (defun* wrapping-source-registry ()
3402 #+sbcl (:tree ,(getenv "SBCL_HOME"))
3403 :inherit-configuration
3404 #+cmu (:tree #p"modules:")))
3405 (defun* default-source-registry ()
3406 (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
3408 #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
3409 (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
3413 (or (getenv "XDG_DATA_HOME")
3414 (try (user-homedir) ".local/share/")))
3416 (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
3417 (dirs (cons datahome (split-string datadirs :separator ":"))))
3418 #+(and (or win32 windows mswindows mingw32) (not cygwin))
3419 ((datahome (getenv "APPDATA"))
3421 #+lispworks (sys:get-folder-path :local-appdata)
3422 #-lispworks (try (getenv "ALLUSERSPROFILE")
3423 "Application Data"))
3424 (dirs (list datahome datadir)))
3425 #-(or unix win32 windows mswindows mingw32 cygwin)
3427 (loop :for dir :in dirs
3428 :collect `(:directory ,(try dir "common-lisp/systems/"))
3429 :collect `(:tree ,(try dir "common-lisp/source/"))))
3430 :inherit-configuration)))
3431 (defun* user-source-registry ()
3432 (in-user-configuration-directory *source-registry-file*))
3433 (defun* system-source-registry ()
3434 (in-system-configuration-directory *source-registry-file*))
3435 (defun* user-source-registry-directory ()
3436 (in-user-configuration-directory *source-registry-directory*))
3437 (defun* system-source-registry-directory ()
3438 (in-system-configuration-directory *source-registry-directory*))
3439 (defun* environment-source-registry ()
3440 (getenv "CL_SOURCE_REGISTRY"))
3442 (defgeneric* process-source-registry (spec &key inherit register))
3443 (declaim (ftype (function (t &key (:register (or symbol function))) t)
3444 inherit-source-registry))
3445 (declaim (ftype (function (t &key (:register (or symbol function)) (:inherit list)) t)
3446 process-source-registry-directive))
3448 (defmethod process-source-registry ((x symbol) &key inherit register)
3449 (process-source-registry (funcall x) :inherit inherit :register register))
3450 (defmethod process-source-registry ((pathname pathname) &key inherit register)
3452 ((directory-pathname-p pathname)
3453 (process-source-registry (validate-source-registry-directory pathname)
3454 :inherit inherit :register register))
3455 ((probe-file pathname)
3456 (process-source-registry (validate-source-registry-file pathname)
3457 :inherit inherit :register register))
3459 (inherit-source-registry inherit :register register))))
3460 (defmethod process-source-registry ((string string) &key inherit register)
3461 (process-source-registry (parse-source-registry-string string)
3462 :inherit inherit :register register))
3463 (defmethod process-source-registry ((x null) &key inherit register)
3464 (declare (ignorable x))
3465 (inherit-source-registry inherit :register register))
3466 (defmethod process-source-registry ((form cons) &key inherit register)
3467 (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
3468 (dolist (directive (cdr (validate-source-registry-form form)))
3469 (process-source-registry-directive directive :inherit inherit :register register))))
3471 (defun* inherit-source-registry (inherit &key register)
3473 (process-source-registry (first inherit) :register register :inherit (rest inherit))))
3475 (defun* process-source-registry-directive (directive &key inherit register)
3476 (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
3479 (destructuring-bind (pathname) rest
3480 (process-source-registry (resolve-location pathname) :inherit nil :register register)))
3482 (destructuring-bind (pathname) rest
3484 (funcall register (resolve-location pathname :directory t)))))
3486 (destructuring-bind (pathname) rest
3488 (funcall register (resolve-location pathname :directory t)
3489 :recurse t :exclude *source-registry-exclusions*))))
3491 (setf *source-registry-exclusions* rest))
3493 (appendf *source-registry-exclusions* rest))
3494 ((:default-registry)
3495 (inherit-source-registry '(default-source-registry) :register register))
3496 ((:inherit-configuration)
3497 (inherit-source-registry inherit :register register))
3498 ((:ignore-inherited-configuration)
3502 (defun* flatten-source-registry (&optional parameter)
3504 (while-collecting (collect)
3505 (inherit-source-registry
3506 `(wrapping-source-registry
3508 ,@*default-source-registries*)
3509 :register (lambda (directory &key recurse exclude)
3510 (collect (list directory :recurse recurse :exclude exclude)))))
3511 :test 'equal :from-end t))
3513 ;; Will read the configuration and initialize all internal variables,
3514 ;; and return the new configuration.
3515 (defun* compute-source-registry (&optional parameter)
3516 (while-collecting (collect)
3517 (dolist (entry (flatten-source-registry parameter))
3518 (destructuring-bind (directory &key recurse exclude) entry
3519 (register-asd-directory
3521 :recurse recurse :exclude exclude :collect #'collect)))))
3523 (defun* initialize-source-registry (&optional parameter)
3524 (setf (source-registry) (compute-source-registry parameter)))
3526 ;; Checks an initial variable to see whether the state is initialized
3527 ;; or cleared. In the former case, return current configuration; in
3528 ;; the latter, initialize. ASDF will call this function at the start
3529 ;; of (asdf:find-system) to make sure the source registry is initialized.
3530 ;; However, it will do so *without* a parameter, at which point it
3531 ;; will be too late to provide a parameter to this function, though
3532 ;; you may override the configuration explicitly by calling
3533 ;; initialize-source-registry directly with your parameter.
3534 (defun* ensure-source-registry (&optional parameter)
3535 (if (source-registry-initialized-p)
3537 (initialize-source-registry parameter)))
3539 (defun* sysdef-source-registry-search (system)
3540 (ensure-source-registry)
3541 (loop :with name = (coerce-name system)
3542 :for defaults :in (source-registry)
3543 :for file = (probe-asd name defaults)
3544 :when file :return file))
3546 (defun* clear-configuration ()
3547 (clear-source-registry)
3548 (clear-output-translations))
3550 ;;;; -----------------------------------------------------------------
3551 ;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
3553 (defun* module-provide-asdf (name)
3555 ((style-warning #'muffle-warning)
3556 (missing-component (constantly nil))
3558 (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
3560 (let* ((*verbose-out* (make-broadcast-stream))
3561 (system (find-system (string-downcase name) nil)))
3563 (load-system system)
3566 #+(or abcl clisp clozure cmu ecl sbcl)
3567 (let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
3569 (eval `(pushnew 'module-provide-asdf
3570 #+abcl sys::*module-provider-functions*
3572 #+clozure ccl:*module-provider-functions*
3573 #+cmu ext:*module-provider-functions*
3574 #+ecl si:*module-provider-functions*
3575 #+sbcl sb-ext:*module-provider-functions*))))
3578 ;;;; -------------------------------------------------------------------------
3579 ;;;; Cleanups after hot-upgrade.
3580 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
3581 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
3583 ;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
3584 (eval-when (:compile-toplevel :load-toplevel :execute)
3585 #+ecl ;; Support upgrade from before ECL went to 1.369
3586 (when (fboundp 'compile-op-system-p)
3587 (defmethod compile-op-system-p ((op compile-op))
3588 (getf :system-p (compile-op-flags op)))
3589 (defmethod initialize-instance :after ((op compile-op)
3591 &key system-p &allow-other-keys)
3592 (declare (ignorable initargs))
3593 (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
3595 ;;;; -----------------------------------------------------------------
3597 (when *load-verbose*
3598 (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
3601 (eval-when (:compile-toplevel :execute)
3602 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
3603 (setf excl:*warn-on-nested-reader-conditionals* *acl-warn-save*)))
3605 (pushnew :asdf *features*)
3606 (pushnew :asdf2 *features*)
3610 ;;; Local Variables: