0.8.0.76:

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

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f7c6050..dd6c403 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -150,7 +150,13 @@
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
 (!define-type-method (values :unparse) (type)
-  (cons 'values (unparse-args-types type)))
+  (cons 'values
+        (let ((unparsed (unparse-args-types type)))
+          (if (or (values-type-optional type)
+                  (values-type-rest type)
+                  (values-type-allowp type))
+              unparsed
+              (nconc unparsed '(&optional))))))
 
 ;;; Return true if LIST1 and LIST2 have the same elements in the same
 ;;; positions according to TYPE=. We return NIL, NIL if there is an
@@ -273,10 +279,41 @@
     ((type= type1 (specifier-type 'function)) type1)
     (t nil)))
 
-;;; ### Not very real, but good enough for redefining transforms
-;;; according to type:
 (!define-type-method (function :simple-=) (type1 type2)
-  (values (equalp type1 type2) t))
+  (macrolet ((compare (comparator field)
+               (let ((reader (symbolicate '#:fun-type- field)))
+                 `(,comparator (,reader type1) (,reader type2)))))
+    (and/type (compare type= returns)
+              (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2))
+                     (values nil t))
+                    ((eq (fun-type-wild-args type1) t)
+                     (values t t))
+                    (t (and/type
+                        (cond ((null (fun-type-rest type1))
+                               (values (null (fun-type-rest type2)) t))
+                              ((null (fun-type-rest type2))
+                               (values nil t))
+                              (t
+                               (compare type= rest)))
+                        (labels ((type-list-= (l1 l2)
+                                   (cond ((null l1)
+                                          (values (null l2) t))
+                                         ((null l2)
+                                          (values nil t))
+                                         (t (multiple-value-bind (res winp)
+                                                (type= (first l1) (first l2))
+                                              (cond ((not winp)
+                                                     (values nil nil))
+                                                    ((not res)
+                                                     (values nil t))
+                                                    (t
+                                                     (type-list-= (rest l1)
+                                                                  (rest l2)))))))))
+                          (and/type (and/type (compare type-list-= required)
+                                              (compare type-list-= optional))
+                              (if (or (fun-type-keyp type1) (fun-type-keyp type2))
+                                  (values nil nil)
+                                  (values t t))))))))))
 
 (!define-type-class constant :inherits values)
 
@@ -287,7 +324,7 @@
   (type= (constant-type-type type1) (constant-type-type type2)))
 
 (!def-type-translator constant-arg (type)
-  (make-constant-type :type (specifier-type type)))
+  (make-constant-type :type (single-value-specifier-type type)))
 
 ;;; Return the lambda-list-like type specification corresponding
 ;;; to an ARGS-TYPE.
@@ -396,7 +433,7 @@
 
 ;;; If COUNT values are supplied, which types should they have?
 (defun values-type-start (type count)
-  (declare (ctype type) (unsigned-byte count))
+  (declare (type ctype type) (type unsigned-byte count))
   (if (eq type *wild-type*)
       (make-list count :initial-element *universal-type*)
       (collect ((res))
@@ -972,10 +1009,11 @@
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *universal-fun-type*)
+
 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn
-                (setq ,var (make-named-type :name ',name))
+                 (setq ,var (make-named-type :name ',name))
                 (setf (info :type :kind ',name)
                       #+sb-xc-host :defined #-sb-xc-host :primitive)
                 (setf (info :type :builtin ',name) ,var))))
@@ -2661,8 +2699,8 @@
 (!define-type-class cons)
 
 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
-  (let ((car-type (specifier-type car-type-spec))
-       (cdr-type (specifier-type cdr-type-spec)))
+  (let ((car-type (single-value-specifier-type car-type-spec))
+       (cdr-type (single-value-specifier-type cdr-type-spec)))
     (make-cons-type car-type cdr-type)))
  
 (!define-type-method (cons :unparse) (type)
@@ -2788,14 +2826,18 @@
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
                     :complexp :maybe
-                   :element-type (specifier-type element-type))))
+                   :element-type (if (eq element-type '*)
+                                      *wild-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)
                     :complexp nil
-                   :element-type (specifier-type element-type))))
+                   :element-type (if (eq element-type '*)
+                                      *wild-type*
+                                      (specifier-type element-type)))))
 \f
 ;;;; utilities shared between cross-compiler and target system