Changeset 4216 for trunk/j/src/org/armedbear/lisp/subtypep.lisp
 Timestamp:
 10/06/03 02:25:00 (19 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/j/src/org/armedbear/lisp/subtypep.lisp
r4119 r4216 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: subtypep.lisp,v 1.1 6 20030929 01:29:13piso Exp $4 ;;; $Id: subtypep.lisp,v 1.17 20031006 02:25:00 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 110 110 presentp)) 111 111 112 (defun normalizetype (type)112 (defun subtypepnormalizetype (type) 113 113 (let (tp i) 114 114 (loop … … 135 135 ((SHORTFLOAT SINGLEFLOAT DOUBLEFLOAT LONGFLOAT) 136 136 (setq tp 'float))) 137 ( cons tp i)))137 (if i (cons tp i) tp))) 138 138 139 139 (defun subintervalp (i1 i2) … … 208 208 (when (or (null type1) (eq type2 t)) 209 209 (returnfrom subtypep (values t t))) 210 (setq type1 ( normalizetype type1)211 type2 ( normalizetype type2))210 (setq type1 (subtypepnormalizetype type1) 211 type2 (subtypepnormalizetype type2)) 212 212 (when (equal type1 type2) 213 213 (returnfrom 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))) 218 221 (when (eq t2 'atom) 219 222 (returnfrom subtypep (cond ((memq t1 '(cons list)) (values nil t)) 220 223 ((knowntypep t1) (values t t)) 221 224 (t (values nil nil))))) 222 (cond ((eq t1 'or) 223 (dolist (tt i1) 224 (multiplevaluebind (tv flag) (subtypep tt type2) 225 (unless tv (returnfrom subtypep (values tv flag))))) 226 (returnfrom subtypep (values t t))) 227 ((eq t1 'and) 228 (dolist (tt i1) 229 (let ((tv (subtypep tt type2))) 230 (when tv (returnfrom subtypep (values t t))))) 231 (returnfrom subtypep (values nil nil))) 232 ((eq t2 'or) 233 (dolist (tt i2) 234 (let ((tv (subtypep type1 tt))) 235 (when tv (returnfrom subtypep (values t t))))) 236 (returnfrom subtypep (values nil nil))) 237 ((eq t2 'and) 238 (dolist (tt i2) 239 (multiplevaluebind (tv flag) (subtypep type1 tt) 240 (unless tv (returnfrom subtypep (values tv flag))))) 241 (returnfrom subtypep (values t t))) 242 ((null (or i1 i2)) 243 (returnfrom subtypep (values (simplesubtypep t1 t2) t))) 244 ((eq t2 'sequence) 245 (cond ((memq t1 '(null cons list)) 246 (values t t)) 247 ((memq t1 '(array simplearray)) 248 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) 249 (values t t) 250 (values nil t))) 251 (t (values nil (knowntypep t1))))) 252 ((eq t2 'vector) 253 (if (eq t1 'basestring) 254 (if (eq (car i2) 'basechar) 255 (values t t) 256 (values nil t)) 257 (values nil (knowntypep t2)))) 258 ((eq t2 'simplestring) 259 (if (memq t1 '(simplestring simplebasestring)) 260 (if (or (null i2) (eq (car i2) '*)) 261 (values t t) 262 (values nil t)) 263 (values nil (knowntypep t2)))) 264 ((eq t2 'basestring) 265 (if (eq t1 'vector) 266 (if (eq (car i1) 'basechar) 267 (values t t) 268 (values nil t)) 269 (values nil (knowntypep 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 (knowntypep t2)))) 276 (t 277 (cond ((eq t1 'float) 278 (if (memq t2 '(float real number)) 279 (values (subintervalp i1 i2) t) 280 (values nil (knowntypep t2)))) 281 ((eq t1 'integer) 282 (if (memq t2 '(integer rational real number)) 283 (values (subintervalp i1 i2) t) 284 (values nil (knowntypep t2)))) 285 ((eq t1 'rational) 286 (if (memq t2 '(rational real number)) 287 (values (subintervalp i1 i2) t) 288 (values nil (knowntypep t2)))) 289 ((eq t1 'real) 290 (if (memq t2 '(real number)) 291 (values (subintervalp i1 i2) t) 292 (values nil (knowntypep t2)))) 293 ((memq t1 '(string simplestring basestring 294 simplebasestring)) 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 (knowntypep t2))))) 301 (t 302 (values nil nil))))))) 225 (cond ((eq t1 'member) 226 (dolist (e i1) 227 (unless (typep e type2) (returnfrom subtypep (values nil t)))) 228 (returnfrom subtypep (values t t))) 229 ((eq t1 'or) 230 (dolist (tt i1) 231 (multiplevaluebind (tv flag) (subtypep tt type2) 232 (unless tv (returnfrom subtypep (values tv flag))))) 233 (returnfrom subtypep (values t t))) 234 ((eq t1 'and) 235 (dolist (tt i1) 236 (let ((tv (subtypep tt type2))) 237 (when tv (returnfrom subtypep (values t t))))) 238 (returnfrom subtypep (values nil nil))) 239 ((eq t2 'or) 240 (dolist (tt i2) 241 (let ((tv (subtypep type1 tt))) 242 (when tv (returnfrom subtypep (values t t))))) 243 (returnfrom subtypep (values nil nil))) 244 ((eq t2 'and) 245 (dolist (tt i2) 246 (multiplevaluebind (tv flag) (subtypep type1 tt) 247 (unless tv (returnfrom subtypep (values tv flag))))) 248 (returnfrom subtypep (values t t))) 249 ((null (or i1 i2)) 250 (returnfrom subtypep (values (simplesubtypep t1 t2) t))) 251 ((eq t2 'sequence) 252 (cond ((memq t1 '(null cons list)) 253 (values t t)) 254 ((memq t1 '(array simplearray)) 255 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) 256 (values t t) 257 (values nil t))) 258 (t (values nil (knowntypep t1))))) 259 ((eq t2 'vector) 260 (if (eq t1 'basestring) 261 (if (eq (car i2) 'basechar) 262 (values t t) 263 (values nil t)) 264 (values nil (knowntypep t2)))) 265 ((eq t2 'simplestring) 266 (if (memq t1 '(simplestring simplebasestring)) 267 (if (or (null i2) (eq (car i2) '*)) 268 (values t t) 269 (values nil t)) 270 (values nil (knowntypep t2)))) 271 ((eq t2 'basestring) 272 (if (eq t1 'vector) 273 (if (eq (car i1) 'basechar) 274 (values t t) 275 (values nil t)) 276 (values nil (knowntypep 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 (knowntypep t2)))) 283 (t 284 (cond ((eq t1 'float) 285 (if (memq t2 '(float real number)) 286 (values (subintervalp i1 i2) t) 287 (values nil (knowntypep t2)))) 288 ((eq t1 'integer) 289 (if (memq t2 '(integer rational real number)) 290 (values (subintervalp i1 i2) t) 291 (values nil (knowntypep t2)))) 292 ((eq t1 'rational) 293 (if (memq t2 '(rational real number)) 294 (values (subintervalp i1 i2) t) 295 (values nil (knowntypep t2)))) 296 ((eq t1 'real) 297 (if (memq t2 '(real number)) 298 (values (subintervalp i1 i2) t) 299 (values nil (knowntypep t2)))) 300 ((memq t1 '(string simplestring basestring 301 simplebasestring)) 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 (knowntypep t2))))) 308 (t 309 (values nil nil)))))))
Note: See TracChangeset
for help on using the changeset viewer.