From: Alexey D. <ade...@us...> - 2003-04-09 12:42:30
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv11176/src/code Modified Files: early-extensions.lisp late-type.lisp Log Message: 0.pre8.51: TYPE=-SET uses 3-values logic. Index: early-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v retrieving revision 1.54 retrieving revision 1.55 diff -u -d -r1.54 -r1.55 --- early-extensions.lisp 1 Apr 2003 13:18:19 -0000 1.54 +++ early-extensions.lisp 9 Apr 2003 12:42:25 -0000 1.55 @@ -916,6 +916,15 @@ ;;;; utilities for two-VALUES predicates +(defmacro and/type (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2)))))))) + ;;; sort of like ANY and EVERY, except: ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. ;;; (And if the result is uncertain, then we return (VALUES NIL NIL), Index: late-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v retrieving revision 1.75 retrieving revision 1.76 diff -u -d -r1.75 -r1.76 --- late-type.lisp 24 Mar 2003 18:39:01 -0000 1.75 +++ late-type.lisp 9 Apr 2003 12:42:25 -0000 1.76 @@ -231,43 +231,35 @@ (csubtypep a1 a2) (unless res (return (values res sure-p)))) finally (return (values t t))))) - (macrolet ((3and (x y) - `(multiple-value-bind (val1 win1) ,x - (if (and (not val1) win1) - (values nil t) - (multiple-value-bind (val2 win2) ,y - (if (and val1 val2) - (values t t) - (values nil (and win2 (not val2))))))))) - (3and (values-subtypep (fun-type-returns type1) - (fun-type-returns type2)) - (cond ((fun-type-wild-args type2) (values t t)) - ((fun-type-wild-args type1) - (cond ((fun-type-keyp type2) (values nil nil)) - ((not (fun-type-rest type2)) (values nil t)) - ((not (null (fun-type-required type2))) (values nil t)) - (t (3and (type= *universal-type* (fun-type-rest type2)) - (every/type #'type= *universal-type* - (fun-type-optional type2)))))) - ((not (and (fun-type-simple-p type1) - (fun-type-simple-p type2))) - (values nil nil)) - (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) - (multiple-value-bind (min2 max2) (fun-type-nargs type2) - (cond ((or (> max1 max2) (< min1 min2)) - (values nil t)) - ((and (= min1 min2) (= max1 max2)) - (3and (every-csubtypep (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep (fun-type-optional type1) - (fun-type-optional type2)))) - (t (every-csubtypep - (concatenate 'list - (fun-type-required type1) - (fun-type-optional type1)) - (concatenate 'list - (fun-type-required type2) - (fun-type-optional type2))))))))))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) (values nil t)) + (t (and/type (type= *universal-type* (fun-type-rest type2)) + (every/type #'type= *universal-type* + (fun-type-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (and/type (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -2404,15 +2396,13 @@ ;;; shared machinery for type equality: true if every type in the set ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (flet (;; true if every type in the set X matches a type in the set Y - (type<=-set (x y) + (flet ((type<=-set (x y) (declare (type list x y)) - (every (lambda (xelement) - (position xelement y :test #'type=)) - x))) - (values (and (type<=-set types1 types2) - (type<=-set types2 types1)) - t))) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) ;;; Two intersection types are equal if their subtypes are equal sets. ;;; |