Changeset 4216

Timestamp:

10/06/03 02:25:00 (19 years ago)

Author:

piso

Message:

Work in progress.

File:

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

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

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: subtypep.lisp,v 1.16 2003-09-29 01:29:13 piso Exp $
+;;; $Id: subtypep.lisp,v 1.17 2003-10-06 02:25:00 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -110 +110 @@
     present-p))
 
-(defun normalize-type (type)
+(defun subtypep-normalize-type (type)
   (let (tp i)
     (loop
@@ -135 +135 @@
       ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
        (setq tp 'float)))
-    (cons tp i)))
+    (if i (cons tp i) tp)))
 
 (defun sub-interval-p (i1 i2)
@@ -208 +208 @@
   (when (or (null type1) (eq type2 t))
     (return-from subtypep (values t t)))
-  (setq type1 (normalize-type type1)
-        type2 (normalize-type type2))
+  (setq type1 (subtypep-normalize-type type1)
+        type2 (subtypep-normalize-type type2))
   (when (equal type1 type2)
     (return-from subtypep (values t t)))
-  (let ((t1 (car type1))
-        (t2 (car type2))
-        (i1 (cdr type1))
-        (i2 (cdr type2)))
+  (let (t1 t2 i1 i2)
+    (if (atom type1)
+        (setq t1 type1 i1 nil)
+        (setq t1 (car type1) i1 (cdr type1)))
+    (if (atom type2)
+        (setq t2 type2 i2 nil)
+        (setq t2 (car type2) i2 (cdr type2)))
     (when (eq t2 'atom)
       (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
                                   ((known-type-p t1) (values t t))
                                   (t (values nil nil)))))
-    (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 'vector)
-            (if (eq t1 'base-string)
-                (if (eq (car i2) 'base-char)
-                    (values t t)
-                    (values nil t))
-                (values nil (known-type-p t2))))
-           ((eq t2 'simple-string)
-            (if (memq t1 '(simple-string simple-base-string))
-                (if (or (null i2) (eq (car i2) '*))
-                    (values t t)
-                    (values nil t))
-                (values nil (known-type-p t2))))
-           ((eq t2 'base-string)
-            (if (eq t1 'vector)
-                (if (eq (car i1) 'base-char)
-                    (values t t)
-                    (values nil t))
-                (values nil (known-type-p t2))))
-           ((eq t2 'string)
-            (if (eq t1 'vector)
-                (if (eq (car i1) 'character)
-                    (values t t)
-                    (values nil t))
-                (values nil (known-type-p t2))))
-           (t
-            (cond ((eq t1 'float)
-                   (if (memq t2 '(float real number))
-                       (values (sub-interval-p i1 i2) t)
-                       (values nil (known-type-p t2))))
-                  ((eq t1 'integer)
-                   (if (memq t2 '(integer rational real number))
-                       (values (sub-interval-p i1 i2) t)
-                       (values nil (known-type-p t2))))
-                  ((eq t1 'rational)
-                   (if (memq t2 '(rational real number))
-                       (values (sub-interval-p i1 i2) t)
-                       (values nil (known-type-p t2))))
-                  ((eq t1 'real)
-                   (if (memq t2 '(real number))
-                       (values (sub-interval-p i1 i2) t)
-                       (values nil (known-type-p t2))))
-                  ((memq t1 '(string simple-string base-string
-                              simple-base-string))
-                   (cond ((eq t2 'string)
-                          (if (or (null i2) (eq (car i2) '*))
-                              (values t t)
-                              (values nil t)))
-                         (t
-                          (values nil (known-type-p t2)))))
-                  (t
-                   (values nil nil)))))))
+    (cond ((eq t1 'member)
+           (dolist (e i1)
+             (unless (typep e type2) (return-from subtypep (values nil t))))
+           (return-from subtypep (values t t)))
+          ((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 'vector)
+           (if (eq t1 'base-string)
+               (if (eq (car i2) 'base-char)
+                   (values t t)
+                   (values nil t))
+               (values nil (known-type-p t2))))
+          ((eq t2 'simple-string)
+           (if (memq t1 '(simple-string simple-base-string))
+               (if (or (null i2) (eq (car i2) '*))
+                   (values t t)
+                   (values nil t))
+               (values nil (known-type-p t2))))
+          ((eq t2 'base-string)
+           (if (eq t1 'vector)
+               (if (eq (car i1) 'base-char)
+                   (values t t)
+                   (values nil t))
+               (values nil (known-type-p t2))))
+          ((eq t2 'string)
+           (if (eq t1 'vector)
+               (if (eq (car i1) 'character)
+                   (values t t)
+                   (values nil t))
+               (values nil (known-type-p t2))))
+          (t
+           (cond ((eq t1 'float)
+                  (if (memq t2 '(float real number))
+                      (values (sub-interval-p i1 i2) t)
+                      (values nil (known-type-p t2))))
+                 ((eq t1 'integer)
+                  (if (memq t2 '(integer rational real number))
+                      (values (sub-interval-p i1 i2) t)
+                      (values nil (known-type-p t2))))
+                 ((eq t1 'rational)
+                  (if (memq t2 '(rational real number))
+                      (values (sub-interval-p i1 i2) t)
+                      (values nil (known-type-p t2))))
+                 ((eq t1 'real)
+                  (if (memq t2 '(real number))
+                      (values (sub-interval-p i1 i2) t)
+                      (values nil (known-type-p t2))))
+                 ((memq t1 '(string simple-string base-string
+                             simple-base-string))
+                  (cond ((eq t2 'string)
+                         (if (or (null i2) (eq (car i2) '*))
+                             (values t t)
+                             (values nil t)))
+                        (t
+                         (values nil (known-type-p t2)))))
+                 (t
+                  (values nil nil)))))))