hg.stevelosh.com > jarl

7fbb6f4abee8 

Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL

The MOP calls this an "accessor" so I feel like I shouldn't need to do this, but
CCL only defines this function as a reader.  Instead of `setf`ing it, we can
wrap `make-instance` and hack the initargs we pass to `call-next-method`.
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Fri, 21 Aug 2020 00:34:26 -0400
parents 6c1bac83e3c9
children 64303dece177
branches/tags (none)
files .TODO.done TODO src/mop.lisp

Changes

--- a/.TODO.done	Thu Aug 20 23:21:01 2020 -0400
+++ b/.TODO.done	Fri Aug 21 00:34:26 2020 -0400
@@ -1,6 +1,8 @@
 Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
 Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
+Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
 Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039
 Add size and depth limits | id:ab9b49ec993f1e46c34b9d627549f41cad80609d
 Add fuzz tests against other implementations | id:cd53968480f72453ee820d65a180efe6da0fef71
+Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd
 Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
--- a/TODO	Thu Aug 20 23:21:01 2020 -0400
+++ b/TODO	Fri Aug 21 00:34:26 2020 -0400
@@ -1,8 +1,6 @@
 Fix :allow-print and :allow-read to set t when removing them during class redef. | id:21cce1bed829a138de33b33e3ad3219f7888be04
 Clean up error hierarchy | id:3d3efa4af649474151661a9d294080ab24e22ff7
 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
-Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
 Add extra key preservation | id:cfb63b37d87893083fc98477ec3d488fb909a984
 Test reading explicit types, not just t. | id:d2def699c46f12c02d49c01c869fc9b927bda72d
 Add more MOP-based tests (including errors). | id:df727baeb41bad02c7d79b92f98c24c8a28ca772
-Fix `Undefined function (SETF CCL:SLOT-DEFINITION-INITARGS)` in CCL | id:e834dd6749849e10669a643019337533e87f5cdd
--- a/src/mop.lisp	Thu Aug 20 23:21:01 2020 -0400
+++ b/src/mop.lisp	Fri Aug 21 00:34:26 2020 -0400
@@ -34,6 +34,20 @@
    (before-print :initarg :json/before-print :accessor before-print :initform nil)
    (after-read :initarg :json/after-read :accessor after-read :initform nil)))
 
+(defmethod make-instance ((class (eql (find-class 'json-effective-slot-definition))) &rest initargs)
+  ;; We need to wrap this to make sure that every JSON slot has at least one
+  ;; initarg, so we can use it when calling `make-instance` during reading.
+  ;;
+  ;; If none of the direct slots have an initarg, we'll gensym one.  Otherwise
+  ;; we can use an existing one and not clutter things up.
+  (apply #'call-next-method class
+         (append
+           (when (null (getf initargs :initargs))
+             (list :initargs
+                   (list (gensym (string (getf initargs :name))))))
+           initargs)))
+
+
 (defmethod c2mop:direct-slot-definition-class ((class json-class) &rest initargs)
   (if (getf initargs :json)
     (find-class 'json-direct-slot-definition)
@@ -48,7 +62,6 @@
   ;; like it does in direct-slot-definition-class.  So we need another way to
   ;; know which class to use here.
   (or *effective-slot-definition-class* (call-next-method)))
-
 (defmethod c2mop:compute-effective-slot-definition ((class json-class) name direct-slots)
   (if (not (some (lambda (dslot)
                    (typep dslot 'json-direct-slot-definition))
@@ -56,22 +69,21 @@
     (call-next-method)
     (let* ((*effective-slot-definition-class* (find-class 'json-effective-slot-definition))
            (eslot (call-next-method))
-           (dslot (first direct-slots)) ; todo be smarter about coalescing these
-           (initarg (gensym (format nil "json-initarg-~A" name)))) ; todo nicer name
+           (dslot (first direct-slots)))
+      ;; todo be smarter about coalescing this stuff
       (setf (json-name eslot) (if (slot-boundp dslot 'json-name)
                                 (json-name dslot)
                                 (funcall (slot-name-to-json-name class) name)) ; todo make this less shitty
             (json-class eslot) (if (slot-boundp dslot 'json-class)
                                  (canonicalize-class-designator (json-class dslot))
                                  '(t))
-            (json-initarg eslot) initarg ; todo nicer name
+            (json-initarg eslot) (first (c2mop:slot-definition-initargs eslot))
             (after-read eslot) (if (slot-boundp dslot 'after-read)
                                  (after-read dslot)
                                  nil)
             (before-print eslot) (if (slot-boundp dslot 'before-print)
                                    (before-print dslot)
                                    nil))
-      (push initarg (c2mop:slot-definition-initargs eslot))
       eslot)))