# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1598759329 14400
# Node ID 8baa554470fd3d58cb66b2c28ecf0249aa52f952
# Parent  a7ad406182d859a1d944d254a04e7191825effdc
Fix direct-superclasses patching in CCL/ECL

diff -r a7ad406182d8 -r 8baa554470fd src/mop.lisp
--- a/src/mop.lisp	Sat Aug 29 19:46:58 2020 -0400
+++ b/src/mop.lisp	Sat Aug 29 23:48:49 2020 -0400
@@ -122,6 +122,23 @@
                         (before-print slot))))
           (json-slots class)))
 
+
+(defmethod shared-initialize :around
+  ((class json-class) slot-names
+   &rest initargs
+   &key slot-name-to-json-name unknown-slots allow-print allow-read
+   &allow-other-keys)
+  (flet ((arg (initarg args)
+           (when args ; todo assert length = 1
+             (list initarg (first args)))))
+    (apply #'call-next-method class slot-names
+           (append (arg :slot-name-to-json-name slot-name-to-json-name)
+                   (arg :unknown-slots unknown-slots)
+                   (arg :allow-read (or allow-read '(t)))
+                   (arg :allow-print (or allow-print '(t)))
+                   initargs))))
+
+
 (defun patch-direct-superclasses (direct-superclasses)
   "Patch `direct-superclasses` to ensure `json-object` will be a superclass.
 
@@ -136,21 +153,25 @@
       direct-superclasses
       (append direct-superclasses (list super)))))
 
-(defmethod shared-initialize :around
-  ((class json-class) slot-names
-   &rest initargs
-   &key slot-name-to-json-name unknown-slots allow-print allow-read direct-superclasses
-   &allow-other-keys)
-  (flet ((arg (initarg args)
-           (when args ; todo assert length = 1
-             (list initarg (first args)))))
-    (apply #'call-next-method class slot-names
+(defmethod initialize-instance :around
+    ((class json-class) &rest initargs
+     &key direct-superclasses &allow-other-keys)
+  ;;; I have no idea why doing this once in shared-initialize works in SBCL but
+  ;;; not in CCL/ECL.  Oh well.  This solution from https://www.cliki.net/MOP%20design%20patterns
+  ;;; seems to work everywhere.
+  (apply #'call-next-method class
+         :direct-superclasses (patch-direct-superclasses direct-superclasses)
+         initargs))
+
+(defmethod reinitialize-instance :around
+    ((class json-class) &rest initargs
+     &key (direct-superclasses nil direct-superclasses?) &allow-other-keys)
+  (if direct-superclasses?
+    (apply #'call-next-method class
            :direct-superclasses (patch-direct-superclasses direct-superclasses)
-           (append (arg :slot-name-to-json-name slot-name-to-json-name)
-                   (arg :unknown-slots unknown-slots)
-                   (arg :allow-read (or allow-read '(t)))
-                   (arg :allow-print (or allow-print '(t)))
-                   initargs))))
+           initargs)
+    (call-next-method)))
+
 
 (defmethod c2mop:finalize-inheritance :after ((class json-class))
   (setf (slot-map class) (make-slot-map class)
@@ -176,9 +197,9 @@
       :with map = (slot-map class)
       :with init = (list)
       :for name = (read% 'string nil input)
-      :for sep = (parse-kv-separator class-name input)
       :for (initarg c cc after-read) = (gethash name map)
       :do (progn
+            (parse-kv-separator class-name input)
             (if (null initarg)
               (ecase unknown
                 (:preserve (setf (gethash name (or preserved (setf preserved (make-hash-table :test #'equal))))