Corrected VAX Fix

[Jacky Combs <combs@STC.LOCKHEED.COM>]

Here is the file I meant to send concerning the PCL VAX Common Lisp fix.  Sorry
about the mixup in last week's message.


;;; Modified EXPAND-DCODE-CACHE function for VAX Common Lisp.  Should replace
;;; the function by the same name in the dcode.lisp file prior to compiling PCL
;;; on the VAX.

(defun expand-dcode-cache (generic-function
			   old-cache
			   old-size
			   line-size
			   nkeys
			   next-scan-limit
			   dcode-constructor)
  (let* ((new-size (* old-size 2))
	 (new-number-of-lines (floor new-size line-size))
	 (new-mask (make-wrapper-cache-mask new-number-of-lines))
	 (new-cache (get-generic-function-cache new-size))
	 (new-dcode nil)
	 (wrappers ())
	 (value nil))
    (flet ((collect-wrappers (loc)
            (block collect-wrappers  ; need to explicitly create a 
                                     ; collect-wrappers block for 
                                     ; VAX Common Lisp in order to do a
                                     ; return-from collect-wrappers in the 
                                     ; following if statement
	     (when (%svref old-cache loc)
	       (setq wrappers ())
	       (dotimes (i nkeys)
		 (let ((wrapper (%svref old-cache (+ i loc))))
		   (if (zerop (wrapper-cache-no wrapper))
		       ;; This wrapper is obsolete, we don't have an instance
		       ;; so there is no related trap.  Just drop this line
		       ;; on the floor.
		       (return-from collect-wrappers nil) ; here is the return that
                                                  ; was causing a problem in
                                                  ; VAX CL
		       (push wrapper wrappers))))
	       (setq wrappers (nreverse wrappers)
		     value (and (< nkeys line-size)
				(%svref old-cache (+ loc nkeys))))
	       t))))
      (flush-generic-function-caches-internal new-cache)
      
      (do ((old-location line-size (+ old-location line-size)))
	  ((= old-location old-size))
	(when (collect-wrappers old-location)
	  (apply #'dcode-cache-miss generic-function
				    #'(lambda (&rest ignore)
					(declare (ignore ignore))
					value)
				    new-cache
				    new-size
				    new-mask
				    line-size
				    nkeys
				    next-scan-limit
				    nil		;Means don't allow another
						;expand while filling the
						;new cache.  This can only
						;happen in one pathological
						;case, but prevent it anyways.
				    dcode-constructor
				    wrappers)))
    
      (setq new-dcode (funcall dcode-constructor generic-function new-cache))
      (setf (generic-function-cache generic-function) new-cache)
      (install-discriminating-function generic-function new-dcode)
      (free-generic-function-cache old-cache)
      new-cache)))


;;; The following is to correct the problem printing generic function 
;;; stuff when you are using VAX Common Lisp and should be loaded after the
;;; "regular" PCL files are loaded.

(setq *print-pretty* t)
(setq *print-level* 2)
(setq *print-length* 5)
(setq *debug-print-level* 2)
(setq *debug-print-length* 5)

(define-list-print-function system::%compiled-closure%
     (alist stream)
   (if (generic-function-p alist)
       (write (generic-function-name alist) :stream stream)
       (write alist :stream stream)))

;; For VAX Common Lisp we have to define a different DESCRIBE-INSTANCE function
;; in order to printout the description of a generic function without
;; getting into an infinite loop.

(defun describe-instance (object &optional (stream t))
  (let* ((class (class-of object))
	 (slotds (slots-to-inspect class object))
	 (max-slot-name-length 0)
	 (instance-slotds ())
	 (class-slotds ())
	 (other-slotds ()))
    (flet ((adjust-slot-name-length (name)
	     (setq max-slot-name-length
		   (max max-slot-name-length
			(length (the string (symbol-name name))))))
	   (describe-slot (name value &optional (allocation () alloc-p))
	     (if alloc-p
		 (format stream
			 "~% ~A ~S ~VT  ~S"
			 name allocation (+ max-slot-name-length 7) value)
		 (format stream
			 "~% ~A~VT  ~S"
			 name max-slot-name-length value))))
      ;; Figure out a good width for the slot-name column.
      (dolist (slotd slotds)
      ;; VAX Comon Lisp fix - don't print out DISCRIMINATOR-CODE slot,
      ;; it is a circular list
        (if (equalp (slotd-name slotd) 'discriminator-code)
            ()
            (progn 
              (adjust-slot-name-length (slotd-name slotd))
              (case (slotd-allocation slotd)
                (:instance (push slotd instance-slotds))
                (:class  (push slotd class-slotds))
                (otherwise (push slotd other-slotds))))))
      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
      (format stream "~%~S is an instance of class ~S:" object class)
      (when instance-slotds
	(format stream "~% The following slots have :INSTANCE allocation:")
	(dolist (slotd (nreverse instance-slotds))
	  (describe-slot (slotd-name slotd)
			 (slot-value-or-default object (slotd-name slotd)))))
      (when class-slotds
	(format stream "~% The following slots have :CLASS allocation:")
	(dolist (slotd (nreverse class-slotds))
	  (describe-slot (slotd-name slotd)
			 (slot-value-or-default object (slotd-name slotd)))))
      (when other-slotds 
	(format stream "~% The following slots have allocation as shown:")
	(dolist (slotd (nreverse other-slotds))
	  (describe-slot (slotd-name slotd)
			 (slot-value-or-default object (slotd-name slotd))
			 (slotd-allocation slotd))))
      (values))))