Re: Problems with eql method specifiers

[Gregor.pa@Xerox.COM]

    Date: Thu, 27 Apr 89 19:54:44 MDT
    From: Andreas Girgensohn <andreasg@boulder.Colorado.EDU>

    I'm using the PCL version from 4/20/89 with Genera 7.2.  I have a few
    problems with eql specifiers in methods.  Here is an example:

This patch should fix this problem with eql methods.  It hasn't been
thoroughly tested yet (ha!) but I thought I would send it out right
away anyways.  This will be included as part of a release I hope to get
out Friday.

It should work to simply edit points.lisp to have this patch and then
compile and load that file into a running PCL.  Note that existing
generic functions won't be `fixed' unless you first redefine some method
on them (easy to do by reloading your code).

;from points.lisp

(defun adjust-points-for-eql-methods (points eql-methods eql-classes)
  (labels ((eql-method-p (method)
	     (memq method eql-methods))
	   (eql-class-p (class)
	     (rassoc class eql-classes))
	   (has-eql-method-p (methods)
	     (dolist (m methods)
	       (when (eql-method-p m) (return 't)))))
    (let ((adjusted ())
	  (pending ())
	  (super-eqls ()))
      ;;
      ;; Pass 1:
      ;;
      ;; In this pass, all points which have no eql methods are separated
      ;; from those that do.  Points without eql methods go on the list
      ;; adjusted, points with eql methods go on the list pending.
      ;;
      (dolist (point points)
	(destructuring-bind (nil methods) point
	  (if (has-eql-method-p methods)
	      (push point pending)
	      (push point adjusted))))
      ;;
      ;; Pass 2:
      ;;
      ;;
      ;;
      (flet ((get-super-point (point)
	       (destructuring-bind (classes methods) point
		 (let ((super-classes
			 (gathering1 (collecting)
			   (dolist (c classes)
			     (gather1 (if (eql-class-p c)
					  (cadr (class-precedence-list c))
					  c))))))
		   (or (assoc super-classes super-eqls :test #'equal)
		       (let ((adjusted-hit
			       (assoc super-classes adjusted :test #'equal)))
			 (when adjusted-hit
			   (push adjusted-hit super-eqls)
			   adjusted-hit))
		       (let ((new (list super-classes
					(remove-if #'eql-method-p methods))))
			 (push new adjusted)
			 (push new super-eqls)
			 new))))))
	(dolist (point pending)
	  (destructuring-bind (classes methods) point
	    (let ((super (get-super-point point)))
	      (push (cons (gathering1 (collecting)
			    (dolist (c classes)
			      (let ((hit (rassq c eql-classes)))
				(gather1
				  (if hit
				      (car hit)
				      '..not-an-eql-specializer-object..)))))
			  methods)
		    (cddr super))))))
      adjusted)))
-------