Misc. PCL patches

[LaMott Oren <Oren@Home.csc.ti.com>]

I don't read this mailing list (yet), so forgive me if any of these have
been discussed before.

I'm working with *pcl-system-date* "7/7/88 (beta) July 7th PCL"
and made the following patches:

;;; Reason: Common-lisp allows macros to define declarations.
;;;         Patch PCL to allow this also.

; From the MACROS file
(defun extract-declarations (body &optional environment)
  (declare (values documentation declarations body))
  (let (documentation declarations form)
    (when (and (stringp (car body))
	       (cdr body))
      (setq documentation (pop body)))
    (loop
      (when (null body) (return))
      (setq form (car body))
      (cond ((and (listp form) (eq (car (SETQ form (macroexpand form environment)))
				   'declare))
	     (pop body)
	     (dolist (declaration (cdr form))
	       (push declaration declarations)))
	    (t (return))))
    (values documentation
	    (and declarations `((declare ,.declarations)))
	    body)))


;;; Reason: Explorer DEFSTRUCT has a bug where an inefficient predicate
;;;         gets generated the first time its compiled.  Redefine
;;;         IWMC-CLASS-P with an efficient definition. (This makes some
;;;	    PCL applications run TWICE as fast)

;; In the TI-LOW  file
(proclaim '(inline IWMC-CLASS-P))
(defun IWMC-CLASS-P (thing) (typep thing 'iwmc-class))


;;; Reason: slotd-name is used a LOT, and is only 2 instructions long (2 aref's)
;;; Unfortunately, slotd-name isn't defined until after its used, so
;;; this won't help unless PCL is compiled twice... (at least the SLOTS file)

(proclaim '(inline slotd-name))


;;; Reason: Optimize initialize-instance for the common case
;;;         where there are less than two slot-initargs.

;;; This is not as effective as it could be, because slot-initargs
;;; sometimes contains a list with duplicate entries, for example:
;;; 
;;; (defclass foo1 ()
;;;   ((slot :initform nil :initarg :slot)))
;;; 
;;; (defclass foo2 (foo1)
;;;   ((slot :initform nil :initarg :slot)))
;;;
;;; The slotd for slot in foo2 will be (:slot :slot)
;;; (Somebody please fix this, I don't know where to look...)

;; from the MKI file:
(defmethod initialize-instance ((object object) &rest initargs)
  (let* ((class (class-of object))
	 (slotds (class-slots class)))
    (dolist (slotd slotds)
      (let ((slot-name (slotd-name slotd))
	    (slot-initargs (slotd-initargs slotd)))

	;; Initialize slot from initargs
	(when slot-initargs
	  (if (cdr slot-initargs)
	      ;; more than one initarg
	      (labels ((walk-backwards (tail)
			 (if (null tail)
			     nil
			   (progn
			     (walk-backwards (cddr tail))
			     (let ((key (pop tail))
				   (val (pop tail)))
			       (when (memq key slot-initargs)
				 (setf (slot-value object slot-name) val)))))))
		(walk-backwards initargs))

	    ;; Optimize for the common-case of only one initarg
	    (let* ((not-found '#.(gensym))
		   (val (getf initargs (car slot-initargs) not-found)))
	      (unless (eq val not-found)
		(setf (slot-value object slot-name) val)))))
	
	;; If no initarg found, try the initfunction.
	(unless (slot-boundp object slot-name)
	  (let ((initfunction (slotd-initfunction slotd)))
	    (when initfunction 
	      (setf (slot-value object slot-name)
		    (funcall initfunction )))))))))