Lucid compiler barfs

[Michael Sokolov <sokolov@a-boy.media.mit.edu>]

	For some strange reason, the Lucid compiler goes into an
infinite loop when trying to compile the function "describe-instance"
in high.lisp of 8/28/88 AAAI PCL.  While tail merging, It complains
about the argument list to describe-slot:

> ;;; Compiling function DESCRIBE-INSTANCE...tail merging...
;;; Warning: Malformed optional argument (ALLOCATION (QUOTE NIL)
ALLOC-P ALLOC-P ALLOC-P ALLOC-P ALLOC-P ... (etc)

This seems like a compiler bug to me, but this seems to patch over the
rough spots:

(The key here is to make alloc-p an explicit keyword argument and
bypass whatever weirdness is happening as a result of the supplied-p
parameter. I don't claim to understand it.)

____________________________________________________________________
(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 &key 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)
	(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 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 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 object (slotd-name slotd))
			 (slotd-allocation slotd)
			 :alloc-p t)))
      (values))))