Changeset 4216
- 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 2003-09-29 01:29:13piso Exp $4 ;;; $Id: subtypep.lisp,v 1.17 2003-10-06 02:25:00 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 110 110 present-p)) 111 111 112 (defun normalize-type (type)112 (defun subtypep-normalize-type (type) 113 113 (let (tp i) 114 114 (loop … … 135 135 ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT) 136 136 (setq tp 'float))) 137 ( cons tp i)))137 (if i (cons tp i) tp))) 138 138 139 139 (defun sub-interval-p (i1 i2) … … 208 208 (when (or (null type1) (eq type2 t)) 209 209 (return-from subtypep (values t t))) 210 (setq type1 ( normalize-type type1)211 type2 ( normalize-type type2))210 (setq type1 (subtypep-normalize-type type1) 211 type2 (subtypep-normalize-type type2)) 212 212 (when (equal type1 type2) 213 213 (return-from 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 (return-from subtypep (cond ((memq t1 '(cons list)) (values nil t)) 220 223 ((known-type-p t1) (values t t)) 221 224 (t (values nil nil))))) 222 (cond ((eq t1 'or) 223 (dolist (tt i1) 224 (multiple-value-bind (tv flag) (subtypep tt type2) 225 (unless tv (return-from subtypep (values tv flag))))) 226 (return-from subtypep (values t t))) 227 ((eq t1 'and) 228 (dolist (tt i1) 229 (let ((tv (subtypep tt type2))) 230 (when tv (return-from subtypep (values t t))))) 231 (return-from subtypep (values nil nil))) 232 ((eq t2 'or) 233 (dolist (tt i2) 234 (let ((tv (subtypep type1 tt))) 235 (when tv (return-from subtypep (values t t))))) 236 (return-from subtypep (values nil nil))) 237 ((eq t2 'and) 238 (dolist (tt i2) 239 (multiple-value-bind (tv flag) (subtypep type1 tt) 240 (unless tv (return-from subtypep (values tv flag))))) 241 (return-from subtypep (values t t))) 242 ((null (or i1 i2)) 243 (return-from subtypep (values (simple-subtypep t1 t2) t))) 244 ((eq t2 'sequence) 245 (cond ((memq t1 '(null cons list)) 246 (values t t)) 247 ((memq t1 '(array simple-array)) 248 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) 249 (values t t) 250 (values nil t))) 251 (t (values nil (known-type-p t1))))) 252 ((eq t2 'vector) 253 (if (eq t1 'base-string) 254 (if (eq (car i2) 'base-char) 255 (values t t) 256 (values nil t)) 257 (values nil (known-type-p t2)))) 258 ((eq t2 'simple-string) 259 (if (memq t1 '(simple-string simple-base-string)) 260 (if (or (null i2) (eq (car i2) '*)) 261 (values t t) 262 (values nil t)) 263 (values nil (known-type-p t2)))) 264 ((eq t2 'base-string) 265 (if (eq t1 'vector) 266 (if (eq (car i1) 'base-char) 267 (values t t) 268 (values nil t)) 269 (values nil (known-type-p 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 (known-type-p t2)))) 276 (t 277 (cond ((eq t1 'float) 278 (if (memq t2 '(float real number)) 279 (values (sub-interval-p i1 i2) t) 280 (values nil (known-type-p t2)))) 281 ((eq t1 'integer) 282 (if (memq t2 '(integer rational real number)) 283 (values (sub-interval-p i1 i2) t) 284 (values nil (known-type-p t2)))) 285 ((eq t1 'rational) 286 (if (memq t2 '(rational real number)) 287 (values (sub-interval-p i1 i2) t) 288 (values nil (known-type-p t2)))) 289 ((eq t1 'real) 290 (if (memq t2 '(real number)) 291 (values (sub-interval-p i1 i2) t) 292 (values nil (known-type-p t2)))) 293 ((memq t1 '(string simple-string base-string 294 simple-base-string)) 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 (known-type-p t2))))) 301 (t 302 (values nil nil))))))) 225 (cond ((eq t1 'member) 226 (dolist (e i1) 227 (unless (typep e type2) (return-from subtypep (values nil t)))) 228 (return-from subtypep (values t t))) 229 ((eq t1 'or) 230 (dolist (tt i1) 231 (multiple-value-bind (tv flag) (subtypep tt type2) 232 (unless tv (return-from subtypep (values tv flag))))) 233 (return-from subtypep (values t t))) 234 ((eq t1 'and) 235 (dolist (tt i1) 236 (let ((tv (subtypep tt type2))) 237 (when tv (return-from subtypep (values t t))))) 238 (return-from subtypep (values nil nil))) 239 ((eq t2 'or) 240 (dolist (tt i2) 241 (let ((tv (subtypep type1 tt))) 242 (when tv (return-from subtypep (values t t))))) 243 (return-from subtypep (values nil nil))) 244 ((eq t2 'and) 245 (dolist (tt i2) 246 (multiple-value-bind (tv flag) (subtypep type1 tt) 247 (unless tv (return-from subtypep (values tv flag))))) 248 (return-from subtypep (values t t))) 249 ((null (or i1 i2)) 250 (return-from subtypep (values (simple-subtypep t1 t2) t))) 251 ((eq t2 'sequence) 252 (cond ((memq t1 '(null cons list)) 253 (values t t)) 254 ((memq t1 '(array simple-array)) 255 (if (and (cdr i1) (consp (cadr i1)) (null (cdadr i1))) 256 (values t t) 257 (values nil t))) 258 (t (values nil (known-type-p t1))))) 259 ((eq t2 'vector) 260 (if (eq t1 'base-string) 261 (if (eq (car i2) 'base-char) 262 (values t t) 263 (values nil t)) 264 (values nil (known-type-p t2)))) 265 ((eq t2 'simple-string) 266 (if (memq t1 '(simple-string simple-base-string)) 267 (if (or (null i2) (eq (car i2) '*)) 268 (values t t) 269 (values nil t)) 270 (values nil (known-type-p t2)))) 271 ((eq t2 'base-string) 272 (if (eq t1 'vector) 273 (if (eq (car i1) 'base-char) 274 (values t t) 275 (values nil t)) 276 (values nil (known-type-p 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 (known-type-p t2)))) 283 (t 284 (cond ((eq t1 'float) 285 (if (memq t2 '(float real number)) 286 (values (sub-interval-p i1 i2) t) 287 (values nil (known-type-p t2)))) 288 ((eq t1 'integer) 289 (if (memq t2 '(integer rational real number)) 290 (values (sub-interval-p i1 i2) t) 291 (values nil (known-type-p t2)))) 292 ((eq t1 'rational) 293 (if (memq t2 '(rational real number)) 294 (values (sub-interval-p i1 i2) t) 295 (values nil (known-type-p t2)))) 296 ((eq t1 'real) 297 (if (memq t2 '(real number)) 298 (values (sub-interval-p i1 i2) t) 299 (values nil (known-type-p t2)))) 300 ((memq t1 '(string simple-string base-string 301 simple-base-string)) 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 (known-type-p t2))))) 308 (t 309 (values nil nil)))))))
Note: See TracChangeset
for help on using the changeset viewer.