0.8.1.25:

        * Implement intersection of function types.

diff --git a/NEWS b/NEWS
index a7a80b5..97aeccc 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1908,6 +1908,9 @@ changes in sbcl-0.8.2 relative to sbcl-0.8.1:
   * bug fix: (SETF AREF) on byte-sized-element arrays with constant index
     argument now works properly on the MIPS platform.
   * fixed compiler failure on (TYPEP x '(NOT (MEMBER 0d0))).
+  * repeated evaluation of the same DEFSTRUCT, a slot of which is
+    declared to have a functional type, does not cause an error
+    anymore.
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** LAST and [N]BUTLAST should accept a bignum.
 

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 9999bff..048b61a 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -175,7 +175,14 @@
 ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
 (defstruct (fun-type (:include args-type
                               (class-info (type-class-or-lose 'function)))
-                     (:constructor %make-fun-type))
+                     (:constructor
+                      %make-fun-type (&key required optional rest
+                                           keyp keywords allowp
+                                           wild-args
+                                           returns
+                                      &aux (rest (if (eq rest *empty-type*)
+                                                     nil
+                                                     rest)))))
   ;; true if the arguments are unrestrictive, i.e. *
   (wild-args nil :type boolean)
   ;; type describing the return values. This is a values type

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 1f561ac..861ff45 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -275,8 +275,36 @@
   (declare (ignore type1 type2))
   (specifier-type 'function))
 (!define-type-method (function :simple-intersection2) (type1 type2)
-  (declare (ignore type1 type2))
-  (specifier-type 'function))
+  (let ((ftype (specifier-type 'function)))
+    (cond ((eq type1 ftype) type2)
+          ((eq type2 ftype) type1)
+          (t (let ((rtype (values-type-intersection (fun-type-returns type1)
+                                                    (fun-type-returns type2))))
+               (flet ((change-returns (ftype rtype)
+                        (declare (type fun-type ftype) (type ctype rtype))
+                        (make-fun-type :required (fun-type-required ftype)
+                                       :optional (fun-type-optional ftype)
+                                       :keyp (fun-type-keyp ftype)
+                                       :keywords (fun-type-keywords ftype)
+                                       :allowp (fun-type-allowp ftype)
+                                       :returns rtype)))
+               (cond
+                 ((fun-type-wild-args type1)
+                  (if (fun-type-wild-args type2)
+                      (make-fun-type :wild-args t
+                                     :returns rtype)
+                      (change-returns type2 rtype)))
+                 ((fun-type-wild-args type2)
+                  (change-returns type1 rtype))
+                 (t (multiple-value-bind (req opt rest)
+                        (args-type-op type1 type2 #'type-intersection #'max)
+                      (make-fun-type :required req
+                                     :optional opt
+                                     :rest rest
+                                     ;; FIXME: :keys
+                                     :allowp (and (fun-type-allowp type1)
+                                                  (fun-type-allowp type2))
+                                     :returns rtype))))))))))
 
 ;;; The union or intersection of a subclass of FUNCTION with a
 ;;; FUNCTION type is somewhat complicated.
@@ -565,12 +593,17 @@
                                (length (args-type-required type2))))
                  (required (subseq res 0 req))
                  (opt (subseq res req)))
-            (values (make-values-type
-                     :required required
-                     :optional opt
-                     :rest rest)
+            (values required opt rest
                     (and rest-exact res-exact))))))))
 
+(defun values-type-op (type1 type2 operation nreq)
+  (multiple-value-bind (required optional rest exactp)
+      (args-type-op type1 type2 operation nreq)
+    (values (make-values-type :required required
+                              :optional optional
+                              :rest rest)
+            exactp)))
+
 ;;; Do a union or intersection operation on types that might be values
 ;;; types. The result is optimized for utility rather than exactness,
 ;;; but it is guaranteed that it will be no smaller (more restrictive)
@@ -588,7 +621,7 @@
         ((eq type1 *empty-type*) type2)
         ((eq type2 *empty-type*) type1)
         (t
-         (values (args-type-op type1 type2 #'type-union #'min)))))
+         (values (values-type-op type1 type2 #'type-union #'min)))))
 
 (defun-cached (values-type-intersection :hash-function type-cache-hash
                                        :hash-bits 8
@@ -611,9 +644,9 @@
                            :rest (values-type-rest type1)
                            :allowp (values-type-allowp type1))))
         (t
-         (args-type-op type1 (coerce-to-values type2)
-                       #'type-intersection
-                       #'max))))
+         (values-type-op type1 (coerce-to-values type2)
+                         #'type-intersection
+                         #'max))))
 
 ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
 ;;; works on VALUES types. Note that due to the semantics of

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 23f9bc7..029babd 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -514,6 +514,13 @@
   (test list)
   (test vector))
 
+(let* ((name (gensym))
+       (form `(defstruct ,name
+                (x nil :type (or null (function (integer)
+                                                (values number &optional foo)))))))
+  (eval (copy-tree form))
+  (eval (copy-tree form)))
+
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index f1f8534..b6d16fa 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.1.24"
+"0.8.1.25"