0.7.9.20:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f8c6561..46b983f 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -69,7 +69,7 @@
   ;; If TYPE2 might be concealing something related to our class
   ;; hierarchy
   (if (type-might-contain-other-types-p type2)
-      ;; too confusing, gotta punt 
+      ;; too confusing, gotta punt
       (values nil nil)
       ;; ordinary case expected by old CMU CL code, where the taxonomy
       ;; of TYPE2's representation accurately reflects the taxonomy of
@@ -215,9 +215,50 @@
 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.
-(!define-type-method (function :simple-subtypep) (type1 type2)
-  (declare (ignore type1 type2))
-  (values t t))
+(!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))
+                 (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)
 
@@ -1008,8 +1049,9 @@
 \f
 ;;;; hairy and unknown types
 
-(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
-
+(!define-type-method (hairy :unparse) (x)
+  (hairy-type-specifier x))
+    
 (!define-type-method (hairy :simple-subtypep) (type1 type2)
   (let ((hairy-spec1 (hairy-type-specifier type1))
        (hairy-spec2 (hairy-type-specifier type2)))
@@ -1352,7 +1394,7 @@
          (t
           (values nil t)))))
 
-(!define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((number)) !cold-init-forms)
 
 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
 ;;; then return true, otherwise NIL.
@@ -1532,7 +1574,7 @@
        ;; previously we threw an error here:
        ;; (error "Lower bound ~S is greater than upper bound ~S." l h))
        ;; but ANSI doesn't say anything about that, so:
-       (specifier-type 'nil)
+       *empty-type*
       (make-numeric-type :class 'integer
                         :complexp :real
                         :enumerable (not (null (and l h)))
@@ -1547,7 +1589,7 @@
           ;; as above, previously we did
           ;; (error "Lower bound ~S is not less than upper bound ~S." low high))
           ;; but it is correct to do
-          (specifier-type 'nil)
+          *empty-type*
         (make-numeric-type :class ',class :format ',format :low lb :high hb)))))
 
 (!def-bounded-type rational rational nil)
@@ -2018,9 +2060,10 @@
 
 (!define-type-method (member :unparse) (type)
   (let ((members (member-type-members type)))
-    (if (equal members '(nil))
-       'null
-       `(member ,@members))))
+    (cond
+      ((equal members '(nil)) 'null)
+      ((type= type (specifier-type 'standard-char)) 'standard-char)
+      (t `(member ,@members)))))
 
 (!define-type-method (member :simple-subtypep) (type1 type2)
   (values (subsetp (member-type-members type1) (member-type-members type2))
@@ -2173,13 +2216,17 @@
 
 (!define-type-class union)
 
-;;; The LIST type has a special name. Other union types just get
-;;; mechanically unparsed.
+;;; The LIST, FLOAT and REAL types have special names.  Other union
+;;; types just get mechanically unparsed.
 (!define-type-method (union :unparse) (type)
   (declare (type ctype type))
-  (if (type= type (specifier-type 'list))
-      'list
-      `(or ,@(mapcar #'type-specifier (union-type-types type)))))
+  (cond
+    ((type= type (specifier-type 'list)) 'list)
+    ((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
 ;;; other. We need to be this clever because our complex subtypep