Changeset 3923 for trunk/j/src/org/armedbear/lisp/subtypep.lisp

Timestamp:

09/20/03 01:26:41 (20 years ago)

Author:

piso

Message:

Work in progress.

File:

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

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

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: subtypep.lisp,v 1.9 2003-09-19 15:14:56 piso Exp $
+;;; $Id: subtypep.lisp,v 1.10 2003-09-20 01:26:41 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -209 +209 @@
                                   ((known-type-p t1) (values t t))
                                   (t (values nil nil)))))
-    (unless (or i1 i2)
-      (return-from subtypep (values (simple-subtypep t1 t2) t)))
-    (cond ((eq t2 'sequence)
-           (values (simple-subtypep t2 t2) t))
+    (cond  ((eq t1 'or)
+            (dolist (tt i1)
+              (multiple-value-bind (tv flag) (subtypep tt type2)
+                (unless tv (return-from subtypep (values tv flag)))))
+            (return-from subtypep (values t t)))
+           ((eq t1 'and)
+            (dolist (tt i1)
+              (let ((tv (subtypep tt type2)))
+                (when tv (return-from subtypep (values t t)))))
+            (return-from subtypep (values nil nil)))
+           ((eq t2 'or)
+            (dolist (tt i2)
+              (let ((tv (subtypep type1 tt)))
+                (when tv (return-from subtypep (values t t)))))
+            (return-from subtypep (values nil nil)))
+           ((eq t2 'and)
+            (dolist (tt i2)
+              (multiple-value-bind (tv flag) (subtypep type1 tt)
+                (unless tv (return-from subtypep (values tv flag)))))
+            (return-from subtypep (values t t)))
+           ((null (or i1 i2))
+            (return-from subtypep (values (simple-subtypep t1 t2) t)))
+           ((eq t2 'sequence)
+           (cond ((memq t1 '(null cons list))
+                  (values t t))
+                 ((memq t1 '(array simple-array))
+                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
+                      (values t t)
+                      (values nil t)))
+                 (t (values nil (known-type-p t1)))))
           ((eq t2 'simple-string)
            (if (memq t1 '(simple-string simple-base-string))