subtypep questions

[Tom Mitchell <tmitchel@vax.bbn.com>]

    Date: Thu, 22 Jun 89 9:18:42 CDT
    From: Brad Miller - EMD <bmiller@shamash.cdc.com>

Here is what I did to fix this problem.  I have only run it on
a Symbolics machine (7.2) but I think it should work in 
Common Lisp.  The function do-satisfies-deftype is from
the 12/7 version of PCL.  I assume it remains essentially
the same in the latest version (5/22).  Try it and let
me know if it works.  The change is explained in the
comments and set off by two lines of hyphens.

-tom

;;;********************************************************************************
;;;handle deftyping properly...
;;;this gives us the subtype relationship within the CL Type system.
;;;********************************************************************************
;;;the deftype for an associated class now will look like this:
;;;
;;;For
;;;   (defclass baz (foo bar) ())
;;;
;;;We do
;;;   (deftype baz ()
;;;     (and foo bar object t (satisfies |BAZ predicate|)))
;;;
;;;which gives us the subtype relationship we want when defining types of slots,
;;;instead of making all classes disjoint in the Common Lisp Type hierarchy.
;;;this is accomplished by grabbing the class-precedence-list of the class being
;;;defined (or redefined), taking the cdr of it (to eliminate the current class,
;;;which always seems to be the car of the list), and mapping #'class-name through
;;;the list to get the symbol associated with the class.  
(defun do-satisfies-deftype (name predicate)
  (let* ((specifier `(satisfies ,predicate))
	 (expand-fn #'(lambda (&rest ignore)
			(declare (ignore ignore))
;;;--------------------------------------------------
			`(and ,(mapcar #'class-name
				       (cdr (class-precedence-list (find-class name))))
;;;--------------------------------------------------
			      ,specifier))))
    ;; Specific ports can insert their own way of doing this.  Many
    ;; ports may find the expand-fn defined above useful.
    ;;
    (or #+:Genera
	(setf (get name 'deftype) expand-fn)
	#+(and :Lucid (not :Prime))
	(system::define-macro `(deftype ,name) expand-fn nil)
	#+ExCL
	(setf (get name 'excl::deftype-expander) expand-fn)
	#+:coral
	(setf (get name 'ccl::deftype-expander) expand-fn)

	;; This is the default for ports for which we don't know any
	;; better.  Note that for most ports, providing this definition
	;; should just speed up class definition.  It shouldn't have an
	;; effect on performance of most user code.
	(eval `(deftype ,name () '(satisfies ,predicate))))))