Changeset 12467 for trunk/source/level1/l1typesys.lisp
 Timestamp:
 Jul 27, 2009, 7:41:02 PM (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/source/level1/l1typesys.lisp
r12371 r12467 724 724 725 725 726 (definetypemethod (function :complexintersection) (type1 type2) 727 (declare (type functionctype type2)) 728 (let ((function (specifiertype 'function))) 729 (if (eq type1 function) 730 type2 731 (typeintersection2 type1 function)))) 732 733 734 726 735 ;;; ### Not very real, but good enough for redefining transforms according to 727 736 ;;; type: … … 1222 1231 ;;; value (trying not to return a hairy type). 1223 1232 (defun typeapproxintersection2 (type1 type2) 1233 (declare (type ctype type1 type2)) 1224 1234 (cond ((typeintersection2 type1 type2)) 1225 1235 ((hairyctypep type1) type2) … … 1266 1276 (defun simplifyintersections (types) 1267 1277 (when types 1268 (multiplevaluebind (first rest) 1269 (if (intersectionctypep (car types)) 1270 (values (car (intersectionctypetypes (car types))) 1271 (append (cdr (intersectionctypetypes (car types))) 1278 (let ((first (if (typep (car types) 'ctype) 1279 (%car types) 1280 (specifiertype (%car types))))) 1281 (multiplevaluebind (first rest) 1282 (if (intersectionctypep first) 1283 (values (car (intersectionctypetypes first)) 1284 (append (cdr (intersectionctypetypes first)) 1272 1285 (cdr types))) 1273 (values (car types)(cdr types)))1274 1275 (dolist (r rest (cons first rest))1276 (when (setq u (typeintersection2 first r))1277 (return (simplifyintersections (nsubstitute u r rest)))))))))1286 (values first (cdr types))) 1287 (let ((rest (simplifyintersections rest)) u) 1288 (dolist (r rest (cons first rest)) 1289 (when (setq u (typeintersection2 first r)) 1290 (return (simplifyintersections (nsubstitute u r rest)))))))))) 1278 1291 1279 1292 (defun typeintersection2 (type1 type2) … … 1295 1308 ((let ((function (specifiertype 'function))) 1296 1309 (or (and (functionctypep type1) 1297 (not (or (functionctypep type2) (eq function type2))) 1310 (not (functionctypep type2)) 1311 (neq function type2) 1298 1312 (csubtypep type2 function) 1299 1313 (not (csubtypep function type2))) 1300 1314 (and (functionctypep type2) 1301 (not (or (functionctypep type1) (eq function type1))) 1315 (not (functionctypep type1)) 1316 (neq function type1) 1302 1317 (csubtypep type1 function) 1303 1318 (not (csubtypep function type1))))) … … 3544 3559 (> (countif #'classctypep (intersectionctypetypes type1)) 1)) 3545 3560 (values nil nil) 3546 (invokecomplexsubtypeparg1method type1 class2 nil t))) 3561 (if (functionctypep type1) 3562 (csubtypep (specifiertype 'function) class2) 3563 (invokecomplexsubtypeparg1method type1 class2 nil t)))) 3547 3564 3548 3565 (definetypemethod (class :complexsubtypeparg1) (type1 type2)
Note: See TracChangeset
for help on using the changeset viewer.