(in-package "PCL")

Here are 2 bug fixes for March 92 PCL.

--------------------------------------------------------------------------------

There is a problem with discrimination on pcl::structure-object that
appears in every version of PCL newer than March 92 PCL.
In these versions of PCL, typep is sometimes used for discrimination
(when use-dispatch-dfun-p returns t).

The problem is that the class pcl::structure-object is supposed to
be a superclass of every class having metaclass structure-class, and
this requires a change to the way defstruct works.
I can think of three ways to fix this problem:

 (1) Change defstruct to :include the structure named structure-object whenever
     an :include option is not provided and the name is not structure-object
     and :type is not specified.  Move the definition of structure-object
     from pcl/defs.lisp the place that defstruct is defined.  Then change PCL
     to import the symbol structure-object from whatever package defined it.

 (2) Change typep and subtypep to simulate the effect of (1).

 (3) (The easy fix) Change the macro class-test (pcl/methods.lisp), 
     to be the following:

(defmacro class-test (arg class)
  (cond ((eq class *the-class-t*)
	 't)
	((eq class *the-class-slot-object*)
	 `(not (eq *the-class-built-in-class* 
		(wrapper-class (std-instance-wrapper (class-of ,arg))))))
	((eq class *the-class-standard-object*)
	 `(or (std-instance-p ,arg)
              (fsc-instance-p ,arg)
              (typep ,arg 'standard-object)))
	((or (and (structure-class-p class)
		  (not (eq class *the-class-structure-object*)))
             (eq (class-of class) *the-class-built-in-class*))
	 `(typep ,arg ',(class-name class)))
	(t
	 `(memq ',class (class-precedence-list (class-of ,arg))))))

#|
--------------------------------------------------------------------------------

There is a bug in all versions of PCL newer that March 92 PCL:

This bug affects generic functions which use dispatch dfuns, and arises
because of a bug in the proclaim-incompatible-superclasses form that
appears in methods.lisp (which in turn was "caused" by a bug in 
the definition of *built-in-classes*).

   The bug:
   >lisp
   CMU Common Lisp 16e, running on nova0.rdrc.rpi.edu
   Send bug reports and questions to your local CMU CL maintainer, or to
   cmucl-bugs@cs.cmu.edu.
   Loaded subsystems:
       Python 1.0, target SPARCstation/Sun 4
       CLOS based on PCL version:  March 92 PCL (2a)
   * (defmethod test ((x null)) nil)
   
   #<Standard-Method TEST (NULL) {700D63D}>
   * (defmethod test ((x list)) t)
   
   #<Standard-Method TEST (LIST) {70115F5}>
   * (test nil)
   Compiling LAMBDA (#:G4 #:G5): 
   Compiling Top-Level Form: 
   
   NIL
   * (test nil)
   
   T
   * (quit)
   >


The simplest patch:
(in-package :pcl)
(let ((seq (find-class 'sequence))
      (sym (find-class 'symbol)))
  (setf (class-incompatible-superclass-list seq)
	(delete sym (class-incompatible-superclass-list seq)))
  (setf (class-incompatible-superclass-list sym)
	(delete seq (class-incompatible-superclass-list sym))))


The patches to apply to the sources (if you so desire):
;in defs.lisp, in the definition of *built-in-classes*,
;change the line:
    (null       (symbol)   ()                       (symbol list sequence t)
;to:
    (null       (symbol 
		 list)     ()                       (symbol list sequence t)

;in methods.lisp, in the form that begins:
(mapc
 #'proclaim-incompatible-superclasses
;change the lines:
   (number sequence character symbol	; direct subclasses of t, but not array
    standard-object structure-object)
;to:
   (number sequence character   	; direct subclasses of t, but not array
    standard-object structure-object)   ;                         or symbol

;;; also, here is a fix for another bug (I think this bug causes no problems)
;in methods.lisp, in the definition of augment-type,
;change the line:
			    (unless (*subtypep type new-type)
;to:
			    (unless (*subtypep new-type type)


;------------------------
;if you want to look at what is happening in greater detail, use this:
(in-package :pcl)

(defvar gdn #'generate-discrimination-net)
(defun generate-discrimination-net (&rest args)
  (print (list* 'generate-discrimination-net args))
  (let ((net (apply gdn args)))
    (pprint net)(terpri)
    net))

--------------------------------------------------------------------------------
