X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=e6be6208409d1795749bb8e18690094e66286e6a;hb=34e8e7fd14989e1c86e9408733b4a73c46dd0a92;hp=46b983fa46b2e20da249974a97be619e2f25ecd7;hpb=b811c391c7a0913c5047bfca3e15ec031dcb952c;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 46b983f..e6be620 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -213,10 +213,12 @@
 	    (type-specifier
 	     (fun-type-returns type)))))
 
-;;; Since all function types are equivalent to FUNCTION, they are all
-;;; subtypes of each other.
-(!define-type-method
- (function :simple-subtypep) (type1 type2)
+;;; 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))))
@@ -235,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)
@@ -296,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)
@@ -309,7 +320,7 @@
 	    (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
 		   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)))
@@ -351,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))
 
@@ -443,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:
 ;;;    <type>  ==>  (values type &rest t)
 (defun coerce-to-values (type)
   (declare (type ctype type))
@@ -477,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)))
@@ -823,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)))
@@ -912,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)))
@@ -927,12 +945,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
@@ -940,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*)))
@@ -960,7 +987,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
@@ -1204,7 +1232,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))
@@ -1465,7 +1493,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)))
 
@@ -1590,7 +1619,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)
 
@@ -2095,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)
@@ -2225,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
@@ -2485,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