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: * Changes in 0.6.3 relative to 0.6.2:
** Fixed a silly bug in the last refactoring that caused duplicate names. ** Fixed a silly bug in the last refactoring that caused duplicate names.
......
...@@ -4,12 +4,36 @@ ...@@ -4,12 +4,36 @@
(:use :asdf :cl)) (:use :asdf :cl))
(cl:in-package #:asdf-dependency-grovel.system) (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 (defsystem asdf-dependency-grovel
:components ((:file "package") :components ((:file "package")
(:file "variables" :depends-on ("package")) (:file "variables" :depends-on ("package"))
(:file "grovel" :depends-on ("package" "variables")) (: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")))) (:file "asdf-ops" :depends-on ("package" "variables" "grovel"))))
(defmethod perform :after ((op load-op) (c (eql (find-system :asdf-dependency-grovel)))) (defmethod perform :after ((op load-op) (c (eql (find-system :asdf-dependency-grovel))))
(push :asdf-dependency-grovel *features*)) (push :asdf-dependency-grovel *features*))
\ No newline at end of file
This diff is collapsed.
This diff is collapsed.
...@@ -2,32 +2,40 @@ ...@@ -2,32 +2,40 @@
;;; ;;;
;;; TODO: ;;; TODO:
;; * handle more def*: ;; * handle more def*:
;; * defvar & defparameter - works for symbols, but think any use ;; * defvar & defparameter - works for symbols, but thinks any use
;; /somewhere/ in a macro is a dependency. ;; /somewhere/ in a macro is a dependency.
;; * define-compiler-macro - argh. seriously, no idea. if you use ;; * define-compiler-macro - argh. seriously, no idea. if you use
;; this at compile/load time, sorry. ;; this at compile/load time, sorry.
;; * deftype - we can signal that it was provided, but have to walk ;; * deftype - we can signal that it was provided, but have to walk
;; declarations in def* and generally almost /everwhere/. not fun. ;; declarations in def* and generally almost /everwhere/. not fun.
;; * more package games: :import-from, :shadow
(in-package :asdf-dependency-grovel) (in-package :asdf-dependency-grovel)
(defmacro define-macroexpand-handlers ((form &key (defmacro define-macroexpand-handlers ((form &key
(environment (gensym) environmentp) (environment (gensym) environmentp)
(function (gensym) functionp)) (function (gensym) functionp))
(&rest form-names) &body body) (&rest form-names) &body body)
;;; TODO: destructuring-bind form?
`(progn `(progn
,@(loop for form-name in form-names ,@(loop for form-name in form-names
for fun-name = (intern (format nil "HANDLE-MACROEXPANSION-~A" for symbol-name = (if (symbolp form-name)
form-name)) (symbol-name form-name)
(string (second form-name)))
for pkg-name = (canonical-package-name
(if (symbolp form-name)
(symbol-package form-name)
(first form-name)))
for fun-name = (intern (format nil "HANDLE-MACROEXPANSION-~A/~A"
pkg-name symbol-name)
:asdf-dependency-grovel)
collect `(defun ,fun-name collect `(defun ,fun-name
(,form &key (,form &key
,@(and functionp `(((:function ,function)))) ,@(and functionp `(((:function ,function))))
,@(and environmentp `(((:environment ,environment)))) ,@(and environmentp `(((:environment ,environment))))
&allow-other-keys) &allow-other-keys)
,@body) ,@body)
collect `(setf (gethash ',form-name *macroexpansion-handlers*) collect `(setf (gethash (list ',pkg-name ',symbol-name)
*macroexpansion-handlers*)
',fun-name)))) ',fun-name))))
(defmacro define-simple-macroexpand-handlers (form-var identifier-form (defmacro define-simple-macroexpand-handlers (form-var identifier-form
...@@ -52,10 +60,21 @@ ...@@ -52,10 +60,21 @@
(defsetf define-setf-expander)) (defsetf define-setf-expander))
(define-macroexpand-handlers (form) (setf) (define-macroexpand-handlers (form) (setf)
(when (consp (second form)) (loop for (setee value) on (cdr form) by #'cddr
(signal-user (first (second form)) 'setf)) do (cond
((consp setee)
(signal-user (first setee) 'setf))
((and (symbolp setee) (boundp setee))
(signal-user setee 'defvar)
(signal-provider setee 'defvar))))
(does-not-macroexpand)) (does-not-macroexpand))
(define-macroexpand-handlers (form) (pushnew push)
(let ((setee (third form)))
(when (and (symbolp setee) (boundp setee))
(signal-user setee 'defvar)
(signal-provider setee 'defvar))))
(define-macroexpand-handlers (form) (defgeneric) (define-macroexpand-handlers (form) (defgeneric)
(signal-provider (second form) 'defgeneric) (signal-provider (second form) 'defgeneric)
(let ((method-combination (second (assoc :method-combination (let ((method-combination (second (assoc :method-combination
...@@ -72,8 +91,8 @@ ...@@ -72,8 +91,8 @@
(define-macroexpand-handlers (form :function fun :environment env) (define-macroexpand-handlers (form :function fun :environment env)
(defmethod) (defmethod)
(signal-user (second form) 'defgeneric) (signal-user (second form) 'defgeneric)
;; walk arg list and signal use of specialized-on ;; walk arg list and signal use of specialized-on classes, and
;; classes, and instrument function body. ;; instrument function body.
(let* ((name (second form)) (let* ((name (second form))
(new-expansion (new-expansion
`(defmethod ,name `(defmethod ,name
...@@ -90,8 +109,7 @@ ...@@ -90,8 +109,7 @@
and collect elt into modifiers and collect elt into modifiers
and collect elt and collect elt
and append (instrument-defun-body body and append (instrument-defun-body body
`(signal-macroexpansion `(signal-user
*user-hook*
'(,name ,@modifiers) '(,name ,@modifiers)
'defmethod)) 'defmethod))
and do (loop-finish) and do (loop-finish)
...@@ -102,20 +120,26 @@ ...@@ -102,20 +120,26 @@
(define-macroexpand-handlers (form) (defclass define-condition) (define-macroexpand-handlers (form) (defclass define-condition)
(signal-provider (second form) (first form)) (signal-provider (second form) (first form))
;; signal use of direct (signal-provider (second form) 'deftype)
;; superclasses/superconditions. Note that we ;; signal use of direct superclasses/superconditions. Note that we
;; declare a dependency only if the direct ;; declare a dependency only if the direct superclass is already
;; superclass is already defined through the ;; defined through the current system definition.
;; current system definition.
(loop for superclass in (third form) (loop for superclass in (third form)
do (signal-user superclass (first form))) do (signal-user superclass (first form))
do (signal-user (second form) 'deftype))
(loop for slot in (fourth form)
for slot-type = (and (consp slot)
(getf (cdr slot) :type))
do (when slot-type
(signal-user slot-type 'deftype)))
(does-not-macroexpand)) (does-not-macroexpand))
(define-macroexpand-handlers (form) (defstruct) (define-macroexpand-handlers (form) (defstruct)
(let ((name (etypecase (second form) (let ((name (etypecase (second form)
(symbol (second form)) (symbol (second form))
(cons (first (second form)))))) (cons (first (second form))))))
(signal-provider name 'defclass)) (signal-provider name 'defclass)
(signal-provider (second form) 'deftype))
(does-not-macroexpand)) (does-not-macroexpand))
(define-macroexpand-handlers (form) (defpackage) (define-macroexpand-handlers (form) (defpackage)
...@@ -147,10 +171,26 @@ ...@@ -147,10 +171,26 @@
#'clause-second-element)) #'clause-second-element))
do (signal-user do (signal-user
(canonical-package-name use) (canonical-package-name use)
'defpackage))) 'defpackage))
;; signal imports of symbols (they need to exist before they can
;; be imported)
(loop for (clause-name pkg . symbols)
in (remove-if-not (lambda (clause)
(member (first clause)
'(:import-from
:shadowing-import-from)))
(nthcdr 2 form))
do (loop for sym in symbols
do (signal-user (find-symbol (string sym) pkg)
'internal-symbol))))
(does-not-macroexpand)) (does-not-macroexpand))
(define-macroexpand-handlers (form) (in-package) (define-macroexpand-handlers (form) (in-package)
(when *previous-package*
(signal-new-internal-symbols))
(setf *previous-package* (find-package (second form)))
(do-symbols (symbol *previous-package*)
(setf (gethash symbol *previously-interned-symbols*) t))
(signal-user (canonical-package-name (second form)) 'defpackage) (signal-user (canonical-package-name (second form)) 'defpackage)
(does-not-macroexpand)) (does-not-macroexpand))
...@@ -175,6 +215,17 @@ ...@@ -175,6 +215,17 @@
,@(instrument-defun-body maybe-body ,@(instrument-defun-body maybe-body
`(signal-user ',name 'defun)))))) `(signal-user ',name 'defun))))))
(define-macroexpand-handlers (form :function fun :environment env)
(lambda)
(let ((name (gentemp "ASDF-DEPENDENCY-GROVEL-LAMBDA"
'#:asdf-dependency-grovel.lambdas)))
(destructuring-bind (l arg-list &rest maybe-body) form
(signal-provider name 'defun)
(does-macroexpand (fun env)
`(,l ,arg-list
,@(instrument-defun-body maybe-body
`(signal-user ',name 'defun)))))))
(define-macroexpand-handlers (form :function fun :environment env) (define-macroexpand-handlers (form :function fun :environment env)
(with-open-file) (with-open-file)
(destructuring-bind (stream pathname &key (direction :input) (destructuring-bind (stream pathname &key (direction :input)
...@@ -189,4 +240,44 @@ ...@@ -189,4 +240,44 @@
`(signal-provider `(signal-provider
(namestring (merge-pathnames ,pathname)) (namestring (merge-pathnames ,pathname))
'file-component)))) 'file-component))))
(does-not-macroexpand)))) (does-not-macroexpand))))
\ No newline at end of file
(labels ((traverse-subtypes (typespec)
(cond
((consp typespec)
(case (first typespec)
(quote ; typespecs often come quoted. argh.
(traverse-subtypes (second typespec)))
((and or not) (mapcar #'traverse-subtypes (rest typespec)))
(satisfies (signal-user (second typespec) 'defun))
((vector array) (traverse-subtypes (second typespec)))
(function (and (second typespec)
(traverse-subtypes (second typespec))
(and (third typespec)
(traverse-subtypes (third typespec)))))
(:otherwise nil)))
((not (null typespec))
(signal-user typespec 'deftype)))))
(define-macroexpand-handlers (form) (handler-bind handler-case)
(loop for (condition . stuff) in (if (eql 'handler-bind (first form))
(second form)
(cddr form))
unless (eql condition :no-error)
do (traverse-subtypes condition))
(does-not-macroexpand))
(define-macroexpand-handlers (form) (deftype)
(signal-provider (second form) 'deftype)
(traverse-subtypes (fourth form))
(does-not-macroexpand))
(define-macroexpand-handlers (form) (typecase etypecase)
(loop for (typespec . rest) in (cddr form)
do (traverse-subtypes typespec))
(does-not-macroexpand))
(define-macroexpand-handlers (form) (check-type)
(traverse-subtypes (third form))
(does-not-macroexpand)))
(cl:defpackage #:asdf-dependency-grovel (cl:defpackage #:asdf-dependency-grovel
(:use #:cl) (:use #:cl)
(:export #:component-file #:dependency-op #:instrumented-cl-source-file (:export #:reload
#:component-file #:dependency-op #:compare-dependency-op
#:instrumented-cl-source-file
#:define-symbol-alias #:instrumented-module #:define-symbol-alias #:instrumented-module
#:instrumented-component #:additional-initargs #:instrumented-component #:additional-initargs
#:read-component-file #:systems-in-configuration #:read-component-file #:systems-in-configuration
#:handle-macroexpansion #:define-macroexpand-handlers #:handle-macroexpansion #:define-macroexpand-handlers
#:define-simple-macroexpand-handlers)) #:define-simple-macroexpand-handlers
#:signal-user #:signal-provider
#:with-dependency-tracking
;; feature set when groveling:
#:groveling))
(cl:defpackage #:asdf-dependency-grovel.packages (cl:defpackage #:asdf-dependency-grovel.packages
(:use))
(cl:defpackage #:asdf-dependency-grovel.lambdas
(:use)) (:use))
\ No newline at end of file
;;; Define the package of the test framework ;;; Define the package of the test framework
(cl:defpackage :asdf-dependency-grovel-tester (cl:defpackage :asdf-dependency-grovel-tester
(:use :cl) (:use :cl)
(:export #:test-result)) (:export #:test-result #:check-base-deps))
(cl:in-package :asdf-dependency-grovel-tester) (cl:in-package :asdf-dependency-grovel-tester)
...@@ -25,7 +25,8 @@ ...@@ -25,7 +25,8 @@
(remove-if-not (remove-if-not
(lambda (comp (lambda (comp
&aux (mismatch &aux (mismatch
(mismatch provider-comp (getf comp :file)))) (mismatch provider-comp
(getf comp :file))))
(or (not mismatch) (or (not mismatch)
(eql (length provider-comp) mismatch))) (eql (length provider-comp) mismatch)))
all-comps))) all-comps)))
...@@ -37,13 +38,13 @@ ...@@ -37,13 +38,13 @@
(load "../asdf-dependency-grovel.asd") (load "../asdf-dependency-grovel.asd")
(push *load-truename* asdf:*central-registry*) (push *load-truename* asdf:*central-registry*)
(setf *break-on-signals* '(or error warning)) ;; (setf *break-on-signals* '(or error warning))
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:oos 'asdf:load-op :asdf-dependency-grovel)) (asdf:oos 'asdf:load-op :asdf-dependency-grovel))
(push #p"." asdf:*central-registry*) (push #p"." asdf:*central-registry*)
(asdf:oos 'asdf-dependency-grovel:dependency-op :test-serial)
(defun test-result () (defun test-result ()
(asdf:oos 'asdf-dependency-grovel:dependency-op :test-serial)
(let ((comps (asdf-dependency-grovel:read-component-file (let ((comps (asdf-dependency-grovel:read-component-file
"groveled-components.lisp" :test-serial-system)) "groveled-components.lisp" :test-serial-system))
(failed nil)) (failed nil))
...@@ -56,3 +57,6 @@ ...@@ -56,3 +57,6 @@
(format t "~&;;; ALL TESTS PASSED!~%") (format t "~&;;; ALL TESTS PASSED!~%")
(format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" failed)) (format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" failed))
(length failed))) (length failed)))
(defun check-base-deps ()
(asdf:oos 'asdf-dependency-grovel:compare-dependency-op :test-serial))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test) (cl:in-package :asdf-dependency-grovel-test)
(defstruct test-defstruct) (defstruct test-defstruct)
\ No newline at end of file
(defstruct test-defstruct/function
a b c)
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(deftype foo () 'string)
(deftype bar () 'integer)
(defun satisfies-something (#1=#:a)
(declare (ignore #1#))
t)
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test) (cl:in-package :asdf-dependency-grovel-test)
(defun test-defun.1 (x) (declare (ignore x))) (defun test-defun.1 (x) (declare (ignore x)))
\ No newline at end of file
(defun test-defun.2 (x) (declare (ignore x)) "foo" (declare (special x)))
\ No newline at end of file
test-symbol-exports::something
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defpackage test-symbol-exports (:use))
\ No newline at end of file
#!/bin/sh
LISP="${1:-openmcl}"
cd `dirname $0`
$LISP --load `pwd`/grovel-tests.lisp --eval '(ccl:quit (asdf-dependency-grovel-tester:test-result))'
STATUS=$?
rm -rf asdf-dependency-grovel-tmp-*
#$LISP --load `pwd`/grovel-tests.lisp --eval '(asdf-dependency-grovel-tester:check-base-deps)' --eval '(ccl:quit)'
rm -rf asdf-dependency-grovel-tmp-* groveled-components.lisp
exit $STATUS
#!/bin/sh #!/bin/sh
SBCL="${1:-sbcl}"
cd `dirname $0` cd `dirname $0`
sbcl --load grovel-tests.lisp --eval '(sb-ext:quit :unix-status (asdf-dependency-grovel-tester:test-result))' $SBCL --load `pwd`/grovel-tests.lisp --eval '(sb-ext:quit :unix-status (asdf-dependency-grovel-tester:test-result))'
STATUS=$? STATUS=$?
rm -rf asdf-dependency-grovel-tmp-* groveled-components.lisp rm -rf asdf-dependency-grovel-tmp-*
#$SBCL --load `pwd`/grovel-tests.lisp --eval '(asdf-dependency-grovel-tester:check-base-deps)' --eval '(sb-ext:quit)'
#rm -rf asdf-dependency-grovel-tmp-* groveled-components.lisp
exit $STATUS exit $STATUS
;;; -*- lisp -*-
(asdf:defsystem :test-serial-system
:serial t
:components (
(:file "package")
;; simple stuff
(:file "p-defmacro")
(:file "p-define-method-combination")
;; setf
(:file "p-define-setf-expander")
(:file "p-defsetf")
;; clos
(:file "p-defclass")
(:file "p-defstruct")
(:file "p-defgeneric")
(:file "p-defmethod")
(:file "p-define-condition")
;; package system
(:file "p-defpackage")
;; defunoids / instrumented stuff
(:file "p-defun")
(:file "p-define-symbol-macro")
(:file "p-defconstant")
;; deftype
(:file "p-deftype")
;;; users
;; simple stuff
(:file "u-defmacro")
(:file "u-define-method-combination")
;; setf
(:file "u-define-setf-expander")
(:file "u-defsetf")
;; clos
(:file "u-defclass.defclass")
(:file "u-defclass.defmethod")
(:file "u-defstruct")
(:file "u-defstruct.defmethod")
(:file "u-defstruct.functions")
(:file "u-defgeneric")
(:file "u-defmethod")
(:file "u-define-condition")
;; package system
(:file "u-defpackage")
(:file "u-defpackage.1")
(:file "u-defpackage.2")
;; defunoids / instrumented stuff
(:file "u-defun")
(:file "u-defun.sharpquote")
(:file "u-define-symbol-macro")
(:file "u-defconstant")
;; deftypes
(:file "u-deftype.foo")
(:file "u-deftype.bar")
(:file "u-deftype.satisfies")
(:file "u-deftype.etypecase")
(:file "u-deftype.typecase")))
...@@ -16,6 +16,7 @@ ...@@ -16,6 +16,7 @@
:load-systems (:test-serial-system) :load-systems (:test-serial-system)
:merge-systems (:test-serial-system) :merge-systems (:test-serial-system)
:output-file "groveled-components.lisp" :output-file "groveled-components.lisp"
:cull-redundant nil :base-asd-file "groveled-components.output.asd"
:verbose nil))) :cull-redundant t
:verbose t)))
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel)
(test-defstruct/function-a *function-defstruct*))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defvar *function-defstruct* (make-test-defstruct/function :a 2 :b 3 :c 4))
(test-defstruct/function-a *function-defstruct*)
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(deftype uses-bar ()
`(or (not bar)
(and bar rational)))
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(etypecase 2
(bar 2)
(integer 2))
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(deftype uses-foo ()
'(and foo base-string))
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(deftype uses-satisfies ()
`(satisfies satisfies-something))
\ No newline at end of file
(in-package :asdf-dependency-grovel-test)
(typecase 1
(foo 1))
\ No newline at end of file
(cl:in-package :asdf-dependency-grovel-test)
(defvar #.(gensym) #'test-defun.1)
\ No newline at end of file
(cl:defpackage test-symbol-exports.uses
(:import-from test-symbol-exports "SOMETHING"))
\ No newline at end of file
(cl:in-package #:asdf-dependency-grovel) (cl:in-package #:asdf-dependency-grovel)
(defvar *provider-hook* nil) (defvar *macroexpansion-handlers* (make-hash-table :test #'equal))
(defvar *user-hook* nil)
(defvar *macroexpansion-handlers* (make-hash-table :test #'eql))
(defvar *old-macroexpand-hook* nil (defvar *old-macroexpand-hook* nil
"When the override macroexpand hook is active, this is bound to "When the override macroexpand hook is active, this is bound to
...@@ -19,6 +16,24 @@ ...@@ -19,6 +16,24 @@
"Hash table containing the symbols that should be treated as if they "Hash table containing the symbols that should be treated as if they
were variables when used in forms.") were variables when used in forms.")
(defvar *current-dependency-state* nil
"The state of dependency information for the current groveling run.")
(defvar *previous-package* nil
"The package that was current previous to this run. Allows the
symbol-interning heuristic.")
(defvar *previously-interned-symbols* (make-hash-table :test #'eql)
"The symbols that were interned in *previous-package* before the
current in-package stretch.")
(defvar *grovel-dir-suffix* nil (defvar *grovel-dir-suffix* nil
"Bound to a value that is unique once per operating on each "Bound to a value that is unique once per operating on each
dependency-groveling system.") dependency-groveling system.")
\ No newline at end of file
(defvar *debug-object-types* nil
"List containing object type names (as string designators) for which
dependency information should be printed.")
(defvar *component-dependency-op-times* (make-hash-table)
"Maps components to the last universal-time they were groveled.")
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment