[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
CLOS Object Saver
- To: info-macl@cambridge.apple.com, kerry@ads.com
- Subject: CLOS Object Saver
- From: claris!clarisii!ashok@apple.com (Ashok Khosla)
- Date: Mon, 22 Apr 91 11:55:30 PDT
Kerry,
Thanks a lot fo the clos save object code. I spent an evening porting it to Mac/Allegro Common Lisp v2.0B1. It seems to work fine. Attached is a copy, if
youUd like to use it on a Macintosh. IUm sorry - I stripped out a lot of the Symbolics/Lucid stuff...
#| SAVE-OBJECT by K.V. Koitzsch
Copyright (c) 1990, 1991 Advanced Decision Systems
The views, opinions and/or findings contained in this document are
those of the author, and should not be construed as official
Advanced Decision Systems position, policy, or decision, unless
designated by other documentation.
Permission is granted to any individual or instituion to use, copy,
modify and distribute this document, provided this complete copyright
and permission notice is maintained, intact, in all copies and
supporting documentation. Advanced Decision Systems makes no representations
about the suitability of the software described herein for any purpose.
It is provided "as is" without express or implied warranty.
Suggestions, bugs, criticism and questions to kerry@ads.com.
Modified for Allegro Common Lisp/Mac Common Lisp v2.0 by Ashok Khosla, CLARIS Inc. 4/22/91
Modification changes:
1.) package references using lisp:: have been removed. in-package uses common-lisp-user package instead.
2.) cons-p, and structure-p are replaced by built-in functions consp and structurep
3.) structure saving functions were rewritten for MACL 2.0
4.) Compiled functions are not saveable
Modification caveats are annotated (AMK)
Suggestions, bugs, criticism and questions about modifications should be sent to:
Ashok_Khosla@claris.com
CLARIS makes no representations
about the suitability of the software described herein for any purpose.
It is provided "as is" without express or implied warranty.
SAVE-OBJECT is a recursive function which writes an ASCII representation of
a LISP object to a designated file.
Objects which may be saved include:
---- symbols, keywords, numbers, characters, strings, and pathnames.
---- vectors and multi-dimensional arrays.
---- objects produced by defstruct.
---- CLOS (PCL) instances.
---- hash-tables.
---- compiled functions (represented as (FUNCTION <function-name>). ) (not supported - AMK)
---- conses.
---- lists.
---- user defined methods may be defined for arbitrary objects, such as images. (not supported - AMK)
This version has been tested on the Symbolics Lisp Machine as well as in
Lucid Common Lisp: it is similar to SYS::DUMP-FORMS-TO-FILE on the Symbolics,
except that the output file is an ASCII representation of the dumped object.
This file may then be compiled to produce a binary representation.
(AMK) - tested MACL version only on MACL 2.0 Beta - on MacIIfx under 6.05. CLARIS makes no
representations about the suitability of the software described herein for any purpose.
It is provided "as is" without express or implied warranty.
To save an object to a file, invoke the SAVE-OBJECT function:
(in-package 'DATABASE) ;;; or invoke from your favorite package.
;;; Define what version of PCL it is, if PCL.
;;; Simple test class definition.
(defclass TEST ()
((a :initarg :a
:accessor test-a
:documentation "")
(b :initarg :b
:accessor test-b
:documentation ""))
(:default-initargs :a 333 :b 444)
(:documentation "Try something like this simple class definition to test!"))
;;;; How to save an object:
(SAVE-OBJECT (MAKE-INSTANCE 'TEST) "/yourmachine/yourdir/saved-object")
(SAVE-OBJECT (MAKE-INSTANCE 'TEST) "yourdir:saved-object") (AMK)
;;; If you want it in binary format:
(SAVE-OBJECT (MAKE-INSTANCE 'TEST) "/yourmachine/yourdir/saved-object"
:compile T)
(SAVE-OBJECT (MAKE-INSTANCE 'TEST) "yourdir:saved-object" (AMK)
:compile T)
;;;( This produces saved-object.bin or saved-object.sbin, depending on machine type).
;;; See SAVE-OBJECT documentation string for further information on its use.
;;; (LOAD <saved-object>) whether binary or source, should be enough to restore the object.
;;; Circular references should be dealt with: try READ-FILE, defined at the bottom of this
;;; file, to debug and test buggus loads....
;;; Upon loading the saved object file, the result will be bound to db::*db-input*.
REVISION LIST:
======== =====
---- defined FUNCTION-NAME for Lucid 4.0. in terms of SYS:PROCEDURE-REF. (SYS:PROCEDURE-SYMBOL).
---- redefined MAKE-KEYWORD per barmars suggestion.
---- revised for Mac/Allegro Common Lisp v2.0 (AMK)
|#
(defpackage "database" (:nicknames "db") (:use :Common-lisp-user))
(in-package DATABASE)
(use-package 'common-lisp-user)
(export '(*db-input*
*global-unsavable-slots*
save-object
pseudo-quote-reader
reset-symbol-counter
;hash-table-size
;hash-table-rehash-size
;hash-table-rehash-threshold
;hash-table-test
make-keyword
string-append
all-slots
all-slots-and-values
copy-instance
all-values
symbol-fasd-form
instance-p
instance-name
;structure-p
get-slot-values
pushsym
list-array
coerce-2d-array
array-fasd-form
make-defstruct-body
structure-fasd-form
vector-fasd-form
;compiled-function-fasd-form
get-fasd-form
fasd-form
has-fasd-form-p
define-fasd-form
instance-fasd-form
%make-array
describe-htab
;cons-p
cons-fasd-form
array-list-aux
set-defstruct-slot
get-defstruct-value
search-symbols
read-file
makesyms
*save-object-system-date*
write-global-header))
#|
Initial setup: (make SLOT-VALUE a METHOD in package DATABASE by shadowing
the PCL/CLOS function.) NOTE: We cant do this yet,,,,,
#+ignore
(shadow '(slot-value))
#+ignore
(defmethod SLOT-VALUE ((self standard-object)(slotname symbol))
(slot-value self slotname))
|#
(defvar *save-object-system-date* "April 91 Save Object Experimental")
(defun PSEUDO-QUOTE-READER (stream subchar arg)
"Reader to convert a function spec into a more parsable format."
(declare (ignore subchar arg))
(eval
(list 'quote
(second (read-from-string
(nsubstitute #\space #\#
(concatenate 'string "("
(read-line stream t nil t) ")")
:test #'equal))))))
(defun MAKE-KEYWORD (x)
"Makes a keyword out of a symbol."
(if (keywordp x) x (intern (symbol-name x) 'keyword)))
(defun NEWSYM (symbol)
""
(if (null (get symbol 'namecounter))
(setf (get symbol 'namecounter) 0))
(read-from-string (concatenate 'string (string symbol)
(format nil "~S" (incf (get symbol 'namecounter))))))
(defmethod INSTANCE-NAME ((instance T))
"returns the symbol naming the given class object."
(class-name (class-of instance)))
(defmacro INSTANCE-P (X)
"predicate to determine if something is an CLOS INSTANCE: "
`(typep ,x 'standard-object))
(defmethod ALL-SLOTS ((instance T) &optional (all-allocations T))
"returns the names of the slots in instance, uses what MOP stuff is available."
(mapcar #'slot-definition-name (class-slots (class-of instance))))
(defmethod ALL-SLOTS-AND-VALUES ((instance T))
"returns an alist of slot value pairs. NOTE: Each alist cell is a LIST, NOT a CONS!"
(loop for slot in (all-slots instance) nconc
(list slot (when (slot-boundp instance slot)
(slot-value instance slot)))))
;;; Globals.
(defvar *DB-INPUT* NIL
"when a file is reloaded, the lisp object saved in it goes into
this variable, unless otherwise defined at save-time.")
(defvar *GLOBAL-UNSAVABLE-SLOTS* NIL
"put the symbol name of the instance slots you don't want to be
saved in this global list, for example: '(common-lisp-user::polygon) will
prevent the common-lisp-user::polygon slot of all instances from being saved.")
(defvar *seen* nil "list of objects already seen")
(defvar *vars* nil "list of unique identifiers assigned to *seen* objects")
(defvar *global-var-counter* 0)
;;; The main routine, SAVE-OBJECT.
(defun SAVE-OBJECT (object-instance filename &key
(compile nil)
(variable '*db-input*)
(if-exists :append)
(print-pretty nil)
(max-print-level 10000000)
(package nil)
(if-does-not-exist :create))
(setf *global-instance-count* 0)
(let* ((*print-level* max-print-level)
(*print-pretty* print-pretty)
(*print-length* 50000000)
(*package* (or (and package (find-package package))
*package*))
(pathname filename)
(form (get-fasd-form object-instance :reset t)))
(setf (get '.%%SYMBOL-LABEL%%. 'namecounter) 0)
(with-open-file (stream pathname :direction :output :if-exists if-exists
:if-does-not-exist if-does-not-exist)
(format stream "~%~s"
`(in-package ',(read-from-string (package-name *package*))))
(write-global-header stream
'.%%SYMBOL-LABEL%%. 0
*global-instance-count*)
(format stream "~%~s" `(setq ,variable ,form)))
(when compile (format t "~% compiling file ~A" pathname)
(compile-file pathname))
(values pathname (format nil "~& object saved to file: ~A" pathname))))
;;; ======= Object type predicates. ========
#|(defun STRUCTURE-P (x)
(and (typep x 'structure)
(NOT (VECTORP X))
(not (typep x 'simple-vector))
(not (typep x 'simple-array))
(not (and (arrayp x)(> (array-rank x) 1)))))|#
;;; ======= FASD forms. ===========
(defvar *global-instance-count* 0)
(setf *global-instance-count* 0)
(defmethod STRIP-PACKAGE ((x symbol))
"strip the package designator off the symbol, return the rest,
if keyword, return self.."
(cond ((keywordp x) x)
(T (let ((sym (format nil "~A" x)))
(cond ((search "::" sym)
(read-from-string (subseq sym (1+ (search "::" sym)))))
((search ":" sym)
(read-from-string (subseq sym (1+ (search ":" sym)))))
(T (read-from-string sym)))))))
(defun SLOT-EXISTS-P-ANY (instance name)
"returns t if the slotname exists with any package designator."
(let ((slots (mapcar #'strip-package (all-slots instance))))
(member (strip-package name) slots :test #'equal)))
(defun PAIR-SYMBOLS (instance)
(let ((slots (all-slots instance)))
(pairlis (mapcar #'strip-package slots) slots)))
(defun FIND-PACKAGED-SLOTNAME (instance stripped)
"given the slotname without package, find the slotname WITH package."
(let* ((choices (pair-symbols instance)))
(rest (assoc stripped choices :test #'equal))))
(defun SLOT-VALUE-ANY (instance stripped)
"find the value of the real slot given the stripped name."
(setf stripped (strip-package stripped))
(let ((slotname (find-packaged-slotname instance stripped)))
(when slotname (slot-value instance slotname))))
(defun GET-UNSAVEABLE-SLOTNAMES (instance)
"Returns a list of the slotnames in instance, or the slotnames in the
class of instance, which should not be saved."
(slot-value-any instance 'unsaveable))
(defun GET-SLOT-VALUES (clos-instance)
"given a pcl instance,constructs a plist of all the saveable
slot/value pairs."
(incf *global-instance-count*)
(let ((slots (all-slots-and-values clos-instance))
(unsaveable (get-unsaveable-slotnames clos-instance))
(variable nil)
(answers nil))
(loop while slots do
(cond ((member (second slots) *seen* :test #'equal)
(setq variable (nth (position (second slots)
*seen*
:test #'equal)
*vars*))
(setq answers (append answers
`( ,(make-keyword (pop slots))
',variable)))
(pop slots))
((or (member (first slots) unsaveable :test #'equal)
(member (first slots) *global-unsavable-slots* :test #'equal))
(pop slots)
(pop slots))
(T (setq answers (append answers
`( ,(make-keyword (pop slots))
,(get-fasd-form (pop slots))))))))
answers))
(defun PUSHSYM (list &optional (label '.%%SYMBOL-LABEL%%.))
"label must match with special-marker-p, and must be upper-case."
(push (newsym label) list))
(defun MAKESYMS (symbol min max &optional (pkg *package*))
(loop for count from min to max do
(eval `(defvar
,(read-from-string (concatenate 'string (format nil "~A" symbol)
(format nil "~A" count))
pkg)))))
(defun WRITE-GLOBAL-HEADER (stream symbol min max
&optional (pkg-name (package-name *package*)))
(format stream (format nil "~%(EVAL-WHEN (COMPILE LOAD EVAL)
(DB:MAKESYMS '~A ~A ~A ~s))~%"
symbol min max pkg-name)))
#|(defun CONS-P (x)
"ingenious predicate for testing whether something is a cons cell vs. a list.
note that this returns nil for (LIST 'A 'B) whereas it returns T for (CONS 'A 'B)."
(and (listp x) (null (listp (rest x)))))|#
(defun CONS-FASD-FORM (item)
`(CONS ,(get-fasd-form (first item))
,(get-fasd-form (rest item))))
(defun LIST-ARRAY (array)
(list-array-aux array 0 nil))
(defun LIST-ARRAY-AUX (array level subscript-list)
(let ((new-level (1+ level))
(dims (array-dimensions array)))
(loop for i from 0 to (1- (nth level dims))
collect
(cond ((equal level (1- (length dims)))
(let* ((aref-arg-list
(cons array (append subscript-list
(list i))))
(array-val (apply #'aref aref-arg-list)))
(if (numberp array-val) array-val
(get-fasd-form array-val))))
(T (list-array-aux array new-level
(append subscript-list (list i)))))
into temp finally (return (append '(list) temp)))))
(defun COERCE-2D-ARRAY (2d-array)
(let ((rows (array-dimension 2d-array 0))
(cols (array-dimension 2d-array 1)))
(loop for x from 0 to (1- rows) collect
(loop for y from 0 to (1- cols) collect
(aref 2d-array x y)) into answers
finally (return answers))))
(defun ARRAY-FASD-FORM (array)
"this function return a make-array form."
(setf *print-array* T)
`(make-array ,(get-fasd-form (array-dimensions array))
:element-type ',(array-element-type array)
:initial-contents ,(list-array array)))
;;; HASH TABLES...
(defun CREATE-HASH-TABLE (&key (test #'eql)
(size 67)
(rehash-size nil)
(rehash-threshold nil))
(let ((args (remove nil `(:size ,(get-fasd-form size)
:test ,test
,@(when rehash-size (list :rehash-size (get-fasd-form rehash-size)))
,@(when rehash-threshold (list :rehash-threshold (get-fasd-form rehash-threshold)))))))
(apply #'make-hash-table args)))
(defun LOAD-HTAB (lst &key (test #'eql)
(size 67)
(rehash-size nil)
(rehash-threshold nil))
(let ((htab (create-hash-table :test test
:size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(dolist (cell lst)
(setf (gethash (first cell) htab)(eval (second cell))))
htab))
(defun DESCRIBE-HTAB (htab)
"Utility to describe a hash table, printing out values."
(describe htab)
(maphash #'(lambda (key val)
(format t "~%~10t Key: ~A, ~45t Value: ~a.~%" key val))
htab))
(defun HTAB-FASD-FORM (htab)
"The dump form for hash tables."
(let ((vals nil)
(size (hash-table-size htab))
(rehash-size (hash-table-rehash-size htab))
(rehash-threshold (hash-table-rehash-threshold htab))
(test (hash-table-test htab)))
(maphash #'(lambda (key value)
(push (list key (GET-FASD-FORM value)) vals))
htab)
(if (null vals) `(create-hash-table :size ,size
:rehash-size ,rehash-size
:test ',test
:rehash-threshold ,rehash-threshold)
`(load-htab ',vals :size ,size
:rehash-size ,rehash-size
:test ',test
:rehash-threshold ,rehash-threshold))))
;;; STRCTURES (DEFSTRUCTS)
(eval-when (eval compile load)
(defun GET-DEFSTRUCT-TYPE (instance)
(car (ccl::struct-ref instance 0)))
(defun SET-DEFSTRUCT-VALUE (instance slotname value)
(let* ((struct-slot-value-list (inspector::structure-slots instance))
(slotname-position (1+ (position slotname
struct-slot-value-list
:key #'first))))
(ccl::struct-set instance slotname-position value)))
(defun GET-DEFSTRUCT-VALUE (instance slotname)
"Given an instance of a defstruct, and the name of some slot, return the slots value."
(let* ((struct-slot-value-list (inspector::structure-slots instance))
(slotname-position (1+ (position slotname
struct-slot-value-list
:key #'first))))
(ccl::struct-ref instance slotname-position)))
(defsetf get-defstruct-value set-defstruct-value)
)
#+ignore
(defmethod SLOT-VALUE ((self sys::structure)(slotname symbol))
"Cant write a method on slot-value? what is this????"
(get-defstruct-value self slotname))
(defun GET-DEFSTRUCT-SLOT-ACCESSOR (instance slotname)
""
(let* ((id (GET-DEFSTRUCT-TYPE instance)))
(read-from-string (concatenate 'string (symbol-name id) "-" (symbol-name slotname)))))
(defun GET-DEFSTRUCT-SLOTS-AND-VALS (instance)
"Return a list of slots and values" ;Note that slots are not keyword names
(labels ((interlock-lists (list1 list2 &optional interlocked-list)
(if (and list1 list2)
(cons (car list1)
(cons (car list2)
(interlock-lists (rest list1)
(rest list2)
interlocked-list)))
interlocked-list)))
(let* ((struct-slot-value-list (inspector::structure-slots instance))
(slot-list (mapcar #'first struct-slot-value-list))
(vals-list '()))
(dotimes (i (length slot-list))
(push (ccl::struct-ref instance (1+ i)) vals-list))
(setf vals-list (nreverse vals-list))
(interlock-lists slot-list vals-list))))
(defun GET-DEFSTRUCT-SLOTS (instance)
"Return a list of slots" ;Note that slots are not keyword names
(let* ((struct-slot-value-list (inspector::structure-slots instance)))
(mapcar #'first struct-slot-value-list)))
(defun STRUCTURE-FASD-FORM (instance)
(labels ((interlock-lists (list1 list2 &optional interlocked-list)
(if (and list1 list2)
(cons (car list1)
(cons (car list2)
(interlock-lists (rest list1)
(rest list2)
interlocked-list)))
interlocked-list)))
(let* ((ID (get-defstruct-type instance))
(struct-slot-value-list (inspector::structure-slots instance))
(slot-list (mapcar #'first struct-slot-value-list))
(keyword-list (mapcar #'make-keyword slot-list))
(vals-list '()))
(dolist (slotname slot-list)
(push (get-fasd-form (get-defstruct-value instance slotname)) vals-list))
(setf vals-list (nreverse vals-list))
(read-from-string (format nil "#S~S" `(,ID ,@(interlock-lists keyword-list vals-list)))))))
;;;; Arrays & Vectors.
(defun %MAKE-ARRAY (dims &key (element-type T) initial-contents)
(make-array dims :element-type element-type
:initial-contents (eval initial-contents)))
(defun VECTOR-FASD-FORM (X)
(let ((l (length x))
(data (get-fasd-form (coerce x 'list))))
`(%make-array ,l :element-type T
:initial-contents ',data)))
;;; Compiled functions.
#+ignore
(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
(let ((ans nil))
(setq *readtable* (copy-readtable))
(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
(setq ans (read-from-string (format nil "~A" compiled-function)))
(setq *readtable* (copy-readtable nil))
ans))
#+ignore
(defun FUNCTION-NAME (x)
"The 1th slot of the procedure struct is the function name in Lucid 4.0.
i.e. SYS:PROCEDURE-SYMBOL <X>. SYS:PROCEDURE-SYMBOL is a constant, representing the
index to the function name within the procedures slots. (see wizard doc for 4.0 lucid."
(when (sys:procedurep x)(sys:procedure-ref x SYS:PROCEDURE-SYMBOL)))
#+ignore
(defun GET-COMPILED-FUNCTION-NAME (compiled-function)
(function-name compiled-function))
#+ignore
(defun COMPILED-FUNCTION-FASD-FORM (X)
`(function ,(get-compiled-function-name x)))
(defun INSTANCE-FASD-FORM (instance)
(if (has-fasd-form-p (instance-name instance))
`(setq ,(first *vars*) ,(funcall #'(lambda (x)
(get-fasd-form x))
instance))
`(setq ,(first *vars*)(make-instance ',(instance-name instance)
,@(get-slot-values instance)))))
;;; symbols.
(defun SPECIAL-MARKER-P (X &optional (label ".%%SYMBOL-LABEL%%."))
"label must match with pushsym, and must be upper-case."
(search label
(format nil "~A" x)
:test #'equal))
(defun SYMBOL-FASD-FORM (instance)
(read-from-string (format nil "'~s" instance)))
(defun REGULAR-FUNCTION-FASD-FORM (instance)
`(FUNCTION ,instance))
(defun LONG-LIST-FASD-FORM (instance)
`(nconc ,@(make-list-forms (partition-long-list instance))))
(defun MAKE-LIST-FORMS (lists)
(loop for list in lists collect (get-fasd-form list)))
(defun PARTITION-LONG-LIST (long-list &optional (limit 512))
(loop while long-list collect
(loop for count from 0 to (- limit 2) while long-list
collect (pop long-list))))
(defun CONSTANT-FASD-FORM (i)
"anything that evals to itself, e.g. keywords, etc. just return that thing."
i)
;;; the workhorse. NOTE: The case statement is very ORDER-DEPENDENT!
;;; If your version of CLOS supports specialization on ALL LISP types,
;;; you could write this as a set of FASD-FORM methods on the LISP types.
;;; This has not always been possible with PCL, thus the case statement.
;;; NOTE that a CONS is not necessarily a list! CONS-P distinguishes
;;; between items such as (CONS 'A 'B) and (LIST 'A 'B).
(defun GET-FASD-FORM (instance &key reset (CAL 512))
(when reset (setf *seen* nil *vars* nil))
(cond ((null instance) nil)
((equal instance T) T)
((keywordp instance) instance)
((symbolp instance)(symbol-fasd-form instance))
;((functionp instance) (compiled-function-fasd-form instance))
((PATHNAMEP instance) (coerce instance 'string))
((instance-p instance)
(if (member instance *seen* :test #'equal)
(symbol-fasd-form
(nth (position instance *seen* :test #'equal) *vars*))
(progn (push instance *seen*)
(setq *vars* (pushsym *vars*))
(instance-fasd-form instance))))
((hash-table-p instance) (htab-fasd-form instance))
((structurep instance) (structure-fasd-form instance))
((or (characterp instance) (stringp instance))
instance)
((typep instance 'VECTOR) (vector-fasd-form instance))
((arrayp instance) (array-fasd-form instance))
((consp instance) (cons-fasd-form instance))
((and (listp instance)(> (length instance) CAL))
(long-list-fasd-form instance))
((listp instance)
`(list ,@(mapcar #'(lambda (thing)
(get-fasd-form thing)) instance)))
((numberp instance) instance)
(T (progn (format t "couldn't parse ~A, with type ~A."
instance (type-of instance))
NIL))))
;;; ========= user defined fasd forms ==========
(defun HAS-FASD-FORM-P (class-name)
"Predicate, returns t if a class has a user-defined FASD FORM method."
(get class-name 'common-lisp-user::%%FASD-FORM-METHOD%%))
(defmacro DEFINE-FASD-FORM (class-name arglist &body body)
"Macro to define a user-defined fasd-form for a given class-name.
You could do this as two discrete steps, programmatically where you need it."
`(progn (setf (get ',class-name 'common-lisp-user::%%fasd-form-method%%) T)
(defmethod FASD-FORM ,arglist ,@body)
',class-name))
;;; ====================
(defun READ-FILE (pathname &key
(variable '*db-input*))
(cond ((load pathname :if-does-not-exist nil)
(setf *vars* nil
*seen* nil)
(setf (symbol-value variable)
(search-symbols (symbol-value variable)))
(eval variable))
(T (format t "the pathname ~a does not exist." pathname)
NIL)))
(defun SEARCH-SYMBOLS (instance)
(cond ((null instance) nil)
((symbolp instance)
;; Now that we are keeping track of seen instances below,
;; checking for variables may be redundant.
(cond ((not (special-marker-p instance)) instance)
((member instance *vars* :test #'equal)
(eval instance))
(T (push instance *vars*)
(search-symbols (eval instance)))
))
((functionp instance) instance)
((pathnamep instance) instance)
((instance-p instance)
;; Searching symbols but not instances is not enough,
;; since the root node (for example) is first seen
;; as an object, not a special symbol. You tend
;; to get two copies of each node: one for the
;; (setq %%... (make-instance ...)), and one for
;; the first (quote %%...).
(unless (member instance *seen* :test #'equal)
(push instance *seen*)
(let ((slots (all-slots-and-values instance)))
(loop while slots do
(setf (slot-value instance (pop slots))
(search-symbols (pop slots))))))
instance)
((HASH-TABLE-P instance)
(maphash #'(lambda (key value)
(setf (gethash key instance)
(search-symbols value)))
instance) instance)
((structurep instance)
#|
(dolist (slot (get-defstruct-slots instance))
(set-defstruct-slot instance slot
(search-symbols
(get-defstruct-value instance slot)
)))
|#
instance
)
((or (CHARACTERP instance)(STRINGP instance)) instance)
((typep instance 'VECTOR)
(map 'vector #'(lambda (elt)
(search-symbols elt)) instance)
instance)
((ARRAYP instance)
(let ((dims (array-dimensions instance)))
(case (length dims)
(1 (dotimes (i (first dims))
(setf (aref instance i)
(search-symbols (aref instance i)))))
(2 (dotimes (i (first dims))
(dotimes (j (second dims))
(setf (aref instance i j)
(search-symbols (aref instance i j))))))))
instance)
((consp instance)(cons (search-symbols (first instance)
)
(search-symbols (rest instance))))
((LISTP instance)
(dotimes (count (length instance))
(setf (nth count instance)
(search-symbols (nth count instance))))
instance)
((NUMBERP instance) instance)
(T (progn (format t "~%couldn't parse ~A, with type ~A.~%" instance
(type-of instance))
nil))))
;;; eof.