From a64589ed34ce0298fae164476af7de14c4652909 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 5 Jul 2003 08:07:09 +0000 Subject: [PATCH] 0.8.1.25: * Implement intersection of function types. --- NEWS | 3 +++ src/code/early-type.lisp | 9 +++++++- src/code/late-type.lisp | 53 +++++++++++++++++++++++++++++++++++-------- tests/defstruct.impure.lisp | 7 ++++++ version.lisp-expr | 2 +- 5 files changed, 62 insertions(+), 12 deletions(-) diff --git a/NEWS b/NEWS index a7a80b5..97aeccc 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4