To: Felipe Provencano <felipep@dcc.unicamp.br>, Manuel Kolp <kolp@qant.ucl.ac.be>
cc: cmucl-bugs@cs.cmu.edu
Subject: PCL, Re: Source distribution 
Fcc: out-copy
In-reply-to: Your message of Sat, 27 Apr 1996 14:49:06 -0300.
             <199604271749.OAA26981@grande> 
Reply-To: ram+@cs.cmu.edu
--------

PCL, which is in CMU CL, is not entirely the same as Clossete, which Gregor
wrote for AMOP.  

In addition, there are some problems with integration with CMU CL.  In
particular, there are two versions of some of the basic classes, for
example lisp:standard-class (a.k.a. just STANDARD-CLASS) and
PCL::STANDARD-CLASS.

PCL is integrated into CMU CL in a somewhat strange way.  The CMU CL system
code and PCL disagree on what a class is.  This is because classes are
fundamental to the CMU CL type system, yet CMU CL needs to be able to
function without PCL loaded:

 -- The loader needs to be able to function so that PCL *can* be loaded, and
 -- PCL is a big system, and we like the idea of being able to have a CMU CL
    without it.

The way that we have resolved this problem is by having PCL and the CMU CL
kernel maintain parallel class hierarchies.  LISP:CLASS and PCL:CLASS are
different types.  LISP:FIND-CLASS returns LISP:CLASS instances, whereas
PCL:FIND-CLASS returns PCL:CLASS instances.  For example:
    * (pcl:find-class 'cons)
    #<Built-In-Class CONS {28191605}>
    * (lisp:find-class 'cons)
    #<BUILT-IN-CLASS CONS (sealed) {2802FAB5}>

NOTE: these two classes are really the "same" class, in that they represent
the exact same type: CONS.  It's just that PCL has a different way of
representing that type.

In order to make this situation livable, PCL has been hacked up to accept
LISP:CLASS objects in the common places where people supply classes to PCL
operations.  You can also explicitly convert between the two kinds of classes,
either by using the class name and the appropriate find-class, or by:
    (kernel:class-pcl-class lisp-class)  ==> the PCL class
    (kernel:layout-class (pcl::class-wrapper pcl-class))  ==> the LISP class

Another problem area is with GFs that are called by PCL with classes as
arguments.  These classes will be PCL:CLASSes, so if you try to specialize on
e.g. ALLOCATE-INSTANCE using an EQL specializer, then make sure the class in
the specializer is a PCL:CLASS.

People who stick to using standard CLOS operations shouldn't ever notice all
this smoke and mirrors.  People using standard CLOS operations shouldn't have
their packages use the PCL package, since the Common-Lisp package exports a
consistent set of definitions for standard CLOS operations.

Though the above hacks usually work for simple stuff, they often seem to
break down when defining new metaclasses.  What you need to do is explictly
specify the PCL:: prefix on the class name.

There is an example of PCL metaclass definition in pcl/user-instances.lisp
in our source distribution.  I have also appended this file.  I can't swear
that this will actually work in CMU CL, but it should show how to define
new metaclasses in PCL v.s. CLOSette.  Since it seems to be actually inside
the PCL package, there probably won't be the package problem noted above.

  Rob

________________________________________________________________
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-

;;;
;;; *************************************************************************
;;;
;;;   File: user-instances.lisp.
;;;
;;;     by Trent E. Lange, Effective Date 06-02-92
;;;
;;;
;;;  This file contains a metaclass (User-Vector-Class) whose instances
;;; are stored as simple-vectors, saving space over PCL's standard instance
;;; representations of PCL at the cost of some class redefinition flexibiliity.
;;;
;;; Permission is granted to any individual or institution to use, copy,
;;; modify and distribute this document.
;;;
;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
;;; *************************************************************************
;;;

(in-package 'pcl)

;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple
;;; vectors.  The first element of the instance vector is the instance's
;;; class wrapper (providing internal PCL information about the instance's
;;; class).  The remaining elements of the instance vector are the instance's
;;; slots themselves.
;;;
;;;   The space overhead of user-vector-instances is only two vector cells
;;; (one for the vector, one for the wrapper).  This is contrast to standard
;;; PCL instances, which have a total overhead of four cells.  (Standard
;;; instances in PCL are represented as instances of structure STD-INSTANCE
;;; having two slots, one for the wrapper and one holding a simple-vector
;;; which is the instance's slots).  This two-cell space savings per instance
;;; comes at the cost of losing some class redefinition flexibility, since
;;; simple-vectors cannot have their sizes changed dynamically.
;;; All current instances of user-instance-vectors therefore become
;;; permanently obsolete if the classes' instance slots change.
;;;
;;;   This code requires July 92 PCL or later compiled with the
;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file).
;;;

#-pcl-user-instances
(eval-when (compile load eval)
(error "Cannot use user-instances, since PCL was compiled without
        PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)")
)

(eval-when (compile load eval)
(defclass user-vector-class-mixin () ()
  (:documentation
    "Use this mixin for metaclasses whose instances are USER-INSTANCES
     instantiated as simple-vectors.  This saves space over the standard
     instances used by standard-class, at the cost of losing the ability to
     redefine the slots in a class and still have old instances updated correctly."))

(defclass user-vector-class (user-vector-class-mixin standard-class) ()
  (:documentation
    "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors.
     This saves space over the standard instances used by standard-class, at the
     cost of losing the ability to redefine the slots in a class and still have old
     instances updated correctly."))

(defmethod validate-superclass ((class user-vector-class-mixin)
                                (new-super T))
  (or (typep new-super 'user-vector-class-mixin)
      (eq new-super (find-class 'standard-object))))

(defclass user-vector-object (standard-object) ()
  (:metaclass user-vector-class))
)

;;;
;;;
;;; Instance allocation stuff.
;;;

(defmacro user-vector-instance-p (object)
  (once-only (object)
    `(the boolean
          (and (simple-vector-p ,object)
               (plusp (length (the simple-vector ,object)))
               (wrapper-p (%svref ,object 0))))))

(defmacro user-vector-instance-wrapper (object)
  `(%svref ,object 0))

(defsetf user-vector-instance-wrapper (object) (new-value)
  `(setf (%svref ,object 0) ,new-value))

(defmacro user-vector-instance-slots (instance)
  ;; The slots vector of user-vector instances is the instance itself.
  instance)

(defmacro set-user-vector-instance-slots (instance new-value)
  `(progn
     (warn "Attempt to set user-vector-instance-slots of ~S to ~S"
           ,instance ,new-value)
     ,new-value))

(defun user-instance-p (x)
  "Is X a user instance, specifically a user-vector-instance?"
  (user-vector-instance-p x))

(defun user-instance-slots (x)
  "Return the slots of this user-vector-instance."
  (user-vector-instance-slots x))

(defun user-instance-wrapper (x)
  "Return the wrapper of this user-vector-instance."
  (user-vector-instance-wrapper x))

(defun set-user-instance-wrapper (x new)
  (setf (user-vector-instance-wrapper x) new))

(defmacro get-user-instance-p (x)
  `(user-vector-instance-p ,x))

(defmacro get-user-instance-wrapper (x)
  `(user-vector-instance-wrapper ,x))

(defmacro get-user-instance-slots (x)
  `(user-vector-instance-slots ,x))

(eval-when (eval #+cmu load)
  (force-compile 'user-instance-p)
  (force-compile 'user-instance-slots)
  (force-compile 'user-instance-wrapper)
  (force-compile 'set-user-instance-wrapper))


;;;
;;; Methods needed for user-vector-class-mixin.
;;;

(defconstant *not-a-slot* (gensym "NOT-A-SLOT"))

(defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs)
  (declare (ignore initargs))
  (unless (class-finalized-p class) (finalize-inheritance class))
  (let* ((class-wrapper (class-wrapper class))
         (copy-instance (wrapper-allocate-static-slot-storage-copy
                           class-wrapper))
         (instance      (copy-simple-vector copy-instance)))
    (declare (type simple-vector copy-instance instance))
    (setf (user-vector-instance-wrapper instance) class-wrapper)
    instance))

(defmethod make-instances-obsolete ((class user-vector-class-mixin))
  "The slots of user-vector-instances are stored in the instance vector
   themselves (a simple-vector), so old instances cannot be updated properly."
  (setf (slot-value class 'prototype) NIL)
  (warn "Obsoleting user-vector class ~A, all current instances will be invalid..."
        class))

(defmethod compute-layout :around ((class user-vector-class-mixin)
                                    cpl instance-eslotds)
  ;; First element of user-vector-instance is actually its wrapper.
  (declare (ignore cpl instance-eslotds))
  (cons *not-a-slot* (call-next-method)))

(defmethod compute-instance-layout :around ((class user-vector-class-mixin)
                                            instance-eslotds)
  ;; First element of user-vector-instance is actually its wrapper.
  (declare (ignore instance-eslotds))
  (cons *not-a-slot* (call-next-method)))

(defmethod wrapper-fetcher ((class user-vector-class-mixin))
  'user-vector-instance-wrapper)

(defmethod slots-fetcher ((class user-vector-class-mixin))
  'user-vector-instance-slots)

(defmethod raw-instance-allocator ((class user-vector-class-mixin))
  'allocate-user-vector-instance)


;;;
;;; The following functions and methods are not strictly necessary for
;;; user-vector-instances, but do speed things up a bit.
;;;

;;; Inform PCL that it is still safe to use its standard slot-value
;;; optimizations with user-vector-class-mixin's slot-value-using-class
;;; methods:

(pushnew
  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
   *safe-slot-value-using-class-specializers*)

(pushnew
  '(T user-vector-class-mixin standard-object standard-effective-slot-definition)
   *safe-set-slot-value-using-class-specializers*)

(pushnew
  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
  *safe-slot-boundp-using-class-specializers*)

(defmethod slot-value-using-class
  ((class user-vector-class-mixin)
   (object standard-object)
   (slotd standard-effective-slot-definition))
  (let* ((location (slot-definition-location slotd))
	 (value
           (typecase location
	      (fixnum
                (%svref (user-vector-instance-slots object) location))
	      (cons
	        (cdr location))
	      (t
	       (error
                 "The slot ~s has neither :instance nor :class allocation, ~@
                              so it can't be read by the default ~s method."
		  slotd 'slot-value-using-class)))))
    (if (eq value *slot-unbound*)
	(slot-unbound class object (slot-definition-name slotd))
	value)))

(defmethod (setf slot-value-using-class)
	   (new-value (class user-vector-class-mixin)
                      (object standard-object)
		      (slotd standard-effective-slot-definition))
  (let ((location (slot-definition-location slotd)))
    (typecase location
      (fixnum
        (setf (%svref (user-vector-instance-slots object) location) new-value))
      (cons
        (setf (cdr location) new-value))
      (t
       (error "The slot ~s has neither :instance nor :class allocation, ~@
                           so it can't be written by the default ~s method."
	      slotd '(setf slot-value-using-class))))))

(defmethod slot-boundp-using-class
  ((class user-vector-class-mixin)
   (object standard-object)
   (slotd standard-effective-slot-definition))
  (let* ((location (slot-definition-location slotd))
	 (value
           (typecase location
	     (fixnum
               (%svref (user-vector-instance-slots object) location))
	     (cons
	       (cdr location))
	     (t
	       (error
                 "The slot ~s has neither :instance nor :class allocation, ~@
                              so it can't be read by the default ~s method."
		 slotd 'slot-boundp-using-class)))))
    (not (eq value *slot-unbound*))))



(defmethod make-optimized-reader-method-function
           ((class user-vector-class-mixin)
            generic-function
            reader-method-prototype
            slot-name)
  (declare (ignore generic-function reader-method-prototype))
  (make-user-vector-instance-reader-method-function slot-name))

(defmethod make-optimized-writer-method-function
           ((class user-vector-class-mixin)
            generic-function
            reader-method-prototype
            slot-name)
  (declare (ignore generic-function reader-method-prototype))
  (make-user-vector-instance-writer-method-function slot-name))

(defmethod make-optimized-method-function
           ((class user-vector-class-mixin)
            generic-function
            boundp-method-prototype
            slot-name)
  (declare (ignore generic-function boundp-method-prototype))
  (make-user-vector-instance-boundp-method-function slot-name))

(defun make-user-vector-instance-reader-method-function (slot-name)
  (declare #.*optimize-speed*)
  #'(lambda (instance)
      (user-instance-slot-value instance slot-name)))

(defun make-user-vector-instance-writer-method-function (slot-name)
  (declare #.*optimize-speed*)
  #'(lambda (nv instance)
      (setf (user-instance-slot-value instance slot-name) nv)))

(defun make-user-vector-instance-boundp-method-function (slot-name)
  (declare #.*optimize-speed*)
  #'(lambda (instance)
      (user-instance-slot-boundp instance slot-name)))


(defun make-optimized-user-reader-method-function (slot-name index)
  (declare #.*optimize-speed*)
  (progn slot-name)
  #'(lambda (instance)
      (let ((value (%svref (user-vector-instance-slots instance) index)))
        (if (eq value *slot-unbound*)
            (slot-unbound (class-of instance) instance slot-name)
            value))))

(defun make-optimized-user-writer-method-function (index)
  (declare #.*optimize-speed*)
  #'(lambda (nv instance)
      (setf (%svref (user-vector-instance-slots instance) index) nv)))

(defun make-optimized-user-boundp-method-function (index)
  (declare #.*optimize-speed*)
  #'(lambda (instance)
      (not (eq (%svref (user-vector-instance-slots instance) index)
               *slot-unbound*))))



(defmacro with-user-instance-slots (slot-entries instance-form &body body)
  "Optimized version of With-Slots that assumes that the instance-form
   evaluates to a user-vector-instance.  The result is undefined if it does not.
   With-user-vector-instance-slots is faster than With-Slots because it factors
   out functions common to all slot accesses on the instance.  It has two
   extensions to With-Slots: (1) the second value of slot-entries are
   evaluated as forms rather than considered to be hard slot-names, allowing
   access of variable slot-names.  (2) if a :variable-instance keyword is
   the first part of the body, then the instance-form is treated as a variable
   form, which is always expected to return an instance of the same class.
   The value of the keyword must be an instance that is the same class as
   instance-form will always return."
  (build-with-optimized-slots-form slot-entries instance-form body 'user-instance))



;;;
;;;  Lisp and CLOS print compatability functions:
;;;
;;;  This gets really ugly because most lisps don't use PRINT-OBJECT
;;;  for the printed representation of their objects like they're supposed
;;;  to.  (And if the lisp did, it wouldn't be using PCL.).  And since
;;;  user-vector-instances are implemented as simple-vectors, the only
;;;  way to get their printed representations to look right is to make
;;;  PRINT-OBJECT object to work.
;;;    We therefore have to patch the standard lisp printing functions.
;;;  If all goes well, then everything is honky-dory.  If it doesn't, then
;;;  debugging can get pretty messy since we were screwing with the standard
;;;  printing functions.  Things should work, but if they don't, then calling
;;;  RESTORE-LISP-PRINTERS will get things back to normal.

(defvar *old-write* NIL)
(defvar *old-princ* NIL)
(defvar *old-prin1* NIL)
(defvar *old-print* NIL)

;; Structure dummy-print-instance is a structure whose sole purpose
;; in life is to act as a placeholder to allow the print-object of 
;; user-vector-class objects to be printed.

(defstruct (dummy-print-instance
              (:print-function print-dummy-print-instance))
  (print-object-string nil))

(declaim (type list *dummy-print-instance-garbage*))
(defvar      *dummy-print-instance-garbage* NIL)
(defconstant *dummy-print-instance-garbage-limit* 100)

(defmacro pure-array-p (x &optional (test-user-vector-instance-p T))
  "Returns whether item is a 'pure' array -- i.e. not a string, and
   not something holding a CLOS instance."
  (once-only (x)
    `(the boolean
          (locally (declare (inline arrayp stringp typep))
            (and (arrayp ,x)
                 (not (stringp ,x))
                 #-(or cmu (and lucid pcl))
                 (not (typep ,x 'structure))
                 ,@(when test-user-vector-instance-p
                     `((not (user-vector-instance-p ,x))))
                 #-(or cmu (and lucid pcl))
                 (not (typep ,x 'standard-object)))))))

(defun copy-any-array (old-array &rest keys-passed &key key dimensions)
  ;; Returns a copy of old-array.  If :key is provided, then the
  ;; elements of the new-array are the result of key applied to
  ;; old-array's elements.  If :dimensions is provided, and it is
  ;; different than old-array's dimensions, then the new-array is created
  ;; with those dimensions, and everything that can be copied from
  ;; old-array is copied into it.  It is an error if the rank of
  ;; the array specified by dimensionss is different than that of the
  ;; old-array.
  (declare (type array              old-array)
           (type (or function null) key)
           (type list               dimensions keys-passed))
  (cond
    ((simple-vector-p old-array)
     (apply #'copy-array-contents
            old-array
            (make-array (the index
                             (if dimensions
                                 (car dimensions)
                               (length (the simple-vector old-array)))))
            keys-passed))
    ((vectorp old-array)
     (apply #'copy-array-contents
            old-array
            (make-array (the index
                             (if dimensions
                                 (car dimensions)
                               (length (the vector old-array))))
                        :element-type (array-element-type old-array)
                        :adjustable   (adjustable-array-p old-array))
            keys-passed))
    ((arrayp old-array)
     (let* ((old-dimensions (array-dimensions   old-array))
            (new-dimensions (or dimensions old-dimensions))
            (element-type   (array-element-type old-array))
            (new-array
              (make-array new-dimensions
                          :element-type element-type
                          :adjustable   (adjustable-array-p old-array))))
       (declare (type list  old-dimensions new-dimensions)
                (type array new-array))
       (if (or (null dimensions) (equal new-dimensions old-dimensions))
           (let* ((displaced-old-array
                    (make-array (array-total-size old-array)
                      :element-type element-type
                      :displaced-to old-array))
                  (displaced-new-array
                    (make-array (array-total-size new-array)
                      :element-type element-type
                      :displaced-to new-array)))
             (declare (type array displaced-old-array displaced-new-array))
             (copy-array-contents displaced-old-array
                                  displaced-new-array
                                  :key key))
         (let ((first-dimension
                  (min (the index (car new-dimensions))
                       (the index (car old-dimensions)))))
            (declare (type index first-dimension))
            (walk-dimensions
              (mapcar #'min (cdr new-dimensions) (cdr old-dimensions))
              #'(lambda (post-indices)
                 (copy-array-contents old-array new-array
                                      :key key
                                      :length first-dimension
                                      :post-indices post-indices)))))
       new-array))))

(defun copy-array-contents
       (old-array new-array &key key length post-indices &allow-other-keys)
  ;; Copies the contents of old-array into new-array, using key if
  ;; supplied.  Only the first :length items are copied (defaulting
  ;; to the length of the old-array).  If :post-indices are passed, then
  ;; they are used as "post" indices to an aref.
  (macrolet
   ((do-copy (aref old new key key-type len post-indices)
     (let ((atype (if (eq aref #'svref) 'simple-vector 'array)))
       `(dotimes (i (the index ,len))
          (setf ,(if post-indices
                     `(apply #'aref (the ,atype ,new) i ,post-indices)
                    `(,aref (the ,atype ,new) i))
                ,(if key-type
                     `(funcall
                        (the ,key-type ,key)
                        ,(if post-indices
                             `(apply #'aref (the ,atype ,old)
                                     i ,post-indices)
                           `(,aref (the ,atype ,old) i)))
                   (if post-indices
                      `(apply #'aref (the ,atype ,old) i ,post-indices)
                    `(,aref (the ,atype ,old) i)))))))
     (expand-on-key (aref key old new len post-ind)
       `(cond
         ((null ,key)
          (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind))
         ((compiled-function-p ,key)
          (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind))
         (T
          (do-copy ,aref ,old ,new ,key function ,len ,post-ind)))))
    (if (simple-vector-p old-array)
        (progn
          (when post-indices
            (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS
                    from simple-vector"))
          
          (unless length
            (setf length (min (length (the simple-vector old-array))
                              (length (the simple-vector new-array)))))
          (expand-on-key svref key old-array new-array length NIL))
       (progn
         (unless length
           (setf length (min (the index (car (array-dimensions old-array)))
                             (the index (car (array-dimensions new-array))))))
         (if post-indices
             (expand-on-key #'aref key old-array new-array length post-indices)
             (expand-on-key aref key old-array new-array length NIL)))))
  new-array)

(declaim (ftype (function (list function) T) walk-dimensions))
(defun walk-dimensions (dimensions fn)
  (declare (type list     dimensions)
           (type function fn))
  ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks
  ;; through every possible combination from 0 to 1- each of those
  ;; dimensions, and calling fn on each of them.
  (let ((compiled-p (compiled-function-p fn)))
    (labels
      ((doit (dims apply-dims)
         (declare (type list dims apply-dims))
         (if (cdr dims)
             (let ((last-dim  NIL)
                   (dims-left NIL))
                (loop (when (null (cdr dims))
                        (setf last-dim (car dims))
                        (return))
                      (if dims-left
                          (nconc dims-left (list (car dims)))
                        (setf dims-left (list (car dims))))
                      (setf dims (cdr dims)))
                 (dotimes (i (the index last-dim))
                   (doit dims-left (cons i apply-dims))))
           (if compiled-p 
               (dotimes (i (the index (car dims)))
                 (funcall (the compiled-function fn) (cons i apply-dims)))
             (dotimes (i (the index (car dims)))
               (funcall fn (cons i apply-dims)))))))
      (doit dimensions NIL))))

(defmacro funcall-printer (applyer print-function object keys)
  `(progn
     (if (or (arrayp ,object) (consp ,object))
         (multiple-value-bind (converted-item garbage)
           (convert-user-vector-instances-to-dummy-print-instances ,object)
           (,applyer (the compiled-function ,print-function)
                     converted-item ,keys)
           (deallocate-dummy-print-instances garbage))
       (,applyer (the compiled-function ,print-function)
                ,object ,keys))
     ,object))

(defun print-dummy-print-instance (instance stream depth)
  (declare (ignore depth))
  (let ((*print-pretty* NIL))
    (funcall (the compiled-function *old-princ*)
             (dummy-print-instance-print-object-string instance)
             stream)))

(defun allocate-dummy-print-instance (print-object-string)
  (if *dummy-print-instance-garbage*
      (let ((instance (pop *dummy-print-instance-garbage*)))
        (setf (dummy-print-instance-print-object-string instance)
              print-object-string)
        instance)
    (make-dummy-print-instance :print-object-string print-object-string)))

(defun dummy-print-instance-of (user-vector-instance)
  (allocate-dummy-print-instance 
    (with-output-to-string (str)
      (print-object user-vector-instance str))))

(defun deallocate-dummy-print-instances (dummies)
  (let ((count (length *dummy-print-instance-garbage*)))
    (declare (type index count))
    (dolist (dummy dummies)
      (when (> count *dummy-print-instance-garbage-limit*)
        (return))
      (push dummy *dummy-print-instance-garbage*)
      (setf count (the index (1+ count))))))
   
(defun convert-user-vector-instances-to-dummy-print-instances (item)
  (let ((print-length
          (or *print-length* 1000))
        (print-level
          (or *print-level* 1000))
        (dummy-print-instances-used NIL))
    (declare (fixnum print-length print-level))
    (labels
      ((doit (item level length)
         (declare (fixnum level length))
         (labels
           ((user-vector-instance-visible-within-p (item level length)
              (declare (fixnum level length))
              (cond
                ((>= length print-length) NIL)
                ((> level print-level) NIL)
                ((= level print-level) (user-vector-instance-p item))
                (T (cond
                    ((user-vector-instance-p item) T)
                    ((consp item)
                     (or (user-vector-instance-visible-within-p
                           (car item) (the fixnum (1+ level)) 0)
                         (user-vector-instance-visible-within-p
                           (cdr item) level (the fixnum (1+ length)))))
                    ((and *print-array* (pure-array-p item))
                     (let ((next-level (the fixnum (1+ level))))
                       (declare (fixnum next-level))
                       (dotimes (i (1- (length (the array item))) NIL)
                         (unless (< i print-length)
                           (return NIL))
                         (if (user-vector-instance-visible-within-p
                               (aref item i) next-level 0)
                             (return T))))))))))
            ;; doit body
            (cond
              ((user-vector-instance-p item)
               (let ((dummy (dummy-print-instance-of item)))
                 (push dummy dummy-print-instances-used)
                 dummy))
              ((consp item)
               (if (user-vector-instance-visible-within-p item level length)
                   (cons (doit (car item) (the fixnum (1+ level)) length)
                         (doit (cdr item) level (the fixnum (1+ length))))
                 item))
              ((and *print-array* (pure-array-p item NIL))
               (if (user-vector-instance-visible-within-p item level length)
                   (copy-any-array
                     item
                     :key
                     #'(lambda (item)
                         (if (user-vector-instance-p item)
                             (let ((dummy (dummy-print-instance-of item)))
                               (push dummy dummy-print-instances-used)
                               dummy)
                           item))
                     :dimensions
                       (mapcar #'1+ (array-dimensions item)))
                    item))
              (T item)))))

      ;; convert-user-vector-instances-to-dummy-print-instances body

      (let ((converted (doit item 0 0)))
        (values converted dummy-print-instances-used)))))

(force-compile 'convert-user-vector-instances-to-dummy-print-instances)

(unless *old-write* (setf *old-write* (symbol-function 'write)))
(defun new-write (object &rest keys-passed)
  (declare (list keys-passed))
  (funcall-printer apply *old-write* object keys-passed))
(force-compile 'write)
(setf (symbol-function 'write) (symbol-function 'new-write))

(unless *old-princ* (setf *old-princ* (symbol-function 'princ)))
(defun princ (object &optional stream)
  (funcall-printer funcall *old-princ* object stream))
(force-compile 'princ)

(unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1)))
(defun prin1 (object &optional stream)
  (funcall-printer funcall *old-prin1* object stream))
(force-compile 'prin1)

(unless *old-print* (setf *old-print* (symbol-function 'print)))
(defun print (object &optional stream)
  (funcall-printer funcall *old-print* object stream))
(force-compile 'print)

(defun new-write-to-string (object &rest keys-passed)
  (declare (list keys-passed))
  (with-output-to-string (string-stream)
    (apply #'write object :stream string-stream keys-passed)))
(force-compile 'write-to-string)
(setf (symbol-function 'write-to-string)
      (symbol-function 'new-write-to-string))

(defun princ-to-string (object)
  (with-output-to-string (string-stream)
    (funcall-printer funcall *old-princ* object string-stream)
    string-stream))
(force-compile 'princ-to-string)

(defun prin1-to-string (object)
  (with-output-to-string (string-stream)
    (funcall-printer funcall *old-prin1* object string-stream)
    string-stream))
(force-compile 'prin1-to-string)
 
(defun restore-lisp-printers ()
  (setf (symbol-function 'write) *old-write*)
  (setf (symbol-function 'princ) *old-princ*)
  (setf (symbol-function 'prin1) *old-prin1*)
  (setf (symbol-function 'print) *old-print*))