Commit bebb5e86 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Remove a few asdf: prefixes.

parent 76ec11df
......@@ -2,7 +2,7 @@
(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)))
......@@ -30,7 +30,6 @@ to the base of the system."
(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))))
......@@ -38,7 +37,7 @@ to the base of the system."
;; (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
......@@ -53,38 +52,38 @@ to the base of the system."
#|
(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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -93,7 +92,7 @@ to the base of the system."
;;; * 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)
......@@ -113,7 +112,7 @@ to the base of the system."
(: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))
......@@ -123,50 +122,50 @@ to the base of the system."
(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."
......@@ -181,8 +180,8 @@ to the base of the system."
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))))
......@@ -201,29 +200,29 @@ to the base of the system."
(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
......@@ -274,15 +273,15 @@ to the base of the system."
;; (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
......@@ -293,19 +292,19 @@ to the base of the system."
;; (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
......
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