Changeset 3990


Ignore:
Timestamp:
09/22/03 12:06:46 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r3979 r3990  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.13 2003-09-21 19:49:33 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.14 2003-09-22 12:06:46 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    133133    (cons tp i)))
    134134
    135 (defun simple-subtypep (type1 type2)
    136   (cond ((and (symbolp type1) (symbolp type2))
    137          (if (memq type2 (supertypes type1))
    138              t
    139              (dolist (supertype (supertypes type1))
    140                (when (simple-subtypep supertype type2)
    141                  (return t)))))
    142         (t
    143          nil)))
    144 
    145135(defun sub-interval-p (i1 i2)
    146136  (let (low1 high1 low2 high2)
     
    195185    (return-from sub-interval-p t)))
    196186
     187(defun simple-subtypep (type1 type2)
     188  (when (and (symbolp type1) (symbolp type2) (known-type-p type1))
     189    ;; type1 is a known type. type1 can only be a subtype of type2 if type2 is
     190    ;; also a known type.
     191    (return-from simple-subtypep (if (memq type2 (supertypes type1))
     192                                     t
     193                                     (dolist (supertype (supertypes type1))
     194                                       (when (simple-subtypep supertype type2)
     195                                         (return (values t)))))))
     196  (let ((c1 (if (classp type1) type1 (find-class type1 nil)))
     197        (c2 (if (classp type2) type2 (find-class type2 nil))))
     198    (when (and c1 c2)
     199      (return-from simple-subtypep
     200                   (if (memq c2 (class-precedence-list c1)) t nil))))
     201  nil)
     202
    197203(defun subtypep (type1 type2)
    198204  (when (or (null type1) (eq type2 t))
    199205    (return-from subtypep (values t t)))
    200   (let ((c1 (classp type1)) (c2 (classp type2)))
    201     (when (and c1 c2)
    202       (return-from subtypep
    203        (if (memq type2 (class-precedence-list type1))
    204            (values t t) (values nil t))))
    205     (when (and c1 (or (eq type2 'structure-object) (eq type2 'standard-object)))
    206       (return-from subtypep
    207        (if (member (find-class type2) (class-precedence-list type1))
    208            (values t t) (values nil t))))
    209     (when (or c1 c2)
    210       (return-from subtypep (values nil t))))
    211206  (setq type1 (normalize-type type1)
    212207        type2 (normalize-type type2))
     
    244239            (return-from subtypep (values (simple-subtypep t1 t2) t)))
    245240           ((eq t2 'sequence)
    246            (cond ((memq t1 '(null cons list))
    247                   (values t t))
    248                  ((memq t1 '(array simple-array))
    249                   (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
    250                       (values t t)
    251                       (values nil t)))
    252                  (t (values nil (known-type-p t1)))))
    253           ((eq t2 'simple-string)
    254            (if (memq t1 '(simple-string simple-base-string))
    255                (if (or (null i2) (eq (car i2) '*))
    256                    (values t t)
    257                    (values nil t))
    258                (values nil (known-type-p t2))))
    259           (t
    260            (cond ((eq t1 'float)
    261                   (if (memq t2 '(float real number))
    262                       (values (sub-interval-p i1 i2) t)
    263                       (values nil (known-type-p t2))))
    264                  ((eq t1 'integer)
    265                   (if (memq t2 '(integer rational real number))
    266                       (values (sub-interval-p i1 i2) t)
    267                       (values nil (known-type-p t2))))
    268                  ((eq t1 'rational)
    269                   (if (memq t2 '(rational real number))
    270                       (values (sub-interval-p i1 i2) t)
    271                       (values nil (known-type-p t2))))
    272                  ((eq t1 'real)
    273                   (if (memq t2 '(real number))
    274                       (values (sub-interval-p i1 i2) t)
    275                       (values nil (known-type-p t2))))
    276                  ((memq t1 '(string simple-string base-string
    277                              simple-base-string))
    278                   (cond ((eq t2 'string)
    279                          (if (or (null i2) (eq (car i2) '*))
    280                              (values t t)
    281                              (values nil t)))
    282                         (t
    283                          (values nil (known-type-p t2)))))
    284                  (t
    285                   (values nil nil)))))))
     241            (cond ((memq t1 '(null cons list))
     242                   (values t t))
     243                  ((memq t1 '(array simple-array))
     244                   (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
     245                       (values t t)
     246                       (values nil t)))
     247                  (t (values nil (known-type-p t1)))))
     248           ((eq t2 'simple-string)
     249            (if (memq t1 '(simple-string simple-base-string))
     250                (if (or (null i2) (eq (car i2) '*))
     251                    (values t t)
     252                    (values nil t))
     253                (values nil (known-type-p t2))))
     254           (t
     255            (cond ((eq t1 'float)
     256                   (if (memq t2 '(float real number))
     257                       (values (sub-interval-p i1 i2) t)
     258                       (values nil (known-type-p t2))))
     259                  ((eq t1 'integer)
     260                   (if (memq t2 '(integer rational real number))
     261                       (values (sub-interval-p i1 i2) t)
     262                       (values nil (known-type-p t2))))
     263                  ((eq t1 'rational)
     264                   (if (memq t2 '(rational real number))
     265                       (values (sub-interval-p i1 i2) t)
     266                       (values nil (known-type-p t2))))
     267                  ((eq t1 'real)
     268                   (if (memq t2 '(real number))
     269                       (values (sub-interval-p i1 i2) t)
     270                       (values nil (known-type-p t2))))
     271                  ((memq t1 '(string simple-string base-string
     272                              simple-base-string))
     273                   (cond ((eq t2 'string)
     274                          (if (or (null i2) (eq (car i2) '*))
     275                              (values t t)
     276                              (values nil t)))
     277                         (t
     278                          (values nil (known-type-p t2)))))
     279                  (t
     280                   (values nil nil)))))))
Note: See TracChangeset for help on using the changeset viewer.