0.7.9.41:

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 46b983f..3cd0808 100644 (file)
--- 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))))
@@ -351,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))
 \f
@@ -477,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)))
@@ -912,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)))
@@ -927,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
@@ -940,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*)))
@@ -960,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
@@ -1204,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))
@@ -1465,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)))
 
@@ -1590,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)
 
@@ -2095,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)
@@ -2485,14 +2508,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))))
 \f
 ;;;; utilities shared between cross-compiler and target system