Changeset 12467


Ignore:
Timestamp:
Jul 27, 2009, 7:41:02 PM (10 years ago)
Author:
gz
Message:

Better handling for function ctype

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-typesys.lisp

    r12371 r12467  
    724724
    725725
     726(define-type-method (function :complex-intersection) (type1 type2)
     727  (declare (type function-ctype type2))
     728  (let ((function (specifier-type 'function)))
     729    (if (eq type1 function)
     730      type2
     731      (type-intersection2 type1 function))))
     732
     733
     734
    726735;;; ### Not very real, but good enough for redefining transforms according to
    727736;;; type:
     
    12221231;;; value (trying not to return a hairy type).
    12231232(defun type-approx-intersection2 (type1 type2)
     1233  (declare (type ctype type1 type2))
    12241234  (cond ((type-intersection2 type1 type2))
    12251235        ((hairy-ctype-p type1) type2)
     
    12661276(defun simplify-intersections (types)
    12671277  (when types
    1268     (multiple-value-bind (first rest)
    1269         (if (intersection-ctype-p (car types))
    1270             (values (car (intersection-ctype-types (car types)))
    1271                     (append (cdr (intersection-ctype-types (car types)))
     1278    (let ((first (if (typep (car types) 'ctype)
     1279                   (%car types)
     1280                   (specifier-type (%car types)))))
     1281      (multiple-value-bind (first rest)
     1282          (if (intersection-ctype-p first)
     1283            (values (car (intersection-ctype-types first))
     1284                    (append (cdr (intersection-ctype-types first))
    12721285                            (cdr types)))
    1273             (values (car types) (cdr types)))
    1274       (let ((rest (simplify-intersections rest)) u)
    1275         (dolist (r rest (cons first rest))
    1276           (when (setq u (type-intersection2 first r))
    1277             (return (simplify-intersections (nsubstitute u r rest)))))))))
     1286            (values first (cdr types)))
     1287        (let ((rest (simplify-intersections rest)) u)
     1288          (dolist (r rest (cons first rest))
     1289            (when (setq u (type-intersection2 first r))
     1290              (return (simplify-intersections (nsubstitute u r rest))))))))))
    12781291
    12791292(defun type-intersection2 (type1 type2)
     
    12951308        ((let ((function (specifier-type 'function)))
    12961309           (or (and (function-ctype-p type1)
    1297                     (not (or (function-ctype-p type2) (eq function type2)))
     1310                    (not (function-ctype-p type2))
     1311                    (neq function type2)
    12981312                    (csubtypep type2 function)
    12991313                    (not (csubtypep function type2)))
    13001314               (and (function-ctype-p type2)
    1301                     (not (or (function-ctype-p type1) (eq function type1)))
     1315                    (not (function-ctype-p type1))
     1316                    (neq function type1)
    13021317                    (csubtypep type1 function)
    13031318                    (not (csubtypep function type1)))))
     
    35443559           (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1))
    35453560      (values nil nil)
    3546       (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
     3561      (if (function-ctype-p type1)
     3562        (csubtypep (specifier-type 'function) class2)
     3563        (invoke-complex-subtypep-arg1-method type1 class2 nil t))))
    35473564
    35483565(define-type-method (class :complex-subtypep-arg1) (type1 type2)
Note: See TracChangeset for help on using the changeset viewer.