;;; -*- Base: 10; Mode: LISP; Package: (DATABASE :USE LISP); Syntax: Common-Lisp -*-

;;; SAVE-OBJECT, Version 10.2
;;; Effective Date: June 2001
;;; Copyright (C) Kerry V. Koitzsch, 1992,1993,1994,1995.  kerry@crl.com
;;; New work and beautification by Kevin Thompson, NASA Ames Research Center.  kthompso@ptolemy.arc.nasa.gov
;;; Additional fixes, and porting to modern CMUCL and SBCL by kr (Markus Krummenacker kr@n-a-n-o.com)

;;; the version info is stored in db:*save-object-system-date*

;;; (load "/lisp/kb/save-object/save-object-10.2.lisp")
;;; (compile-file "/lisp/kb/save-object/save-object")

#|
The views, opinions, and/or findings contained in this document are those
of the author, and should not be construed as an official position, policy,
or decision of any company or other individual, unless designated by other
documentation.

Permission is granted to any individual or institution to use, copy, 
modify and distribute this document, provided the copyright and permission
notice is maintained, intact, in all copies and supporting documentation.
The author 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@crl.com.

Description of SAVE OBJECT:
----------- -- ---- -------

SAVE-OBJECT is a recursive function which writes an ASCII representation
of a LISP object to a designated file.

kr010622: in other words, it serializes arbitrary LISP data
structures, very similar to what the "pickle" operation does in the
scripting language python.

NOTE: SAVE-OBJECT doesnt need a special LOAD function! 
You can load files created by SAVE-OBJECT with the
standard LOAD function

To save:

(SAVE-OBJECT (list 10 20 30) "myfile.lisp")    ,

To restore the data in the saved list:

(LOAD "myfile.lisp")

Where the newly restored data ends up:

db:*db-input* == (LIST 10 20 30)

Objects which may be saved include:

--- symbols, keywords, characters, strings, and pathnames.
--- numbers, including integer, rational, complex, and floating point.
--- vectors and multi-dimensional arrays.
--- objects produced by DEFSTRUCT.
--- CLOS (PCL) instances, and CLOS(PCL) classes.
--- hash tables.
--- compiled functions, represented as (FUNCTION <function name>),
    internally.
--- generic functions, method objects, and class objects.
--- conses and lists.
--- circular conses and lists (new)
--- user defined methods may be defined for arbitrary objects, such
    as images.
--- readtables (a kludge for now)
--- CLIM objects (saved as ordinary CLOS instances)

Calling sequence for INSTANCE-DUMP-FORM:
------- -------- --- ------------------

class-slots ==> all-slotnames ==> all-slots-and-values ==>
map-instance ==> get-slot-values ==> get-ordered-slot-values ==>
instance-dump-form.


========================= D I R E C T I O N S ============================

(1) Redefine the IN-PACKAGEs below to suit: they should USE CLOS or PCL,
though.

In version 5a, the attribute line should be correct to 'just load' the
file, even if the package database does not exist.
Or, try this:

(make-package 'DATABASE :nicknames '(db) :use '(common-lisp))
(in-package 'database)
(shadowing-import '(setf documentation) 'database)
(use-package 'clos)

If at any point an error occurs about conflicting symbols, select the
proceed option which prefers the symbols in the common lisp package.

(2) After defining an appropriate package, load the file,
    save-object.lisp, or its compiled version.

(3) Enter package DATABASE with (in-package 'DATABASE) or 
(in-package "database"). You are now ready to save objects!

(4) To save an object to a file, invoke the SAVE-OBJECT function:

(in-package 'database) or (in-package "database") if in 8.1.1.

(save-object (list 20 30 19.6) "my-simple-filename.lisp")

to reload the saved-object file:

(load "my-simple-filename.lisp")

The result of the load is stored in the global variable *db-input*,
in the DATABASE package.

(in-package 'db)
*db-input* ====> (20 30 19.6)

(5) To save MULTIPLE OBJECTS to a file, use the macro WITH-SAVED-
OBJECTS:

(with-saved-objects (x "my-multiple-save-file.lisp")
    (make-whiz) ;; a defstruct
    (make-instance 'my-class) ;; a clos/pcl instance...
    PI ;; whatever you want....
    #c(0 1)
)

To re-load a multiple-object data-file, simply use LOAD:

(load "my-multiple-save-file.lisp")

Results end up in the global variable *storage-vector*:

(aref *storage-vector* 0) ====> a whiz instance
                       1  ====> clos pcl instance
                       2   ====> pi
                       3   ====> a complex number...

Since save-object uses vector-push-extend on *storage-vector*,
no allocation or manipulation of *storage-vector* is necessary.

To forget and reset *storage-vector*, simply do

(defvar *storage-vector*) or (mkunbound '*storage-vector*).

=========
PLATFORMS this was tested on:
=========          ------ --

Machines: Sun-4,
          Symbolics 3670,
          Mac IIfx and Mac Quadra, Mac Classic II with MCL 2.0.1.

          Allegro\PC Version 1.0 on an IBM-PC with 16 meg, Windows 3.1,
          MSDOS 5.0.

Versions of Symbolics Common Lisp: Genera 8.1, Genera 7.2 w/rev 4b PCL.

Versions of PCL/CLOS: AAAI PCL, Victoria Day PCL, REV 4b PCL, Lucid 4.0
CLOS, Lucid 4.1 CLOS.

Versions of CMU Common Lisp: 16c, SunOS 4.1, Sun 4, and:
                             17b, SunOS 4.1, Sun 4 with PCL Sept. 1992 (f).
                             18c, RedHat Linux-6.2 on Intel, kr010612
                             (probably won't run on the really old pre-18 versions anymore)
            
Versions of SBCL Common Lisp: 0.6.6, RedHat Linux-6.2 on Intel, kr010612

Versions of MCL: 2.0b3, Version 2.0.1.

Versions of Allegro Common Lisp: 4.0, 4.1, 4.2b.

Note: ALLEGRO 4.0 users (SUNS): the patch which fixes the defstruct slot-
value problem must be installed in your 4.0 image for this code to
work properly! Franz internal problem number: spr4914, patch25.fasl.
See your Franz dealer to get a copy.

Versions of Lucid (Sun) Common Lisp: 4.0, LCL 4.1.

=======================================================================
Changes in Version 10:
=======================================================================

;;;kr010608: declared new version-10.2
;;; - applied patch that contains the diff of v.9X.2 versus v.10A
;;;   found v.10A at: ftp://ftp.digitool.com/pub/mcl/contrib/save-object.lisp
;;;   first had to convert Macintosh-CR to Unix-LF of that file
;;; - kr010611: in a few places, used (delete ) instead of (remove ) to reduce cons'ing
;;; - kr010619: had to fight it out quite bit with the dotted lists, to get
;;;   (TEST-CONS-SAVE) to not bomb out right away, and subsequently with
;;;   circular lists, because of a code circularity that entered an infinite loop.
;;;   to me, this seemd like quite mess, and i tried to clean it up and stream-line
;;;   a bit.  (dotted-list-p ) now does not check for circularity, which needs to be
;;;   done beforehand.  reworked (%list-length ) , which now works correctly and
;;;   probably a lot more efficiently too.
;;; - kr010620: no doubt a ton of additional clean-up work is really needed.  a lot of
;;;   the code looks messy and duplicative, but given that i do not feel responsible for it,
;;;   i won't find time to clean it up right now.

=======================================================================
Changes in Version 9X:
=======================================================================

;;;kr0103??: made a version-9x.3 to contain a bunch of changes,
;;; such as trying to get it to run on SBCL and CMUCL-18c.
;;;kr010601: in the pcl-related versions of (%ALLOCATE-INSTANCE ) , i had to make sure that
;;; (sb-pcl::find-class ) was used instead of just (find-class ) !!!!  this got dumping
;;; of clos objects to work (at least for the instances).

- Fixed definition of CIRCULAR-LIST-P for MCL.

Notes on version 9
===== == ======= =

In MCL 2.0.1, the slot-definition-... access functions remain undefined.
This means some components of the generated DEFCLASS DUMP FORM may be
unpredictable; this will be fixed when MCL has all the appropriate access
functions available.kvk

Changes in Version 9
  (Changes by KOT == Kevin Thompson, kthompso@ptolemy.arc.nasa.gov)
    Tried to make indentation relatively uniform (only top-level forms in
      col 1, and only use 3 ;;;'s if in column 1).  This makes most GNU Emacs
      Lisp modes work better (since begin-of-defun looks for lparen in col 1),
      but makes etags fail ...
    Tried to make it all fit in 80 columns, since 90% of it did already.
    Various fixes for Allegro 4.2 (mostly just change #+)
    Wrapped several top-level (def***) and (setf) forms in eval-when.
      My understanding of CL fails here; but one way or another previously one
      had to load this first to get it to compile in Allegro, and now that's
      unnecessary.
    Many declare's etc, in an anal attempt to remove most compiler warnings.
    Fixed get-defstruct-constructor when defstruct has a :constructor option.
    Other misc bug fixes -- search for 'KOT' below.

=======================================================================
Changes in Version 7:
=======================================================================

1. Support for the newer PCL versions: March, June and August PCLs.

2. Support for CMU Common Lisp.

3. Support for Austin Kyoto Common Lisp.

4. Support for the saving of multiple objects to one file with the
   macro WITH-SAVED-OBJECTS.

5. The ability to save defstruct 'classes' to file, as well as 
   defstruct instances.

6. A complete re-write of defstruct accessors: most of these functions
   are generated automatically by the function CREATE-DEFSTRUCT-ACCESS-
   FUNCTIONS.

7. Support for Symbolics Genera 8.1.1.

8. Improved array and vector functions: added MAP-INTO if needed.

9. The ability to save GENSYMed symbols, circular CONSes, and
    symbol property lists (if the global variable flag is set).
 
10. Numerous bug fixes and documentation changes.

11. Added DOTTED-LIST-P, DOTTED-LIST-DUMP-FORM, modified
    GET-DUMP-FORM, added %EVERY, %SOME:
    changed all occurences of EVERY and SOME to
    %EVERY and %SOME (predicates which dont barf on dotted lists)
    This means (SAVE-OBJECT (LIST* 1 2 3 4 5) "my-dotted-list.lisp")
    should work.

=======================================================================
Changes from Version 4A;
------------------------

--- Attribute line is fixed for Symbolics users.

--- the ability to save CLOS instances with unbound slots: fixed the
    bug where nil was installed as the slot value. (see TEST-UNBOUND-
    SLOT-SAVE function)

--- the ability to save out CONSes (vs LISTS) in the appropriate
    format: required modification to predicate CONS-P and %TYPE-OF.
    (see TEST-CONS-SAVE function)

--- predicate %CONS-P is the internal cons predicate: EXCL uses an
    internal function: the non-EXCL version uses a Common Lisp
    version. Ideally one would use (LAST X 0) as in CLtl2 pg. 416,
    but here i use (CDR (LAST X)).

--- Unsaveable slot bug, which screwed up slots and values returned,
    is now fixed in the new mechanism using INSTANCE-SLOTNAMES.

=======================================================================

Changes to newest version:

*save-symbol-plist* ==> *save-symbol-plists* global variable.

=======================================================================

 Defstruct functions used by SAVE-OBJECT:
 --------- --------- ---- -- -----------

   STRUCTURE-P (x) [Function] :
   Predicate, returns T if X is a structure instance.

   GET-DEFSTRUCT-LENGTH (s) [Function] :
   Returns the number of slots in a structure instance S.

   GET-DEFSTRUCT-DESCRIPTOR (symbol) [Function] :
   Given a symbol, returns a standard defstruct spec if
   SYMBOL is the name of a defined defstruct class:
   NIL otherwise.

   ALLOCATE-STRUCT (type) [Function] :
   Given a symbol TYPE which is the name of a defined defstruct
   class, make a default instance of that class.

   FILL-STRUCT (struct vals) [Function] :
   Fills the structure instance struct with the values vals.

   GET-DEFSTRUCT-CONSTRUCTOR (s) [Function] :
   Given a symbol or structure instance, return the
   name of the function that can construct an instance 
   of the same type as S.

   GET-DEFSTRUCT-NAME (s) [Function] :
   Given a structure instance S, return the name of
   that instances class.

   GET-DEFSTRUCT-TYPE (s) [Function] :
   Given a symbol or structure instance <s>, return the
   type of that structure class.

   SET-DEFSTRUCT-SLOT-VALUE (s slotname new-value) [Function] :
   Sets the defstruct instance <s> slot named <slotname>
   with the new value <newval>.

   GET-DEFSTRUCT-SLOT-VALUE (s slotname) [Function]:
   Given the defstruct instance <s> and the slot name <slotname>,
   return the value of <slotname> in <s>.

   GET-DEFSTRUCT-SLOT-NAMES (s) [Function] :
   Given a structure instance S, return a list of the
   names of that instances slots, in no particular order.

   COPY-STRUCTURE (s &key (mode :shallow)) [Function] :
   Analogous to the COPY-INSTANCE method. Mode may be :SHALLOW or
   :DEEP : make a copy of the structure instance S.

   GET-DEFSTRUCT-SLOTS-AND-VALS (s) [Function] :

   MAKE-STRUCTURE (struct-type &rest kwd-val-pairs) [Macro] :
   Analogous to MAKE-INSTANCE.

   GET-DEFSTRUCT-VALUES (s) [Function] :
   Return the values of all the slots in structure instance S,
   in the same order that the slot names are returned from
   GET-DEFSTRUCT-SLOT-NAMES.

   GET-DEFSTRUCT-DOCUMENTATION:

   GET-DEFSTRUCT-PREDICATE:

   GET-DEFSTRUCT-PRINT-FUNCTION:

   GET-DEFSTRUCT-INCLUDE:

   GET-DEFSTRUCT-CONC-NAME:


Slot operations:
==== ===========

GET-DEFSTRUCT-SLOT-READ-STATUS (sd) [Function]:

GET-DEFSTRUCT-SLOT-ACCESSOR (sd): [Function]:

GET-DEFSTRUCT-SLOT-NAME (sd) [Function]:

GET-DEFSTRUCT-SLOT-TYPE (sd) [Function]:

GET-DEFSTRUCT-SLOT-READER (sd) [Function]:

GET-DEFSTRUCT-SLOT-WRITER (sd) [Function]:

GET-DEFSTRUCT-SLOT-DESCRIPTOR (sd) [Function]:


NEW MACINTOSH CHANGES:
=== ========= =======

#+:mcl changed to #+mcl. (12-19-93)

|#

;;; Package engineering....

#+akcl
(eval-when (load eval compile)
  (in-package 'DATABASE :nicknames '(DB) :use '(LISP))
  )

#+lucid
(in-package 'DATABASE :nicknames '(DB) :use '(CLOS LISP))

#+mcl
(eval-when (load eval compile)

(ccl::old-in-package :COMMON-LISP :nicknames '(LISP))
(ccl::old-in-package :COMMON-LISP-USER :nicknames '(USER)) ;;; added this for version X.

  (unless (find-package 'database)
    (make-package 'database  :nicknames '(db) :use '(common-lisp)))

  (in-package DATABASE) ;; ANSI definition of IN-PACKAGE

  ;; Uncomment the following line if using mcl....
  ;;(PUSHNEW :mcl *features*)
  (pushnew :clos *features*) ;; MCL has clos, but it isnt in the features list.

  (unless (find-package 'clos)
    (make-package 'clos :use '(ccl common-lisp))) ;;hence no cl package, either

  (when (equal (machine-instance) "Quadra")
    (pushnew :quadra *features*) ;; note that its a 68040 on features....
    )

  (when (equal (machine-type) "Macintosh IIfx")
    (pushnew :fx *features*) ;; note that its an fx on features....
    )
  ) ;; end of MCL eval-when...

#+lispm
(eval-when (load eval compile)
  ;; NEW: added 1.1 to the minor release list below....
  (multiple-value-bind (major minor status)
      (sct:get-release-version)
    (cond ((and (equal major 7)(equal minor "2"))(pushnew :rel-7-2 *features*))
          ((and (equal major 8)(member minor '("0" "1" "1.1") :test #'equal))
           (pushnew :rel8 *features*)
           (if (equal minor "0")(pushnew :rel-8-0 *features*)
             (pushnew :rel-8-1 *features*)))
          (T (error "Can't deal with major release ~a, minor release ~a!" 
                    major minor))))

  (when (find-package 'clos)
    (pushnew :clos *features*))

  (unless (find-package 'database)
    (make-package 'database :nicknames '(db) :use '(clos)))

  (shadowing-import '(setf documentation) 'database)

  (unless (find-package 'clos)
    (format t "Couldnt find the CLOS package, trying to continue.~%"))

  #-rel-8-1(in-package 'database :use '(LISP))
  #+rel-8-1(in-package "database" :use '(LISP))

  (defun UNLOCK-PKG (packagename)
    "Changes read-only package status to read+write, if package exists."
    (when (find-package packagename)
      (setf (si:pkg-locked (find-package packagename)) NIL)))

  ) ;; end of Symbolics eval-when. Worry about TI much later.

;;; Initial package-building eval-when for allegro on suns.

#+excl
(eval-when (load eval compile)

  (setf excl:*cltl1-in-package-compatibility-p* T)

  (in-package :Common-lisp-user)

  (defpackage "database" (:nicknames "dbs") 
    (:use :clos :excl :common-lisp-user))

  (in-package DATABASE)

  (in-package 'DATABASE)

  #+(or allegro-v4.1 allegro-v4.2)
  (defun UNLOCK-pKG (packagename)
    (setf (excl:package-definition-lock (find-package packagename)) nil))

  #+(or allegro-v4.1 allegro-v4.2)
  (unlock-pkg 'common-lisp)

  #|

  #+(or allegro-v4.1 allegro-v4.2)
  (defun UNLOCK-PKG (packagename)
    "Changes read-only package status to read+write, if package exists."
    (when (find-package packagename)
      (setf (excl::package-lock-fdefinitions
             (find-package packagename)) NIL)))

  #+(or allegro-v4.1 allegro-v4.2)
  (unlock-pkg 'common-lisp)
  |#

  ) ;; end of excl eval-when...

;;; Set up correct Lucid hash-table accessors....

#+lucid
(shadowing-import '(lcl::hash-table-rehash-size
                    lcl::hash-table-size
                    lcl::hash-table-test
                    lcl::hash-table-rehash-threshold
                    lcl::ignore-errors
                    ) 'database)

;;; Set up correct ACL\PC hash-table accessors....

#+aclpc

(eval-when (load eval compile)

  (in-package 'DATABASE :nicknames '(DB) :use '(LISP))


  (shadowing-import '(acl::hash-table-rehash-size
                      acl::hash-table-size
                      acl::hash-table-test
                      acl::hash-table-rehash-threshold
                      ) 'database)

  ) ;; end aclpc eval-when...

#+cmu
(eval-when (load eval compile)

  ;;kr010205: replaced the following (in-package ) with a (defpackage ) :
  ;;(in-package 'database :nicknames '(db) :use '(PCL LISP))
  (defpackage "DATABASE"
    (:nicknames "DB")
    (:use "COMMON-LISP")
    )
  (in-package "DATABASE")

  (shadowing-import '(;;common-lisp::hash-table-rehash-size
                      ;;common-lisp::hash-table-rehash-threshold
                      ;;kr010210:
                      PCL:METHOD-SPECIALIZERS
                      PCL:METHOD-GENERIC-FUNCTION
                      PCL:GENERIC-FUNCTION-NAME
                      PCL:GENERIC-FUNCTION-LAMBDA-LIST

                      ;;PCL::FIND-CLASS
                      ) 'database)
  #|;;kr010602: what weird old stuff is this ??? : commented out !
  (setf (symbol-function 'hash-table-rehash-size)
    #'common-lisp::hash-table-rehash-size)
  (setf (symbol-function 'hash-table-rehash-threshold) 
    #'common-lisp::hash-table-rehash-threshold)
  |#
  ) ;; end of cmu evalwhen....

;;;kr010120: added SBCL support
#+:sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)

  (defpackage "DATABASE"
    (:nicknames "DB")
    (:use "COMMON-LISP")
    )
  (in-package "DATABASE")

  (shadowing-import '(;;common-lisp::hash-table-rehash-size
                      ;;common-lisp::hash-table-rehash-threshold
                      ;;kr010210:
                      SB-PCL:METHOD-SPECIALIZERS
                      SB-PCL:METHOD-GENERIC-FUNCTION
                      SB-PCL:GENERIC-FUNCTION-NAME
                      SB-PCL:GENERIC-FUNCTION-LAMBDA-LIST
                      #|;;kr010313: needed to comment out, after having added the SBCL PCL stuff further below.
                        ;; otherwise, bad hang when file load...
                      SB-PCL::CLASS-NAME
                      SB-PCL::CLASS-SLOTS
                      SB-PCL::CLASS-OF
                      SB-PCL::CLASSP
                      SB-PCL::FIND-CLASS
                      |#
                      ) :database)

  #|;;kr010605: what weird old stuff is this ??? : commented out !
  (setf (symbol-function 'hash-table-rehash-size)
    #'common-lisp::hash-table-rehash-size)
  (setf (symbol-function 'hash-table-rehash-threshold) 
    #'common-lisp::hash-table-rehash-threshold)
  |#
  ) ;; end of sbcl evalwhen....

#+lucid
(eval-when (load eval compile)
  (setf (symbol-function 'hash-table-rehash-size)
        #'lcl::hash-table-rehash-size)
  (setf (symbol-function 'hash-table-size) #'lcl::hash-table-size)
  (setf (symbol-function 'hash-table-test) #'lcl::hash-table-test)
  (setf (symbol-function 'hash-table-rehash-threshold) 
    #'lcl::hash-table-rehash-threshold)
  ) ;; end lucid eval-when

;;; 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.

#+lispm
(in-package 'DATABASE :nicknames '(DB) :use '(CLOS LISP))

#+pcl
;;;kr010207: had to introduce the (unless ) clause for :CMU
(unless (find-package "DATABASE")
  (in-package "DATABASE" :nicknames '(DB) :use '(PCL LISP)))

#+pcl
(eval-when (load eval compile)
  (when (equal pcl::*pcl-system-date* "July 92 PCL (beta)")
    (pushnew :july-pcl *features*))
  (when (equal pcl::*pcl-system-date* "March 92 PCL (3a)")
    (pushnew :march-pcl *features*))
  (when (equal pcl::*pcl-system-date* "Aug 92 PCL (a)")
    (pushnew :aug-pcl *features*))
  (when (equal pcl::*pcl-system-date* "September 16 92 PCL (f)")
    (pushnew :sept-pcl *features*))
  (when (or (member :march-pcl *features*)
            (member :july-pcl *features*)
            (member :aug-pcl *features*)
            (member :sept-pcl *features*))
    (pushnew :new-pcl *features*))
  )

;;; KOT added this, made some directives simpler below.
#+(or allegro-v4.0 allegro-v4.1 allegro-v4.2)
(eval-when (load eval compile)
  (pushnew :allegro-v4 *features*))

;;; KOT first cut, this might not be portable but should work.  See if
;;; function-lambda-expression is defined, and if so can use it below.
(eval-when (load eval compile)
  (let ((apropos (apropos-list "FUNCTION-LAMBDA-EXPRESSION"
                               (find-package :user))))
    (when (some #'fboundp apropos)
      (pushnew :function-lambda-expression *features*))))

#+lucid
(in-package :DATABASE :nicknames '(DB) :use '(LISP))


;;; ========= end of package engineering .... ===========

;;; Tracing defun eval-when follows....

#+ignore
(eval-when (load eval compile)
  
  (shadow '(defun))

(in-package :DATABASE :nicknames '(DB) :use '(LISP))

  (defmacro DEFUN (name &rest args)
    `(eval-when (load eval compile)
       (when (fboundp ',name)
	     (format t "Warning: ~s was already defined!~%" ',name))
       (format t "now compiling: ~a.~%" ',name)
       (lisp:defun ,name ,@args)))

#+ignore
  (defmacro DEFMETHOD (name &rest args)
    `(eval-when (load eval compile)
       (when (fboundp ',name)
	     (format t "Warning: METHOD ~s was already defined!~%" ',name))
       (format t "now compiling method: ~a.~%" ',name)
       (pcl::defmethod ,name ,@args)))


 ) ;; end of tracing defun eval-when.....

;; Exports.

(export '(save-object
          with-saved-objects
          makesyms
          *save-object-system-date*
          *db-input*
          *storage-vector*
          get-slot-values))

;;; Global variables.

(defvar *db-input* nil "where the loaded data file deposits 
the saved object on reload.")

(defvar *list-hash-table* nil "Gets initialized by function INIT-LIST-HTAB.")

#-akcl ;;; new, AKCL (PCL defclass) doesnt like this one!
(eval-when (load eval compile)
  (setf *print-circle* t)
  )

#+lucid
(defvar *lucid-structure-types*
    '(package  hash-table  defstruct  system::process  
                            lucid:arrayheader  lucid:%pathname  
                            lucid::area  lucid::region  lucid::stack-group
                            lucid::defstruct-slot  lucid::%fs-slot 
                            lucid::%fsft-pointer  lucid::%fsft-structure 
                            lucid::%fsft-field  lucid::%fsft-array 
                            lucid::%fsft-primitive  lucid::%fsft-set  
                            lucid::%fsft-enumerate  lucid::%foreign-type
                            #+LCL4.l lucid::fsft 
        ))

(defvar *storage-list* nil)

;;; KOT wrapped eval-when around this, in Allegro-V4 allows better compilation
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (compile load eval)
  (defvar *storage-hash-table* (make-hash-table)
    "Used by with-saved-objects : NEW.")
  ) ;; end of eval-when


(defvar *use-file-encoded-format* nil "NEW:")

(defvar *use-symbol-long-form* nil
  "if t, use a make-symbol form instead of quote+letter.")

(defvar *minimum-storage-vector-length* 5
  "default length of *storage-vector*")

(defvar *save-symbol-plists* nil
  "Used in long-symbol-dump-form. if t, the symbols property
 list is saved with the occurrence of the symbol.")



(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  ;; KOT -- older version of this had the defvar at top level, and the (if)
  ;; form in the eval-when.  Allegro V4 (at least) bombed on this, saying
  ;; *allow-defstruct-save* didn't yet exist in this case.  This fixes it,
  ;; though I'm not clear why.
  (defvar *allow-defstruct-save* t
    "when t, allow the saving of defstruct 'classes', e.g. the thing
  defined by DEFSTRUCT.")
  (if *allow-defstruct-save* (pushnew :allow-defstruct-save *features*))
  )

(defvar *debug-instance-storage* nil
  "when this one is T, status messages are printed by the CLOS instance saver 
   to aid diagnosis of problems.")

(defvar *debug-local-bindings* nil
  "set this var to t to see a printout of the constructed lexical bindings as 
   they are created.")

(defvar *supress-standard-object* T "")

(defvar *save-contents-of-class-allocated-classes* T
  "This one, if true, includes the slot contents of slots with :allocation 
  :class.")

(defvar *make-list-length-threshold* 10
  "any list longer than this, which has the same element throughout,
  is constructed with MAKE-LIST instead of (list el el el el el el....)."
  )
(defvar *load-object-hash-table* (make-hash-table :size 50 :test #'eql)
  "A hash table which is filled at load time with objects restored from a
   file.")

(defvar *save-object-hash-table* (make-hash-table :size 50 :test #'eql)
  "A hash table which is filled at save time by the invokation of the
  save object function.")

(defvar *mode-for-set-object-var* nil
  "Either :load or :save, depending on the context. Used by SET-OBJECT-VAR.")

(defvar *mode-for-object-var* :save)

(defvar *global-unsaveable-slotnames* nil "")

(defvar *save-object-system-date* 
  "save-object-10.2 of June 2001")

(defvar *unbound-slot-token* '%%.us.%)
(defvar *debug-htab-load* t)
(defvar *debug-struct-save* nil)

(defvar *classes-seen* nil)
(defvar *class-vars* nil)

(defvar *seen* nil "when using linear search, where the CLOS instances go.")
(defvar *vars* nil)
(defvar *structs-seen* nil)
(defvar *struct-vars* nil)
(defvar *htabs-seen* nil)
(defvar *htab-vars* nil)

(defvar *arrays-seen* nil)
(defvar *array-vars* nil)
(defvar *vectors-seen* nil)
(defvar *vector-vars* nil)

(defvar *current-htab-size* 5000)

(defvar *class-safety-p* T "When t, use safe-class-dump-form, not class-dump-form.")

(defvar *current-htab-rehash-threshold* #-akcl 65
        #+akcl 0.6
        )
(defvar *current-htab-rehash-size* 39)
(defvar *current-htab-test* #'eql)

(defvar *pco-types* '(structure hash-table array-type-t
                      class instance circular-list)
  "A list of the type names returned by function %type-of, that
  are potentially circular objects (PCOs).")

(setf *pco-types* '(structure hash-table array-type-t 
                    class instance circular-list))

#+lucid
(setf lcl::*print-structure* T) ;; "Prints the #S form of a defstruct when t."

(defvar *global-instance-count* 0)

(defvar *global-object-count* 0
  "count of varnames made for object hashtable objects, by makevar in 
   cache-object invokations.")

(defvar *use-default-class-initargs* nil)

(defvar *unsaveable-slot-token* '%.uns.%)

(defvar *unsaveable-slotname-hash-table* (make-hash-table))
;;; Used by WITH-SAVED-OBJECTS to store more than one result...

(defvar *storage-vector*)

(defvar *save-defstruct-includes* nil "")

(defvar *construct-pkg-if-not-found* nil "")

#|

   Vendor Dependent Defstruct Internal Structure Access Control Variables:
   =======================================================================
  Vendor dependent defstruct access info is encoded in the following
  global lists:

  *vendor-set-slot-function*:
  *vendor-defstruct-type-function*:
  *vendor-defstruct-name-function*:
  *vendor-defstruct-descriptor-function*:
  *vendor-defstruct-slot-descriptors-function*:

  |#

;;;; Vendor dependent defstruct access data.

(defvar *vendor-set-slot-function*)

(setf *vendor-set-slot-function*
  
  #+symbolics  #'(lambda (struct slotname newval)
                   (setf (slot-value struct slotname) newval))
  #+lucid #'(lambda (struct slotname newval)
              (eval `(SETF (,(get-defstruct-slot-accessor struct slotname) 
                            ,struct)
                           ,newval)))
  #+excl #'(lambda (struct slotname newval)
             (setf (slot-value struct slotname) newval))
  #+akcl #'(lambda (struct slotname newval)
             (let ((offset (get-defstruct-slot-offset struct slotname))
                   (type (get-defstruct-type struct)))
               (si:structure-set struct type offset newval)))
  #+cmu #'(lambda (struct slotname newval)
            (let ((offset (%get-defstruct-slot-offset struct slotname)))
              #+(and :cmu (not :cmu18)) (kernel::structure-set struct offset newval)
              ;;kr010602: it seems to be necessary to distinguish between yet another newer cmucl version:
              #+(and :cmu :cmu18) (kernel::%instance-set struct offset newval)
              ))
  ;;kr010120: added SBCL support
  #+sbcl #'(lambda (struct slotname newval)
            (let ((offset (%get-defstruct-slot-offset struct slotname)))
              (sb-kernel::%instance-set struct offset newval)))
  #+mcl #'(lambda (struct slotname newval)
            (let ((offset (get-defstruct-slot-offset struct slotname)))
              (ccl::struct-set struct offset newval))) ;;; corrected this typo
  #+xerox #'(lambda (struct slotname newval)
              ) 
  #+aclpc #'(lambda (struct slotname newval)
              (eval `(SETF (,(get-defstruct-slot-accessor struct slotname) 
                            ,struct)
                           ,newval)))
  )

;;;kr010602: enabled this also for SBCL
#+(or :cmu :sbcl)
(defun %GET-DEFSTRUCT-SLOT-OFFSET (struct slotname)
  (let ((sd (get-sd-named struct slotname)))
    (when sd (#+:old-cmu c::dsd-index
              ;;kr010602: this is now in the kernel package
              #+:cmu18 kernel::dsd-index
              #+:sbcl sb-kernel::dsd-index
              sd))))

(defvar *vendor-defstruct-type-function*)
(defvar *vendor-dependent-special-predicate*)

(defvar *save-symbol-constants-by-name* nil)
(defvar *save-symbol-constants-by-value* T "The default.")

(setf *vendor-dependent-special-predicate*
  #+Symbolics 'si:special-variable-p
  #+Lucid     'lucid::proclaimed-special-p
  #+KCL	      'si:specialp
  #+excl #'(lambda (symbol)
            (get symbol 'excl::.globally-special))
  #+:CMU #'(lambda (symbol)
	     (or (get symbol 'lisp::globally-special)
                 ;;kr010612: commented out the following.  the package clc doesn't even exist...
		 ;;(get symbol 'clc::globally-special-in-compiler)
                 ))
  ;;kr010609: attempt to add the SBCL version too.  hope this is right.
  #+:SBCL #'sb-walker:variable-globally-special-p
  #+MCL #'(lambda (symbol)
	    (or (ccl::symbol-special-p symbol)
		(ccl::constant-symbol-p symbol)))
  )

(defun SYMBOL-SPECIAL-P (symbol)
  "Predicate, returns T if <symbol> is a symbol, and if it is a constant or declared
 special. "
  (and (symbolp symbol)
       (funcall *vendor-dependent-special-predicate* symbol)))

(setf *vendor-defstruct-type-function*
  #+akcl #'(lambda(desc)(si::s-data-type desc))
  #+excl #'(lambda(desc)(slot-value desc 'excl::type))
  #+lucid #'(lambda(desc)(system::structure-ref desc 1 'lucid::defstruct))
  #+lispm #'(lambda(desc)(si:defstruct-description-type desc))
  ;;#+mcl #'(lambda(desc)(car (ccl::struct-ref desc 0))) ;;kr010608: the path to 10A replaced this.  hope this is right.
  #+mcl #'(lambda (desc i)(elt desc i))  ;;; This is correct for MCL 2.0.1.
  #+(and :cmu (not :cmu18)) #'(lambda(desc)(kernel::structure-ref struct 1)) ;; ???
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda(desc)(pcl::%instance-ref desc 1))
  ;;kr010120: added SBCL support
  #+sbcl #'(lambda(desc)(sb-kernel::%instance-ref desc 1))
  #+xerox #'(lambda(desc))
  #+aclpc #'(lambda (desc) (first (aref desc 0)))
  )

(defvar *vendor-defstruct-name-function*)

;;; Added for 9X.

#+lucid
(proclaim '(special lucid::*defstructs*))

(setf *vendor-defstruct-name-function*
  #+akcl #'(lambda(desc)(si::s-data-name desc))
  #+excl #'(lambda(desc)(slot-value desc 'excl::name))
  #+lucid #'(lambda(desc)(system::structure-ref desc 0 'lucid::defstruct))
  #+lispm #'(lambda(desc)(si:defstruct-description-name desc))
  #+mcl #'(lambda(desc)(class-name (class-of desc)))
  #+(and :cmu (not :cmu18)) #'(lambda(desc)(kernel::structure-ref struct 0)) ;; ???
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda(desc)(pcl::%instance-ref desc 0))
  ;;kr010120: added SBCL support
  #+sbcl #'(lambda(desc)(sb-kernel::%instance-ref desc 0))
  #+xerox #'(lambda(desc))
  #+aclpc #'(lambda (desc) desc)
  )

(defvar *vendor-defstruct-descriptor-function* nil
  "from symbol name of defstruct get the defstruct descriptor.")

(setf *vendor-defstruct-descriptor-function*
  #+symbolics #'(lambda(name)(si:get name 'si:defstruct-description))
  #+lucid #'(lambda(name)(gethash name lucid::*defstructs*))
  #+excl #'(lambda(name)(get name 'excl::%structure-definition))
  #+akcl #'(lambda (name)(get name 'si::s-data))
  #+old-cmu #'(lambda (name)(ext:info c::type c::defined-structure-info name))
  #+(and :cmu (not :cmu18)) #'(lambda (name)(ext:info c::type c::defined-structure-info name))
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda (name)(KERNEL:LAYOUT-INFO (ext:info :type :compiler-layout name)))
  ;;kr010120: added SBCL support.  needed some major hunting around.
  #+:sbcl #'(lambda (name)(SB-KERNEL:LAYOUT-INFO (sb-int:info :type :compiler-layout name)))
  #+mcl #'(lambda (name)(gethash name ccl::%defstructs%))
  #+xerox #'(lambda(name))
  #+aclpc #'(lambda (name)(acl::structure-name-p name))
  )


(defvar *vendor-defstruct-slot-descriptors-function* nil
  "from name of defstruct get list of the defstruct slot descriptors.")

;;; KOT wrapped eval-when around -- think it makes later compilation cleaner
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  (setf *vendor-defstruct-slot-descriptors-function*
    #+symbolics #'(lambda(name)
                    (let ((desc (get-defstruct-descriptor name)))
                     (FOURTH DESC)))
    #+lucid #'(lambda(name)
                (let ((desc (get-defstruct-descriptor name)))
                  (coerce (system:structure-ref desc 7 'lucid::defstruct)
                          'list)))
    #+excl #'(lambda(name)
               (let ((desc (get-defstruct-descriptor name)))
                 (slot-value desc 'excl::slots)))
    #+akcl #'(lambda (name)
               (let ((desc (get-defstruct-descriptor name)))
                 (si::s-data-slot-descriptions desc)))
    #+cmu #'(lambda (name)
              (let ((desc (get-defstruct-descriptor name)))
                ;;kr010602: moved from c to kernel package
                (kernel::dd-slots desc)))
    ;;kr010120: added SBCL support
    #+sbcl #'(lambda (name)
               (let ((desc (get-defstruct-descriptor name)))
                 (sb-kernel::dd-slots desc)))
    #+mcl #'(lambda (name)
              (let ((desc (gethash name ccl::%defstructs%)))
                (mapcar #'(lambda (cell)(list (first cell)(second cell)))
                        (REST (elt desc 1)))))
    #+xerox #'(lambda (name)
                )
    #+aclpc #'(lambda (name)
                (let ((desc (get-defstruct-descriptor name)))
                  (when desc (rest (aref desc 1)))))))


(defvar *vendor-defstruct-predicate-function*)

;;; KOT wrapped eval-when around -- think it makes later compilation cleaner
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  (setf *vendor-defstruct-predicate-function*
    #+aclpc #'(lambda (x)(and (not (hash-table-p x))
                              (typep x 'structure-object)))
    #+symbolics #'cli::structurep
    #+lucid #'(lambda (x)
                (and (system:structurep x)
                     (let ((type (system:structure-type x)))
                       (and (not (lucid::memq type *lucid-structure-types*))
                            (not #+LCL4.1 
                                 (lucid::memq type lucid::*stream-type-names*)
                                 #-LCL4.1
                                 (streamp x))
                            (not (typep x 'standard-object))))))
    #+excl #'excl::structurep
;;;    #+akcl #'(lambda (x)(and (system::structurep x)
;;;                             (not (hash-table-p x))))
    #+akcl #'(lambda (x)(and (not (classp x))
			     (not (hash-table-p x))
			     (not (instance-p x))
			     (sys:structurep x)))
    #+old-cmu #'(lambda (x)
                  (and (system::structurep x)
                       (not (hash-table-p x))
                       (not (instance-p x))))
    #|;;kr010602: let's rather try the thing below.
    #+cmu #'(lambda (instance)
              (equal (class-name (class-of (find-class (type-of instance))))
                     'structure-class))
    |#
    ;;kr010614: noticed the bizarre fact that apparently, (pcl::structurep ) will
    ;; return t on hash-tables too.  so we need to filter against them after all.
    #+:CMU #'(lambda (instance)
               (and (pcl::structurep instance)
                    ;; hash-table exclusion was essential
                    (not (hash-table-p instance))
                    ) )
    ;;kr010120: added SBCL support
    #|;;kr010212: let's rather try the thing below.
    #+sbcl #'(lambda (instance)
               (equal (class-name (class-of (find-class (type-of instance))))
                      'structure-class))
    |#
    ;;kr010614: noticed the bizarre fact that apparently, (sb-pcl::structurep ) will
    ;; return t on hash-tables too.  so we need to filter against them after all.
    #+:SBCL #'(lambda (instance)
                (and (sb-pcl::structurep instance)
                     ;; hash-table exclusion was essential
                     (not (hash-table-p instance))
                     ) )
    #+mcl
    #'(lambda (x) (ccl::structurep x))
;;;; old def: (equal (class-of x) 'structure-class))
    #+xerox #'(lambda (x))
    ))

(defvar *vendor-data-table-access-function* nil
  "This function accesses a particular column of the data tables,
 dependent upon which vendor it is. ")

(setf *vendor-data-table-access-function*
  #+symbolics #'first
  #+lucid     #'second
  #+excl      #'third
  #+akcl      #'fourth
  #+cmu       #'fifth
  #+mcl       #'sixth
  #+xerox     #'seventh
  #+aclpc     #'eighth
  ;;kr010120: added SBCL support
  #+sbcl      #'ninth
  )

(defvar *vendor-defstruct-slot-desc-access-function* nil
  "given a slot description and an index, return the contents of index.")

(setf *vendor-defstruct-slot-desc-access-function*
  #+symbolics #'(lambda (desc i)(elt desc i))
  #+lucid #'(lambda(desc i)
              (system::structure-ref desc i 'lucid::defstruct-slot))
  #+excl #'(lambda(desc i)(excl::structure-ref desc i))
  #+akcl #'(lambda (desc i)(elt desc i))
  #+(and :cmu (not :cmu18)) #'(lambda(desc i)(kernel::structure-ref desc i))
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda(desc i)(pcl::%instance-ref desc i))
  ;;kr010120: added SBCL support
  #+sbcl #'(lambda(desc i)(sb-kernel::%instance-ref desc i))
  #+mcl #'(lambda(desc i)(ccl::struct-ref desc i))
  #+xerox #'(lambda(desc i))
  #+aclpc #'(lambda(desc i))
  )

(defvar *vendor-defstruct-desc-access-function* nil
  "given a description and an index, return the contents of index."
  )

(setf *vendor-defstruct-desc-access-function*
  #+symbolics #'(lambda(desc i)(nth i desc))
  #+lucid #'(lambda(desc i)(system::structure-ref desc i 'lucid::defstruct))
  #+excl #'(lambda(desc i)(excl::structure-ref desc i))
  #+akcl #'(lambda (desc i)(system::structure-ref desc i))
  #+(and :cmu (not :cmu18)) #'(lambda(desc i)(kernel::structure-ref desc i))
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda(desc i)(pcl::%instance-ref desc i))
  ;;kr010120: added SBCL support
  #+sbcl #'(lambda(desc i)(sb-kernel::%instance-ref desc i))
  #+mcl #'(lambda(desc i)(ccl::struct-ref desc i))
  #+xerox #'(lambda(desc i))
  #+aclpc #'(lambda(desc i))
  )


(defvar *vendor-defstruct-slot-desc-index-table* nil
  "values in this table are either nil, a number, or a symbol.
 if nil, funcall desc index function on slot desc only.
 if a number, funcall desc index function on slot desc, index.
 if a symbol, the symbol represents a slot name. call slot-value
 on desc (which is presumed to be a CLOS instance) and the slot name.
 If t, we dont know what it is: return the result of a default function."
  )


(setf *vendor-defstruct-slot-desc-index-table*
  ;;"SYMBOLICS LUCID EXCL AKCL    CMU           MCL   XEROX ACLPC SBCL"
  '((:name 0
           0
           #+excl excl::name #-excl nil
           #+akcl 0 #-akcl nil
           #+cmu #'c::dsd-name #-cmu nil
           #+mcl #'first #-mcl nil
           #+xerox t #-xerox nil
           0 ;; aclpc
           ;;kr010212: added sbcl support
           #+:SBCL #'sb-kernel:dsd-name #-:SBCL nil
           )
    (:type 4
           3
           #+excl excl::type #-excl nil
           #+akcl 2 #-akcl nil
           #+cmu #'c::dsd-type #-cmu nil
           #+mcl t #-mcl nil
           #+xerox t #-xerox nil
           3 ;; aclpc
           #+:SBCL #'sb-kernel:dsd-type #-:SBCL nil
           )
    (:read-status 0
                  5
                  #+excl excl::read-only #-excl nil
                  #+akcl 3 #-akcl nil
                  #+cmu #'c::dsd-read-only #-cmu nil 
                  #+mcl t #-mcl nil
                  #+xerox t #+xerox nil
                  4 ;; aclpc
                  #+:SBCL #'sb-kernel:dsd-read-only #-:SBCL nil 
                  )
    (:position    1
                  1
                  #+excl excl::index #-excl nil
                  #+akcl 4 #-akcl nil
                  #+cmu #'c::dsd-index #-cmu nil
                  #+mcl t #-mcl nil
                  #+xerox t #-xerox nil
                  #+aclpc t #-aclpc nil
                  #+:SBCL #'sb-kernel::dsd-index #-:SBCL nil
                  )
    (:default-value 3
                    4
                    #+excl excl::default #-excl nil
                    #+akcl 1 #-akcl nil
                    ;;kr010602: moved from c to kernel package
                    #+cmu #'kernel::dsd-default #-cmu nil  
                    #+mcl #'second #-mcl nil
                    #+xerox t #-xerox nil
                    2 ;; aclpc
                    #+:SBCL #'sb-kernel::dsd-default #-:SBCL nil  
                    )
    (:accessor 6
               2
               #+excl excl::accessor #-excl nil
               #+akcl t #-akcl nil
               #+cmu #'c::dsd-accessor #-cmu nil 
               #+mcl t #-mcl nil
               #+xerox t #-xerox nil
               1 ;; aclpc
               #+:SBCL #'sb-kernel:dsd-accessor #-:SBCL nil 
               )
    ))

(defvar *vendor-dependent-defstruct-symbol-function* nil
  "Given a name of a defstruct as a symbol, return the defstruct descriptor
   data structure for that defstruct."
  )

(setf *vendor-dependent-defstruct-symbol-function*
  #+symbolics #'(lambda(name)(si:get name 'si:defstruct-description))
  #+lucid #'(lambda(name)(gethash name lucid::*defstructs*))
  #+excl #'(lambda(name)(get name 'excl::%structure-definition))
  #+akcl #'(lambda (name)(get name 'si::s-data))
  #+(and :cmu (not :cmu18)) #'(lambda (name)(ext:info c::type c::defined-structure-info name))
  ;;kr010601: it seems to be necessary to distinguish between yet another newer cmucl version:
  #+(and :cmu :cmu18) #'(lambda (name)(KERNEL:LAYOUT-INFO (ext:info :type :compiler-layout name)))
  ;;kr010120: added SBCL support
  ;;#+sbcl #'(lambda (name)(sb-int:info sb-c::type sb-c::defined-structure-info name))
  #+:sbcl #'(lambda (name)(SB-KERNEL:LAYOUT-INFO (sb-int:info :type :compiler-layout name)))
  #+mcl #'(lambda (name)(gethash name ccl::%defstructs%))
  #+xerox #'(lambda(name))
  #+aclpc #'(lambda(name)(acl::structure-name-p name))
  )

;;;kr010605: this is just used in the table below.  made this low-level extractor work
;;; in modern cmu-derived lisps.  using a separate fn allows this often used code to be compiled.
;;;
#+(or :sbcl (and :cmu :cmu18))
(defun cmu-and-sbcl-defstruct-constructor-extractor (defstruct-description)
  ;;kr010601: for cmu18c, changed package from c to kernel
  (let ((them (#+:cmu kernel::dd-constructors
               #+:sbcl sb-kernel::dd-constructors
               defstruct-description)))
    (if (consp them)
        (first them)
      ;;kr010604: well, guess what, in cmucl-18c, this defstruct slot is empty !
      ;; and we need to get the following:
      (#+:cmu kernel::dd-default-constructor
       #+:sbcl sb-kernel::dd-default-constructor
       defstruct-description))))

(defvar *vendor-defstruct-desc-index-table* nil
  "values in this table are either nil, a number, or a symbol.
 if nil, funcall desc index function on desc only.
 if a number, funcall desc index function on desc, index.
 if a symbol, the symbol represents a slot name. call slot-value
 on desc (which is presumed to be a CLOS instance) and the slot name.")


(setf *vendor-defstruct-desc-index-table*
  ;;"SYMBOLICS LUCID EXCL             AKCL                      CMU MCL   XEROX ACLPC SBCL"

  '((:NAME #+lispm #'si:defstruct-description-name #-lispm nil
           0
           #+excl excl::name #-excl nil
           #+akcl #'si::s-data-conc-name #-akcl nil          
           ;;kr010601: for cmu18c, changed package from c to kernel
           #+cmu #'kernel::dd-name #-cmu nil
           #+mcl t #-mcl nil
           #+xerox t #-xerox nil
           #+aclpc t #-aclpc nil
           ;;kr010213: added sbcl support
           #+:SBCL #'sb-kernel:dd-name #-:SBCL nil
           )
    (:PRINT-FUNCTION #+lispm #'si:defstruct-description-print-function #-lispm nil
                     6  
                     #+excl excl::print-function  #-excl nil
                     #+akcl #'si::s-data-print-function  #-akcl nil
                     ;;kr010601: for cmu18c, changed package from c to kernel
                     #+cmu #'kernel::dd-print-function  #-cmu nil
                     #+mcl t #-mcl nil
                     #+xerox t #-xerox nil
                     #+aclpc t #-aclpc nil
                     #+:SBCL #'sb-kernel::dd-print-function  #-:SBCL nil
                     )
    (:TYPE #+lispm #'si:defstruct-description-type #-lispm nil
           1
           #+excl excl::type #-excl nil
           #+akcl #'si::s-data-type #-akcl nil             
           ;;kr010601: for cmu18c, changed package from c to kernel
           #+cmu #'kernel::dd-type #-cmu nil
           #+mcl t #-mcl nil
           #+xerox t #-xerox nil
           0 ;; aclpc
           #+:SBCL #'sb-kernel:dd-type #-:SBCL nil
           )
    (:PREDICATE #+lispm #'si:defstruct-description-predicate #-lispm nil
                5    
                #+excl  excl::predicate #-excl nil
                #+akcl t #-akcl nil                    
                ;;kr010601: for cmu18c, changed package from c to kernel
                #+cmu #'kernel::dd-predicate #-cmu nil
                #+mcl t #-mcl nil
                #+xerox t #-xerox nil
                4 ;; aclpc
                #+:SBCL #'sb-kernel:dd-predicate #-:SBCL nil
                )
    (:COPIER #+lispm #'si:defstruct-description-copier #-lispm nil
             4 
             #+excl excl::copier #-excl nil
             #+akcl t #-akcl nil           
             ;;kr010601: for cmu18c, changed package from c to kernel
             #+cmu #'kernel::dd-copier #-cmu nil
             #+mcl t #-mcl nil
             #+xerox t #-xerox nil
             5 ;; aclpc
             #+:SBCL #'sb-kernel:dd-copier #-:SBCL nil
             )
    (:DOCUMENTATION #+lispm #'si:defstruct-description-documentation #-lispm nil
                    t   #+excl excl::doc #-excl nil
                    #+akcl #'si::s-data-documentation #-akcl nil
                    ;;kr010601: for cmu18c, changed package from c to kernel
                    #+cmu #'kernel::dd-doc #-cmu nil
                    #+mcl t #-mcl nil
                    #+xerox t #-xerox nil
                    #+aclpc t #-aclpc nil
                    #+:SBCL #'sb-kernel::dd-doc #-:SBCL nil
                    )
    (:CONC-NAME #+lispm #'si::defstruct-description-conc-name #-lispm nil
                2  
                #+excl excl::conc-name #-excl nil
                #+akcl #'si::s-data-conc-name  #-akcl nil
                ;;kr010601: for cmu18c, changed package from c to kernel
                #+cmu #'kernel::dd-conc-name #-cmu nil
                #+mcl t #-mcl nil
                #+xerox t #-xerox nil
                #+aclpc t #-aclpc nil
                #+:SBCL #'sb-kernel::dd-conc-name #-:SBCL nil
                )
    (:INCLUDE #+lispm #'si:defstruct-description-include #-lispm nil
              0
              #+excl excl::include #-excl nil
              #+akcl #'si::s-data-include #-akcl nil
              ;;kr010601: for cmu18c, changed package from c to kernel
              #+cmu #'kernel::dd-include #-cmu nil
              #+mcl t #-mcl nil
              #+xerox t #-xerox nil
              3 ;; aclpc
              #+:SBCL #'sb-kernel::dd-include #-:SBCL nil
              )
    (:CONSTRUCTOR #+lispm #'si::defstruct-description-constructor #-lispm nil
                  3
                  #+excl  excl::constructor #-excl nil
                  #+akcl #'(lambda (x)
                             (let ((them (si::s-data-constructors x)))
                               (if (listp them)(first them) them)))
                  #-akcl nil
                  #+(and :cmu (not :cmu18)) #'(lambda (x)
                                                (let ((them (kernel::dd-constructors x)))
                                                  (if (listp them)(first them) them)))
                  #+(and :cmu :cmu18) #'cmu-and-sbcl-defstruct-constructor-extractor
                  #-cmu nil
                  ;; #+mcl t #-mcl nil
                  4 ;;;; fifth thing in the descriptor in mcl 2.0.1
                  #+xerox t #-xerox nil
                  2 ;; aclpc
                  #+:SBCL #'cmu-and-sbcl-defstruct-constructor-extractor #-:SBCL nil
                  )
    ))

(defvar *cons-hash-table* nil
  "cache for conses: initialized in INIT-LIST-HTABS, used in INDEX-LIST.")
(defvar *dl-hash-table* nil
  "cache for dotted lists: initialized in INIT-LIST-HTABS, used in INDEX-LIST.")
(defvar *list-hash-table* nil
  "cache for ordinary lists: initialized in INIT-LIST-HTABS, used in INDEX-LIST.")

(defvar *use-default-defstruct-options-in-save* nil "")

(defvar *test-for-circularities* T "This should normally be t.")
(setf *test-for-circularities* T)

(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  (when *test-for-circularities* (pushnew :CIRCULAR-TESTS *FEATURES*)))

;;;======================================================================

#+akcl
(eval-when (load eval compile)
  ;; HASH-TABLE-SIZE does not seem to exist in AKCL!
  (when (not (fboundp 'hash-table-size))
    (defun HASH-TABLE-SIZE (htab)
      39)
    )
  (defun INSTANCE-P (X) (typep x 'pcl::standard-object))
  (defun %CLASSP (X) (pcl::classp x))

  ) ;; end of akcl eval-when....

;;; ROW MAJOR AREF --- ACL doesnt have it, Genera has it in package FCL....

;;; lucid has row-major-aref, no problem.

#+(or rel-8-0 rel-8-1)
(shadowing-import '(future-common-lisp:row-major-aref) 'database)

#+cmu
(shadowing-import '(user::row-major-aref) 'database)

;;; KOT I think don't need this in Allegro 4.2 (Sun); it's defined in CL
;;; package but I don't know how to test whether it works as I don't use
;;; arrays in my test cases.
#-(or lispm rel-8-0 rel-8-1 lucid cmu aclpc)
(when (not (fboundp 'row-major-aref))
  (pushnew :need-row-major-aref *features*))

;;; lispm has it, CMU has it.

#-(or cmu lispm aclpc)
(eval-when (load eval compile)
  
  #+need-row-major-aref 
  (defun ROW-MAJOR-AREF (array index)
    "We have to define this, as Franz does not implement RMA pg. 450 CLtL2.
     NOTE: Neither does Symbolics."
    (aref (make-array (array-total-size array)
                      :displaced-to array
                      :element-type (array-element-type array))
          index))

  #+need-row-major-aref
  (defun ROW-MAJOR-SETA (array index newval)
    "so we can defsetf row-major-aref!"
    (setf (aref (make-array (array-total-size array)
                            :displaced-to array
                            :element-type (array-element-type array))
                index) newval))

  #+need-row-major-aref
  (defsetf row-major-aref row-major-seta)

  ) ;; row-major-aref eval-when....


(defun %FILL-INSTANCE (i ordered-slot-values)
  "Modified by KJ for MCL: Fills in the slots alphabetically. 
  Assumes the slot values come into the function
  alphabetically ordered already: Returns the instance object.
  NOTE: modification to deal with unbound slots is included!"
  (if (null ordered-slot-values) i
    (let ((osv (copy-list ordered-slot-values))
          (unbound-slot nil)
          (default-slot nil)
          (names (get-ordered-slot-names i))
          (thang nil)
          (name nil))
(IF (NULL NAMES) I
      (loop (setf name (pop names))
        (setf thang (pop osv))
        (cond ((unbound-slot-token-p thang)
               (setf unbound-slot T)
               (setf default-slot NIL))
              ((unsaveable-slot-token-p thang)
               (setf default-slot T))
              ((and thang (symbolp thang))
               ;; mod by KJ to get rid of annoying quotes that
               ;; don't belong (I think this is because
               ;; initialize-instance is no longer getting
               ;; called so the quotes aren't needed.)
                              ;(setf thang `(quote ,thang))
               (setf unbound-slot NIL)
               (setf default-slot NIL))
              (T (setf unbound-slot NIL)
                 (setf default-slot NIL)))
        ;; if this slot was marked as unsaveable,
        ;; let the value be whatever allocate-instace willed it to be.
        ;; if it was unbound when saved, make the new instace slot
        ;; unbound, too. if neither, put the supplied slot value from
        ;; the file in the slot.
        (if default-slot NIL ;; do nothing.
          (if (not unbound-slot)
              (cond ((instance-p i)
                     (setf (slot-value i name) thang)) ;; put the value in.
                    ((structure-p i)(set-defstruct-slot-value i name thang)))
            (slot-makunbound i name))) ;; make the slot unbound.
        (when (and (null names)(null osv))(return i)))))))

(defmacro ASV (new-element)
  "Add to storage vector, create, or vector push extend if necessary."
  `(progn (when (not (boundp '*storage-vector*))
            (setf *storage-vector* 
              (make-array *minimum-storage-vector-length*
                          :adjustable t :fill-pointer 0)))
          (vector-push-extend (EVAL ',new-element) *storage-vector*)))

(defun WRITE-ASV-FORM (stream instance)
  "Write the dump form of the instance for appending to the storage vector.
 make sure that print-pretty is turned off to save room."
  (let* ((*print-pretty* nil))
    (format stream "~s~%" `(ASV ,(get-dump-form instance))))
  )

(defun %WRITE-ASV-FORM (stream instance)
  "Write the dump form of the instance for appending to the storage vector.
 make sure that print-pretty is turned off to save room."
  (let* ((*print-pretty* nil))
    (format stream "~s~%" `(ASV ,(make-dumpable-form instance))))
  )

(defun WRITE-ASV-FORMS (stream)
  ""
  (maphash #'(lambda (key val)
               (declare (ignore key))
               (format stream "~s~%" `(ASV ,val)))
           *storage-hash-table*))

#+ignore
(defmacro WITH-SAVED-OBJECTS-INTERNAL ((so-var construction-form) &rest body)
  "Internal workhorse macro for WITH-SAVED-OBJECTS... derived from WITH-OPEN-
 FILE...."
  (declare (special so-var)) ;;; new!
  `(let ((.stream-abort-flag. :ABORT))
     (unwind-protect
         (multiple-value-prog1
             (progn (set ',so-var ,construction-form)
                    (write-attribute-line ,so-var)
                    (write-package-info ,so-var)
                    (dolist (form ',body)
                      ;;(let ((result (eval form)))              
                        ;;(if (not (pco-p result))
                            ;;(write-asv-form ,so-var result)
                          ;;(get-dump-form result)
                          ;;))
                      (%write-asv-form ,so-var (eval form))              
                      )
                    ;;(write-lex-env-prelude ,so-var)
                    ;;(write-asv-forms ,so-var)
                    ;;(write-lex-env-apotheosis ,so-var)
                    (setf .stream-abort-flag. nil))
           (when ,so-var (close ,so-var :abort .stream-abort-flag.))))))

(defmacro WITH-SAVED-OBJECTS-INTERNAL ((so-var construction-form) &rest body)
  "Internal workhorse macro for WITH-SAVED-OBJECTS... derived from WITH-OPEN-
 FILE...."
  (declare (special so-var))
  `(let ((.stream-abort-flag. :ABORT))
     (unwind-protect
         (multiple-value-prog1
             (progn (set ',so-var ,construction-form)
                    (write-attribute-line ,so-var)
                    (write-package-info ,so-var)
                    (dolist (form ',body)
                      (%write-asv-form ,so-var (eval form))              
                      )
                    (setf .stream-abort-flag. nil))
           (when ,so-var (close ,so-var :abort .stream-abort-flag.))))))

(defun WRITE-LEX-ENV-PRELUDE (stream)
  (format stream "(LET* ( ")
  (maphash #'(lambda (key value)
               (format stream "(~A ~A)"
                       key value))
           *storage-hash-table*)
  (format stream ")"))

(defun WRITE-LEX-ENV-APOTHEOSIS (stream)
  ""
  (format stream ")~%"))

(defmacro WITH-SAVED-OBJECTS ((svar sspec . options) &body body)
  "Macro which evaluates, then dumps, as many forms as you want to
 the specified file. If you do not specify file attributes, a reasonable
 set (such as :direction :output, if does not exist :create) is assumed.
 NOTE: This macro now returns the filename where the data is stored."
  (declare (special svar))
  (clrhash *storage-hash-table*)
  ;;kr010612: what is this good for ?  commented out.
  ;;(setf (get 'already-exists 'file)(probe-file sspec))
  (when (null options)(setf options (list :direction :output
                                          :if-exists :append
                                          :if-does-not-exist :create)))
  `(progn (with-saved-objects-internal (,svar (open ,sspec . ,options))
            . ,body)
          ,sspec))

;;; Dump forms.

#|
  Dump forms include:

  constant 
  complex
  quoted-symbol
  simple-list
  defstruct-instance
  defstruct-class

  |#

(defun STREAM-DUMP-FORM (instance)
  "Very machine dependent! for now, just recognize we got one, return NIL as
   DUMP FORM."
  (format t "Recognized a stream in save object: ~a.~%" instance)
  NIL)

(defun CONSTANT-DUMP-FORM (instance)
  "Anything which evals to itself (aside from structured objects),
 can be written as is."
  instance)

(defun COMPLEX-DUMP-FORM (instance)
  "Dumps anything which is a complex number."
  `(COMPLEX ,(get-dump-form (REALPART instance))
            ,(get-dump-form (IMAGPART instance))))

(defun QUOTED-SYMBOL-DUMP-FORM (instance)
  "PATCHED: ADDED SECOND QUOTE FOR 9X: Dump form for a quoted symbol."
  `(QUOTE (QUOTE ,(second instance))))

#+ignore
(defun SIMPLE-LEX-DUMP-FORM (lst)
  `(QUOTE (LIST ,@lst)))

(defun SIMPLE-LEX-DUMP-FORM (lst)
  `(LIST ,@lst))

(defun SIMPLE-LIST-DUMP-FORM (instance)
  "Dump form for lists of admissible cnstants."
  #-cmu `(LIST ,@instance)
  #+cmu `(LIST ',@instance)
  )

(defun DOTTED-LIST-DUMP-FORM (instance)
  "Dump form whose last element is a dotted air, e.g. returned by LIST*."
  `(LIST*  ,(get-dump-form (first instance))
           ,(get-dump-form (rest instance))))

(defun DEFSTRUCT-INSTANCE-DUMP-FORM (instance)
  "Vendor independent!"
  `(fill-struct ,(get-instance-label instance)
                ;; ',(get-defstruct-values instance)
                (LIST ,@(get-defstruct-values instance))))

(defun REGULAR-FUNCTION-DUMP-FORM (instance)
  ""
  `(FUNCTION ,instance))

;;; Lucid is the only one that has a list length limit.

#-lucid
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  
  (defun LONG-LIST-DUMP-FORM (instance)
    ""
    (list-dump-form instance))

  ) ;; long-list eval-when.

(defun LIST-DUMP-FORM (instance)
  ""
  `(LIST ,@(mapcar #'(lambda (thing)
                       (get-dump-form thing))
                   instance)))

#+ignore
(defun NEW-CACHE-OBJECT (object object-list var-list1 var-list2
                         dump-form)
  "Fixed bug in position call this time."
  (if (member object object-list :test #'equal)
      (symbol-dump-form (nth (position OBJECT object-list :test #'equal)
			     var-list1))
    (progn (push object object-list)
           (setq var-list2 (pushsym var-list1))
           (funcall dump-form object))))

;;; KOT added this; though not clearly how to completely add it in.
(defun CLOSUREP (x)
  "This machine dependent predicate returns t if the object <x> is
   a lexical closure, ie. either a (function (lambda .... thing, or
   a hash-mark quote thing,"
  #+lucid (and (not (typep x 'compiled-function))
               (typep x 'system:procedure))
  #+allegro-v4 (typep x 'excl::closure)
  #-(or lucid allegro-v4)(progn x nil)
  )

(defun CLOSURE-DUMP-FORM (closure)
  #-:function-lambda-expression (declare (ignore closure))
  #+:function-lambda-expression
  (multiple-value-bind (lambda-expression closure-p name)
      (function-lambda-expression closure)
    ;; KOT's reading of ANSI Draft 12.24, page 5-26, is that only the primary
    ;; value is something that potentially could be readable.
    (declare (ignore closure-p name))
    lambda-expression)
  #-:function-lambda-expression nil
  )

;;; KOT put this in here to look at, but it doesn't write anything useful
;;; in Allegro-V4
#+:ignore 
(defun CLOSURE-DUMP-FORM-V70 (closure)
  (let ((ans nil)
        (strname ""))
    (setq *readtable* (copy-readtable))
    (set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
    (set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
    (setf strname (format nil "~S" closure))
    (setq ans (read-from-string  (SUBSEQ strname 0 (length strname))))
    (setq *readtable* (copy-readtable nil))
    `(FUNCTION ,ans)))

(defun STRUCTURED-OBJECT-DUMP-FORM (object)
  "Routine which deals with any potentially circular objects (PCOS).
 NEW: Adds the local variable and the dump form to the *Storage-hash-table*
 so that with-saved-objects need to only do one set of local bindings for
 structure-sharing. need to complete arrayp, hash-table-p clauses, test."
  (cond ((null object) NIL)
        ((%classp object)
         (if (member object *classes-seen* :test #'equal)
             (symbol-dump-form
              (nth (position object *classes-seen* :test #'equal)
                   *class-vars*))
           (let ((df nil))
             (push object *classes-seen*)
             (setq *vars* (pushsym *class-vars*))
             (setf df (if *class-safety-p* (safe-class-dump-form object)
                          (class-dump-form object)))
             (push (list (first *vars*) df) *storage-list*)
             (setf (gethash (first *vars*) *storage-hash-table*)
               df)
             df)))
        ((instance-p object)
         (if (member object *seen* :test #'equal)
             (symbol-dump-form
              (nth (position object *seen* :test #'equal) *vars*))
           (let ((df nil))
             (push object *seen*)
             (setq *vars* (pushsym *vars*))
             (setf df (instance-dump-form object))
             (push (list (first *vars*) df) *storage-list*)
             (setf (gethash (first *vars*) *storage-hash-table*)
               df)
             df)))
        ((structure-p object)
         (if (member object *structs-seen* :test #'equal)
             (symbol-dump-form (nth (position object *structs-seen*
                                              :test #'equal)
                                    *struct-vars*))
           (let* ((df nil))
             (push object *structs-seen*)
             (setf *struct-vars* (pushsym *struct-vars*))
             (setf df  (structure-dump-form object))
             (push (list (first *struct-vars*) df) *storage-list*)
             (setf (gethash (first *struct-vars*) *storage-hash-table*)
               df)
             df)))
        ((vectorp object)
         (if (member object *vectors-seen* :test #'equal)
             (progn (symbol-dump-form (nth (position object *vectors-seen*
                                                     :test #'equal)
                                           *vector-vars*)))
           (let ((df nil))
             (push object *vectors-seen*)
             (setf *vector-vars* (pushsym *vector-vars*))
             (setf df (vector-dump-form object))
             (push (list (first *vector-vars*) df) *storage-list*)
             (setf (gethash (first *vector-vars*) *storage-hash-table*)
               df)
             df)))
        ((arrayp object)
         (if (member object *arrays-seen* :test #'equal)
             (progn (symbol-dump-form (nth (position object *arrays-seen*
                                                     :test #'equal)
                                           *array-vars*)))
           (let ((df nil))
             (push object *arrays-seen*)
             (setf *array-vars* (pushsym *array-vars*))
             (setf df (array-dump-form object))
             (push (list (first *array-vars*) df) *storage-list*)
             (setf (gethash (first *array-vars*) *storage-hash-table*)
               df)
             df)))
        ((hash-table-p object)
         (if (member object *htabs-seen* :test #'equal)
             (symbol-dump-form  (nth (position object *htabs-seen* 
                                               :test #'equal) *htab-vars*))
           (let* ((df nil))
             (push object *htabs-seen*)
             (setf *htab-vars* (pushsym *htab-vars*))
             (setf *current-htab-size* (or (hash-table-size object) 5000))
             (setf *current-htab-rehash-threshold* 
                   (or (hash-table-rehash-threshold object) 20))
             (setf *current-htab-test* (hash-table-test object))
             (setf *current-htab-rehash-size*
                   (or (hash-table-rehash-size object) 67))
             (setf df (htab-dump-form object))
             (push (list (first *htab-vars*) df) *storage-list*)
             (setf (gethash (first *htab-vars*) *storage-hash-table*)
               df)
             df)))
 #+CIRCULAR-TESTS ((circular-list-p object)(circular-list-dump-form object))
        (T (error "couldnt parse ~a as a structured object!" object))))

(defun DEFSTRUCT-OBJECT-P (obj)
  "Predicate for testing whether something is a defstruct descriptor."
  (typep obj #+lispm 'si::defstruct-description
         #+allegro 'excl::defstruct-description
         #+lucid 'defstruct
         #+akcl 'system::s-data
         #+(and :cmu (not :cmu18)) 'c::defstruct-descriptor
         ;;kr010602: it seems to be necessary to distinguish between yet another newer cmucl version:
         #+(and :cmu :cmu18)  'kernel::defstruct-description
         ;;kr010210: added support for SBCL
         #+:SBCL  'sb-kernel::defstruct-description
         #+mcl 'vector
         #+aclpc 'vector ;; the descriptor as a whole is a simple vector.
         )
  )

#|

  (defun STRUCTURED-OBJECT-DUMP-FORM (object)
    "Routine which deals with any potentially circular objects (PCOS)."
  (cond ((null object) NIL)
  ((defstruct-object-p object)
  (defstruct-object-dump-form object))
  ((%classp object)
  (new-cache-object object *classes-seen* *class-vars* *vars*
  #'class-dump-form))
  ((instance-p object)
  (new-cache-object object *seen* *vars* *vars*
  #'instance-dump-form))
  ((structure-p object)
  (new-cache-object object *structs-seen* *struct-vars* 
  *struct-vars*
  #'defstruct-instance-dump-form))
  ((vectorp object)
  (new-cache-object object *vectors-seen* *vector-vars* 
  *vector-vars*
  #'vector-dump-form))
  ((arrayp object)
  (new-cache-object object *arrays-seen* *array-vars* 
  *array-vars*
  #'array-dump-form))
  ((hash-table-p object)
  (if (member object *htabs-seen* :test #'equal)
  (symbol-dump-form 
  (nth (position object *htabs-seen* :test #'equal) *htab-vars*))
  (progn (push object *htabs-seen*)
  (setf *htab-vars* (pushsym *htab-vars*))
  (setf *current-htab-size* (or (hash-table-size object) 5000))
  (setf *current-htab-rehash-threshold*
  (or (hash-table-rehash-threshold object) 20))
  (setf *current-htab-test* (hash-table-test object))
  (setf *current-htab-rehash-size*
  (or (hash-table-rehash-size object) 67))
  (htab-dump-form object))))
  ((circular-list-p object)(circular-list-dump-form object))
  (T (error "couldnt parse ~a as a structured object!" object))))
  |#

(defun HTAB-DUMP-FORM (htab)
  "Dump for for hash tables.... "
  `(makehash ,(get-instance-label htab)
             :test ,(get-dump-form (hash-table-test htab))
             :size ,(get-dump-form (hash-table-size htab))
             :rehash-size ,(get-dump-form (hash-table-rehash-size htab))
             :rehash-threshold ,(get-dump-form
                                 (hash-table-rehash-threshold htab))
             :values (LIST ,@(get-htab-values htab))))

(defun PACKAGE-DUMP-FORM (package)
  "assume its there in the environment, somewhere."
  (let ((pn (get-dump-form (package-name package))))
    `(FIND-PACKAGE ,pn)))

(defun REPEATING-ELEMENT-LIST-DUMP-FORM (instance)
"A dump form for a list which has a repeating element."
  (let ((length (length instance))
        (form (get-dump-form (first instance))))
    `(MAKE-LIST ,length :initial-element ,form)))

(defun REC-LIST-DUMP-FORM (l)
  `(LIST ,@(%rec-list-dump-form l)))

(defun %REC-LIST-DUMP-FORM (l)
  ""
  (cond ((null l) nil)
        ((not (listp (first l)))
         (cons (get-dump-form (first l))
               (%rec-list-dump-form (rest l))))
        (T (cons (%rec-list-dump-form (first l))
                 (%rec-list-dump-form (rest l))))))

(defun CONS-DUMP-FORM (item)
  `(CONS ,(get-dump-form (first item))
         ,(get-dump-form (rest item))))

(defun PRINT-SLOTS (instance)
"Utility function to print the slots in the instance, ala describe."
(mapcar #'(lambda (s)(format t "Name:~a, Value:~a~%" s 
(if (slot-boundp instance s)(slot-value instance s) :UNBOUND)))
(all-slotnames instance)))

(defun ARRAY-DUMP-FORM (array)
  "this function return a make-array form."  
  (setf *print-array* T)
  (let ((vals (%list-array array)))
    `(let ((tmp (allocate-array ,(get-dump-form (array-dimensions array))
                                :element-type ',(array-element-type array)
                                :adjustable ,(adjustable-array-p array)
                                :initial-contents ,(get-dump-form vals)
                                )))
       TMP)))

(defun SIMPLE-ARRAY-DUMP-FORM (array)
  "Numerical arrays are stored using this routine...."
  (let ((vals (%list-array array)))
  `(allocate-array ,(get-dump-form (array-dimensions array))
               :element-type ',(array-element-type array)
               :initial-contents ,(get-dump-form vals)
               )))

(defun VECTOR-DUMP-FORM (array)
  "this function return a make-array form."  
  (setf *print-array* T)
  (let ((vals (%list-array array)))
    `(let ((tmp (allocate-array ,(get-dump-form (array-dimensions array))
                                :element-type ',(array-element-type array)
                                :adjustable ,(adjustable-array-p array)
                                :initial-contents ,(get-dump-form vals))))
       TMP)))

(defun READTABLE-DUMP-FORM (i)
  "Doesnt seem to be a good way to probe the internals of readtables, even
   machine specific ways!!!!"
  (declare (ignore i))
  `(copy-readtable *readtable*))

(defun GENERIC-FUNCTION-DUMP-FORM (instance)
  "Dump Form for saving out generic functions..."
  (let ((name (generic-function-name instance))
        (arglist (generic-function-lambda-list instance))
        (documentation (%generic-function-documentation instance)))
    `(OR (FIND-GENERIC-FUNCTION ',name)
         (DEFGENERIC ,name ,arglist (:DOCUMENTATION ,(or documentation ""))))))

(defun METHOD-DUMP-FORM (instance)
  "dump form for saving out method objects."
  (LET* ((name (generic-function-name (method-generic-function instance)))
         (qualifiers (method-qualifiers instance))
         (specializers (method-specializers instance)))
        `(FIND-METHOD (FUNCTION ,name)
                      (LIST ,@qualifiers)
                      (LIST ,@(DO-SPECIALIZERS specializers))
                      NIL)))

;;; PCL/CLOS classes and instances:

;;; NOTE: CLASS DEFINITIONS, WHEN READ IN, WILL OVERWRITE THE CLASS
;;; DEFINITION PREVIOUSLY IN MEMORY. IF YOU DO NOT WANT THIS TO HAPPEN,
;;; REPLACE 'DEFCLASS' BELOW WITH 'FIND CLASS' + the APPROPRIATE ARGUMENTS!

(defun SAFE-CLASS-DUMP-FORM (instance)
  "MODIFIED: does not do the let unless the class is not found...
   his version of the class-dump-form function WILL NOT overwrite 
   current class definitions with the same name. It is the one invoked
   by GET-DUMP-FORM and SAVE-OBJECT."
  (let* ((name (%class-name instance)))
    `(FIND-CLASS ',name)))

#|
         `(OR (FIND-CLASS ',name)
              (let* ((supertypes (get-class-superclasses ,instance))
                     (slots (generate-class-slot-forms ,instance))
                     (options (generate-class-options-form ,instance)))
                `(DEFCLASS ,name ,supertypes ,slots ,@options)))))
|#

(defun CLASS-DUMP-FORM (instance)
  "This version of the class-dump-form function WILL OVERWRITE 
 CURRENT CLASS DEFINITIONS WITH THE SAME NAME. Sunstitute a call to
 this one in GET-DUMP-FORM and SAVE-OBJECT."
  (let* ((name (%class-name instance))
         (supertypes (get-class-superclasses instance))
         (slots (generate-class-slot-forms instance))
         (options (generate-class-options-form instance)))
    (if (builtin-class-p instance) `(FIND-CLASS ',name)
      `(DEFCLASS ,name ,supertypes ,slots ,@options))))

(defun INSTANCE-DUMP-FORM (instance)
  "Basic dump form for clos/pcl instances. checks if the instance has a custom
 dump form, binds it to a generated symbol name, recursively expands the
 instances contents."
  (declare (special tmp))
  (if (has-dump-form-p (instance-name instance))
      `(setq ,(get-instance-label instance) ,(funcall #'(lambda (x)
                                                          (get-dump-form x))
                                                      instance))
    `(fill-instance ,(get-instance-label instance)
                    (LIST ,@(get-ordered-slot-values instance)))))

(defun LONG-SYMBOL-DUMP-FORM (instance &optional (package *package*))
  "Uses a MAKE-SYMBOL form to re-create the symbol: 
   saves the property list of the symbol if the global flag *save-symbol-plists* is T."
  (if *save-symbol-plists*
  `(let ((sym (intern ,(symbol-name instance) (find-package ,(package-name package)))))
     (setf (symbol-plist sym) ,(get-dump-form (symbol-plist instance))))
    `(intern ,(symbol-name instance) (find-package ,(package-name package)))))

(defun SYMBOL-DUMP-FORM (instance)
  "Better bolder symbol saving formula which includes the package data 
   implicitly: if package cell is NULL (as returned by GENSYM), 
   default *package* is used."
  (let ((package-name nil)
        (the-package (symbol-package instance)))
    (if (null the-package)(setf package-name (package-name *package*))
      (setf package-name (package-name the-package)))
    (if (null instance) NIL
      (if (special-marker-p instance) instance
        (if *use-symbol-long-form*
            (long-symbol-dump-form instance)
          (read-from-string (format nil "~a"
                                    (concatenate 'string "'"
                                                 package-name "::"
                                                 (symbol-name instance)))))))))

(defun SIMPLE-QUOTED-LIST-DUMP-FORM (x)
  (let ((it (quoteit x)))
    `(QUOTE (,@it))))

 #|
  (defun SIMPLE-QUOTED-LIST-DUMP-FORM (x)
    "If the list contains no sublists, and the elements are admissible
      constants, use this dump form."
  `(QUOTE (,@x)))
  |#

(defun ALL-NUMBERS-LIST-DUMP-FORM (instance)
  `(LIST ,@instance))

(defun QUOTED-LIST-DUMP-FORM (instance)
  "If something is a quoted list (may contain sublists), 
  put the quote at the right place."
  `(QUOTE ,instance)
  )

(defun COMPILED-FUNCTION-DUMP-FORM (X)
  "dump form for hashmark-quote e.g. (FUNCTION name) forms."
  #+lispm (if (si:lexical-closure-p x) nil)
  `(function ,(get-compiled-function-name x)))

;;; *** beginning of MCL common lisp definitions...***

;;; NOTE: mst of the slot definition access functions remain undefined in
;;; MCL 2.0.1 --- see introspective-mop.txt for details! kvk

#+mcl
(eval-when (load eval compile)
  
  (defun CLASS-SLOTNAMES (class-object)
    "Calls the clos internal function to compute class slot names."
    (lisp:remove nil (mapcar #'first (class-slots class-object))))

  (defun CLASS-SLOTS (class)
    "MODIFIED: Given a class object, return all the slot objects."
                              ;#+quadra(ccl::class-instance-slots class)
                              ;#+fx (ccl::class-slots class)
                              ;#+mcl(class-direct-slots class)
    ;; modified by KJ
    #+mcl(ccl::class-instance-slots class)
    )

  ;; ---- new experimental routines for Mcl ------

  #-ccl-2
  (defun CLASS-DIRECT-SLOTS (class)
    "Given a class object return the slot objects."
    (ccl::class-direct-slots class))

  #+ccl-2
  (defun CLASS-DIRECT-SLOTS (class)
    "Given a class object return the slot objects."
    (ccl::class-direct-class-slots class))

  (defun INSTANCE-P (X)
    "Predicate to determine whether something is an INSTANCE."
    (and (not (%classp x))(typep x 'standard-object)))

  (defun GET-CLASS-DEFAULT-INITARGS (class)
    "Gets the default-initargs out of the class object."
    class
    nil)

  (defun %CLASSP (X)
    "predicate to tell if something is a class object."
    (typep x 'ccl::standard-class))

  (defun %GENERIC-FUNCTION-DOCUMENTATION (f)
    ""
    (or (documentation f) ""))

  (defun GET-SLOT-TYPE (S)
    ""
    #+mcl-3 
    (progn  
      (if (dotted-list-p s)(rest (%last s)) ;;; this line is new, kvk.
        nil))
    #-mcl-3
    (progn
      (if (dotted-list-p s)(rest (%last s)) ;;; this line is new, kvk.
        nil))
    )

  #+ignore
  (defun GET-SLOT-TYPE (S)
    ""
    (if (dotted-list-p s)(rest (%last s)) ;;; this line is new, kvk.
    (first (reverse s))))

  (defun GET-DIRECT-SLOTS (class-object)
    "Gets the immediately available 'new' non inheried slot OBJECTS."
    (class-direct-slots class-object))

  (defun GET-SLOT-DOCUMENTATION (s)
    ""
    (if (listp s) ""
    (or (documentation s) "")))

  (defun GET-SLOT-NAME (S)
    "Method to get the name from a standard slot."
    (clos::slot-definition-name s))

  (defun SLOT-HAS-AN-INITFORM-P (slot-object)
    "Predicate for ccl (where slots are represented as lists) to determine 
    whether a slot object has an initform component."
    (second slot-object))

  (defun GET-SLOT-READERS (s)
    ""
    s
    nil)

  (defun GET-SLOT-WRITERS (s)
    ""
    s
    nil)

  (defun %SLOT-DEFINITION-ALLOCATION (S)
    ""
    s
    NIL)

  (defun GET-SLOT-NAMED (instance name)
    ""
    (find-if #'(lambda (slot)
                 (equal (get-slot-name slot) name))
             (all-slots instance)))

  (defun GET-SLOT-ALLOCATION (S)
    "Method to get the type of allocation from a standard slot: oneof
    :CLASS or :INSTANCE."
    (let ((alloc (%slot-definition-allocation s)))
      (cond ((%classp alloc) :CLASS)
            ((member alloc '(:INSTANCE :CLASS)) alloc) 
            (T :INSTANCE))))

  (defun GET-SLOT-INITFORM (s)
    "For ccl:returns the initform of a slot object."
    (when (slot-has-an-initform-p s)
      (first (second s))))

  (defun GET-SLOT-INITARGS (s)
    ""
    (format t "s == ~a~%" s)
    (if (listp s)(list (second s))
    (ccl::class-slot-initargs s)))

  (defun GET-SLOT-INITARG (s)
    ""
    (format t "s <==> ~a~%" s)
    (if (listp s)(second s)
    (first (ccl::class-slot-initargs s))))

  (defmethod ALL-SLOTNAMES ((instance T) &optional (all-allocations T))
    "returns the names of the slots in instance, uses what MOP stuff is 
    available."
    (declare (ignore all-allocations))
    (lisp:REMOVE NIL (mapcar #'clos::slot-definition-name 
                        (class-slots (clos::class-of instance)))))

  ;; Hohmann patch...
  (setf (symbol-function 'classp) #'ccl::classp) ;; FIXED!!!!

  (defun ALL-SLOTS (instance)
    "Gets all the slots from the instances class, whether inherited or not."
    (class-slots (clos::class-of instance)))

  (defun GET-SUPERCLASS-NAMES (class)
    ""
    (mapcar #'clos::class-name (clos::class-direct-superclasses class)))

  ) ;; *END OF MCL CCL CLOS eval-when! ****


;;; A CLOS eval-when for Allegro PC:

#+clos
(eval-when (load eval compile)
  
  #-aclpc
  (defun %CLASS-NAME (x)
    "If instance, gets the name of the class of the instance."
    (if (instance-p x)(clos::class-name (clos::class-of x))
      (clos::class-name x)))

  #+aclpc
  (defun %CLASS-NAME (x)
    "If instance, gets the name of the class of the instance."
    (if (instance-p x)(class-name (class-of x))
      (class-name x)))

  #+aclpc
  (defun ACLPC-GET-DEFSTRUCT-CONSTRUCTOR (symbol)
    (read-from-string (concatenate 'string "MAKE-" (format nil "~A" symbol))))

  #+aclpc
  (defmethod ALLOCATE-INSTANCE ((class structure-class) &rest initargs)
    ""
    (apply (aclpc-get-defstruct-constructor (class-name class)) nil))

  ) ;; end of eval-when....

;;; HASH TABLES...

;;; PCL Dependent functions & methods,,,

#+pcl
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  
  (defvar *the-pcl-standard-class-name* 'pcl::standard-class)

  (defun BUILTIN-CLASS-P (X)
    ;;kr010602: wow! this seems idiotically inefficient for such a predicate that is used quite a bit.
    ;; (mapcar ) always conses up a new list !!
    ;;(member (type-of x) (mapcar #'first pcl::*built-in-classes*))
    ;;kr010602: do this instead:
    (find (type-of x) pcl::*built-in-classes* :key #'first)
    )

  (defun GET-SLOT-READERS (slot-object)
    #-new-pcl(pcl::slotd-readers slot-object)
    #+new-pcl(pcl::slot-definition-readers slot-object)
    )

  (defun GET-SLOT-WRITERS (slot-object)
    #-new-pcl(pcl::slotd-writers slot-object)
    #+new-pcl(pcl::slot-definition-writers slot-object)
    )

  (defun %GET-SLOT-ALLOCATION (s)
    #-new-pcl(pcl::slotd-allocation s)
    #+new-pcl(pcl::slot-definition-allocation s)
    )

  (defun GET-SLOT-ALLOCATION (S)
    "Method to get the type of allocation from a standard slot: oneof
    :CLASS or :INSTANCE."
    (let ((alloc (%get-slot-allocation s)))
      (cond ((%classp alloc) :CLASS)
            ((member alloc '(:INSTANCE :CLASS)) alloc) 
            (T :INSTANCE))))

  (defun GET-SLOT-NAME (S)
    "Method to get the name from a standard slot."
    #-new-pcl(pcl::slotd-name s)
    #+new-pcl(pcl::slot-definition-name s)
    )

  (defun %CLASS-NAME (class)
    ""
    (pcl::class-name class))

  (defmethod GET-SLOT-INITFORM (s)
    ""
    (when (slot-has-an-initform-p s)
      #-new-pcl(pcl::slotd-initform s)
      #+new-pcl(pcl::slot-definition-initform s)
      ))

  (defun SLOT-HAS-AN-INITFORM-P (s)
    ""
    (slot-boundp s 'pcl::initform))

  (defun GET-SLOT-INITARGS (s)
    ""
    #-new-pcl(pcl::slotd-initargs s)
    #+new-pcl(pcl::slot-definition-initargs s)
    )

  (defun GET-SLOT-INITARG (s)
    ""
    #-new-pcl(first (pcl::slotd-initargs s))
    #+new-pcl(first (pcl::slot-definition-initargs s))
    )

  #-akcl
  (defun CLASS-SLOTS (class-object)
    "Calls the clos internal function to compute class slot objects:
     used in CMUCL, too!"
    (pcl::slots-to-inspect (class-of class-object) class-object))

  (defun %ALLOCATE-INSTANCE (class-object &rest htab-plist)
    (cond
     ((equal class-object 'HASH-TABLE)
      (allocate-htab class-object 
                     :size (getf htab-plist :size 5000)
                     :rehash-size (getf htab-plist :rehash-size 67)
                     :rehash-threshold (getf htab-plist :rehash-threshold 0.67)
                     :test (getf htab-plist :test #'eql)))
     ((get-symbol-defstruct-spec class-object)
      (allocate-struct class-object))
     ((structure-p class-object)(allocate-struct class-object))
     ((symbolp class-object)
      ;;kr010601: use (pcl::find-class ) here, certainly for cmu18c
      (pcl::allocate-instance (pcl::find-class class-object nil)))
     ((%classp class-object)(pcl::allocate-instance class-object))
     ((instance-p class-object) class-object)
     (T (format T "Warning: couldnt allocate instance for object: ~A!" class-object) NIL)))

  ;; CLASSP is not exported from PCL, the next two are substitutes.

  (defun CLASSP (x)
    "Predicate, determines whether the object x is a class object."
    (pcl::classp x))

  (defun %CLASSP (x)
    "Predicate, determines whether the object x is a class object."
    (classp x))

  (defun INSTANCE-NAME (instance)
    "returns the symbol naming the given class object."
    (cond ((hash-table-p instance) 'hash-table)
          ((structure-p instance)(get-defstruct-name instance))
          ((instance-p instance)(pcl::class-name (pcl::class-of instance)))
          (T NIL)))

  (defun ALL-SLOTNAMES (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 
        (remove-if-not #'(lambda (slot)
                           (equal (%get-slot-allocation slot) :instance))
                       them))))

  (defun ALL-SLOTS (instance &optional (all-allocations T))
    "returns the names of the slots in instance."
    (let ((them (pcl::slots-to-inspect (pcl::class-of instance)
                                       instance)))
      (if all-allocations them 
        (remove-if-not #'(lambda (slot)
                           (equal (%get-slot-allocation slot) :instance))
                       them))))

  (defun %GENERIC-FUNCTION-P (X)
    ""
    (pcl::generic-function-p x))

  (defun GET-SLOT-DOCUMENTATION (slot)
    ""
    (or (documentation slot (type-of slot)) ""))

  (defun GET-SLOT-TYPE (slot)
    ""
    #-new-pcl(pcl::slotd-type slot)
    #+new-pcl(pcl::slot-definition-type slot)
    )

  (defun GET-SUPERCLASS-NAMES (class)
    ""
    (mapcar #'%class-name (pcl::class-direct-superclasses class)))

  (defun GET-CLASS-DEFAULT-INITARGS (class)
    ""
    (pcl::class-default-initargs class))

  (defun GET-CLASS-METACLASS (class-object)
    "Given a class object, returns the metaclass name to help build
 CLASS-DUMP-FORM:  (NEW)."
    (when (%classp class-object)
      (let ((meta (%class-name (class-of (class-of class-object)))))
        (if (not (equal meta *the-pcl-standard-class-name*)) ;; the default...
            (list (list :metaclass meta))))))

  #+cmu
  (eval-when (load eval compile)

    (defun INSTANCE-P (x)
      "Predicate for CMU Common Lisp: detects instances."
      ;; used to be std-instance.
      (and (not (%classp x))(typep x 'pcl::standard-object))) 

    ) ;; end of CMU CL eval-when for PCL.....

  (defun GET-DOCUMENTATION (object)
    ""
    (let ((answers nil))
      (dolist (current-type (get-available-types object)(nreverse answers))
        (push (documentation object current-type) answers))))

  )  ;; *** END PCL EVAL-WHEN.... ***

;;;kr010301: copied the above pcl block, and modified for SBCL
;;;
#+SBCL
(eval-when (:compile-toplevel :load-toplevel :execute)
  
  (defvar *the-pcl-standard-class-name* 'sb-pcl::standard-class)

  (defun BUILTIN-CLASS-P (X)
    ;;kr010602: less wasteful than what was here before:
    (find (type-of x) sb-pcl::*built-in-classes* :key #'first)
    )

  (defun GET-SLOT-READERS (slot-object)
    (sb-pcl::slot-definition-readers slot-object)
    )

  (defun GET-SLOT-WRITERS (slot-object)
    (sb-pcl::slot-definition-writers slot-object)
    )

  (defun %GET-SLOT-ALLOCATION (s)
    (sb-pcl::slot-definition-allocation s)
    )

  (defun GET-SLOT-ALLOCATION (S)
    "Method to get the type of allocation from a standard slot: oneof
    :CLASS or :INSTANCE."
    (let ((alloc (%get-slot-allocation s)))
      (cond ((%classp alloc) :CLASS)
            ((member alloc '(:INSTANCE :CLASS)) alloc) 
            (T :INSTANCE))))

  (defun GET-SLOT-NAME (S)
    "Method to get the name from a standard slot."
    (sb-pcl::slot-definition-name s)
    )

  (defun %CLASS-NAME (class)
    ""
    (sb-pcl::class-name class))

  (defmethod GET-SLOT-INITFORM (s)
    ""
    (when (slot-has-an-initform-p s)
      (sb-pcl::slot-definition-initform s)
      ))

  (defun SLOT-HAS-AN-INITFORM-P (s)
    ""
    (slot-boundp s 'sb-pcl::initform))

  (defun GET-SLOT-INITARGS (s)
    ""
    (sb-pcl::slot-definition-initargs s)
    )

  (defun GET-SLOT-INITARG (s)
    ""
    (first (sb-pcl::slot-definition-initargs s))
    )

  (defun CLASS-SLOTS (class-object)
    "Calls the clos internal function to compute class slot objects:
     used in CMUCL, too!"
    (sb-pcl::slots-to-inspect (class-of class-object) class-object))

  (defun %ALLOCATE-INSTANCE (class-object &rest htab-plist)
    (cond
     ((equal class-object 'HASH-TABLE)
      (allocate-htab class-object 
                     :size (getf htab-plist :size 5000)
                     :rehash-size (getf htab-plist :rehash-size 67)
                     :rehash-threshold (getf htab-plist :rehash-threshold 0.67)
                     :test (getf htab-plist :test #'eql)))
     ((get-symbol-defstruct-spec class-object)
      (allocate-struct class-object))
     ((structure-p class-object)(allocate-struct class-object))
     ((symbolp class-object)
      ;;kr010601: use (sb-pcl::find-class ) here, certainly for early sbcl-0.6.x
      (sb-pcl::allocate-instance (sb-pcl::find-class class-object nil)))
     ((%classp class-object)(sb-pcl::allocate-instance class-object))
     ((instance-p class-object) class-object)
     (T (format T "Warning: couldnt allocate instance for object: ~A!" class-object) NIL)))

  ;; CLASSP is not exported from SB-PCL, the next two are substitutes.

  (defun CLASSP (x)
    "Predicate, determines whether the object x is a class object."
    (sb-pcl::classp x))

  (defun %CLASSP (x)
    "Predicate, determines whether the object x is a class object."
    (classp x))

  (defun INSTANCE-NAME (instance)
    "returns the symbol naming the given class object."
    (cond ((hash-table-p instance) 'hash-table)
          ((structure-p instance)(get-defstruct-name instance))
          ((instance-p instance)(sb-pcl::class-name (sb-pcl::class-of instance)))
          (T NIL)))

  (defun ALL-SLOTNAMES (instance &optional (all-allocations T))
    "returns the names of the slots in instance."
    (let ((them (mapcar #'(lambda (slot)
                            (sb-pcl::slot-value slot 'sb-pcl::name))
                        (sb-pcl::slots-to-inspect (sb-pcl::class-of instance)
                                               instance))))
      (if all-allocations them 
        (remove-if-not #'(lambda (slot)
                           (equal (%get-slot-allocation slot) :instance))
                       them))))

  (defun ALL-SLOTS (instance &optional (all-allocations T))
    "returns the names of the slots in instance."
    (let ((them (sb-pcl::slots-to-inspect (sb-pcl::class-of instance)
                                       instance)))
      (if all-allocations them 
        (remove-if-not #'(lambda (slot)
                           (equal (%get-slot-allocation slot) :instance))
                       them))))

  (defun %GENERIC-FUNCTION-P (X)
    ""
    (sb-pcl::generic-function-p x))

  (defun GET-SLOT-DOCUMENTATION (slot)
    ""
    (or (documentation slot (type-of slot)) ""))

  (defun GET-SLOT-TYPE (slot)
    ""
    (sb-pcl::slot-definition-type slot)
    )

  (defun GET-SUPERCLASS-NAMES (class)
    ""
    (mapcar #'%class-name (sb-pcl::class-direct-superclasses class)))

  (defun GET-CLASS-DEFAULT-INITARGS (class)
    ""
    (sb-pcl::class-default-initargs class))

  (defun GET-CLASS-METACLASS (class-object)
    "Given a class object, returns the metaclass name to help build
 CLASS-DUMP-FORM:  (NEW)."
    (when (%classp class-object)
      (let ((meta (%class-name (class-of (class-of class-object)))))
        (if (not (equal meta *the-pcl-standard-class-name*)) ;; the default...
            (list (list :metaclass meta))))))

    (defun INSTANCE-P (x)
      "Predicate for CMU Common Lisp: detects instances."
      ;; used to be std-instance.
      (and (not (%classp x))(typep x 'sb-pcl::standard-object))) 

    ;;kr010120: added SBCL support
    ;; would this work too ?  :
    ;; (defun INSTANCE-P (X) (typep x 'standard-object))

  (defun GET-DOCUMENTATION (object)
    ""
    (let ((answers nil))
      (dolist (current-type (get-available-types object)(nreverse answers))
        (push (documentation object current-type) answers))))

  )  ;; *** END SBCL PCL EVAL-WHEN.... ***

(defun GET-COMPILED-FUNCTION-NAME (fn)
  "Given a function object <fn>, return the symbol name of the function."
  #+lispm
  (when (si:lexical-closure-p fn)
    (return-from get-compiled-function-name nil))
  (etypecase fn 
    (symbol fn)
    (compiled-function #+old-cmu(kernel:%function-header-name fn)
                       #+cmu(kernel:%function-name fn)
                       #+mcl(ccl::function-name fn)
                       #+lispm(si:compiled-function-name fn)
                       #+akcl(system::compiled-function-name fn)
                       #+lucid
                       (when (sys:procedurep fn)
                         (sys:procedure-ref fn SYS:PROCEDURE-SYMBOL))
                       #+excl (xref::object-to-function-name fn)
                       )))

;;;(let ((ans nil)
;;;      (strname ""))
;;;(setq *readtable* (copy-readtable))
;;;(set-dispatch-macro-character #\# #\' (function pseudo-quote-reader))
;;;(set-dispatch-macro-character #\# #\< (function pseudo-quote-reader))
;;;(setf strname (format nil "~S" fn))
;;;(setq ans (read-from-string (SUBSEQ strname 0 (length strname))))
;;;(setq *readtable* (copy-readtable nil))
;;;ans)
;;;)))

;;; Support functions for MAP-CLASS.

#+lucid
(defun ALL-SLOTS (class-object)
  ""
  (class-slots class-object))

(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  
  (defun GET-SLOT-COMPONENT (key slot-object)
    ""
    (let* ((keylist '((:all identity)
                      (:initform get-slot-initform)))
           (applyfun (second (assoc key keylist :test #'equal))))
      (when applyfun (funcall applyfun slot-object))))

  (defun MAP-CLASS (function class-object &key (component :all)
                                               (save T)
                                               (plist T))
    "Iterator for class objects. Applies a function to each (slot). "
    (let ((slots (all-slots class-object))
          (answer nil)
          (current nil))
      (dolist (slot slots answer)
        (if plist
            (setf current (list (make-keyword (get-slot-name slot))
                                (funcall function
                                         (get-slot-component component slot))))
          (setf current (funcall function
                                 (get-slot-component component slot))))
        (when (and save (not plist)) (push current answer))
        (when (and save plist)(setf answer (append answer current))))
      answer))

  (defun MAP-CLASS-DUMP-FORM (class-object &key (component :all))
    ""
    (get-dump-form
     (map-class #'get-dump-form class-object :plist t 
                :component component :save t)))
  ) ;; non clos/pcl eval-when end.

(defun SIMPLE-ARRAY-P (instance)
  ""
  ;; KOT fixed typo here.
  (and (arrayp instance)(not (pco-p instance))))

#+mcl
(defun MAC-HANDLE-DUMP-FORM (instance)
  "STUB."
  (declare (ignore instance))
  nil)

(defun BUILTIN-INSTANCE-P (instance)
  (and instance
       (not (eq instance T))
       (not (instance-p instance))
       ;;kr010602: from my reading of the code, (instance-p ) is only supposed to cover the CLOS instances,
       ;; and so we need to exclude structure instances as well (or this predicate will fire accidentally):
       (not (structure-p instance))
       (not (stringp instance))
       (not (hash-table-p instance))
       (not (pathnamep instance))
       (not (numberp instance))
       (not (keywordp instance))
       (not (arrayp instance))
       (not (consp instance))
       ;;kr010602: comment: the following fn call seems somewhat expensive.  no wonder it comes last.
       (builtin-class-p (type-of instance))))

(defun MAKE-BUILTIN-INSTANCE (instance)
  "STUB!"
  (declare (ignore instance))
  :INSTANCE)

(defun BUILTIN-INSTANCE-DUMP-FORM (instance)
  ""
  `(MAKE-BUILTIN-INSTANCE ',(instance-name instance)))

(defun INIT-LIST-HTABS (&optional (test #'equal))
  "Initialize or clear the hash tables associated with list caching."
  (if *cons-hash-table*
      (progn
        (clrhash *cons-hash-table*)
        (clrhash *dl-hash-table*)
        (clrhash *list-hash-table*))
    (progn
      (setf *cons-hash-table* (make-hash-table :test test))
      (setf *dl-hash-table* (make-hash-table :test test))
      (setf *list-hash-table* (make-hash-table :test test)))))

(defun LOOKUP-LIST (x)
  "Returns a (possibly cached) dump form for list <x>."
  (when (null x)(return-from lookup-list nil))
  (when (eq x T)(return-from lookup-list  T))
  (cond ((or (cons-p x)(circular-cons-p x))(gethash x *cons-hash-table*))
        ((or (dotted-list-p x)(circular-dotted-list-p x))
         (gethash x *dl-hash-table*))
        ((listp x)(gethash x *list-hash-table*))
        (T NIL)))

(defun INDEX-LIST (x)
  "When we index list forms, we cache them in one of three hash tables: conses, dotted lists,
 and ordinary lists."
  (cond ((cons-p x)
         (unless *cons-hash-table* (setf *cons-hash-table* (make-hash-table)))
         (unless (gethash x *cons-hash-table*)
           (setf (gethash x *cons-hash-table*)
                 (%get-dump-form x))))
	((dotted-list-p x)
         (unless *dl-hash-table* (setf *dl-hash-table* (make-hash-table)))
         (unless (gethash x *dl-hash-table*)
           (setf (gethash x *dl-hash-table*)
                 (%get-dump-form x))))
	((listp x)
         (unless *list-hash-table* (setf *list-hash-table* (make-hash-table)))
         (unless (gethash x *list-hash-table*)
           (setf (gethash x *list-hash-table*)
                 (%get-dump-form x))))
	(T NIL)))

(defun ANY-CONS-P (X)
  "Either a cons, dotted list, or list. Any may be circular."
  (and (not (null x))(not (eq x T))
       (or  (cons-p x)(listp x)(dotted-list-p x))))

(defun STANDARD-STREAM-DUMP-FORM (instance)
  "In interface code, *standard-output*, etc. get dumped a lot.
 This replaces them with their appropriate global variables."
  (cond ((eq instance :STANDARD-OUTPUT) '*STANDARD-OUTPUT*)
        ((eq instance :TERMINAL-IO) '*TERMINAL-IO*)
        ((eq instance :STANDARD-INPUT) '*STANDARD-INPUT*)
        ((eq instance :ERROR-OUTPUT) '*ERROR-OUTPUT*)
        (T (warn "Couldnt dump a supposed stream: ~a!" instance))))

(defun STANDARD-STREAM-P (instance)
  "Predicate: returns t if instance is oneof STANDARD-OUTPUT, 
 standard-input, terminal-io, or error-output."
  (if (not (streamp instance)) nil
    (cond ((eq instance *standard-output*) :STANDARD-OUTPUT)
          ((eq instance *terminal-io*) :TERMINAL-IO)
          ((eq instance *standard-input*) :STANDARD-INPUT)
          ((eq instance *error-output*) :ERROR-OUTPUT)
          (T NIL))))

(defun %GET-DUMP-FORM (instance)
  "New incarnation of get-dump-form: if the instance is a structured
   object, construct a representation for it anticipating that it might
   be a PCO. NOTE: in MCL Common Lisp, note that STREAMS are implemented as
   CLASSES! This makes it possible to SAVE-OBJECT things like *TERMINAL-IO*!"
  (cond ((null instance) nil)
        ((equal instance T) T)
        #+mcl ((ccl::handlep instance)(mac-handle-dump-form instance))
#+CIRCULAR-TESTS ((circular-cons-p instance)(circular-cons-dump-form instance))
#+CIRCULAR-TESTS ((circular-dotted-list-p instance)(circular-dotted-list-dump-form instance))
        ((numberp instance) instance)
        ((or (pathnamep instance)
             (stringp instance)
             (keywordp instance)
             (special-marker-p instance)
             (characterp instance)) instance)
        ((packagep instance)(package-dump-form instance))
        ((quoted-symbol-p instance)(quoted-symbol-dump-form instance))
        ((symbolp instance)(symbol-dump-form instance))
        ((vectorp instance)(vector-dump-form instance))
        ((cons-p instance)(cons-dump-form instance))
        ((BUILTIN-INSTANCE-P INSTANCE)
         (format t "found builtin : ~a~%" instance)
         (BUILTIN-INSTANCE-DUMP-FORM INSTANCE))
        ((standard-stream-p instance)(standard-stream-dump-form (standard-stream-p instance)))
        ((pco-p instance)(structured-object-dump-form instance))
        ((arrayp instance)(array-dump-form instance))

        ;; KOT put this in.  Might be wrong for many people, but for my
        ;; application dumping closures just caused me to have unreadable
        ;; forms, so I've basically stubbed out closures (as nil) above.
        ;; I'm unconvinced these can be written portably, do with this what
        ;; you want.
        ((closurep instance) (closure-dump-form instance))

        #-mcl ((functionp instance) (compiled-function-dump-form instance))
        #+mcl ((functionp instance)
               (if (ccl::function-name instance)
                   (compiled-function-dump-form instance)))

        ((stream-p instance)(stream-dump-form instance))
        ((readtablep instance)(readtable-dump-form instance))
 ((repeating-element-list-p instance)(repeating-element-list-dump-form instance))
 ((dotted-list-p instance)(dotted-list-dump-form instance))
 ((all-numbers-list-p instance)(all-numbers-list-dump-form instance))
 ((simple-lex-list-p instance)(simple-lex-dump-form instance))
        #-mcl((listp instance) 
	      `(LIST ,@(mapcar #'(lambda (thing)
                                               (get-dump-form thing)) 
                                           instance)))
        #+mcl((listp instance)(list-dump-form instance))
        (T (error "could not parse object ~a, of type ~a.~%"
                  instance (type-of instance)))))

(defun GET-DUMP-FORM (instance)
  "New incarnation of get-dump-form: if the instance is a structured
   object, construct a representation for it anticipating that it might
   be a PCO. NOTE: in MCL Common Lisp, note that STREAMS are implemented as
   CLASSES! This makes it possible to SAVE-OBJECT things like *TERMINAL-IO*!"
(when (any-cons-p instance)(index-list instance))
  (cond ((null instance) nil)
        ((equal instance T) T)
        #+mcl ((ccl::handlep instance)(mac-handle-dump-form instance))
#+CIRCULAR-TESTS ((circular-cons-p instance)
		  (or (lookup-list instance)
		      (circular-cons-dump-form instance)))
#+CIRCULAR-TESTS ((circular-dotted-list-p instance)
		  (or (lookup-list instance)
		      (circular-dotted-list-dump-form instance)))
((numberp instance) instance)
((or (pathnamep instance)
     (stringp instance)
     (keywordp instance)
     (special-marker-p instance)
     (characterp instance)) instance)
((packagep instance)(package-dump-form instance))
((quoted-symbol-p instance)(quoted-symbol-dump-form instance))
;;;        ((quoted-form-p instance)(quoted-form-dump-form instance))
((symbolp instance)(symbol-dump-form instance))
        ;; ((simple-array-p instance)(simple-array-dump-form instance))
((vectorp instance)(vector-dump-form instance))
((cons-p instance)(cons-dump-form instance))
((BUILTIN-INSTANCE-P INSTANCE)
 (format t "found builtin : ~a~%" instance)
 (BUILTIN-INSTANCE-DUMP-FORM INSTANCE))
((standard-stream-p instance)(standard-stream-dump-form (standard-stream-p instance)))
((has-predicate-dump-form-p instance)(get-predicate-dump-form instance))
((pco-p instance)(structured-object-dump-form instance))
((arrayp instance)(array-dump-form instance))

        ;; KOT put this in.  Might be wrong for many people, but for my
        ;; application dumping closures just caused me to have unreadable
        ;; forms, so I've basically stubbed out closures (as nil) above.
        ;; I'm unconvinced these can be written portably, do with this what
        ;; you want.
        ((closurep instance) (closure-dump-form instance))

        #-mcl ((functionp instance) (compiled-function-dump-form instance))
        #+mcl ((functionp instance)
               (if (ccl::function-name instance)
                   (compiled-function-dump-form instance)))

        ((stream-p instance)(stream-dump-form instance))
        ((readtablep instance)(readtable-dump-form instance))
        ((repeating-element-list-p instance)
	 (or (lookup-list instance)
         (repeating-element-list-dump-form instance)))
        ((dotted-list-p instance)
	 (or (lookup-list instance)(dotted-list-dump-form instance)))
        ((all-numbers-list-p instance)
	 (or (lookup-list instance)
	 (all-numbers-list-dump-form instance)))
        ((simple-lex-list-p instance)
	 (or (lookup-list instance)(simple-lex-dump-form instance)))
        #-mcl((listp instance) 
	      (or (lookup-list instance)
	      `(LIST ,@(mapcar #'(lambda (thing)
                                               (get-dump-form thing)) 
                                           instance))))
        #+mcl((listp instance)
	      (or (lookup-list instance)(list-dump-form instance)))
        (T (error "could not parse object ~a, of type ~a.~%"
                  instance (type-of instance)))))

(defun MAPAPPEND (fun &rest args)
  "From the MOP book!"
  (if (%some #'null args)
      ()
    (append (apply fun (mapcar #'car args))
            (apply #'mapappend fun (mapcar #'cdr args)))))

(defun QUOTEIT (l)
  (cond ((null l) nil)
        ((null (first l))
         (cons nil (quoteit (rest l))))
        ((equal (first l) T)
         (cons t (quoteit (rest l))))
        ((not (listp (first l)))
         (cons (get-dump-form (first l))(quoteit (rest l))))
        ((simple-quoted-list-p (first l))
         (cons (simple-quoted-list-dump-form (first l))
               (quoteit (rest l))))
        (T (cons (quoted-list-dump-form (first l))
                 (quoteit (rest l))))))

(defun SAMESET (l1 l2 &key (test #'equal))
  "predicate, returns t if the two sets contain the same elements."
  (and (subsetp l1 l2 :test test)(subsetp l2 l1 :test test)))

(defun MAPPLIST (fun x)
  "From the MOP book!"
  (if (null x) nil (cons (funcall fun (first x)(second x))
                         (mapplist fun (cddr x)))))

(defun %TYPE-OF (x)
  "Special type-of operator, returns more intelligent type for object caching:"
  (cond ((%classp x) 'class)
        ((instance-p x) 'instance)
        ((structure-p x) 'structure)
        ((hash-table-p x) 'hash-table)
        ((typep x 'vector) 'vector)
        ((array-type-t-p x) 'array-type-t)
        ((arrayp x) 'array)
        ((cons-p x) 'cons)
        ((listp x)(if (circular-list-p x) 'circular-list 'list))
        (T (type-of x))))

;;; NOTE: For the following two functions, NCONC should be used to
;;; construct the list ANSWER, not APPEND!
;;;kr010611: i am puzzled by this comment, because it is new in 10A, compared to 9X2.
;;; those functions always used (nconc ) , so what was the issue here ?
;;; but the two versions (%FLATTEN ) and (%FLATTEN1 ) are new, and they seem to use
;;; (append ) .  is this necessary ???

(defun FLATTEN (l)
  ""
(if (circular-list-p l)(flatten (get-circular-list-elements l))
  (let ((answers nil))
    (dolist (cell l answers)
      (setf answers (NCONC answers cell)))
    answers)))

(defun FLATTEN1 (cells)
""
(if (circular-list-p l)(flatten1 (get-circular-list-elements l))
  (let ((answer nil))
    (dolist (cell cells answer)
      (setf answer (NCONC answer cell)))
    answer)))

(defun %FLATTEN (l)
  ""
(if (circular-list-p l)(flatten (get-circular-list-elements l))
  (let ((answers nil))
    (dolist (cell l answers)
      (setf answers (APPEND answers cell))) ;;; was NCONC.
    answers)))

(defun %FLATTEN1 (cells)
""
(if (circular-list-p l)(flatten1 (get-circular-list-elements l))
  (let ((answer nil))
    (dolist (cell cells answer)
      (setf answer (APPEND answer cell))) ;;; was NCONC.
    answer)))

(defun PAIR-UP (l)
  ""
  (let ((answers nil))
    (loop (push (list (pop l)(pop l)) answers)
      (when (null l)
        ;;kr010607: used the non-consing (nreverse ) as answers is cons'd from scratch anyway
        (return (nreverse answers))))))

(defun GET-ORDERED-SLOT-VALUES (i)
  "Gets the dump forms out of the instance slot values, then alphabetizes them"
  (cond ((instance-p i)(alphabetize-by-keyword (get-slot-values i)))
        ((structure-p i)(%%get-defstruct-values i))
        (T (error "could not parse object ~a~%" i))))

(defmacro MAKE-KEYWORD (thing)
"Macro which makes a keyword out of a string or a non-string."
  (if (keywordp thing) thing
  (if (stringp thing)
    `(intern ,thing (find-package :keyword))
    `(intern (format nil "~A" ,thing) (find-package :keyword)))))

#+ignore
(defun MAKE-KEYWORD (x)
  "Makes a keyword out of a symbol."
  (if (keywordp x) x (intern (symbol-name x) 'keyword)))

(defun NEWSYM (symbol)
  "Similar to GENSYM, but allows access to the gensym counter unlike pre-ANSI 
   GENSYM."
  (if (null (get symbol 'namecounter))
      (setf (get symbol 'namecounter) 0))
  (read-from-string (concatenate 'string (string symbol)
                                 (format nil "~S" 
                                         (incf (get symbol 'namecounter))))))

(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 INSURE-LIST (X)
"If <x> is not a list, it makes (list <x>) and returns it."
  (if (listp x) x (list x)))

(defun NASSOC (key list &key (test #'equal))
  "Given a key and a list, return the thing AFTER that key in the list.
 Similar to GETF."
  (let ((where (position key list :test test)))
    (when where (nth (1+ where) list))))

(defun MAKEVAR (&optional (label '.%%SL%%.))
  "makes a new variable for something in the global object hashtable."
  (incf *global-object-count*)
  (newsym label))

(defun PUSHSYM (list &optional (label '.%%SL%%.))
  "label must match with special-marker-p, and must be upper-case."
  (push (newsym label) list))

(defun MAKESYMS (symbol min max &optional (pkg *package*))
  (let ((c min))
    (progn
      ;; KOT *nowarn* isn't defined in 4.2, not sure why ...
      #+(and excl (not :allegro-v4.2)) (setf excl::*nowarn* T)
      #+symbolics (setf compiler::*suppress-compiler-warnings* T)
      (dotimes (count max)
        (incf c)

        (eval `(defvar
                   ,(read-from-string (concatenate 'string
                                                   (format nil "~A" symbol)
                                                   (format nil "~A" c))
                                      pkg))))
      #+(and excl (not :allegro-v4.2)) (setf excl::*nowarn* NIL)
      #+symbolics (setf compiler::*suppress-compiler-warnings* NIL)
      )))

(defun %INSURE-LIST (X)
"If a list retrns it, if not a list, makes it one."
  (if (listp x) x
    (list nil x)))

;;; Functions for allocating and maniulating arrays.

(defmacro ALLOCATE-ARRAY (dims &key (element-type t)
                                    (adjustable nil)
                                    (initial-contents nil))
  "Function to allocate an array. No fill-pointer.
 suggested by kanderson@bbn.com."
  `(make-array ,dims :element-type ,element-type
               :initial-contents #-mcl ,initial-contents
                                 #+mcl ,initial-contents
               :adjustable ,adjustable))

(defmacro ALLOCATE-VECTOR (dims &key (element-type t)
                                     (adjustable nil)
                                     (fill-pointer nil))
  "Function to allocate an array. suggested by kanderson@bbn.com."
  `(make-array ,dims :element-type ,element-type
               :adjustable ,adjustable
               :fill-pointer ,fill-pointer))

(defun LIST-ARRAY (array)
  "Function for converting an n-dimensional array into the kind of list approp
   riate for the initial-elements keyword of a make-array function: dump-form-on-p
   means that the elements of the array are generated as dump forms, not just
   the explict LISP values within the array!"
  (list-array-aux array 0 nil :dump-form-on-p T))

(defun %LIST-ARRAY (array)
  "Function for converting an n-dimensional array into the kind of list approp
   riate for the initial-elements keyword of a make-array function. 
   DUMP-FORM-ON is NIL. The generated list contains the explicit values which
   were in the array, NOT the dump forms! This is used in VECTOR-DUMP-FORM and
   ARRAY-DUMP-FORM, among others."
  (list-array-aux array 0 nil :dump-form-on-p nil))

#-(or mcl akcl allegro aclpc)
(defun LIST-ARRAY-AUX (array level subscript-list &key (dump-form-on-p T))
  "Helper function for coercing an n-dimensional array into a 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
                       (if dump-form-on-p (get-dump-form array-val)
                           array-val))))
                (T (list-array-aux array new-level
                                   (append subscript-list (list i)))))
          ;; (append '(list) temp)
        into temp finally (return temp))))

#+(or akcl mcl allegro aclpc)
(defun LIST-ARRAY-AUX (array level subscript-list &key (dump-form-on-p nil))
  "Helper function for coercing an n-dimensional array into a list."
  (let ((new-level (1+ level))
        (dims (array-dimensions array))
        (answers nil))
    ;; was 1- nth level-dims before.
    (dotimes (i (nth level dims) answers)
      (setf answers (append 
                     answers
                     (list
                      (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
                                   (if dump-form-on-p (get-dump-form array-val)
                                       array-val))))
                            (T (list-array-aux array new-level
                                               (append subscript-list
                                                       (list i)))))))))
    answers))

(defun CLEAR-GLOBAL-VARS-AND-HTABS ()
  "Initializes the SAVE-OBJECT enviroment for recording graph cycles."
  (setf *classes-seen* nil *class-vars* nil)
  (setf *structs-seen* nil *struct-vars* nil)
  (setf *vectors-seen* nil *vector-vars* nil)
  (setf *arrays-seen* nil *array-vars* nil)
  (setf *htabs-seen* nil *htab-vars* nil)
  (setf *seen* nil *vars* nil)
  (clrhash *save-object-hash-table*))

;;; Functions for manipulating hash tables....

(defun %LOAD-HTAB  (htab &optional lst)
  ""
  (loop
    (when *debug-htab-load* (format t "setting slot ~a to ~a.~%"
                                    (first lst)(second lst)))
    (setf (gethash (pop lst) htab)(pop lst)) 
    (when (null lst)(return htab))))

;;; Map lucid/allegro htab incompatibility of rehash threshold
;;; parameter into mutually acceptable values. (i.e. fix bug)

#+lucid
(defun SCALE-REHASH-THRESHOLD (num)
  (if (> num 1)(float (/ num 100)) num))

#+allegro
(defun  SCALE-REHASH-THRESHOLD (num)
  (if (<= num 1)(* num 100) num))

#-(or allegro lucid)
(defun SCALE-REHASH-THRESHOLD (num)
  num)

(defun MAKEHASH (h &key (test #'eql)
                        (size 5000)
                        (rehash-size 67)
                        (rehash-threshold 0.65)
                        values)
  ""
  (let ((htab (or h 
                  (make-hash-table 
                   :test test
                   :size size
                   :rehash-size rehash-size
                   :rehash-threshold (scale-rehash-threshold rehash-threshold)
                   ))))
    (if (null values) htab
      (progn (%load-htab htab values) htab))))

(defun GET-HTAB-VALUES (htab)
  (let ((values nil))
    (maphash #'(lambda (key val)
                 (push (get-dump-form val) values)
                 (push (get-dump-form key) values))
             htab) values))

(defun PRINT-HTAB (htab)
  (maphash #'(lambda (key val)
               (format t "~%Key: ~a, value=~a.~%" key val))
           htab))

;;; Now, the Symbolics....

#+lispm
(eval-when  (load eval compile)

  (defun HASH-TABLE-SIZE (x)
    (scl:send x :size))

  (defun HASH-TABLE-TEST (x)
    (si:function-name (cli::test-function x)))

  )

(defun CREATE-HASH-TABLE (&key (test #'eql)
                               (size 67)
                               (rehash-size nil)
                               (rehash-threshold nil))
  (let ((args (delete ;;kr010611: to avoid cons'ing, use (delete ) here instead of (remove ). should be safe.
               ;;remove
               nil
               `(:size ,(get-dump-form size)
                       :test ,test
                       ,@(when rehash-size
                           (list :rehash-size
                                 (get-dump-form rehash-size)))
                       ,@(when rehash-threshold
                           (list :rehash-threshold
                                 (get-dump-form rehash-threshold)))))))
    (cache-object (apply #'make-hash-table args) :mode :load)))

(defun LOAD-HTAB (values &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))
        (key nil)(val nil))
    (dolist (cell values)
      (setf key (first cell))
      (setf val (eval (second cell)))
      (setf (gethash key htab) val))))

;;; Defstruct access functions.

(defun GET-DEFSTRUCT-TYPE (structname)
  ""
  (if (structure-p structname)(type-of structname)
    (let ((desc (get-defstruct-descriptor structname)))
      (funcall *vendor-defstruct-type-function* desc))))

;;; KOT wrapped eval-when around this -- in Allegro-V4 at least, allowed the
;;; succeeding (setf (symbol-function 'structurep)) to compile (???).
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  (defun STRUCTURE-P (X)
    "Predicate: returns T if x is a structure instance!"
    (funcall *vendor-defstruct-predicate-function* x)))

#-aclpc
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  (setf (symbol-function 'structurep) #'structure-p)
  ) ;; end of eval-when....

(defun GET-DEFSTRUCT-DESCRIPTOR (structname)
  ""
  (when (structure-p structname)
    (setf structname (get-defstruct-name structname)))
  (funcall *vendor-defstruct-descriptor-function* structname))

(defun GET-DEFSTRUCT-SLOT-DESCRIPTORS (structname)
  ""
  (when (structure-p structname)
    (setf structname (get-defstruct-name structname)))
  (funcall *vendor-defstruct-slot-descriptors-function* structname))

(defun GET-DEFSTRUCT-SLOT-DESCRIPTOR (structname slotname)
  ""
  (dolist (slot (get-defstruct-slot-descriptors structname))
    (when (equal slotname (get-defstruct-slot-name slot))
      (return slot))))

;;; KOT wrapped eval-when around this, in Allegro-V4 allows better compilation
(eval-when #+(or :SBCL :CMU18) (:compile-toplevel :load-toplevel :execute)
	   #-(or :SBCL :CMU18) (load eval compile)
  ;;kr010615: this fn is called quite a bit further below in this file.
  ;; generally, this all seems a bit cumbersome, as it is not immediately apparent
  ;; where those generated functions came from when debugging.
  (defun MAKE-DEFSTRUCT-ACCESS-FUNCTIONS ()
    "Automatically generates the functions we need to access the
     components of the defstruct object and its instances."
    (let* ((kwd-list '(:print-function :predicate :include
                       :constructor :copier :documentation :conc-name))
           (kwd-slot-list '(:name :type :read-status :default-value :position))
           (answers nil))
      (dolist (kwd kwd-slot-list)
;;; This next EVAL seems to have problems in MCL 2.0.1:
        (pushnew (EVAL `(defun
                            ,(read-from-string (concatenate 'string
                                                 "GET-DEFSTRUCT-SLOT-"
                                                 (symbol-name kwd)))
                            (slotd)
                          (defstruct-slot-descriptor-ref slotd ,kwd)))
                 answers))
      (dolist (kwd kwd-list)
        (pushnew (EVAL `(defun
                            ,(read-from-string (concatenate 'string
                                                 "GET-DEFSTRUCT-"
                                                 (symbol-name kwd)))
                            (struct)
                          (let ((desc (get-defstruct-descriptor struct)))
                            (when (null desc)
                              (format t "WARNING: desc was NULL!~%"))
                            (defstruct-descriptor-ref desc ,kwd))))
                 answers))
      ;;kr010615: from what i can tell, the above construction s ensure that the resulting
      ;; functions are only interpretated, which seems awfully slow, given this overall hack.
      ;; so, i am adding a compilation stage here, to at least make use of the otherwise pointless
      ;; collection of all these functions in the answers list.
      (map nil #'compile answers)
      answers
      )))

(defun GET-INDEX-FOR-DD-KWD (kwd)
  (funcall *vendor-data-table-access-function*
           (cdr (assoc kwd *vendor-defstruct-desc-index-table*
                       :test #'equal))))

(defun GET-INDEX-FOR-SD-KWD (kwd)
  (funcall *vendor-data-table-access-function*
           (cdr (assoc kwd *vendor-defstruct-slot-desc-index-table*
                       :test #'equal))))

(defun SD-USE-DEFAULT (sd kwd &optional structname)
  ""
  (let* ((sdname
          (symbol-name (defstruct-slot-descriptor-ref sd :name))))
    (cond ((equal kwd :accessor)
           (return-from sd-use-default
             (read-from-string              
              (concatenate 'string (symbol-name structname)
                           "-" sdname)))))))

(defun DD-USE-DEFAULT (dd kwd)
  ""
  (let* ((name (defstruct-descriptor-ref dd :name))
            (sname (symbol-name name))
            (kwds '((:copier "COPY-")
                    (:constructor "MAKE-")))
          (the-one (second (assoc kwd kwds :test #'equal))))
    (when the-one (return-from dd-use-default
                    (read-from-string (concatenate 'string the-one sname))))))

(defun DEFSTRUCT-DESCRIPTOR-REF (desc kwd)
  "Vendor independent function to extract defstruct info from a defstruct
 descriptor."
  (let ((i (get-index-for-dd-kwd kwd)))
    (cond ((null i)
           (funcall *vendor-defstruct-desc-access-function* desc))
          ((equal i T)(dd-use-default desc kwd))
          ((numberp i)(apply *vendor-defstruct-desc-access-function* 
                             (list desc i)))
          ((compiled-function-p i)(funcall i desc))
          ((symbolp i)(slot-value desc i))
          ((and (listp i)(equal (first i) 'function))
           (funcall (eval i) desc))
          (T (error "not a valid index type: ~s~%" i)))))

(defun DEFSTRUCT-SLOT-DESCRIPTOR-REF (sd kwd &optional structname)
  "Given a slot descriptor and a keyword, return the value for that
 keyword. If the kewyord value is T, that means we dont really know
 how to do it, and to use the default function for that keyword."
  (let ((i (get-index-for-sd-kwd kwd)))
    (cond ((null i)
           ;;kr010212: had to pass argument i as well.  did anybody ever try this before ???
           (funcall *vendor-defstruct-slot-desc-access-function* sd 0))
          ((equal i T)(sd-use-default sd kwd structname))
          ((numberp i)
           (funcall *vendor-defstruct-slot-desc-access-function* sd i))
          ((compiled-function-p i)(funcall i sd))
          ((symbolp i)(slot-value sd i))
          ((and (listp i)(equal (first i) 'function))
           (funcall (eval i) sd))
          (T (error "not a valid index type: ~s~%" i)))))

#+aclpc
(defun GET-DEFSTRUCT-SLOT-NAMES (struct)
  "Gets an unordered list of the structs slotnames."
  (let* ((desc (get-defstruct-slot-descriptors (get-defstruct-name struct))))
    (when desc (mapcar #'first desc))))

#-aclpc
(defun GET-DEFSTRUCT-SLOT-NAMES (struct)
  "Gets an unordered list of the structs slotnames."
  (let* ((slotds (get-defstruct-slot-descriptors (get-defstruct-name struct)))
         (names (mapcar #'(lambda (slotd)
                            (get-defstruct-slot-name slotd))
                        slotds)))
    names))

(defun FILL-STRUCT (struct vals)
  "Fills the structure instance struct with the values vals."
  (when (symbolp struct)(setf struct (allocate-struct struct)))
  (dolist (slotname (get-defstruct-slot-names struct) struct)
;;;;  (format t "Slot name:~s, Value: ~s~%" slotname (first vals))
    (set-defstruct-slot-value struct slotname (pop vals)))
  struct)

(defun ALLOCATE-STRUCT (name)
  "Function to allocate the empty husk of a defstruct."
  (apply (get-defstruct-constructor name) nil))

(defun FIND-STRUCTURE-OBJECT (name)
  "Now its just get-defstruct-descriptor, but it might get mor elaborate."
  (get-defstruct-descriptor name))

(defun GET-NAME-FROM-OPTION-LIST (option-list)
  ""
  ;; KOT put in declare, but what is the use of this??
  (declare (ignore option-list)) 
  )

(defun CONSTRUCT-DEFSTRUCT-OPTION-LIST (name)
  "Given a defstruct descriptor, make an option list for that descriptor."
  (cond ((structure-p name))
        ((symbolp name))
        (T NIL)))

(defun CONSTRUCT-DEFSTRUCT-SLOT-LIST (name)
  "Given a defstruct descriptor, make a slot list for that descriptor."
  (let* ((slist (get-defstruct-slot-descriptors name))
         (answers nil))
    (dolist (slot slist (nreverse answers))
      (let ((name (get-defstruct-slot-name slot))
            (value (get-defstruct-slot-default-value slot))
            (read-status (get-defstruct-slot-read-status slot))
            (type (get-defstruct-slot-type slot)))
        (push (make-canonical-defstruct-slot-form
               name value read-status type)
              answers)))))
  
(defun MAKE-CANONICAL-DEFSTRUCT-SLOT-FORM
    (name value read-status type)
  `( ,(get-dump-form name)
     ,(get-dump-form value)
     :type ,(get-dump-fo