From 5186767b9c32b9f7481bfa85813c1ad34ac5f15c Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 19 Jul 2021 11:37:51 -0700 Subject: DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE: include slots without initargs Signed-off-by: Sean Whitton --- src/util.lisp | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) (limited to 'src/util.lisp') diff --git a/src/util.lisp b/src/util.lisp index 61adcbf..6de9e71 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -210,6 +210,12 @@ symlinks. Not suitable for use by :POSIX properties." (subseq namestring 0 (1- (length namestring))) namestring)) +(defun reinit-structlike (class &rest slots) + (loop with object = (allocate-instance (find-class class)) + for (slot-name slot-value) on slots by #'cddr + do (setf (slot-value object slot-name) slot-value) + finally (return (reinitialize-instance object)))) + (defmacro quote-nonselfeval (x) (once-only (x) `(if (member (type-of ,x) '(cons symbol)) @@ -222,14 +228,13 @@ one-dimensional collections of values." (if (and *print-readably* *read-eval*) (format stream "#.~S" - `(make-instance + `(reinit-structlike ',(type-of object) ;; Call CLASS-OF so that subclasses of CLASS are handled too. ,@(loop for slot in (closer-mop:class-slots (class-of object)) - for initargs = (closer-mop:slot-definition-initargs slot) - and slot-name = (closer-mop:slot-definition-name slot) + for slot-name = (closer-mop:slot-definition-name slot) when (slot-boundp object slot-name) - collect (car initargs) + collect `',slot-name and collect (quote-nonselfeval (slot-value object slot-name))))) (call-next-method)) -- cgit v1.2.3