Add copy-instance, and allow metadata to work with it

Also make compare work for fset

Author: mariari

src/mixins/meta.lisp

@@ -34,3 +34,15 @@ look past weak pointers if they exist"
     (when table
       (let ((value (gethash key table)))
         (if (tg:weak-pointer-p value) (tg:weak-pointer-value value) value)))))
+
+;; We need a custom copy for the meta-object
+
+(defmethod geb.utils:copy-instance ((object meta-mixin) &rest initargs
+                                    &key &allow-other-keys)
+  (declare (ignorable initargs))
+  (let ((new-object (call-next-method))
+        (table      (gethash object (meta object))))
+    (when table
+      (setf (gethash new-object (meta object)) ; should point to the same table
+            table))
+    new-object))

src/mixins/mixins.lisp

@@ -66,3 +66,11 @@
 ;; I should implement it for arrays as well!
 (defmethod obj-equalp ((obj1 t) (obj2 t))
   (equalp obj1 obj2))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Fset comparisons
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defmethod fset:compare ((x direct-pointwise-mixin) (y direct-pointwise-mixin))
+  (fset:compare (to-pointwise-list x)
+                (to-pointwise-list y)))

src/util/package.lisp

@@ -12,6 +12,7 @@ used throughout the GEB codebase"
   (muffle-package-variance pax:macro)
   (subclass-responsibility pax:function)
   (shallow-copy-object     pax:function)
+  (copy-instance           pax:generic-function)
   (make-pattern            pax:macro)
   (number-to-digits        pax:function)
   (digit-to-under          pax:function)

src/util/utils.lisp

@@ -69,6 +69,34 @@ if wanted
     copy))
 
 
+;; from
+;; https://stackoverflow.com/questions/11067899/is-there-a-generic-method-for-cloning-clos-objects
+
+;; Don't need it to be an object on non standard-classes for this
+;; project, if so, we can promote it to the old form of being a
+;; defgeneric.
+
+(defmethod copy-instance ((object standard-object) &rest initargs &key &allow-other-keys)
+  "Makes and returns a shallow copy of OBJECT.
+
+  An uninitialized object of the same class as OBJECT is allocated by
+  calling ALLOCATE-INSTANCE.  For all slots returned by
+  CLASS-SLOTS, the returned object has the
+  same slot values and slot-unbound status as OBJECT.
+
+  REINITIALIZE-INSTANCE is called to update the copy with INITARGS."
+  (let* ((class (class-of object))
+         (copy (allocate-instance class)))
+    (dolist (slot (c2mop:class-slots class))
+      ;; moved the mapcar into a let, as allocation wise, CCL
+      ;; preformed better this way.
+      (let ((slot-name (c2mop:slot-definition-name slot)))
+        (when (slot-boundp object slot-name)
+          (setf (slot-value copy slot-name)
+                (slot-value object slot-name)))))
+    (values
+     (apply #'reinitialize-instance copy initargs))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Numeric Utilities
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

test/meta.lisp

@@ -9,6 +9,11 @@
     (meta-insert obj :a 2)
     (is = (meta-lookup obj :a) 2)))
 
+(define-test copying-meta-data-works :parent geb-meta
+  (let ((obj (make-instance 'mixin-test)))
+    (meta-insert obj :a 2)
+    (is = (meta-lookup (geb.utils:copy-instance obj) :a) 2)))
+
 #+nil
 (define-test weak-pointers-work :parent geb-meta
   (tg:gc :full t)