(cl:in-package #:asdf-dependency-grovel)
-(defmethod asdf:output-files :around ((op asdf:compile-op) (comp instrumented-cl-source-file))
+(defmethod output-files :around ((op compile-op) (comp instrumented-cl-source-file))
"Put instrumented FASL files in a temporary directory relative
to the base of the system."
(let* ((output-file (car (call-next-method)))
(defun call-with-dependency-tracking (comp thunk)
(if *current-constituent*
(operating-on-asdf-component-constituent (comp)
- ;((merge-pathnames (asdf:component-pathname comp)))
(with-groveling-readtable
(with-groveling-macroexpand-hook
(funcall thunk))))
;; (if *current-dependency-state*
;; (operating-on-component (comp)
;; (let ((file (namestring (merge-pathnames
-;; (asdf:component-pathname comp))))
+;; (component-pathname comp))))
;; (*readtable* (make-instrumented-readtable)))
;; (signal-user file 'file-component)
;; (noticing-*feature*-changes
#|
(macrolet ((emit-perform-method (op-type)
- `(defmethod asdf:perform :around
+ `(defmethod perform :around
((op ,op-type)
(comp instrumented-cl-source-file))
(with-dependency-tracking comp (call-next-method)))))
- (emit-perform-method asdf:load-source-op)
- (emit-perform-method asdf:load-op)
- (emit-perform-method asdf:compile-op))
+ (emit-perform-method load-source-op)
+ (emit-perform-method load-op)
+ (emit-perform-method compile-op))
|#
-(defmethod asdf:perform
- ((op asdf:load-source-op)
+(defmethod perform
+ ((op load-source-op)
(comp instrumented-cl-source-file))
- (wtf "Perform asdf:load-source-op ~S" comp)
- (let ((source (asdf:component-pathname comp)))
+ (wtf "Perform load-source-op ~S" comp)
+ (let ((source (component-pathname comp)))
;; do NOT grovel the same file more than once
(operating-on-asdf-component-constituent (comp)
- (unless (asdf:component-property comp 'last-loaded-as-source)
- (setf (asdf:component-property comp 'last-loaded-as-source)
+ (unless (component-property comp 'last-loaded-as-source)
+ (setf (component-property comp 'last-loaded-as-source)
(and (#+sbcl fine-grain-instrumented-load ;;load
#-sbcl instrumented-load
source)
(get-universal-time)))))))
-(defmethod asdf:perform :around
- ((op asdf:compile-op)
+(defmethod perform :around
+ ((op compile-op)
(comp instrumented-cl-source-file))
nil)
-(defmethod asdf:perform :around
- ((op asdf:load-op)
+(defmethod perform :around
+ ((op load-op)
(comp instrumented-cl-source-file))
- (asdf:perform (make-instance 'asdf:load-source-op) comp))
+ (perform (make-instance 'load-source-op) comp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; * ignore component-name. I have no idea what it /should/ indicate.
;; Used by XCVB:
-(defclass component-file (asdf:source-file)
+(defclass component-file (source-file)
((last-grovel-state :initform nil)
(load-system :initarg :load-systems)
(merge-systems :initarg :merge-systems)
(:foo-system (\"component2\") :data-files ())"))))
;; Used by XCVB.
-(defclass dependency-op (asdf:operation) ())
+(defclass dependency-op (operation) ())
(defun state-of (op component)
(declare (ignore op))
(declare (ignore op))
(setf (slot-value component 'last-grovel-state) new-val))
-(defmethod asdf:source-file-type ((c component-file) (s asdf:module))
+(defmethod source-file-type ((c component-file) (s module))
"asd")
-(defmethod asdf:output-files ((op dependency-op) (c component-file))
+(defmethod output-files ((op dependency-op) (c component-file))
(list
;; XXX: base-pathname?
(merge-pathnames (slot-value c 'output-file)
- (asdf:component-pathname c))))
+ (component-pathname c))))
-(defmethod asdf:input-files ((op dependency-op) (c component-file))
+(defmethod input-files ((op dependency-op) (c component-file))
;; XXX: base-pathname?
- (list (asdf:component-pathname c)))
+ (list (component-pathname c)))
-(defmethod asdf:operation-done-p ((op dependency-op) (comp component-file))
+(defmethod operation-done-p ((op dependency-op) (comp component-file))
nil)
-(defvar *default-component-class* (find-class 'asdf:cl-source-file))
+(defvar *default-component-class* (find-class 'cl-source-file))
;;; XXX: nasty hack.
;;; 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))
+(defmethod :module-default-component-class :around ((c module))
(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)))
+ (if (member what-would-asdf-do `(nil cl-source-file
+ ,(find-class 'cl-source-file)))
*default-component-class*
what-would-asdf-do)))
-;; Used by asdf:perform.
+;; Used by perform.
(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)))))
+ (let ((system (find-system system)))
+ (load (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
+ (find-component module (first components))
+ (find-component-in-module (find-component
module (first components))
(rest components))))
(add-initargs (system compspec args)
(let ((component (find-component-in-module
- (asdf:find-system system)
+ (find-system system)
compspec)))
(assert component (component)
"Component spec ~S in ~S didn't find a component."
systems to merge." system)
(add-initargs system compspec initargs))))
-(defmethod asdf:perform ((op dependency-op) (c component-file))
- (let* ((destination-file (first (asdf:output-files op c)))
+(defmethod perform ((op dependency-op) (c component-file))
+ (let* ((destination-file (first (output-files op c)))
(tmp-file-name (format nil "~A-~A"
destination-file
(get-universal-time))))
(truename (make-pathname :name nil
:type nil
:defaults
- (asdf:component-pathname c))))))
+ (component-pathname c))))))
(load-instrumented-systems merge-systems additional-initargs)
(setf (state-of op c)
(if (state-of op c)
(error "I refuse to re-grovel.")
;; (re-grovel-dependencies
-;; (mapcar #'asdf:find-system
+;; (mapcar #'find-system
;; (if (consp load-system)
;; load-system
;; (list load-system)))
;; component-stream
-;; (mapcar #'asdf:find-system merge-systems)
+;; (mapcar #'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
+ (mapcar #'find-system
(if (consp load-system)
load-system
(list load-system)))
component-stream
- (mapcar #'asdf:find-system merge-systems)
+ (mapcar #'find-system merge-systems)
:verbose verbose
;; :cull-redundant cull-redundant
;; :debug-object-types debug-object-types
;; (defclass compare-dependency-op (dependency-op) ())
;; ;; Unused.
-;; (defmethod asdf:input-files ((op compare-dependency-op) (c component-file))
+;; (defmethod input-files ((op compare-dependency-op) (c component-file))
;; (append (call-next-method) (list (slot-value c 'base-asd-file))))
;; ;; Unused.
-;; (defmethod asdf:output-files ((op compare-dependency-op) (c component-file))
+;; (defmethod output-files ((op compare-dependency-op) (c component-file))
;; (append (call-next-method) (list (slot-value c 'output-file))))
;; ;; Unused.
-;; (defmethod asdf:perform ((op compare-dependency-op) (c component-file))
+;; (defmethod 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
;; (make-pathname :name nil
;; :type nil
;; :defaults
-;; (asdf:component-pathname c)))))
-;; (out-pathname (pathname (first (asdf:output-files op c))))
+;; (component-pathname c)))))
+;; (out-pathname (pathname (first (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
+;; (grovel-and-compare-dependencies (mapcar #'find-system
;; (if (consp load-system)
;; load-system
;; (list load-system)))
;; base-asd-file
-;; (mapcar #'asdf:find-system merge-systems)
+;; (mapcar #'find-system merge-systems)
;; :output tmp-pathname
;; :verbose verbose
;; :cull-redundant cull-redundant