From: Alexey D. <ade...@us...> - 2003-07-05 08:07:13
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv7991/src/code Modified Files: early-type.lisp late-type.lisp Log Message: 0.8.1.25: * Implement intersection of function types. Index: early-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- early-type.lisp 11 Jun 2003 09:11:43 -0000 1.38 +++ early-type.lisp 5 Jul 2003 08:07:09 -0000 1.39 @@ -175,7 +175,14 @@ ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes (defstruct (fun-type (:include args-type (class-info (type-class-or-lose 'function))) - (:constructor %make-fun-type)) + (:constructor + %make-fun-type (&key required optional rest + keyp keywords allowp + wild-args + returns + &aux (rest (if (eq rest *empty-type*) + nil + rest))))) ;; true if the arguments are unrestrictive, i.e. * (wild-args nil :type boolean) ;; type describing the return values. This is a values type Index: late-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v retrieving revision 1.90 retrieving revision 1.91 diff -u -d -r1.90 -r1.91 --- late-type.lisp 4 Jul 2003 05:18:25 -0000 1.90 +++ late-type.lisp 5 Jul 2003 08:07:09 -0000 1.91 @@ -275,8 +275,36 @@ (declare (ignore type1 type2)) (specifier-type 'function)) (!define-type-method (function :simple-intersection2) (type1 type2) - (declare (ignore type1 type2)) - (specifier-type 'function)) + (let ((ftype (specifier-type 'function))) + (cond ((eq type1 ftype) type2) + ((eq type2 ftype) type1) + (t (let ((rtype (values-type-intersection (fun-type-returns type1) + (fun-type-returns type2)))) + (flet ((change-returns (ftype rtype) + (declare (type fun-type ftype) (type ctype rtype)) + (make-fun-type :required (fun-type-required ftype) + :optional (fun-type-optional ftype) + :keyp (fun-type-keyp ftype) + :keywords (fun-type-keywords ftype) + :allowp (fun-type-allowp ftype) + :returns rtype))) + (cond + ((fun-type-wild-args type1) + (if (fun-type-wild-args type2) + (make-fun-type :wild-args t + :returns rtype) + (change-returns type2 rtype))) + ((fun-type-wild-args type2) + (change-returns type1 rtype)) + (t (multiple-value-bind (req opt rest) + (args-type-op type1 type2 #'type-intersection #'max) + (make-fun-type :required req + :optional opt + :rest rest + ;; FIXME: :keys + :allowp (and (fun-type-allowp type1) + (fun-type-allowp type2)) + :returns rtype)))))))))) ;;; The union or intersection of a subclass of FUNCTION with a ;;; FUNCTION type is somewhat complicated. @@ -565,12 +593,17 @@ (length (args-type-required type2)))) (required (subseq res 0 req)) (opt (subseq res req))) - (values (make-values-type - :required required - :optional opt - :rest rest) + (values required opt rest (and rest-exact res-exact)))))))) +(defun values-type-op (type1 type2 operation nreq) + (multiple-value-bind (required optional rest exactp) + (args-type-op type1 type2 operation nreq) + (values (make-values-type :required required + :optional optional + :rest rest) + exactp))) + ;;; Do a union or intersection operation on types that might be values ;;; types. The result is optimized for utility rather than exactness, ;;; but it is guaranteed that it will be no smaller (more restrictive) @@ -588,7 +621,7 @@ ((eq type1 *empty-type*) type2) ((eq type2 *empty-type*) type1) (t - (values (args-type-op type1 type2 #'type-union #'min))))) + (values (values-type-op type1 type2 #'type-union #'min))))) (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 @@ -611,9 +644,9 @@ :rest (values-type-rest type1) :allowp (values-type-allowp type1)))) (t - (args-type-op type1 (coerce-to-values type2) - #'type-intersection - #'max)))) + (values-type-op type1 (coerce-to-values type2) + #'type-intersection + #'max)))) ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of ;;; works on VALUES types. Note that due to the semantics of |