Commit 7c1ec163 authored by Andreas Fuchs's avatar Andreas Fuchs

do not rebind macroexpand-hook when instrumenting defmethods.

parent 68de11b2
......@@ -66,6 +66,7 @@ to the base of the system."
(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 ~
......@@ -74,8 +75,30 @@ to the base of the system."
((: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)
())
((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)))))
(defun state-of (op component)
(gethash component (states-of op)))
(defun (setf state-of) (new-val op component)
(setf (gethash component (states-of op)) new-val))
(defmethod asdf:source-file-type ((c component-file) (s asdf:module))
"asd")
......@@ -106,20 +129,19 @@ to the base of the system."
: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 need none of the systems to be loaded.
(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)
(error "Systems ~A are already loaded."
(remove-if #'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))
......@@ -136,16 +158,22 @@ to the base of the system."
"Component translation in System ~A which is not a member of the ~
systems to merge." system)
do (add-initargs system compspec initargs)))
(grovel-dependencies load-system component-stream
:interesting (mapcar #'asdf:find-system merge-systems)
:cull-redundant cull-redundant
:verbose verbose
:base-pathname
(or
(and (slot-boundp c 'base-pathname)
base-pathname)
(truename
(make-pathname :name nil
:type nil
:defaults
(asdf:component-pathname c))))))))
\ No newline at end of file
(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))))))))))
\ No newline at end of file
......@@ -65,7 +65,7 @@
(setf ,expression ,new-value)))
(defmacro symbol-macroify (operator name &rest args &environment env)
(let ((new-name (gentemp)))
(let ((new-name (gentemp (format nil "asdf-dependency-grovel-~A-" operator))))
`(progn
(define-symbol-macro ,name ,new-name)
,(macroexpand `(,operator ,new-name ,@args) env))))
......@@ -125,8 +125,7 @@ keeping declarations intact."
(signal-macroexpansion *user-hook* (second form) 'defgeneric)
;; walk arg list and signal use of specialized-on
;; classes, and instrument function body.
(let* ((*macroexpand-hook* *old-macroexpand-hook*)
(name (second form))
(let* ((name (second form))
(new-expansion
`(defmethod ,name
,@(loop for (elt . body) on (nthcdr 2 form)
......@@ -300,21 +299,52 @@ their :additional-dependencies."
(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)
(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)
:symbol-translations (simple-copy-hash-table (symbol-translations state)
:test #'eql)))
(defun grovel-dependencies (system stream &key interesting verbose cull-redundant
(base-pathname (truename
(make-pathname
:type nil
:name nil
:defaults (asdf:component-pathname system)))))
(let* ((system (asdf:find-system system))
(providers (make-hash-table :test #'equal))
(dependencies (make-hash-table :test #'eql))
:defaults (asdf:component-pathname system))))
initial-state)
(let* ((state (if initial-state
(copy-state initial-state)
(make-instance 'grovel-state)))
(system (asdf:find-system system))
(providers (providers state))
(dependencies (dependencies state))
(*old-macroexpand-hook* *macroexpand-hook*)
(*macroexpand-hook* #'instrumenting-macroexpand-hook)
(*symbol-translations* (make-hash-table))
(*symbol-translations* (symbol-translations state))
(*default-pathname-defaults* base-pathname)
(*grovel-dir-suffix* (get-universal-time)))
(*grovel-dir-suffix* (dir-suffix state)))
(labels ((interestingp (component)
(member (asdf:component-system component) interesting :test #'eql))
(redundantp (from to)
......@@ -407,6 +437,7 @@ their :additional-dependencies."
;; component initargs
(and (typep component 'instrumented-cl-source-file)
(additional-initargs component))))))
(format stream "~&)~%"))))))
(format stream "~&)~%"))))
state))
......@@ -36,8 +36,11 @@
:has depends-on)))))
(load "../asdf-dependency-grovel.asd")
(load "test-serial.asd")
(asdf:oos 'asdf-dependency-grovel:dependency-op :asdf-dependency-grovel-test/generator)
;;(load "test-serial.asd")
(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)
......
......@@ -11,7 +11,7 @@
(in-package :asdf-dependency-grovel-test.system)
(defsystem :asdf-dependency-grovel-test/generator
(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)
......
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