Changeset 3990
 Timestamp:
 09/22/03 12:06:46 (19 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/j/src/org/armedbear/lisp/subtypep.lisp
r3979 r3990 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: subtypep.lisp,v 1.1 3 20030921 19:49:33piso Exp $4 ;;; $Id: subtypep.lisp,v 1.14 20030922 12:06:46 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 133 133 (cons tp i))) 134 134 135 (defun simplesubtypep (type1 type2)136 (cond ((and (symbolp type1) (symbolp type2))137 (if (memq type2 (supertypes type1))138 t139 (dolist (supertype (supertypes type1))140 (when (simplesubtypep supertype type2)141 (return t)))))142 (t143 nil)))144 145 135 (defun subintervalp (i1 i2) 146 136 (let (low1 high1 low2 high2) … … 195 185 (returnfrom subintervalp t))) 196 186 187 (defun simplesubtypep (type1 type2) 188 (when (and (symbolp type1) (symbolp type2) (knowntypep type1)) 189 ;; type1 is a known type. type1 can only be a subtype of type2 if type2 is 190 ;; also a known type. 191 (returnfrom simplesubtypep (if (memq type2 (supertypes type1)) 192 t 193 (dolist (supertype (supertypes type1)) 194 (when (simplesubtypep supertype type2) 195 (return (values t))))))) 196 (let ((c1 (if (classp type1) type1 (findclass type1 nil))) 197 (c2 (if (classp type2) type2 (findclass type2 nil)))) 198 (when (and c1 c2) 199 (returnfrom simplesubtypep 200 (if (memq c2 (classprecedencelist c1)) t nil)))) 201 nil) 202 197 203 (defun subtypep (type1 type2) 198 204 (when (or (null type1) (eq type2 t)) 199 205 (returnfrom subtypep (values t t))) 200 (let ((c1 (classp type1)) (c2 (classp type2)))201 (when (and c1 c2)202 (returnfrom subtypep203 (if (memq type2 (classprecedencelist type1))204 (values t t) (values nil t))))205 (when (and c1 (or (eq type2 'structureobject) (eq type2 'standardobject)))206 (returnfrom subtypep207 (if (member (findclass type2) (classprecedencelist type1))208 (values t t) (values nil t))))209 (when (or c1 c2)210 (returnfrom subtypep (values nil t))))211 206 (setq type1 (normalizetype type1) 212 207 type2 (normalizetype type2)) … … 244 239 (returnfrom subtypep (values (simplesubtypep t1 t2) t))) 245 240 ((eq t2 'sequence) 246 (cond ((memq t1 '(null cons list))247 (values t t))248 ((memq t1 '(array simplearray))249 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1)))250 (values t t)251 (values nil t)))252 (t (values nil (knowntypep t1)))))253 ((eq t2 'simplestring)254 (if (memq t1 '(simplestring simplebasestring))255 (if (or (null i2) (eq (car i2) '*))256 (values t t)257 (values nil t))258 (values nil (knowntypep t2))))259 (t260 (cond ((eq t1 'float)261 (if (memq t2 '(float real number))262 (values (subintervalp i1 i2) t)263 (values nil (knowntypep t2))))264 ((eq t1 'integer)265 (if (memq t2 '(integer rational real number))266 (values (subintervalp i1 i2) t)267 (values nil (knowntypep t2))))268 ((eq t1 'rational)269 (if (memq t2 '(rational real number))270 (values (subintervalp i1 i2) t)271 (values nil (knowntypep t2))))272 ((eq t1 'real)273 (if (memq t2 '(real number))274 (values (subintervalp i1 i2) t)275 (values nil (knowntypep t2))))276 ((memq t1 '(string simplestring basestring277 simplebasestring))278 (cond ((eq t2 'string)279 (if (or (null i2) (eq (car i2) '*))280 (values t t)281 (values nil t)))282 (t283 (values nil (knowntypep t2)))))284 (t285 (values nil nil)))))))241 (cond ((memq t1 '(null cons list)) 242 (values t t)) 243 ((memq t1 '(array simplearray)) 244 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) 245 (values t t) 246 (values nil t))) 247 (t (values nil (knowntypep t1))))) 248 ((eq t2 'simplestring) 249 (if (memq t1 '(simplestring simplebasestring)) 250 (if (or (null i2) (eq (car i2) '*)) 251 (values t t) 252 (values nil t)) 253 (values nil (knowntypep t2)))) 254 (t 255 (cond ((eq t1 'float) 256 (if (memq t2 '(float real number)) 257 (values (subintervalp i1 i2) t) 258 (values nil (knowntypep t2)))) 259 ((eq t1 'integer) 260 (if (memq t2 '(integer rational real number)) 261 (values (subintervalp i1 i2) t) 262 (values nil (knowntypep t2)))) 263 ((eq t1 'rational) 264 (if (memq t2 '(rational real number)) 265 (values (subintervalp i1 i2) t) 266 (values nil (knowntypep t2)))) 267 ((eq t1 'real) 268 (if (memq t2 '(real number)) 269 (values (subintervalp i1 i2) t) 270 (values nil (knowntypep t2)))) 271 ((memq t1 '(string simplestring basestring 272 simplebasestring)) 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 (knowntypep t2))))) 279 (t 280 (values nil nil)))))))
Note: See TracChangeset
for help on using the changeset viewer.