X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=e6be6208409d1795749bb8e18690094e66286e6a;hb=34e8e7fd14989e1c86e9408733b4a73c46dd0a92;hp=f867fc9ad65b55884fb0849e33711cdc4d5b93f5;hpb=f319c3261c5eeb9c96dd003d7bb87664e0eea2fa;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index f867fc9..e6be620 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -237,13 +237,19 @@ (multiple-value-bind (val2 win2) ,y (if (and val1 val2) (values t t) - (values nil (or win1 win2)))))))) + (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) (values nil t)) - ((not (or (fun-type-simple-p type1) - (fun-type-simple-p type2))) + ((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) @@ -298,9 +304,12 @@ (declare (ignore aux)) ; since we require AUXP=NIL (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) (mapcar #'specifier-type required)) - (setf (args-type-optional result) (mapcar #'specifier-type optional)) - (setf (args-type-rest result) (if restp (specifier-type rest) nil)) + (setf (args-type-required result) + (mapcar #'single-value-specifier-type required)) + (setf (args-type-optional result) + (mapcar #'single-value-specifier-type optional)) + (setf (args-type-rest result) + (if restp (single-value-specifier-type rest) nil)) (setf (args-type-keyp result) keyp) (collect ((key-info)) (dolist (key keys) @@ -311,7 +320,7 @@ (error "~@" kwd lambda-list)) (key-info (make-key-info :name kwd - :type (specifier-type (second key)))))) + :type (single-value-specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) (setf (args-type-allowp result) allowp) (values))) @@ -353,7 +362,7 @@ res)) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) + (let ((res (%make-values-type))) (parse-args-types values res) res)) @@ -445,7 +454,7 @@ :initial-element rest2))) exact))) -;;; If Type isn't a values type, then make it into one: +;;; If TYPE isn't a values type, then make it into one: ;;; ==> (values type &rest t) (defun coerce-to-values (type) (declare (type ctype type)) @@ -479,6 +488,8 @@ (defun args-type-op (type1 type2 operation nreq default-type) (declare (type ctype type1 type2 default-type) (type function operation nreq)) + (when (eq type1 type2) + (values type1 t)) (if (or (values-type-p type1) (values-type-p type2)) (let ((type1 (coerce-to-values type1)) (type2 (coerce-to-values type2))) @@ -825,7 +836,7 @@ (defun accumulate1-compound-type (type types %compound-type-p simplify2) (declare (type ctype type)) (declare (type (vector ctype) types)) - (declare (type function simplify2)) + (declare (type function %compound-type-p simplify2)) ;; Any input object satisfying %COMPOUND-TYPE-P should've been ;; broken into components before it reached us. (aver (not (funcall %compound-type-p type))) @@ -914,6 +925,11 @@ nil))) (defun type-intersection (&rest input-types) + (%type-intersection input-types)) +(defun-cached (%type-intersection :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((input-types equal)) (let ((simplified-types (simplified-compound-types input-types #'intersection-type-p #'type-intersection2))) @@ -946,10 +962,15 @@ *universal-type*)))) (defun type-union (&rest input-types) + (%type-union input-types)) +(defun-cached (%type-union :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((input-types equal)) (let ((simplified-types (simplified-compound-types input-types #'union-type-p #'type-union2))) - (make-compound-type-or-something #'%make-union-type + (make-compound-type-or-something #'make-union-type simplified-types (every #'type-enumerable simplified-types) *empty-type*))) @@ -2106,7 +2127,7 @@ *empty-type*)))))) (!define-type-method (member :complex-intersection2) (type1 type2) - (block punt + (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) @@ -2236,7 +2257,6 @@ ((type= type (specifier-type 'float)) 'float) ((type= type (specifier-type 'real)) 'real) ((type= type (specifier-type 'sequence)) 'sequence) - ((type= type (specifier-type 'string-stream)) 'string-stream) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2496,14 +2516,15 @@ (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) + :complexp :maybe :element-type (specifier-type element-type)))) (!def-type-translator simple-array (&optional (element-type '*) (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) - :element-type (specifier-type element-type) - :complexp nil))) + :complexp nil + :element-type (specifier-type element-type)))) ;;;; utilities shared between cross-compiler and target system