0.7.10.3:

        Fix bug: (FUNCTION (&REST T)) = (FUNCTION *).

diff --git a/BUGS b/BUGS
index b7b3e60..9da82f2 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1354,6 +1354,9 @@ WORKAROUND:
   but this first return value is not suitable for input to FUNCTION or
   COMPILE, as required by ANSI.
 
   but this first return value is not suitable for input to FUNCTION or
   COMPILE, as required by ANSI.
 

+229:
+  (subtypep 'function '(function)) => nil, t.
+

 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 8da64b8..9dd7a1f 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1205,7 +1205,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
              "SINGLE-FLOAT-INT-EXPONENT"
              "SINGLE-FLOAT-SIGNIFICAND"
              "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
              "SINGLE-FLOAT-INT-EXPONENT"
              "SINGLE-FLOAT-SIGNIFICAND"

-             "SINGLE-VALUE-TYPE" "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
+             "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
+             "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"

              "SPECIFIER-TYPE" "STACK-REF"
              "STREAMLIKE" "STRINGABLE"
              "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"
              "SPECIFIER-TYPE" "STACK-REF"
              "STREAMLIKE" "STRINGABLE"
              "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index e4df2ee..0af4281 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -364,6 +364,12 @@
       (error "VALUES type illegal in this context:~%  ~S" x))
     res))
 
       (error "VALUES type illegal in this context:~%  ~S" x))
     res))
 

+(defun single-value-specifier-type (x)
+  (let ((res (specifier-type x)))
+    (if (eq res *wild-type*)
+        *universal-type*
+        res)))
+

 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 ;;; returning a second value.
 (defun type-expand (form)
 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 ;;; returning a second value.
 (defun type-expand (form)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f0b2fc6..ff52c67 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -241,7 +241,13 @@
      (3and (values-subtypep (fun-type-returns type1)
                             (fun-type-returns type2))
            (cond ((fun-type-wild-args type2) (values t t))
      (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))
+                 ((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))
                  ((not (and (fun-type-simple-p type1)
                             (fun-type-simple-p type2)))
                   (values nil nil))

@@ -298,9 +304,12 @@
     (declare (ignore aux)) ; since we require AUXP=NIL
     (when auxp
       (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
     (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)
     (setf (args-type-keyp result) keyp)
     (collect ((key-info))
       (dolist (key keys)

@@ -311,7 +320,7 @@
            (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
                   kwd lambda-list))
          (key-info (make-key-info :name kwd
            (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)))
       (setf (args-type-keywords result) (key-info)))
     (setf (args-type-allowp result) allowp)
     (values)))

@@ -445,7 +454,7 @@
                                       :initial-element rest2)))
            exact)))
 
                                       :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))
 ;;;    <type>  ==>  (values type &rest t)
 (defun coerce-to-values (type)
   (declare (type ctype type))

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index e5bd13b..a770835 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -167,6 +167,17 @@
 (assert (not (equal (multiple-value-list
                      (subtypep '(function ()) '(function (&rest t))))
                     '(nil t))))
 (assert (not (equal (multiple-value-list
                      (subtypep '(function ()) '(function (&rest t))))
                     '(nil t))))

+

 (assert (not (equal (multiple-value-list
                      (subtypep '(function (&rest t)) '(function ())))
                     '(t t))))
 (assert (not (equal (multiple-value-list
                      (subtypep '(function (&rest t)) '(function ())))
                     '(t t))))

+
+(assert (subtypep '(function)
+                  '(function (&optional * &rest t))))
+(assert (equal (multiple-value-list
+                (subtypep '(function)
+                          '(function (t &rest t))))
+               '(nil t)))
+#+nil
+(assert (and (subtypep 'function '(function))
+             (subtypep '(function) 'function)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 07b2178..ef3d3fd 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 

-"0.7.10.2"
+"0.7.10.3"