Changeset 3990
- Timestamp:
- 09/22/03 12:06:46 (20 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 2003-09-21 19:49:33piso Exp $4 ;;; $Id: subtypep.lisp,v 1.14 2003-09-22 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 simple-subtypep (type1 type2)136 (cond ((and (symbolp type1) (symbolp type2))137 (if (memq type2 (supertypes type1))138 t139 (dolist (supertype (supertypes type1))140 (when (simple-subtypep supertype type2)141 (return t)))))142 (t143 nil)))144 145 135 (defun sub-interval-p (i1 i2) 146 136 (let (low1 high1 low2 high2) … … 195 185 (return-from sub-interval-p t))) 196 186 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 197 203 (defun subtypep (type1 type2) 198 204 (when (or (null type1) (eq type2 t)) 199 205 (return-from subtypep (values t t))) 200 (let ((c1 (classp type1)) (c2 (classp type2)))201 (when (and c1 c2)202 (return-from subtypep203 (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 subtypep207 (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))))211 206 (setq type1 (normalize-type type1) 212 207 type2 (normalize-type type2)) … … 244 239 (return-from subtypep (values (simple-subtypep t1 t2) t))) 245 240 ((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 (t260 (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-string277 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 (t283 (values nil (known-type-p t2)))))284 (t285 (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.