diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2021-07-19 11:37:51 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-07-23 09:22:47 -0700 |
| commit | 5186767b9c32b9f7481bfa85813c1ad34ac5f15c (patch) | |
| tree | b6f453e1fab76e6001837c963d9b38823351f5cf /src/util.lisp | |
| parent | f16f0f53fe97bf5959b93130eb9c0439841d1c52 (diff) | |
| download | consfigurator-5186767b9c32b9f7481bfa85813c1ad34ac5f15c.tar.gz | |
DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE: include slots without initargs
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src/util.lisp')
| -rw-r--r-- | src/util.lisp | 13 |
1 files changed, 9 insertions, 4 deletions
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)) |