From c6b4ed992d81518f240509e6ab212d8fe705485a Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Sun, 6 Oct 2019 22:50:42 +0100
Subject: [PATCH] src/class-make-{proto,impl}.lisp: Don't always add
 initializers to classes.

Add a switch `:add-to-class' to inhibit adding the new initializer
object to its class.

(The class is still necessary because it's in control of initializer
construction: otherwise I'd do this by passing a `nil' class.)
---
 doc/meta.tex              |  5 +++--
 src/class-make-impl.lisp  | 14 ++++++++------
 src/class-make-proto.lisp |  8 ++++----
 3 files changed, 15 insertions(+), 12 deletions(-)

diff --git a/doc/meta.tex b/doc/meta.tex
index 67e77b2..dc06abf 100644
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -159,11 +159,12 @@
     {\dhead{gf}
       {make-sod-instance-initializer
           \=@<class> @<nick> @<name> @<value> @<pset> \\
-          \>\&key :inhibit-initargs :location
+          \>\&key :inhibit-initargs :location :add-to-class
         \nlret @<init>}
      \dhead{gf}
       {make-sod-class-initializer
-          \=@<class> @<nick> @<name> @<value> @<pset> \&key :location
+          \=@<class> @<nick> @<name> @<value> @<pset> \\
+          \>\&key :location :add-to-class
         \nlret @<init>}}
 \end{describe*}
 
diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp
index 1da8bac..02fd5f5 100644
--- a/src/class-make-impl.lisp
+++ b/src/class-make-impl.lisp
@@ -115,7 +115,8 @@
 ;;; Slot initializers.
 
 (defmethod make-sod-instance-initializer
-    ((class sod-class) nick name value pset &key location inhibit-initargs)
+    ((class sod-class) nick name value pset
+     &key location inhibit-initargs (add-to-class t))
   (with-default-error-location (location)
     (let* ((slot (find-instance-slot-by-name class nick name))
 	   (initarg-name (get-property pset :initarg :id))
@@ -129,21 +130,22 @@
 	(when (and initarg-name (not inhibit-initargs))
 	  (make-sod-slot-initarg-using-slot class initarg-name slot pset
 					    :location location))
-	(when initializer
+	(when (and initializer add-to-class)
 	  (setf instance-initializers
 		(append instance-initializers (list initializer)))))
       initializer)))
 
 (defmethod make-sod-class-initializer
-    ((class sod-class) nick name value pset &key location)
+    ((class sod-class) nick name value pset &key location (add-to-class t))
   (with-default-error-location (location)
     (let* ((slot (find-class-slot-by-name class nick name))
 	   (initializer (make-sod-initializer-using-slot
 			 class slot 'sod-class-initializer
 			 value pset (file-location location))))
-      (with-slots (class-initializers) class
-	(setf class-initializers
-	      (append class-initializers (list initializer))))
+      (when add-to-class
+	(with-slots (class-initializers) class
+	  (setf class-initializers
+		(append class-initializers (list initializer)))))
       initializer)))
 
 (defmethod make-sod-initializer-using-slot
diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp
index 5622dc6..09b9f98 100644
--- a/src/class-make-proto.lisp
+++ b/src/class-make-proto.lisp
@@ -86,7 +86,7 @@
 
 (export 'make-sod-instance-initializer)
 (defgeneric make-sod-instance-initializer
-    (class nick name value pset &key location inhibit-initargs)
+    (class nick name value pset &key location inhibit-initargs add-to-class)
   (:documentation
    "Construct and attach an instance slot initializer, to CLASS.
 
@@ -95,7 +95,7 @@
    construction process.  The default method looks up the slot using
    `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
    actually make the initializer object, and adds it to the appropriate list
-   in CLASS.
+   in CLASS unless ADD-TO-CLASS is nil.
 
    Usually, if an `initarg' property is set on PSET, then a slot initarg is
    created and attached to the slot; this can be prevented by setting
@@ -105,7 +105,7 @@
 
 (export 'make-sod-class-initializer)
 (defgeneric make-sod-class-initializer
-    (class nick name value pset &key location)
+    (class nick name value pset &key location add-to-class)
   (:documentation
    "Construct and attach a class slot initializer, to CLASS.
 
@@ -114,7 +114,7 @@
    construction process.  The default method looks up the slot using
    `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
    actually make the initializer object, and adds it to the appropriate list
-   in CLASS."))
+   in CLASS unless ADD-TO-CLASS is nil."))
 
 (export 'make-sod-initializer-using-slot)
 (defgeneric make-sod-initializer-using-slot
-- 
2.11.0