diff --git a/src/mixins/meta.lisp b/src/mixins/meta.lisp index f11b98aa7..78bb66126 100644 --- a/src/mixins/meta.lisp +++ b/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)) diff --git a/src/mixins/mixins.lisp b/src/mixins/mixins.lisp index 7fbc8aaf5..9d0c81067 100644 --- a/src/mixins/mixins.lisp +++ b/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))) diff --git a/src/util/package.lisp b/src/util/package.lisp index 058fd44fb..ee52d64d0 100644 --- a/src/util/package.lisp +++ b/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) diff --git a/src/util/utils.lisp b/src/util/utils.lisp index c75a76634..be5af8203 100644 --- a/src/util/utils.lisp +++ b/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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test/meta.lisp b/test/meta.lisp index 9a1c52232..ad2580f34 100644 --- a/test/meta.lisp +++ b/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)