>>>> In message <······················@omikron.medizin.uni-ulm.de>
>>>> On the subject of "save-object.lisp /persistent objects"
>>>> Sent on Sun, 24 Oct 1999 11:38:02 +0200
>>>> Honorable ·····@sip.medizin.uni-ulm.de (kp gores) writes:
>> some weeks ago i asked a question about how to save objects to a
>> file to load them later (persistent objects).
Here is what I use (see print.lsp in
http://www.podval.org/~sds/data/cllib.zip) together with
`*print-readably*' set to t:
#+cmu
(defmethod print-object ((xx structure-object) (out stream))
(kernel:default-structure-print xx out 1))
#+cmu
(defun print-struct-object (xx out depth)
(declare (ignore depth))
(print-object xx out))
(eval-when (load compile eval) ; for `*clos-readtable*'
(defun read-object (st char arg)
"Read an instance of a CLOS class printed as #[name{ slot val}]"
(declare (ignore char arg))
(apply #'make-instance (read-delimited-list #\] st t)))
(defun make-clos-readtable ()
"Return the readtable for reading #[]."
(let ((rt (copy-readtable)))
(set-syntax-from-char #\[ #\( rt)
(set-syntax-from-char #\] #\) rt)
(set-macro-character #\] (get-macro-character #\) rt) nil rt)
(set-dispatch-macro-character #\# #\[ #'read-object rt)
rt))
)
(defconstant *clos-readtable* (make-clos-readtable)
"The readtable for reading CLOS objects printed readably with #[].")
(defun class-slot-list (class &optional (all t))
"Return the list of slots of a CLASS.
CLASS can be a symbol, a class object (as returned by `class-of')
or an instance of a class.
If the second optional argument ALL is non-NIL (default),
all slots are returned, otherwise only the slots with
:allocation type :instance are returned."
#-(or allegro clisp cmu lispworks)
(error 'not-implemented :proc 'class-slot-list)
(macrolet ((class-slots* (class)
`(#+allegro clos:class-slots
#+clisp clos::class-slots
#+cmu pcl::class-slots
#+lispworks hcl::class-slots ,class))
(slot-name (slot)
#+allegro `(slot-value ,slot 'clos::name)
#+clisp `(clos::slotdef-name ,slot)
#+cmu `(slot-value ,slot 'pcl::name)
#+lispworks `(hcl::slot-definition-name ,slot))
(slot-alloc (slot)
`(#+allegro clos::slotd-allocation
#+clisp clos::slotdef-allocation
#+cmu pcl::slot-definition-allocation
#+lispworks hcl::slot-definition-allocation ,slot)))
(mapcan (lambda (slot)
(when (or all (eq (slot-alloc slot) :instance))
(list (slot-name slot))))
(class-slots*
(typecase class
(class class) (symbol (find-class class))
((or structure-object standard-object) (class-of class))
(t (error 'case-error :proc 'class-slot-list
:args (list 'class class 'class 'symbol
'structure-object 'standard-object))))))))
(defmethod print-object ((obj standard-object) (out stream))
(let ((cl (class-of obj)))
(format out "#[~s" (class-name cl))
(dolist (slot (class-slot-list cl nil))
(when (slot-boundp obj slot)
(format out " ~s ~s" slot (slot-value obj slot))))
(write-string "]" out)))
--
Sam Steingold (http://www.podval.org/~sds/)
Micros**t is not the answer. Micros**t is a question, and the answer is Linux,
(http://www.linux.org) the choice of the GNU (http://www.gnu.org) generation.
If I had known that it was harmless, I would have killed it myself.