Ignore:
Timestamp:
10/06/03 02:25:00 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/subtypep.lisp

    r4119 r4216  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.16 2003-09-29 01:29:13 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.17 2003-10-06 02:25:00 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    110110    present-p))
    111111
    112 (defun normalize-type (type)
     112(defun subtypep-normalize-type (type)
    113113  (let (tp i)
    114114    (loop
     
    135135      ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
    136136       (setq tp 'float)))
    137     (cons tp i)))
     137    (if i (cons tp i) tp)))
    138138
    139139(defun sub-interval-p (i1 i2)
     
    208208  (when (or (null type1) (eq type2 t))
    209209    (return-from subtypep (values t t)))
    210   (setq type1 (normalize-type type1)
    211         type2 (normalize-type type2))
     210  (setq type1 (subtypep-normalize-type type1)
     211        type2 (subtypep-normalize-type type2))
    212212  (when (equal type1 type2)
    213213    (return-from subtypep (values t t)))
    214   (let ((t1 (car type1))
    215         (t2 (car type2))
    216         (i1 (cdr type1))
    217         (i2 (cdr type2)))
     214  (let (t1 t2 i1 i2)
     215    (if (atom type1)
     216        (setq t1 type1 i1 nil)
     217        (setq t1 (car type1) i1 (cdr type1)))
     218    (if (atom type2)
     219        (setq t2 type2 i2 nil)
     220        (setq t2 (car type2) i2 (cdr type2)))
    218221    (when (eq t2 'atom)
    219222      (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t))
    220223                                  ((known-type-p t1) (values t t))
    221224                                  (t (values nil nil)))))
    222     (cond  ((eq t1 'or)
    223             (dolist (tt i1)
    224               (multiple-value-bind (tv flag) (subtypep tt type2)
    225                 (unless tv (return-from subtypep (values tv flag)))))
    226             (return-from subtypep (values t t)))
    227            ((eq t1 'and)
    228             (dolist (tt i1)
    229               (let ((tv (subtypep tt type2)))
    230                 (when tv (return-from subtypep (values t t)))))
    231             (return-from subtypep (values nil nil)))
    232            ((eq t2 'or)
    233             (dolist (tt i2)
    234               (let ((tv (subtypep type1 tt)))
    235                 (when tv (return-from subtypep (values t t)))))
    236             (return-from subtypep (values nil nil)))
    237            ((eq t2 'and)
    238             (dolist (tt i2)
    239               (multiple-value-bind (tv flag) (subtypep type1 tt)
    240                 (unless tv (return-from subtypep (values tv flag)))))
    241             (return-from subtypep (values t t)))
    242            ((null (or i1 i2))
    243             (return-from subtypep (values (simple-subtypep t1 t2) t)))
    244            ((eq t2 'sequence)
    245             (cond ((memq t1 '(null cons list))
    246                    (values t t))
    247                   ((memq t1 '(array simple-array))
    248                    (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
    249                        (values t t)
    250                        (values nil t)))
    251                   (t (values nil (known-type-p t1)))))
    252            ((eq t2 'vector)
    253             (if (eq t1 'base-string)
    254                 (if (eq (car i2) 'base-char)
    255                     (values t t)
    256                     (values nil t))
    257                 (values nil (known-type-p t2))))
    258            ((eq t2 'simple-string)
    259             (if (memq t1 '(simple-string simple-base-string))
    260                 (if (or (null i2) (eq (car i2) '*))
    261                     (values t t)
    262                     (values nil t))
    263                 (values nil (known-type-p t2))))
    264            ((eq t2 'base-string)
    265             (if (eq t1 'vector)
    266                 (if (eq (car i1) 'base-char)
    267                     (values t t)
    268                     (values nil t))
    269                 (values nil (known-type-p t2))))
    270            ((eq t2 'string)
    271             (if (eq t1 'vector)
    272                 (if (eq (car i1) 'character)
    273                     (values t t)
    274                     (values nil t))
    275                 (values nil (known-type-p t2))))
    276            (t
    277             (cond ((eq t1 'float)
    278                    (if (memq t2 '(float real number))
    279                        (values (sub-interval-p i1 i2) t)
    280                        (values nil (known-type-p t2))))
    281                   ((eq t1 'integer)
    282                    (if (memq t2 '(integer rational real number))
    283                        (values (sub-interval-p i1 i2) t)
    284                        (values nil (known-type-p t2))))
    285                   ((eq t1 'rational)
    286                    (if (memq t2 '(rational real number))
    287                        (values (sub-interval-p i1 i2) t)
    288                        (values nil (known-type-p t2))))
    289                   ((eq t1 'real)
    290                    (if (memq t2 '(real number))
    291                        (values (sub-interval-p i1 i2) t)
    292                        (values nil (known-type-p t2))))
    293                   ((memq t1 '(string simple-string base-string
    294                               simple-base-string))
    295                    (cond ((eq t2 'string)
    296                           (if (or (null i2) (eq (car i2) '*))
    297                               (values t t)
    298                               (values nil t)))
    299                          (t
    300                           (values nil (known-type-p t2)))))
    301                   (t
    302                    (values nil nil)))))))
     225    (cond ((eq t1 'member)
     226           (dolist (e i1)
     227             (unless (typep e type2) (return-from subtypep (values nil t))))
     228           (return-from subtypep (values t t)))
     229          ((eq t1 'or)
     230           (dolist (tt i1)
     231             (multiple-value-bind (tv flag) (subtypep tt type2)
     232               (unless tv (return-from subtypep (values tv flag)))))
     233           (return-from subtypep (values t t)))
     234          ((eq t1 'and)
     235           (dolist (tt i1)
     236             (let ((tv (subtypep tt type2)))
     237               (when tv (return-from subtypep (values t t)))))
     238           (return-from subtypep (values nil nil)))
     239          ((eq t2 'or)
     240           (dolist (tt i2)
     241             (let ((tv (subtypep type1 tt)))
     242               (when tv (return-from subtypep (values t t)))))
     243           (return-from subtypep (values nil nil)))
     244          ((eq t2 'and)
     245           (dolist (tt i2)
     246             (multiple-value-bind (tv flag) (subtypep type1 tt)
     247               (unless tv (return-from subtypep (values tv flag)))))
     248           (return-from subtypep (values t t)))
     249          ((null (or i1 i2))
     250           (return-from subtypep (values (simple-subtypep t1 t2) t)))
     251          ((eq t2 'sequence)
     252           (cond ((memq t1 '(null cons list))
     253                  (values t t))
     254                 ((memq t1 '(array simple-array))
     255                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
     256                      (values t t)
     257                      (values nil t)))
     258                 (t (values nil (known-type-p t1)))))
     259          ((eq t2 'vector)
     260           (if (eq t1 'base-string)
     261               (if (eq (car i2) 'base-char)
     262                   (values t t)
     263                   (values nil t))
     264               (values nil (known-type-p t2))))
     265          ((eq t2 'simple-string)
     266           (if (memq t1 '(simple-string simple-base-string))
     267               (if (or (null i2) (eq (car i2) '*))
     268                   (values t t)
     269                   (values nil t))
     270               (values nil (known-type-p t2))))
     271          ((eq t2 'base-string)
     272           (if (eq t1 'vector)
     273               (if (eq (car i1) 'base-char)
     274                   (values t t)
     275                   (values nil t))
     276               (values nil (known-type-p t2))))
     277          ((eq t2 'string)
     278           (if (eq t1 'vector)
     279               (if (eq (car i1) 'character)
     280                   (values t t)
     281                   (values nil t))
     282               (values nil (known-type-p t2))))
     283          (t
     284           (cond ((eq t1 'float)
     285                  (if (memq t2 '(float real number))
     286                      (values (sub-interval-p i1 i2) t)
     287                      (values nil (known-type-p t2))))
     288                 ((eq t1 'integer)
     289                  (if (memq t2 '(integer rational real number))
     290                      (values (sub-interval-p i1 i2) t)
     291                      (values nil (known-type-p t2))))
     292                 ((eq t1 'rational)
     293                  (if (memq t2 '(rational real number))
     294                      (values (sub-interval-p i1 i2) t)
     295                      (values nil (known-type-p t2))))
     296                 ((eq t1 'real)
     297                  (if (memq t2 '(real number))
     298                      (values (sub-interval-p i1 i2) t)
     299                      (values nil (known-type-p t2))))
     300                 ((memq t1 '(string simple-string base-string
     301                             simple-base-string))
     302                  (cond ((eq t2 'string)
     303                         (if (or (null i2) (eq (car i2) '*))
     304                             (values t t)
     305                             (values nil t)))
     306                        (t
     307                         (values nil (known-type-p t2)))))
     308                 (t
     309                  (values nil nil)))))))
Note: See TracChangeset for help on using the changeset viewer.