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

Add missing operating-on-asdf-component-constituent that broke xcvb a2x.

Add print-object infrastructure for constituents (used while debugging).
parent b209c9dd
......@@ -69,11 +69,12 @@ to the base of the system."
(wtf "Perform asdf:load-source-op ~S" comp)
(let ((source (asdf:component-pathname comp)))
;; do NOT grovel the same file more than once
(unless (asdf:component-property comp 'last-loaded-as-source)
(setf (asdf:component-property comp 'last-loaded-as-source)
(and (fine-grain-instrumented-load ;;load
source)
(get-universal-time))))))
(operating-on-asdf-component-constituent (comp)
(unless (asdf:component-property comp 'last-loaded-as-source)
(setf (asdf:component-property comp 'last-loaded-as-source)
(and (fine-grain-instrumented-load ;;load
source)
(get-universal-time)))))))
(defmethod asdf:perform :around
((op asdf:compile-op)
......
......@@ -135,8 +135,32 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass simple-print-object-mixin ()
())
(defun collect-slots (object slots)
(loop :for slot-spec :in slots :nconc
(if (functionp slot-spec)
(funcall slot-spec object)
(destructuring-bind (slot &optional
(fun #'identity)
(keyword (intern (symbol-name slot) :keyword)))
(if (consp slot-spec) slot-spec (list slot-spec))
(when (slot-boundp object slot)
(list keyword (funcall fun (slot-value object slot))))))))
(defun simple-print-object (object stream &key identity (slots (slots-to-print object)))
(print-unreadable-object (object stream :type t :identity identity)
(write (collect-slots object slots) :stream stream)))
(defgeneric slots-to-print (object)
(:method-combination append))
(defmethod print-object ((object simple-print-object-mixin) stream)
(simple-print-object object stream :slots (slots-to-print object)))
;; Base class for constituents.
(defclass constituent ()
(defclass constituent (simple-print-object-mixin)
((parent
:initarg :parent
:initform nil
......@@ -160,6 +184,13 @@
:accessor constituent-provisions
:documentation "A hashset of things provided by this constituent.")))
(defmethod slots-to-print append ((con constituent))
`(,#'(lambda (x) (list :designator (constituent-designator x)))
(children ,#'length)
index
(uses ,#'hash-table-count)
(provisions ,#'hash-table-count)))
(defmethod initialize-instance :after ((con constituent) &key)
(let ((parent (slot-value con 'parent)))
(when parent
......@@ -182,6 +213,9 @@
:reader asdf-component-constituent-component
:documentation "The ASDF component.")))
(defmethod slots-to-print append ((con asdf-component-constituent))
'(component))
;; A constituent representing a file.
(defclass file-constituent (constituent)
((path
......@@ -215,6 +249,9 @@
:reader temp-constituent-label
:documentation "The label to use as the summary of this constituent.")))
(defmethod slots-to-print append ((con temp-constituent))
'(label))
(defun new-temp-constituent ()
"Create a new temp-constituent with an automatically generated label."
(make-instance 'temp-constituent
......
......@@ -783,7 +783,7 @@
nil)
(:method ((x asdf-component-constituent))
(when (typep (asdf-component-constituent-component x)
'instrumented-cl-source-file)
'asdf:cl-source-file)
x))
(:method ((x file-constituent))
x)
......@@ -802,14 +802,14 @@
:for filecon1 = (enclosing-file-constituent con1)
:when (typep filecon1 'asdf-component-constituent) :do
(let ((comp1 (asdf-component-constituent-component filecon1)))
(loop
:for con2 :being :each :hash-key :of deps
:for filecon2 = (enclosing-file-constituent con2)
:when (typep filecon2 'asdf-component-constituent) :do
(let ((comp2 (asdf-component-constituent-component con2)))
(pushnew comp2 (gethash comp1 component-deps))
(pushnew (asdf:component-system comp2)
(gethash (asdf:component-system comp1) system-deps))))))
(loop
:for con2 :being :each :hash-key :of deps
:for filecon2 = (enclosing-file-constituent con2)
:when (typep filecon2 'asdf-component-constituent) :do
(let ((comp2 (asdf-component-constituent-component con2)))
(pushnew comp2 (gethash comp1 component-deps))
(pushnew (asdf:component-system comp2)
(gethash (asdf:component-system comp1) system-deps))))))
;; Build and return the dependency forms.
(loop :for system :in interesting-systems
:collect `(,system
......
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