Changeset 3979

Timestamp:

09/21/03 19:49:33 (20 years ago)

Author:

piso

Message:

Work in progress.

File:

• trunk/j/src/org/armedbear/lisp/subtypep.lisp (modified) (3 diffs)

trunk/j/src/org/armedbear/lisp/subtypep.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: subtypep.lisp,v 1.12 2003-09-21 19:30:29 piso Exp $
+;;; $Id: subtypep.lisp,v 1.13 2003-09-21 19:49:33 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -134 +134 @@
 
 (defun simple-subtypep (type1 type2)
-;;   (assert (symbolp type1))
-;;   (assert (symbolp type2))
   (cond ((and (symbolp type1) (symbolp type2))
          (if (memq type2 (supertypes type1))
@@ -200 +198 @@
   (when (or (null type1) (eq type2 t))
     (return-from subtypep (values t t)))
+  (let ((c1 (classp type1)) (c2 (classp type2)))
+    (when (and c1 c2)
+      (return-from subtypep
+       (if (memq type2 (class-precedence-list type1))
+           (values t t) (values nil t))))
+    (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object)))
+      (return-from subtypep
+       (if (member (find-class type2) (class-precedence-list type1))
+           (values t t) (values nil t))))
+    (when (or c1 c2)
+      (return-from subtypep (values nil t))))
   (setq type1 (normalize-type type1)
         type2 (normalize-type type2))