bugs in early-dfun

[harrisr@turing.cs.rpi.edu (Richard Harris)]

In order to get "5/5/89  Cinco de Mayo PCL" to compile, I needed
to fix two bugs in early-dfun (boot.lisp):

 1) The sort predicate expects two lists of classes, not lists of class names.

    - Before I fixed problem 1, PCL died in check-super-metaclass-compatibility,
      (while defining the class standard-generic-function, while evaluating
      *methods-defclass-forms* in methods.lisp), because early-dfun picked
      the wrong primary method for check-super-metaclass-compatibility.

    - After fixing problem 1, PCL died with in slot-boundp-using-class, (while 
      checking a slot of the generic function all-std-class-readers-miss-1,
      while running fix-early-generic-functions in fixup.lisp), because
      early-dfun picked the wrong primary method for slot-boundp-using-class.

 2) The sort predicate returned the opposite of the correct answer when
    neither class was *the-class-t*.

Rick Harris


(defun early-dfun (methods args)
  (let ((primary ())
	(before ())
	(after ()))
    (flet ((get-cpl (object)
	     (if (symbolp object)
		 (list *the-class-symbol* *the-class-t*)
		 (bootstrap-get-slot
		   'class (class-of object) 'class-precedence-list)))
	   (early-method-specializers1 (method)
	     (early-method-specializers method t)))
      (dolist (method methods)
	(let* ((specializers (early-method-specializers1 method))
	       (qualifiers (early-method-qualifiers method))
	       (args args)
	       (specs specializers))
	  (when (loop
		  (when (or (null args)
			    (null specs))
		    ;; If we are out of specs, then we must be in the optional,
		    ;; rest or keywords arguments.  This method is applicable
		    ;; to these arguments.  Return T.
		    (return t))
		  (let ((arg (pop args))
			(spec (pop specs)))
		    (unless (or (eq spec *the-class-t*)
				(memq spec (get-cpl arg)))
		      (return nil))))
	    (cond ((null qualifiers) (push method primary))
		  ((equal qualifiers  '(:before)) (push method before))
		  ((equal qualifiers  '(:after))  (push method after))
		  (t
		   (error "Unrecognized qualifer in early method."))))))
      (flet ((sort-methods (list)
	       (if (null (cdr list))
		   list
		   (sort list
			 #'(lambda (specls-1 specls-2)
			     (iterate ((s1 (list-elements specls-1))
				       (s2 (list-elements specls-2))
				       (a (list-elements args)))
			       (cond ((eq s1 s2))
				     ((eq s2 *the-class-t*) (return t))
				     ((eq s1 *the-class-t*) (return nil))
				     (t (return (memq s2 (memq s1 (get-cpl a))))))))
			 :key #'early-method-specializers1))))
	(dolist (m (sort-methods before)) (apply (cadr m) args))
	(multiple-value-prog1
	  (apply (cadar (sort-methods primary)) args)
	  (dolist (m (sort-methods after)) (apply (cadr m) args)))))))