X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=70ccba2a7d02067c34f2894bd3d1e071ba5c0578;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=c61a3ebf98eb50c5e446a57306119bf4feb7869c;hpb=0718147bfb76a6e1fae8f5567eda215d205bbacd;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index c61a3eb..70ccba2 100644
--- 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
@@ -216,8 +216,45 @@
 ;;; 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))
+   (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 (csubtypep (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)))))))))
 
 (!define-superclasses function ((function)) !cold-init-forms)
 
@@ -1353,7 +1390,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.
@@ -1533,7 +1570,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)))
@@ -1548,7 +1585,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)