Commit d4a03e78 authored by Andreas Fuchs's avatar Andreas Fuchs

Merge work funded by ITA software plus lots of other improvements:

 * Better recognition of just about everything.
 * Lots of bug fixes.
 * Make it easier to drop in user-provided handler definitions in the
   handlers/ directory.
parent 91709c76
tests/groveled-components.lisp
tests/groveled-components.output.asd
.DS_Store
*.dx64fsl
*.fasl
* dump core with the dependency info and make it possible to continue from there
* it should be necessary to compile&load only those files that changed.
* dependency tracking refactoring:
** if component A provides X which is already provided somewhere else,
things using X need to depend on A
** need a way to re-provide something: have an explicit component order. This
happened implicitly before, but we now need to track the /reason/
why things depend on each other.
\ No newline at end of file
* Changes in 1.0.0 relative to 0.6.3:
** Lots of changes sponsored by ITA Software:
*** Standard compliance: Better parsing of declare/docstring combinations.
*** Better recognition of just about everything.
*** Incremental dependency groveling.
** Tentative openmcl support.
** Put the macroexpansion handler definitions into handlers/00-standard-handlers.lisp
for easier extension by user packages.
** Exported signal-user and signal-provider functions to ease recognition of
complex dependencies in user code.
** Put asdf-dependency-grovel:groveling on *features* if the groveler
is active.
* Changes in 0.6.3 relative to 0.6.2:
** Fixed a silly bug in the last refactoring that caused duplicate names.
......
......@@ -4,12 +4,36 @@
(:use :asdf :cl))
(cl:in-package #:asdf-dependency-grovel.system)
(defclass grovel-handlers (module)
((%components :accessor %handler-components)))
(defun handler-input-file-list (pathname parent)
(map 'list
(lambda (f)
(make-instance 'cl-source-file
:name (pathname-name f)
:parent parent
:pathname f))
(sort (directory (make-pathname :defaults pathname
:name :wild
:type "lisp"
:version :newest))
#'string<
:key #'namestring)))
(defmethod module-components ((c grovel-handlers))
(if (slot-boundp c '%components)
(%handler-components c)
(setf (%handler-components c)
(handler-input-file-list (component-pathname c) c))))
(defsystem asdf-dependency-grovel
:components ((:file "package")
(:file "variables" :depends-on ("package"))
(:file "grovel" :depends-on ("package" "variables"))
(:file "standard-handlers" :depends-on ("grovel"))
(grovel-handlers "handlers" :pathname #p"handlers/"
:depends-on ("grovel"))
(:file "asdf-ops" :depends-on ("package" "variables" "grovel"))))
(defmethod perform :after ((op load-op) (c (eql (find-system :asdf-dependency-grovel))))
(push :asdf-dependency-grovel *features*))
\ No newline at end of file
(push :asdf-dependency-grovel *features*))
......@@ -12,16 +12,25 @@
:initform nil
:reader additional-dependencies)
(overridden-dependencies :initarg :override-dependencies
:reader overridden-dependencies)))
(defclass instrumented-cl-source-file (asdf:cl-source-file
instrumented-component)
((additional-initargs :initarg :additional-initargs
:reader overridden-dependencies)
(additional-initargs :initarg :additional-initargs
:initform nil
:reader additional-initargs)))
(defclass instrumented-cl-source-file (asdf:cl-source-file
instrumented-component)
())
(defclass instrumented-module (asdf:module instrumented-component)
()
(:default-initargs :default-component-class 'instrumented-cl-source-file)))
(defmethod additional-initargs :around ((comp instrumented-component))
(flet ((slot-when-bound (slot-name initarg)
(when (slot-boundp comp slot-name)
`(,initarg ,(slot-value comp slot-name)))))
`(,@(call-next-method)
,@(slot-when-bound 'translated-name :translated-name)
,@(slot-when-bound 'translated-pathname :translated-pathname-form))))
(defmethod asdf:output-files :around ((op asdf:compile-op) (comp instrumented-cl-source-file))
"Put instrumented FASL files in a temporary directory relative
to the base of the system."
......@@ -44,65 +53,61 @@ to the base of the system."
system-base-dir)
output-file))))
(defmethod asdf:perform :around ((op asdf:load-op) (comp instrumented-cl-source-file))
(let ((*current-component* comp)
(file (namestring (merge-pathnames (asdf:component-pathname comp))))
(*readtable* (make-instrumented-readtable)))
(signal-macroexpansion *user-hook* file 'file-component)
(noticing-*feature*-changes
(call-next-method))))
(defmethod asdf:perform :around ((op asdf:compile-op) (comp instrumented-cl-source-file))
(let* ((*current-component* comp)
(file (namestring (merge-pathnames (asdf:component-pathname comp))))
(*readtable* (make-instrumented-readtable)))
(signal-macroexpansion *user-hook* file 'file-component)
(noticing-*feature*-changes
(call-next-method))))
(defun call-with-dependency-tracking (comp thunk)
(if *current-dependency-state*
(operating-on-component (comp)
(let ((file (namestring (merge-pathnames (asdf:component-pathname comp))))
(*readtable* (make-instrumented-readtable)))
(signal-user file 'file-component)
(noticing-*feature*-changes
(multiple-value-prog1 (funcall thunk)
(signal-new-internal-symbols)))))
(funcall thunk)))
(defmacro with-dependency-tracking (comp &body body)
`(call-with-dependency-tracking ,comp #'(lambda () ,@body)))
(macrolet ((emit-perform-method (op-type)
`(defmethod asdf:perform :around ((op ,op-type)
(comp instrumented-cl-source-file))
(with-dependency-tracking comp (call-next-method)))))
(emit-perform-method asdf:load-op)
(emit-perform-method asdf:compile-op))
;;; TODO for asdf-component/op:
;;; * ignore component-name. I have no idea what it /should/ indicate.
(defclass component-file (asdf:source-file)
((load-system :initarg :load-systems)
(merge-systems :initarg :merge-systems)
(cull-redundant :initarg :cull-redundant :initform nil)
(verbose :initarg :verbose :initform t)
(output-file :initarg :output-file)
(base-pathname :initarg :base-pathname)
(inherit-from :initarg :inherit-from :initform nil)
(additional-initargs :initarg :additional-initargs :initform nil
:documentation
#.(format nil "A list of mappings from ~
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass component-file (asdf:source-file)
((last-grovel-state :initform nil)
(load-system :initarg :load-systems)
(merge-systems :initarg :merge-systems)
(cull-redundant :initarg :cull-redundant :initform nil)
(verbose :initarg :verbose :initform t)
(output-file :initarg :output-file)
(base-pathname :initarg :base-pathname)
(debug-object-types :initarg :debug-object-types :initform nil)
(base-asd-file :initarg :base-asd-file :initform nil)
(additional-initargs :initarg :additional-initargs :initform nil
:documentation
#.(format nil "A list of mappings from ~
components in systems to additional initargs that the ~
instrumented components should receive. E.g.:
((:foo-system (\"module\" \"component-name\") :additional-dependencies ())
(:foo-system (\"component2\") :data-files ())"))))
(defun ancestor-component (component)
(asdf:find-component (asdf:component-parent component)
(slot-value component 'inherit-from)))
(defun inherited-slot-values (slot-name component)
(when (slot-value component 'inherit-from)
(let ((ancestor (ancestor-component component)))
(append (slot-value ancestor slot-name)
(inherited-slot-values slot-name ancestor)))))
(defclass dependency-op (asdf:operation)
())
(defclass dependency-op (asdf:operation)
((states :initform (make-hash-table :test #'equal)
:reader states-of)))
(defmethod asdf:component-depends-on ((op dependency-op) (c component-file))
(with-slots (inherit-from) c
(when inherit-from
`((dependency-op ,inherit-from)))))
(defclass compare-dependency-op (dependency-op) ()))
(defun state-of (op component)
(gethash component (states-of op)))
(declare (ignore op))
(slot-value component 'last-grovel-state))
(defun (setf state-of) (new-val op component)
(setf (gethash component (states-of op)) new-val))
(declare (ignore op))
(setf (slot-value component 'last-grovel-state) new-val))
(defmethod asdf:source-file-type ((c component-file) (s asdf:module))
"asd")
......@@ -115,7 +120,13 @@ to the base of the system."
(defmethod asdf:input-files ((op dependency-op) (c component-file))
;; XXX: base-pathname?
(asdf:component-pathname c))
(list (asdf:component-pathname c)))
(defmethod asdf:input-files ((op compare-dependency-op) (c component-file))
(append (call-next-method) (list (slot-value c 'base-asd-file))))
(defmethod asdf:output-files ((op compare-dependency-op) (c component-file))
(append (call-next-method) (list (slot-value c 'output-file))))
(defmethod asdf:operation-done-p ((op dependency-op) (comp component-file))
nil)
......@@ -126,69 +137,114 @@ to the base of the system."
;;; Necessary to support asd files that weren't rewritten to use
;;; instrumented-module/instrumented-cl-source-file classes.
(defmethod asdf::module-default-component-class :around ((c asdf:module))
*default-component-class*)
(let ((what-would-asdf-do (call-next-method)))
(if (member what-would-asdf-do `(nil asdf:cl-source-file
,(find-class 'asdf:cl-source-file)))
*default-component-class*
what-would-asdf-do)))
(defmethod asdf:perform ((op dependency-op) (c component-file))
(with-open-file (component-stream (car (asdf:output-files op c))
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(with-slots (
load-system merge-systems
component-name-translation cull-redundant verbose
additional-initargs base-pathname) c
;; we require that none of the systems be loaded.
(flet ((system-not-loaded-p (system)
(null
(gethash (asdf::coerce-name system) asdf::*defined-systems*))))
(unless (every #'system-not-loaded-p merge-systems)
(cerror "Continue anyway." "Systems ~A are already loaded."
(remove-if #'system-not-loaded-p merge-systems))))
(let ((*default-component-class* (find-class 'instrumented-cl-source-file)))
(mapc #'asdf:find-system merge-systems))
(labels ((find-component-in-module (module components)
(if (null (rest components))
(asdf:find-component module (first components))
(find-component-in-module (asdf:find-component module (first components))
(rest components))))
(add-initargs (system compspec args)
(let ((component (find-component-in-module
(asdf:find-system system)
compspec)))
(assert component (component)
"Component spec ~S in ~S didn't find a component."
compspec system)
(apply #'reinitialize-instance component
args))))
(loop for (system compspec . initargs) in additional-initargs
do (assert (member (asdf::coerce-name system) merge-systems :key #'asdf::coerce-name
:test #'equal)
()
"Component translation in System ~A which is not a member of the ~
(defun load-instrumented-systems (systems additional-initargs)
(let ((*default-component-class* (find-class 'instrumented-cl-source-file)))
(flet ((reload-system (system)
(let ((system (asdf:find-system system)))
(load (asdf:system-definition-pathname system)))))
(mapc #'reload-system systems)))
(labels ((find-component-in-module (module components)
(if (null (rest components))
(asdf:find-component module (first components))
(find-component-in-module (asdf:find-component module (first components))
(rest components))))
(add-initargs (system compspec args)
(let ((component (find-component-in-module
(asdf:find-system system)
compspec)))
(assert component (component)
"Component spec ~S in ~S didn't find a component."
compspec system)
(apply #'reinitialize-instance component args))))
(loop for (system compspec . initargs) in additional-initargs
do (assert (member (asdf::coerce-name system) systems :key #'asdf::coerce-name
:test #'equal)
()
"Component translation in System ~A which is not a member of the ~
systems to merge." system)
do (add-initargs system compspec initargs)))
(let ((merge-systems (append merge-systems (inherited-slot-values 'merge-systems c)))
(initial-state (when (ancestor-component c)
(state-of op (ancestor-component c)))))
(setf (state-of op c)
(grovel-dependencies load-system component-stream
:interesting (mapcar #'asdf:find-system merge-systems)
:cull-redundant cull-redundant
:verbose verbose
:initial-state initial-state
:base-pathname
(or
(and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c))))))))))
do (add-initargs system compspec initargs))))
;;; Reading the component list back into asdf defsystems
(defmethod asdf:perform ((op dependency-op) (c component-file))
(let ((tmp-file-name (format nil "~A-~A"
(first (asdf:output-files op c))
(get-universal-time))))
(with-open-file (component-stream tmp-file-name
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(with-slots (load-system merge-systems
component-name-translation cull-redundant verbose
additional-initargs base-pathname debug-object-types) c
(let ((base-pathname (or (and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c))))))
(load-instrumented-systems merge-systems additional-initargs)
(setf (state-of op c)
(if (state-of op c)
(re-grovel-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
(mapcar #'asdf:find-system merge-systems)
(state-of op c)
:verbose verbose
:debug-object-types debug-object-types
:base-pathname base-pathname)
(initially-grovel-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
(mapcar #'asdf:find-system merge-systems)
:verbose verbose
:cull-redundant cull-redundant
:debug-object-types debug-object-types
:base-pathname base-pathname))))))
(rename-file tmp-file-name (first (asdf:output-files op c)))))
(defmethod asdf:perform ((op compare-dependency-op) (c component-file))
;; not incremental yet (but it's mostly useless anyway for large systems?)
(with-slots (load-system merge-systems base-asd-file output-file
component-name-translation cull-redundant verbose
additional-initargs base-pathname debug-object-types) c
(let* ((base-pathname (or (and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c)))))
(out-pathname (pathname (first (asdf:output-files op c))))
(tmp-pathname (make-pathname
:name (format nil "~A-~A" (pathname-name out-pathname) (get-universal-time))
:defaults out-pathname)))
(load-instrumented-systems merge-systems additional-initargs)
(prog1
(grovel-and-compare-dependencies (mapcar #'asdf:find-system
(if (consp load-system)
load-system
(list load-system)))
base-asd-file
(mapcar #'asdf:find-system merge-systems)
:output tmp-pathname
:verbose verbose
:cull-redundant cull-redundant
:debug-object-types debug-object-types
:base-pathname base-pathname))
(rename-file tmp-pathname out-pathname))))
;;; Reading the component list back into asdf defsystems
(macrolet
((define-comp-file-reader (fname (1-system-var return-var)
......@@ -217,8 +273,8 @@ to the base of the system."
(do-1-system ,system-name))))
,return-var)))))))
(define-comp-file-reader read-component-file (system component-list)
(setf component-list
(setf component-list
(append component-list (getf (cdr system) :components))))
(define-comp-file-reader systems-in-configuration (system component-names)
(when system
(push (first system) component-names))))
\ No newline at end of file
(push (first system) component-names))))
......@@ -11,18 +11,6 @@
(t (string package-designator)))
:asdf-dependency-grovel.packages))
(defun signal-macroexpansion (hook name macro-type &optional (component *current-component*))
(when (and hook component)
(funcall hook name macro-type component)))
(defun signal-user (name form-type)
(signal-macroexpansion *user-hook* name form-type)
(values))
(defun signal-provider (name form-type)
(signal-macroexpansion *provider-hook* name form-type)
(values))
(defun signal-symbol-use-in-form (form)
(labels ((signal-for-symbol (sym)
(unless (or (null (symbol-package sym))
......@@ -48,6 +36,16 @@
if (symbolp cdr)
do (signal-for-symbol cdr))))))
(defun signal-new-internal-symbols ()
(when *previous-package*
(with-package-iterator (next-sym *previous-package* :internal :inherited)
(loop for (not-at-end-p symbol) = (multiple-value-list (next-sym))
while not-at-end-p
do (unless (gethash symbol *previously-interned-symbols*)
(signal-provider symbol 'internal-symbol)))))
(clrhash *previously-interned-symbols*)
(setf *previous-package* nil))
(defun signal-symbol-macroexpansion (name expansion)
(signal-user name 'define-symbol-macro)
expansion)
......@@ -74,27 +72,33 @@
form)
form))
(defun parse-body (body &key (ignore-multiple-docstrings t) whole)
;; Used with kind permission by Tobias C. Rittweiler.
;; C.f. CLHS 1.4.1.2.1 and 3.4.11.
(prog (current decls doc)
:scan-body
(setf current (car body))
(cond ((stringp current) (go :scan-string))
((eql 'declare (and (listp current) (first current)))
(push (pop body) decls) (go :scan-body))
(t (go :finish)))
:scan-string
(cond ((null (cdr body)) (go :finish)) ; string is form
((not doc)
(setf doc (pop body)) (go :scan-body))
(ignore-multiple-docstrings
(pop body) (go :scan-body)) ; skip redundant docstring
(t (error "Too many documentation strings in ~S." (or whole body))))
:finish
(return (values body (nreverse decls) doc))))
(defun instrument-defun-body (body form)
"Insert FORM into list of defun body forms BODY such that the
return value of BODY is the same as it would be without FORM,
keeping declarations intact."
`(,@
(when (stringp (first body))
(list (pop body)))
,@(loop for (elt . body) on (or body (list nil))
if (or (and (listp elt)
(not (eql (first elt) 'declare)))
(not (listp elt)))
collect form
and collect elt
and append body
and do (loop-finish)
if (null body)
collect elt
and collect form
and collect nil
and do (loop-finish)
collect elt)))
(multiple-value-bind (body decls doc)
(parse-body body :ignore-multiple-docstrings nil)
`(,@decls ,doc ,form ,@(or body (list nil)))))
(defmacro noticing-*feature*-changes (&rest body)
;; naive implementation, doesn't really deal with removed features
......@@ -111,7 +115,7 @@ keeping declarations intact."
(labels ((signal-feature (presentp feature)
(signal-user feature
(if presentp 'feature 'removed-feature)))
(if presentp 'feature 'removed-feature)))
(featurep (x)
(if (consp x)
(case (car x)
......@@ -142,33 +146,51 @@ keeping declarations intact."
(declare (ignore numarg subchar))
(guts stream t)))
(defun instrumented-sharpquote (stream subchar numarg)
(declare (ignore subchar numarg))
(let ((function (read stream t nil t)))
(when (or (symbolp function)
(and (consp function) (eql 'setf (first function))))
(signal-user function 'defun))
`(function ,function)))
(defun make-instrumented-readtable (&optional (readtable *readtable*))
(setf readtable (copy-readtable readtable))
(set-dispatch-macro-character #\# #\+ #'instrumented-sharp+ readtable)
(set-dispatch-macro-character #\# #\- #'instrumented-sharp- readtable)
(set-dispatch-macro-character #\# #\' #'instrumented-sharpquote readtable)
;; TODO: #.
readtable)
(defun does-not-macroexpand ()
(values nil nil))
(defun debug-print (string value)
(format *debug-io* ";; D: ~A ~S~%" string value)
value)
(defmacro does-macroexpand ((function env &key (macroexpand-hook '*old-macroexpand-hook*))
&body new-macro-body)
`(values t
(let ((*macroexpand-hook* ,macroexpand-hook))
(funcall *old-macroexpand-hook* ,function
(progn ,@new-macro-body) ,env))))
(debug-print "Macroexpanding into"
(funcall *old-macroexpand-hook* ,function
(progn ,@new-macro-body) ,env)))))
(defun handle-macroexpansion (translated-name form function environment)
(let ((handler (gethash translated-name *macroexpansion-handlers*)))
(if handler
(funcall handler
form :function function :environment environment)
(signal-user (first form) 'defmacro))))
(let ((handler (gethash (list (canonical-package-name (symbol-package translated-name))
(string (symbol-name translated-name)))
*macroexpansion-handlers*)))
(cond
(handler
(funcall handler
form :function function :environment environment))
(t (signal-user (first form) 'defmacro)
(does-not-macroexpand)))))
;;; The hook itself
(defun instrumenting-macroexpand-hook (fun form env)
(when (listp form)
(if (listp form)
(multiple-value-bind (replacep new-form)
(handle-macroexpansion (unalias-symbol (first form)) form fun env)
(signal-symbol-use-in-form form)
......@@ -177,23 +199,29 @@ keeping declarations intact."
(if replacep
new-form
(let ((expanded (funcall *old-macroexpand-hook* fun form env)))
expanded)))))
expanded)))
(funcall *old-macroexpand-hook* fun form env)))
;;; The actual groveling part.
(defun enough-component-name-from-reader (c)
(read-from-string (maybe-translated-component-name c)))
(defun enough-component-spec (c &optional pn-p)
(flet ((strip/ (name)
(subseq name (or (position #\/ name :from-end t) 0))))
(subseq name (1+ (or (position #\/ name :from-end t) -1)))))
(if (equal (parse-namestring (enough-namestring (asdf:component-pathname c)))
(make-pathname :name (asdf:component-name c) :type "lisp"))
(format nil "~S" (asdf:component-name c))
(let ((pn (parse-namestring (enough-namestring (asdf:component-pathname c)))))
(format nil "~S~:[~; :pathname #.(make-pathname :directory '~S :name ~S :type \"lisp\")~%~]"
;; XXX: make-pathname forms are more portable, but namestrings
;; are more readable.
(format nil "~S~:[~; :pathname #p~S~]"
(enough-namestring (make-pathname :name (strip/ (asdf:component-name c))
:type nil :defaults (asdf:component-pathname c)))
pn-p
(pathname-directory pn)
(pathname-name pn))))))
(enough-namestring pn))))))
(defun system-file-components (system)
"Flatten the tree of modules/components into a list that
......@@ -214,6 +242,8 @@ contains only the non-module components."
(defun dwim-stringify-component-spec (component-spec)
(case (char component-spec 0)
((#\# #\") ; is a subform, insert as-is
;; of course, this fails if the first char of a pathname should
;; be " or #. Let's hope nobody does that, ever.
component-spec)
(otherwise ; should be a string, make it one.
(concatenate 'string (string #\") component-spec (string #\")))))
......@@ -229,168 +259,490 @@ their :additional-dependencies."
(map-over-instrumented-component-and-parents component 'overridden-dependencies)))
(defun maybe-translated-component-name (component &key include-pathname)
(if (and (typep component 'instrumented-component)
(slot-boundp component 'translated-name))
(slot-boundp component 'translated-name))
(format nil "~A~@[ :pathname #.~S~]"
(slot-value component 'translated-name)
(dwim-stringify-component-spec
(slot-value component 'translated-name))
(and include-pathname
(slot-value component 'translated-pathname)))
(enough-component-spec component include-pathname)))
(defclass grovel-state ()
((dir-suffix :initform (get-universal-time)
:initarg :dir-suffix
:reader dir-suffix)
(providers :initform (make-hash-table :test #'equal)
:initarg :providers
:reader providers)
(dependencies :initform (make-hash-table :test #'eql)
:initarg :dependencies
:reader dependencies)
(suspected-variables :initform (make-hash-table :test #'eql)
:initarg :suspected-variables
:reader suspected-variables)
(symbol-translations :initform (make-hash-table)
:initarg :symbol-translations
:reader symbol-translations)))
(defun simple-copy-hash-table (hash-table &key (test #'eql) &aux (return (make-hash-table :test test)))
(loop for key being the hash-keys in hash-table using (hash-value value)
do (setf (gethash key return) value))
return)
(defun copy-state (state)
(make-instance 'grovel-state
:dir-suffix (dir-suffix state)
:providers (simple-copy-hash-table (providers state) :test #'equal)
:dependencies (simple-copy-hash-table (dependencies state) :test #'eql)
:suspected-variables (simple-copy-hash-table (suspected-variables state) :test #'eql)
:symbol-translations (simple-copy-hash-table (symbol-translations state)
:test #'eql)))
(defun grovel-dependencies (system-or-systems stream &key interesting verbose cull-redundant
(base-pathname (truename
(make-pathname
:type nil
:name nil
:defaults *load-truename*)))
initial-state)
(let* ((state (if initial-state
(copy-state initial-state)
(make-instance 'grovel-state)))
(systems (mapcar #'asdf:find-system
(if (consp system-or-systems)
system-or-systems
(list system-or-systems))))
(providers (providers state))
(dependencies (dependencies state))
(*old-macroexpand-hook* *macroexpand-hook*)
(*macroexpand-hook* #'instrumenting-macroexpand-hook)
(*symbol-translations* (symbol-translations state))
(*default-pathname-defaults* base-pathname)
(*grovel-dir-suffix* (dir-suffix state))
(*suspected-variables* (suspected-variables state)))
(labels ((interestingp (component)
(member (asdf:component-system component) interesting :test #'eql))
(redundantp (from to)
(labels ((redundantp-1 (from-1)
(let ((from-deps (gethash from-1 dependencies)))
(cond ((and (member to from-deps) (not (eql from from-1))) t)
(t (dolist (from-dep from-deps)
(when (redundantp-1 from-dep)
(return-from redundantp t)))
nil)))))
(redundantp-1 from)))
(new-dep (from to-components)
(when (and (interestingp from)
(some #'interestingp to-components))
(setf (gethash from dependencies)
(delete-duplicates (append (remove-if-not #'interestingp to-components)
(gethash from dependencies))))
(loop for component in to-components
do (pushnew (asdf:component-system component)
(gethash (asdf:component-system from) dependencies)))))
(coerce-name (maybe-class)
(if (typep maybe-class 'standard-class)
(class-name maybe-class)
maybe-class)))
(let ((*provider-hook*
(lambda (name type component)
(pushnew component (gethash (list type name) providers))))
(*user-hook*
(lambda (name type component)
(cond ((and (gethash (list type name) providers)
(not (member component (gethash (list type name) providers))))
(new-dep component (gethash (list type name) providers)))))))
(let ((*compile-print* verbose)
(*compile-verbose* verbose)
;; (*break-on-signals* 'warning)
)
(dolist (system systems)
(asdf:oos 'asdf:load-op system :verbose verbose)))
(let ((*print-case* :downcase))
(format stream ";;; This file contains -*- lisp -*- expressions.~%")
(format stream "~@<;;; ~@;AUTO-GENERATED file from system definition of system ~A ~
Instead of directly editing this file, please edit the system definition~P of~
~{ ~A~^ or~}, then re-generate this file.~:@>"