Ignore:
Timestamp:
09/20/03 01:26:41 (19 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r3896 r3923  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: subtypep.lisp,v 1.9 2003-09-19 15:14:56 piso Exp $
     4;;; $Id: subtypep.lisp,v 1.10 2003-09-20 01:26:41 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    209209                                  ((known-type-p t1) (values t t))
    210210                                  (t (values nil nil)))))
    211     (unless (or i1 i2)
    212       (return-from subtypep (values (simple-subtypep t1 t2) t)))
    213     (cond ((eq t2 'sequence)
    214            (values (simple-subtypep t2 t2) t))
     211    (cond  ((eq t1 'or)
     212            (dolist (tt i1)
     213              (multiple-value-bind (tv flag) (subtypep tt type2)
     214                (unless tv (return-from subtypep (values tv flag)))))
     215            (return-from subtypep (values t t)))
     216           ((eq t1 'and)
     217            (dolist (tt i1)
     218              (let ((tv (subtypep tt type2)))
     219                (when tv (return-from subtypep (values t t)))))
     220            (return-from subtypep (values nil nil)))
     221           ((eq t2 'or)
     222            (dolist (tt i2)
     223              (let ((tv (subtypep type1 tt)))
     224                (when tv (return-from subtypep (values t t)))))
     225            (return-from subtypep (values nil nil)))
     226           ((eq t2 'and)
     227            (dolist (tt i2)
     228              (multiple-value-bind (tv flag) (subtypep type1 tt)
     229                (unless tv (return-from subtypep (values tv flag)))))
     230            (return-from subtypep (values t t)))
     231           ((null (or i1 i2))
     232            (return-from subtypep (values (simple-subtypep t1 t2) t)))
     233           ((eq t2 'sequence)
     234           (cond ((memq t1 '(null cons list))
     235                  (values t t))
     236                 ((memq t1 '(array simple-array))
     237                  (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))
     238                      (values t t)
     239                      (values nil t)))
     240                 (t (values nil (known-type-p t1)))))
    215241          ((eq t2 'simple-string)
    216242           (if (memq t1 '(simple-string simple-base-string))
Note: See TracChangeset for help on using the changeset viewer.