Commit 91709c76 authored by Andreas Fuchs's avatar Andreas Fuchs

refactor the methods again. fix tests.

parent 9648b4dc
......@@ -16,11 +16,11 @@
(funcall hook name macro-type component)))
(defun signal-user (name form-type)
(signal-user name form-type)
(signal-macroexpansion *user-hook* name form-type)
(values))
(defun signal-provider (name form-type)
(signal-provider name form-type)
(signal-macroexpansion *provider-hook* name form-type)
(values))
(defun signal-symbol-use-in-form (form)
......@@ -159,19 +159,18 @@ keeping declarations intact."
(funcall *old-macroexpand-hook* ,function
(progn ,@new-macro-body) ,env))))
(defgeneric handle-macroexpansion (translated-name form &key name function environment)
(:documentation "Handler for the macroexpansions of forms.
Returns two values: a boolean indicating whether the handler intends to replace the macroexpansion,
an optional form which is the new macroexpansion, or NIL.")
(:method (translated-name form &key name &allow-other-keys)
(signal-user name 'defmacro)))
(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))))
;;; The hook itself
(defun instrumenting-macroexpand-hook (fun form env)
(when (listp form)
(multiple-value-bind (replacep new-form)
(handle-macroexpansion (unalias-symbol (first form)) form
:function fun :environment env :name (first form))
(handle-macroexpansion (unalias-symbol (first form)) form fun env)
(signal-symbol-use-in-form form)
;; XXX: heuristic, doesn't catch everything:
(signal-possible-special-variable-use-in-form form)
......
......@@ -13,28 +13,29 @@
(in-package :asdf-dependency-grovel)
(defmacro define-macroexpand-handlers ((translated-name form
&key (name (gensym) namep)
(environment (gensym) environmentp)
(function (gensym) functionp))
(defmacro define-macroexpand-handlers ((form &key
(environment (gensym) environmentp)
(function (gensym) functionp))
(&rest form-names) &body body)
`(progn
,@(loop for form-name in form-names
collect `(defmethod handle-macroexpansion
((,translated-name (eql ',form-name)) ,form
&key ,@(and namep `(,name))
,@(and functionp `(,function))
,@(and environmentp `(,environment))
for fun-name = (intern (format nil "HANDLE-MACROEXPANSION-~A"
form-name))
collect `(defun ,fun-name
(,form &key
,@(and functionp `(((:function ,function))))
,@(and environmentp `(((:environment ,environment))))
&allow-other-keys)
,@body))))
,@body)
collect `(setf (gethash ',form-name *macroexpansion-handlers*)
',fun-name))))
(defmacro define-simple-macroexpand-handlers (form-var identifier-form
signal-type signal-form-type
(&rest form-names))
(let ((t-name (gensym))
(identifier (gensym)))
`(define-macroexpand-handlers (,t-name ,form-var) (,@form-names)
(let ((identifier (gensym)))
`(define-macroexpand-handlers (,form-var) (,@form-names)
(let ((,identifier ,identifier-form))
(,(ecase signal-type
(:user 'signal-user)
......@@ -42,19 +43,20 @@
,identifier ,signal-form-type)
(does-not-macroexpand)))))
(define-macroexpand-handlers (name form) (defmacro define-method-combination)
(signal-provider (second form) name)
(define-macroexpand-handlers (form) (defmacro define-method-combination)
(signal-provider (second form) (first form))
(does-not-macroexpand))
(define-simple-macroexpand-handlers form
(second form) :provider 'setf
(defsetf define-setf-expander))
(define-simple-macroexpand-handlers form
(first (second form)) :user 'setf
(setf))
(define-macroexpand-handlers (form) (setf)
(when (consp (second form))
(signal-user (first (second form)) 'setf))
(does-not-macroexpand))
(define-macroexpand-handlers (name form) (defgeneric)
(define-macroexpand-handlers (form) (defgeneric)
(signal-provider (second form) 'defgeneric)
(let ((method-combination (second (assoc :method-combination
(nthcdr 3 form)))))
......@@ -62,12 +64,12 @@
(signal-user method-combination 'define-method-combination)))
(does-not-macroexpand))
(define-macroexpand-handlers (name form) (defvar defparameter)
(define-macroexpand-handlers (form) (defvar defparameter)
(signal-provider (second form) 'defvar)
(setf (gethash (second form) *suspected-variables*) t)
(does-not-macroexpand))
(define-macroexpand-handlers (name form :function fun :environment env)
(define-macroexpand-handlers (form :function fun :environment env)
(defmethod)
(signal-user (second form) 'defgeneric)
;; walk arg list and signal use of specialized-on
......@@ -98,7 +100,7 @@
(does-macroexpand (fun env :macroexpand-hook *macroexpand-hook*)
new-expansion)))
(define-macroexpand-handlers (name form) (defclass define-condition)
(define-macroexpand-handlers (form) (defclass define-condition)
(signal-provider (second form) (first form))
;; signal use of direct
;; superclasses/superconditions. Note that we
......@@ -109,14 +111,14 @@
do (signal-user superclass (first form)))
(does-not-macroexpand))
(define-macroexpand-handlers (name form) (defstruct)
(define-macroexpand-handlers (form) (defstruct)
(let ((name (etypecase (second form)
(symbol (second form))
(cons (first (second form))))))
(signal-provider name 'defclass))
(does-not-macroexpand))
(define-macroexpand-handlers (name form) (defpackage)
(define-macroexpand-handlers (form) (defpackage)
;; signal a use for the package first, to do the package
;; redefinition dance right.
(signal-user
......@@ -148,24 +150,24 @@
'defpackage)))
(does-not-macroexpand))
(define-macroexpand-handlers (name form) (in-package)
(define-macroexpand-handlers (form) (in-package)
(signal-user (canonical-package-name (second form)) 'defpackage)
(does-not-macroexpand))
(define-macroexpand-handlers (name form :environment env)
(define-macroexpand-handlers (form :environment env)
(defconstant)
(signal-provider (second form) (first form))
(does-macroexpand ((macro-function 'symbol-macroify) env)
`(symbol-macroify ,@form)))
(define-macroexpand-handlers (name form :function fun :environment env)
(define-macroexpand-handlers (form :function fun :environment env)
(define-symbol-macro)
(destructuring-bind (def name expansion) form
(signal-provider name def)
(does-macroexpand (fun env)
`(,def ,name (signal-symbol-macroexpansion ',name ,expansion)))))
(define-macroexpand-handlers (name form :function fun :environment env) (defun)
(define-macroexpand-handlers (form :function fun :environment env) (defun)
(destructuring-bind (defun name arg-list &rest maybe-body) form
(signal-provider name (first form))
(does-macroexpand (fun env)
......@@ -173,7 +175,7 @@
,@(instrument-defun-body maybe-body
`(signal-user ',name 'defun))))))
(define-macroexpand-handlers (name form :function fun :environment env)
(define-macroexpand-handlers (form :function fun :environment env)
(with-open-file)
(destructuring-bind (stream pathname &key (direction :input)
&allow-other-keys)
......
......@@ -36,22 +36,23 @@
:has depends-on)))))
(load "../asdf-dependency-grovel.asd")
;;(load "test-serial.asd")
(push *load-truename* asdf:*central-registry*)
(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 ()
(with-open-file (f "groveled-components.lisp" :direction :input)
(let ((comps (read f))
(failed nil))
(loop for comp in comps
do (handler-case (apply #'1-component comps comp)
(failed-component (c)
(push (list (failed-file c) (failed-dependency c) (actual-dependency c))
failed))))
(if (null failed)
(format t "~&;;; ALL TESTS PASSED!~%")
(format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" failed))
(length failed))))
(let ((comps (asdf-dependency-grovel:read-component-file
"groveled-components.lisp" :test-serial-system))
(failed nil))
(loop for comp in comps
do (handler-case (apply #'1-component comps comp)
(failed-component (c)
(push (list (failed-file c) (failed-dependency c) (actual-dependency c))
failed))))
(if (null failed)
(format t "~&;;; ALL TESTS PASSED!~%")
(format t "~&;;; TESTS failed: ~:{~&;; ~A should have: ~S, has ~S~}~%" failed))
(length failed)))
......@@ -13,65 +13,9 @@
(defsystem :test-serial
:components ((component-file :asdf-dependency-grovel-test/serial
:load-system :asdf-dependency-grovel-test/serial
:merge-systems (:asdf-dependency-grovel-test/serial)
:load-systems (:test-serial-system)
:merge-systems (:test-serial-system)
:output-file "groveled-components.lisp"
:cull-redundant nil
:verbose nil)))
(defsystem :asdf-dependency-grovel-test/serial
:default-component-class instrumented-cl-source-file
: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")
;; 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.defmethod")
(: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-define-symbol-macro")
(:file "u-defconstant")))
(cl:in-package :asdf-dependency-grovel-test)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar a (list 'a 'b 'c 'd))
(setf (test-define-setf-expander.1 a) 3))
\ No newline at end of file
(defvar a-setf (list 'a 'b 'c 'd))
(setf (test-define-setf-expander.1 a-setf) 3))
......@@ -3,6 +3,8 @@
(defvar *provider-hook* nil)
(defvar *user-hook* nil)
(defvar *macroexpansion-handlers* (make-hash-table :test #'eql))
(defvar *old-macroexpand-hook* nil
"When the override macroexpand hook is active, this is bound to
the old value of *macroexpand-hook*.")
......
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