kerry@ADS.COM (Kerry Koitzsch) (04/12/91)
;;; -*- Base: 10; Syntax: Common-Lisp; Package: DATABASE -*-
#| 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.
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>). )
---- conses.
---- lists.
---- user defined methods may be defined for arbitrary objects, such as images.
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.
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")
;;; If you want it in binary format:
(SAVE-OBJECT (MAKE-INSTANCE 'TEST) "/yourmachine/yourdir/saved-object"
: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*.
|#
;;; NOTE: Change the package def below if it does not suit you:
;;; make sure you USE-PACKAGE your favorite brand of CLOS or PCL, though.
#+clos
(in-package 'DATABASE :nicknames '(DB) :use '(CLOS LISP))
#+pcl
(in-package 'DATABASE :nicknames '(DB) :use '(PCL LISP))
(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.
#+lucid
(setf lcl::*print-structure* T) ;;;; "Prints the #S form of a defstruct when t."
;;; To deal with machine-dependent hash-table parameters in pre-ANSI common lisp...
#+lucid
(setf (symbol-function 'hash-table-rehash-size) #'lcl::hash-table-rehash-size)
#+lucid
(setf (symbol-function 'hash-table-size) #'lcl::hash-table-size)
#+lucid
(setf (symbol-function 'hash-table-test) #'lcl::hash-table-test)
#+lucid
(setf (symbol-function 'hash-table-rehash-threshold) #'lcl::hash-table-rehash-threshold)
;;; Now for the symbolics lisp machine..../.
#|
#+lispm
(scl:defmethod (HASH-TABLE-REHASH-SIZE SI:EQUAL-HASH-TABLE)()
si:growth-factor)
#+lispm
(scl:defmethod (HASH-TABLE-REHASH-SIZE SI:EQ-HASH-TABLE)()
si:growth-factor)
#+lispm
(scl:defmethod (HASH-TABLE-REHASH-SIZE
cli::eql-block-array-process-locking-dummy-gc-locking-association-mutating-table)()
(cli::block-array-table-grow-size scl:self))
#+lispm
(scl:defmethod (HASH-TABLE-REHASH-THRESHOLD
cli::eql-block-array-process-locking-dummy-gc-locking-association-mutating-table)()
(cli::table-array-growth-threshold scl:self))
#+lispm
(scl:defmethod (HASH-TABLE-REHASH-THRESHOLD SI:EQUAL-HASH-TABLE)()
si:rehash-threshold)
|#
#+lispm
(defun HASH-TABLE-SIZE (x)
(scl:send x :size))
#+lispm
(defun HASH-TABLE-TEST (x)
(si:function-name (cli::test-function x)))
#+pcl
(eval-when (load eval compile)
;;; if AAAI PCL....
(if (search "AAAI" pcl::*pcl-system-date*)
(progn (format t "This is AAAI PCL.~%")
(pushnew :AAAI *features*))
(cond ((or (equal pcl::*pcl-system-date* "5/22/89 Victoria Day PCL")
(equal pcl::*pcl-system-date* "5/22/89 Victoria Day PCL (BBN)"))
(format t "initializing victoria day clos feature.")
(pushnew :vic-day *features* :test #'equal))
((equal pcl::*pcl-system-date* "this is a commercial clos."))
(T (format t "initializing may day clos feature.")
(pushnew :may-day *features* :test #'equal))))
)
(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 (symbol)
" use ~A (not ~S !!!) to strip off any package name."
(read-from-string (concatenate 'string ":" (format nil "~A" symbol))))
(defun NEWSYM (symbol)
""
(if (null (lisp:get symbol 'namecounter))
(setf (lisp:get symbol 'namecounter) 0))
(read-from-string (concatenate 'string (string symbol)
(format nil "~S" (incf (lisp:get symbol 'namecounter))))))
#-clos
(defun INSTANCE-NAME (instance)
"returns the symbol naming the given class object."
(pcl::class-name (pcl::class-of instance)))
#+clos
(defmethod INSTANCE-NAME ((instance T))
"returns the symbol naming the given class object."
(clos::class-name (clos::class-of instance)))
#+aaai
(defmacro INSTANCE-P (X)
"Predicate to test if something is an instance: AAAI PCL."
`(typep ,x 'pcl::iwmc-class))
#+may-day
(defmacro INSTANCE-P (X)
"predicate to determine if something is an INSTANCE: May day PCL."
`(and (lisp:typep ,x 'pcl::standard-object)
(not (pcl::classp ,x))))
#+vic-day
(defmacro INSTANCE-P (X)
"predicate to determine if something is an INSTANCE: Victoria day PCL"
`(lisp:typep ,x 'pcl::iwmc-class))
#+clos
(defmacro INSTANCE-P (X)
"predicate to determine if something is an INSTANCE: LCL CLOS. (rev 4.0)"
`(and (not (clos::classp ,x))(lisp:typep ,x 'clos::iwmc-class)))
#-clos
(defun ALL-SLOTS (instance &optional (all-allocations T))
"returns the names of the slots in instance."
(let ((them (mapcar #'(lambda (slot)
(pcl::slot-value slot 'pcl::name))
(pcl::slots-to-inspect (pcl::class-of instance)
instance))))
(if all-allocations them
(lisp:remove-if-not #'(lambda (slot)
(equal (pcl::slotd-allocation slot) :instance))
them))))
#+clos
(defmethod ALL-SLOTS ((instance T) &optional (all-allocations T))
"returns the names of the slots in instance, uses what MOP stuff is available."
(mapcar #'clos::slot-definition-name (clos::class-slots (clos::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)))))
(defvar *save-object-system-date* "June 90 Save Object Released")
#+view
(export '(image-p get-image-types))
;;; 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: '(user::polygon) will
prevent the 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 (lisp: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 ',(lisp:read-from-string (package-name *package*))))
(write-global-header stream
'.%%SYMBOL-LABEL%%. 0
*global-instance-count*)
(format stream "~%~s" `(setq ,variable ,form)))
(format t "~& object saved to file: ~A" pathname)
(when compile (format t "~% compiling file ~A" pathname)
(compile-file pathname)
(format t "~% done compiling file ~A" pathname))))
;;; ======= Object type predicates. ========
#+lispm
(defun STRUCTURE-P (X)
(cli::structurep x))
#+lucid
(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)))))
#+view
(defun GET-IMAGE-TYPES ()
(append (mapcar #'second view::*image-type-table*)
(mapcar #'third view::*image-type-table*)))
#+view
(defun IMAGE-P (X)
(typep x 'view::image))
#+view
(defun RLE-P (X)
(typep x 'view::rle))
#-view
(defun IMAGE-P (X)
(declare (ignore x))
nil)
;;; ======= 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 ((lisp:search "::" sym)
(read-from-string (subseq sym (1+ (lisp:search "::" sym)))))
((lisp:search ":" sym)
(read-from-string (subseq sym (1+ (lisp: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 ((lisp: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 (lisp:member (first slots) unsaveable :test #'equal)
(lisp: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
,(lisp: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 #'lisp: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 (lisp:gethash (first cell) htab)(eval (second cell))))
htab))
(defun DESCRIBE-HTAB (htab)
"Utility to describe a hash table, printing out values."
(describe htab)
(lisp: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)))
(lisp: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)
(defun MAKE-DEFSTRUCT-BODY (slot-names slot-values)
"makes a list of keyword value pairs appropriate for the body of a MAKE-x
defstruct invokation. note the recursive call to fasd-form, which is where
all the real work happens."
(loop while (and slot-names slot-values) nconc
(list (make-keyword (pop slot-names))
(get-fasd-form (pop slot-values)))
into answers finally (return answers)))
#+Lispm
(defun STRUCTURE-FASD-FORM (x)
"produces a list of the form (MAKE-x :A val1 :B val2 :C val3), note that the
recursion to expand all these slots comes later in the fasd (typecase) expression."
(let* ((desc (si:get (or (AND (ARRAYP X) (si:NAMED-STRUCTURE-SYMBOL X))
(AND (LISTP X) (SYMBOLP (CAR X)) (CAR X)))
'si:DEFSTRUCT-DESCRIPTION))
(accessor-functions (mapcar #'(lambda (slot)
(first (reverse slot)))
(fourth desc)))
(slot-names (mapcar #'first (fourth desc)))
(maker (first (first (sixth desc))))
(slot-values (loop for acc in accessor-functions collect (funcall acc x))))
`(,maker ,@(make-defstruct-body slot-names slot-values))))
#+lispm
(defun GET-DEFSTRUCT-SLOTS-AND-VALS (x)
"given a defstruct instance, return a list of the slots and vals in that defstruct."
(let* ((desc (si:get (or (AND (ARRAYP X) (si:NAMED-STRUCTURE-SYMBOL X))
(AND (LISTP X) (SYMBOLP (CAR X)) (CAR X)))
'si:DEFSTRUCT-DESCRIPTION))
(slot-names (mapcar #'first (fourth desc)))
(accessor-functions (mapcar #'(lambda (slot)
(first (reverse slot)))
(fourth desc)))
(slot-values (loop for acc in accessor-functions collect (funcall acc x))))
(pairlis slot-names slot-values)))
#+lispm
(defun FORMATTED-DEFSTRUCT-SLOTS-AND-VALS (x)
(let ((initial (get-defstruct-slots-and-vals x)))
(loop for thang in initial nconc (list (make-keyword (first thang))
(get-fasd-form (rest thang))))))
#+lispm
(defun GET-DEFSTRUCT-SLOTS (x)
"given a defstruct instance, return a list of the slots in that defstruct (no values)."
(let* ((desc (si:get (or (AND (ARRAYP X) (si:NAMED-STRUCTURE-SYMBOL X))
(AND (LISTP X) (SYMBOLP (CAR X)) (CAR X)))
'si:DEFSTRUCT-DESCRIPTION))
(slot-names (mapcar #'first (fourth desc))))
slot-names))
#+lucid
(defun GET-DEFSTRUCT-SLOTS (i)
(let ((id (type-of i)))
(multiple-value-bind (indices a b c)
(system:defstruct-info ID)
(declare (ignore a b c))
(let ((answers nil))
(dotimes (count indices answers)
(multiple-value-bind (name d value e f)
(system:defstruct-slot-info ID count)
(declare (ignore value d e f))
(push name answers)
answers))))))
#+lucid
(defun STRUCTURE-FASD-FORM (i)
(let ((id (type-of i)))
(multiple-value-bind (indices a b c)
(system:defstruct-info ID)
(declare (ignore a b c))
(let ((answers nil))
(dotimes (count indices answers)
(multiple-value-bind (name accessor d e f)
(system:defstruct-slot-info ID count)
(declare (ignore d e f))
(push (make-keyword name) answers)
(push (get-fasd-form (funcall accessor i)) answers)))
(lisp:read-from-string (format nil "#S~S" `(,ID ,@(nreverse answers))))))))
;;;; Arrays & Vectors.
#+lucid
(defun %MAKE-ARRAY (dims &key (element-type T) initial-contents)
(make-array dims :element-type element-type
:initial-contents (eval initial-contents)))
#+lucid
(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)))
#+lispm
(defun VECTOR-FASD-FORM (array)
`(make-array ,(get-fasd-form (array-dimensions array))
:element-type T
:initial-contents ,(list-array array)))
;;; Compiled functions.
#+lucid
(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 (lisp:read-from-string (format nil "~A" compiled-function)))
(setq *readtable* (copy-readtable nil))
ans))
;;; Massive kludge for pre-ansi hash table specs!!!!
#+lispm
(defun PARSE-HASH-TABLE-SPEC (htab)
(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 (rest (butlast (read-from-string
(concatenate 'string "(" (subseq (format nil "~a" htab) 8) ")")))))
(setq *readtable* (copy-readtable nil))
ans))
#+lispm
(defun HASH-TABLE-REHASH-SIZE (x)
(let ((spec (parse-hash-table-spec x)))
(getf spec :rehash-size)))
#+lispm
(defun HASH-TABLE-REHASH-THRESHOLD (x)
(let ((spec (parse-hash-table-spec x)))
(getf spec :rehash-threshold)))
#+lucid
(defun COMPILED-FUNCTION-FASD-FORM (X)
`(function ,(get-compiled-function-name x)))
#+lispm
(defun COMPILED-FUNCTION-FASD-FORM (X)
(if (si:lexical-closure-p x) nil
`(FUNCTION ,(si:compiled-function-name x))))
;;;; PCL/CLOS instances.
(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."
(lisp:search label
(format nil "~A" x)
:test #'equal))
(defun SYMBOL-FASD-FORM (instance)
(lisp: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)
#+view
(defun IMAGE-FASD-FORM (image)
"How to write an image to the appropriate cvl file."
)
#+view
(defun RLE-FASD-FORM (image)
"How to write an RLE to the appropriate RLE file."
)
;;; 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)
#+view ((image-p instance)(image-fasd-form instance))
#+view ((rle-p instance)(rle-fasd-form instance))
((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 (lisp: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))))
((lisp:HASH-TABLE-P instance) (htab-fasd-form instance))
((STRUCTURE-P instance) (structure-fasd-form instance))
((or (CHARACTERP instance) (STRINGP instance))
instance)
((typep instance 'VECTOR) (vector-fasd-form instance))
((ARRAYP instance) (array-fasd-form instance))
((CONS-P 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."
(lisp:get class-name '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 (lisp:get ',class-name '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 SET-DEFSTRUCT-SLOT (instance slotname value)
(declare (ignore instance slotname value))
)
(defun GET-DEFSTRUCT-VALUE (instance slotname)
(declare (ignore instance slotname))
)
(defun SEARCH-SYMBOLS (instance)
(cond ((null instance) nil)
((image-p 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)
((lisp: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 (lisp: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)
((lisp:HASH-TABLE-P instance)
(lisp:maphash #'(lambda (key value)
(setf (lisp:gethash key instance)
(search-symbols value)))
instance) instance)
((STRUCTURE-P 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)
((CONS-P 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.