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*))
This diff is collapsed.
This diff is collapsed.
......@@ -2,32 +2,40 @@
;;;
;;; TODO:
;; * 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.
;; * define-compiler-macro - argh. seriously, no idea. if you use
;; this at compile/load time, sorry.
;; * deftype - we can signal that it was provided, but have to walk
;; declarations in def* and generally almost /everwhere/. not fun.
;; * more package games: :import-from, :shadow
(in-package :asdf-dependency-grovel)
(defmacro define-macroexpand-handlers ((form &key
(environment (gensym) environmentp)
(function (gensym) functionp))
(&rest form-names) &body body)
;;; TODO: destructuring-bind form?
`(progn
,@(loop for form-name in form-names
for fun-name = (intern (format nil "HANDLE-MACROEXPANSION-~A"
form-name))
for symbol-name = (if (symbolp 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
(,form &key
,@(and functionp `(((:function ,function))))
,@(and environmentp `(((:environment ,environment))))
&allow-other-keys)
,@body)
collect `(setf (gethash ',form-name *macroexpansion-handlers*)
collect `(setf (gethash (list ',pkg-name ',symbol-name)
*macroexpansion-handlers*)
',fun-name))))
(defmacro define-simple-macroexpand-handlers (form-var identifier-form
......@@ -52,10 +60,21 @@
(defsetf define-setf-expander))
(define-macroexpand-handlers (form) (setf)
(when (consp (second form))
(signal-user (first (second form)) 'setf))
(loop for (setee value) on (cdr form) by #'cddr
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))
(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)
(signal-provider (second form) 'defgeneric)
(let ((method-combination (second (assoc :method-combination
......@@ -72,8 +91,8 @@
(define-macroexpand-handlers (form :function fun :environment env)
(defmethod)
(signal-user (second form) 'defgeneric)
;; walk arg list and signal use of specialized-on
;; classes, and instrument function body.
;; walk arg list and signal use of specialized-on classes, and
;; instrument function body.
(let* ((name (second form))
(new-expansion
`(defmethod ,name
......@@ -90,8 +109,7 @@
and collect elt into modifiers
and collect elt
and append (instrument-defun-body body
`(signal-macroexpansion
*user-hook*
`(signal-user
'(,name ,@modifiers)
'defmethod))
and do (loop-finish)
......@@ -102,20 +120,26 @@
(define-macroexpand-handlers (form) (defclass define-condition)
(signal-provider (second form) (first form))
;; signal use of direct
;; superclasses/superconditions. Note that we
;; declare a dependency only if the direct
;; superclass is already defined through the
;; current system definition.
(signal-provider (second form) 'deftype)
;; signal use of direct superclasses/superconditions. Note that we
;; declare a dependency only if the direct superclass is already
;; defined through the current system definition.
(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))
(define-macroexpand-handlers (form) (defstruct)
(let ((name (etypecase (second form)
(symbol (second form))
(cons (first (second form))))))
(signal-provider name 'defclass))
(signal-provider name 'defclass)
(signal-provider (second form) 'deftype))
(does-not-macroexpand))
(define-macroexpand-handlers (form) (defpackage)
......@@ -147,10 +171,26 @@
#'clause-second-element))
do (signal-user
(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))
(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)
(does-not-macroexpand))
......@@ -175,6 +215,17 @@
,@(instrument-defun-body maybe-body
`(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)
(with-open-file)
(destructuring-bind (stream pathname &key (direction :input)
......@@ -189,4 +240,44 @@
`(signal-provider
(namestring (merge-pathnames ,pathname))
'file-component))))
(does-not-macroexpand))))
\ No newline at end of file
(does-not-macroexpand))))
(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
(: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
#:instrumented-component #:additional-initargs
#:read-component-file #:systems-in-configuration
#: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
(:use))
(cl:defpackage #:asdf-dependency-grovel.lambdas
(:use))
\ No newline at end of file
;;; Define the package of the test framework
(cl:defpackage :asdf-dependency-grovel-tester
(:use :cl)
(:export #:test-result))
(:export #:test-result #:check-base-deps))
(cl:in-package :asdf-dependency-grovel-tester)
......@@ -25,7 +25,8 @@
(remove-if-not
(lambda (comp
&aux (mismatch
(mismatch provider-comp (getf comp :file))))
(mismatch provider-comp
(getf comp :file))))
(or (not mismatch)
(eql (length provider-comp) mismatch)))
all-comps)))
......@@ -37,13 +38,13 @@
(load "../asdf-dependency-grovel.asd")
(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)
(asdf:oos 'asdf:load-op :asdf-dependency-grovel))
(push #p"." asdf:*central-registry*)
(asdf:oos 'asdf-dependency-grovel:dependency-op :test-serial)
(defun test-result ()
(asdf:oos 'asdf-dependency-grovel:dependency-op :test-serial)
(let ((comps (asdf-dependency-grovel:read-component-file
"groveled-components.lisp" :test-serial-system))
(failed nil))
......@@ -56,3 +57,6 @@
(format t "~&;;; ALL TESTS PASSED!~%")
(format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" 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)
(defstruct test-defstruct)
\ No newline at end of file
(defstruct test-defstruct)
(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)
(defun test-defun.1 (x) (declare (ignore x)))
\ No newline at end of file
(defun test-defun.1 (x) (declare (ignore x)))
(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
SBCL="${1:-sbcl}"
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=$?
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
;;; -*- 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 @@
:load-systems (:test-serial-system)
:merge-systems (:test-serial-system)
:output-file "groveled-components.lisp"
:cull-redundant nil
:verbose nil)))
:base-asd-file "groveled-components.output.asd"
: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)
(defvar *provider-hook* nil)
(defvar *user-hook* nil)
(defvar *macroexpansion-handlers* (make-hash-table :test #'eql))
(defvar *macroexpansion-handlers* (make-hash-table :test #'equal))
(defvar *old-macroexpand-hook* nil
"When the override macroexpand hook is active, this is bound to
......@@ -19,6 +16,24 @@
"Hash table containing the symbols that should be treated as if they
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
"Bound to a value that is unique once per operating on each
dependency-groveling system.")
\ No newline at end of file
dependency-groveling system.")
(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