X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=a790c44a31e1c0a82a83e6329bcac1d0b4685230;hb=a96369c72588c5457d71d6aaea35f2c450b19ef5;hp=f3f7f0d77526d5dc63e145cfdf7bcaf1180a00a0;hpb=f3b213e5fea9992b3a9a1f2a6c482239a1aff3c1;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index f3f7f0d..a790c44 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -213,46 +213,54 @@ (type-specifier (fun-type-returns type))))) +;;; The meaning of this is a little confused. On the one hand, all +;;; function objects are represented the same way regardless of the +;;; arglists and return values, and apps don't get to ask things like +;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the +;;; other hand, Python wants to reason about function types. So... (!define-type-method (function :simple-subtypep) (type1 type2) - (flet ((fun-type-simple-p (type) - (not (or (fun-type-rest type) - (fun-type-keyp type)))) - (every-csubtypep (types1 types2) - (loop - for a1 in types1 - for a2 in types2 - do (multiple-value-bind (res sure-p) - (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 (or win1 win2)))))))) - (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))) - (values nil nil)) - ((not (and (= (length (fun-type-required type1)) - (length (fun-type-required type2))) - (= (length (fun-type-optional type1)) - (length (fun-type-optional type2))))) - (values nil t)) - (t (3and (every-csubtypep (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep (fun-type-optional type1) - (fun-type-optional type2))))))))) + (flet ((fun-type-simple-p (type) + (not (or (fun-type-rest type) + (fun-type-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (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 (or win1 win2)))))))) + (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))) + (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))))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -345,7 +353,7 @@ res)) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) + (let ((res (%make-values-type))) (parse-args-types values res) res)) @@ -471,6 +479,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))) @@ -906,6 +916,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))) @@ -921,12 +936,16 @@ (if (and (> (length simplified-types) 1) (some #'union-type-p simplified-types)) (let* ((first-union (find-if #'union-type-p simplified-types)) - (other-types (coerce (remove first-union simplified-types) 'list)) - (distributed (maybe-distribute-one-union first-union other-types))) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) (if distributed (apply #'type-union distributed) (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))))) + :specifier `(and ,@(map 'list + #'type-specifier + simplified-types))))) (make-compound-type-or-something #'%make-intersection-type simplified-types (some #'type-enumerable @@ -934,10 +953,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*))) @@ -954,7 +978,8 @@ (macrolet ((frob (name var) `(progn (setq ,var (make-named-type :name ',name)) - (setf (info :type :kind ',name) #+sb-xc-host :defined #-sb-xc-host :primitive) + (setf (info :type :kind ',name) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin ',name) ,var)))) ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a ;; special symbol which can be stuck in some places where an @@ -1198,7 +1223,7 @@ (error 'simple-type-error :datum predicate-name :expected-type 'symbol - :format-control "~S is not a symbol." + :format-control "The SATISFIES predicate name is not a symbol: ~S" :format-arguments (list predicate-name)))) ;; Create object. (make-hairy-type :specifier whole)) @@ -1459,7 +1484,8 @@ >= > t))))))) (!cold-init-forms - (setf (info :type :kind 'number) #+sb-xc-host :defined #-sb-xc-host :primitive) + (setf (info :type :kind 'number) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) @@ -1584,7 +1610,10 @@ ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) ;; but it is correct to do *empty-type* - (make-numeric-type :class ',class :format ',format :low lb :high hb))))) + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) @@ -2089,7 +2118,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) @@ -2219,7 +2248,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 @@ -2479,14 +2507,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