;the following is a _preliminary_ _hack_  ...
;which means it will probably look like this in 10 yrs time too
(eval-when (load)

(setf (symbol-function 'specialized-coerce) (symbol-function 'coerce))

(pcl::make-specializable 'specialized-coerce :arglist '(obj typ))

(defmethod specialized-coerce ((obj t) (type symbol))
  (call-next-method))

(setf (symbol-function 'coerce) (symbol-function 'specialized-coerce))

(defmethod coerce ((obj t) (type symbol))
  (call-next-method))
  
(defmethod coerce ((obj t) (type built-in-class))
  (if (eq (class-of obj)
	  type)
      obj
      (error 'type-error :datum obj
	     :expected-type (type-of obj))))

(defmethod coerce ((obj t) (type standard-class))
  (if (eq (class-of obj)
	  type)
      obj
      (error 'type-error :datum obj
	     :expected-type (type-of obj))))
  
(fmakunbound 'specialized-coerce)
(unintern 'specialized-coerce)

(setf (symbol-function 'specialized-typep) (symbol-function 'typep))

(pcl::make-specializable 'specialized-typep :arglist '(obj type &optional (env nil) &aux tp i tem))

(setf (symbol-function 'typep) (symbol-function 'specialized-typep))

(defmethod typep ((obj t) (type built-in-class) &optional (env nil) &aux tp i tem)
  (when (eq (class-of obj)
	    type)
    obj))

(defmethod typep ((obj t) (type standard-class) &optional (env nil) &aux tp i tem)
  (when (eq (class-of obj)
	    type)
    obj))

(defmethod typep ((obj t) (type structure-class) &optional (env nil))
  (when (eq (class-of obj)
	    type)
    obj))

(fmakunbound 'specialized-typep)
(unintern 'specialized-typep)

(setf (symbol-function 'specialized-subtypep) (symbol-function 'subtypep))

(pcl::make-specializable 'specialized-subtypep :arglist '(type1 type2 &optional (env nil)))

(setf (symbol-function 'subtypep) (symbol-function 'specialized-subtypep))

(defmethod subtypep ((type-1 built-in-class) (type-2 built-in-class) &optional (env nil))
  (values (member type-2 (pcl::class-precedence-list type-1)) t))

(defmethod subtypep ((type-1 standard-class) (type-2 standard-class) &optional (env nil))
  (values (member type-2 (pcl::class-precedence-list type-1)) t))

(defmethod subtypep ((type-1 standard-class) (type-2 built-in-class) &optional (env nil))
  (values (member type-2 (pcl::class-precedence-list type-1)) t))

(defmethod subtypep ((type-1 symbol) (type-2 built-in-class) &optional (env nil))
  (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(defmethod subtypep ((type-1 symbol) (type-2 standard-class) &optional (env nil))
  (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(defmethod subtypep ((type-1 symbol) (type-2 structure-class) &optional (env nil))
  (if (member type-1 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(defmethod subtypep ((type-1 structure-class) (type-2 symbol) &optional (env nil))
  (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(defmethod subtypep ((type-1 standard-class) (type-2 symbol) &optional (env nil))
  (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(defmethod subtypep ((type-1 built-in-class) (type-2 symbol) &optional (env nil))
  (if (member type-2 '(CONS SYMBOL ARRAY NUMBER CHARACTER HASH-TABLE FUNCTION READTABLE
				PACKAGE PATHNAME STREAM RANDOM-STATE CONDITION RESTART))
      (values nil t)
      (values nil nil)))

(fmakunbound 'specialized-subtypep)
(unintern 'specialized-subtypep))