From 64fd357d12215eea696478dd3d8993a572935a3d Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 30 Dec 2015 00:34:15 +0000
Subject: [PATCH] src/class-output.lisp, src/output-impl.lisp: Warn about
 unused items.

After an output run, report warnings about all of the items which didn't
get output (because they're not named in any constraints).

Unfortunately, this reports a whole bunch of internally generated items
which (harmlessly) never actually reach the output, so arrange not to
make those items in the first place.
---
 src/class-output.lisp | 61 ++++++++++++++++++++++++++++-----------------------
 src/output-impl.lisp  | 12 +++++++---
 2 files changed, 43 insertions(+), 30 deletions(-)

diff --git a/src/class-output.lisp b/src/class-output.lisp
index a975ebe..b47f6ba 100644
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -255,18 +255,21 @@
 			      (reason (eql :h))
 			      sequencer)
   (with-slots ((class %class) chain-head chain-tail) vtptr
-    (sequence-output (stream sequencer)
-      ((class :ichain chain-head :slots)
-       (format stream "  const struct ~A *_vt;~%"
-	       (vtable-struct-tag chain-tail chain-head))))))
+    (when (eq class chain-tail)
+      (sequence-output (stream sequencer)
+	((class :ichain chain-head :slots)
+	 (format stream "  const struct ~A *_vt;~%"
+		 (vtable-struct-tag chain-tail chain-head)))))))
 
 (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer)
   (with-slots ((class %class) subclass slots) islots
-    (sequence-output (stream sequencer)
-      ((subclass :ichain (sod-class-chain-head class) :slots)
-       (format stream "  struct ~A ~A;~%"
-	       (islots-struct-tag class)
-	       (sod-class-nickname class))))))
+    (let ((head (sod-class-chain-head class)))
+      (when (eq head (sod-class-chain-head subclass))
+	(sequence-output (stream sequencer)
+	  ((subclass :ichain (sod-class-chain-head class) :slots)
+	   (format stream "  struct ~A ~A;~%"
+		   (islots-struct-tag class)
+		   (sod-class-nickname class))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Vtable structure.
@@ -317,11 +320,12 @@
 
 (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
   (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs
-    (sequence-output (stream sequencer)
-      ((subclass :vtable chain-head :slots)
-       (format stream "  struct ~A ~A;~%"
-	       (vtmsgs-struct-tag subclass class)
-	       (sod-class-nickname class))))))
+    (when (eq subclass chain-tail)
+      (sequence-output (stream sequencer)
+	((subclass :vtable chain-head :slots)
+	 (format stream "  struct ~A ~A;~%"
+		 (vtmsgs-struct-tag subclass class)
+		 (sod-class-nickname class)))))))
 
 (defmethod hook-output progn
     ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer)
@@ -358,26 +362,29 @@
 (defmethod hook-output progn
     ((cptr class-pointer) (reason (eql :h)) sequencer)
   (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr
-    (sequence-output (stream sequencer)
-      ((class :vtable chain-head :slots)
-       (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
-	       metaclass
-	       (and (sod-class-direct-superclasses meta-chain-head)
-		    (sod-class-nickname meta-chain-head)))))))
+    (when (eq chain-head (sod-class-chain-head class))
+      (sequence-output (stream sequencer)
+	((class :vtable chain-head :slots)
+	 (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
+		 metaclass
+		 (and (sod-class-direct-superclasses meta-chain-head)
+		      (sod-class-nickname meta-chain-head))))))))
 
 (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer)
   (with-slots ((class %class) chain-head) boff
-    (sequence-output (stream sequencer)
-      ((class :vtable chain-head :slots)
-       (write-line "  size_t _base;" stream)))))
+    (when (eq chain-head (sod-class-chain-head class))
+      (sequence-output (stream sequencer)
+	((class :vtable chain-head :slots)
+	 (write-line "  size_t _base;" stream))))))
 
 (defmethod hook-output progn
     ((choff chain-offset) (reason (eql :h)) sequencer)
   (with-slots ((class %class) chain-head target-head) choff
-    (sequence-output (stream sequencer)
-      ((class :vtable chain-head :slots)
-       (format stream "  ptrdiff_t _off_~A;~%"
-	       (sod-class-nickname target-head))))))
+    (when (eq chain-head (sod-class-chain-head class))
+      (sequence-output (stream sequencer)
+	((class :vtable chain-head :slots)
+	 (format stream "  ptrdiff_t _off_~A;~%"
+		 (sod-class-nickname target-head)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Implementation output.
diff --git a/src/output-impl.lisp b/src/output-impl.lisp
index f668fef..d85d77d 100644
--- a/src/output-impl.lisp
+++ b/src/output-impl.lisp
@@ -62,8 +62,14 @@
     (pushnew function (sequencer-item-functions item))))
 
 (defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
-  (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
-    (dolist (function (reverse (sequencer-item-functions item)))
-      (apply function arguments))))
+  (let ((seen (make-hash-table)))
+    (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+      (setf (gethash item seen) t)
+      (dolist (function (reverse (sequencer-item-functions item)))
+	(apply function arguments)))
+    (maphash (lambda (name item)
+	       (unless (gethash item seen)
+		 (warn "Unused output item ~S" name)))
+	     (sequencer-table sequencer))))
 
 ;;;----- That's all, folks --------------------------------------------------
-- 
2.11.0