From 83b88ebcc07cda4daec275fa851664495a840445 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Tue, 20 Mar 2001 16:49:07 +0000 Subject: [PATCH] 0.6.11.19: fixed bug 88: made CROSS-TYPEP support KEYWORD, so that (SUBTYPEP '(MEMBER :FOO) 'KEYWORD)=>T,T made CROSS-TYPEP use EVERY/TYPE and ANY/TYPE for AND and OR types --- BUGS | 5 --- base-target-features.lisp-expr | 4 ++ package-data-list.lisp-expr | 1 + src/code/cross-type.lisp | 79 ++++++++++++++++++---------------------- src/code/early-extensions.lisp | 25 +++++++++++++ src/code/typedefs.lisp | 25 +------------ tests/type.before-xc.lisp | 14 +++++-- version.lisp-expr | 2 +- 8 files changed, 78 insertions(+), 77 deletions(-) diff --git a/BUGS b/BUGS index 5e56ae9..0ee92e1 100644 --- a/BUGS +++ b/BUGS @@ -832,11 +832,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0)) does not. -88: - The type system doesn't understand that the intersection of the - types (MEMBER :FOO) and (OR KEYWORD NULL) is (MEMBER :FOO). Thus, - the optimizer can't make some useful valid type inferences. - 89: The type system doesn't understand the the intersection of the types KEYWORD and (OR KEYWORD NULL) is KEYWORD, perhaps because KEYWORD diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 8f169b8..85d3723 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -2,6 +2,10 @@ ;;;; CL:*FEATURES* in the target SBCL, plus some comments about other ;;;; CL:*FEATURES* tags which have special meaning to SBCL or which ;;;; have a special conventional meaning +;;;; +;;;; Note that the preferred way to customize the features of a local +;;;; build of SBCL is not to edit this file, but to tweak +;;;; customize-target-features.lisp. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9834167..00b5e5e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -681,6 +681,7 @@ retained, possibly temporariliy, because it might be used internally." "SANE-PACKAGE" "CIRCULAR-LIST-P" "SWAPPED-ARGS-FUN" + "ANY/TYPE" "EVERY/TYPE" ;; ..and macros.. "COLLECT" diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index a43b3c4..cb84278 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -109,9 +109,10 @@ (warn-about-possible-float-info-loss () (warn-possible-cross-type-float-info-loss `(cross-typep ,host-object ,target-type)))) - (cond (;; Handle various SBCL-specific types which can't exist on the - ;; ANSI cross-compilation host. KLUDGE: This code will need to be - ;; tweaked by hand if the names of these types ever change, ugh! + (cond (;; Handle various SBCL-specific types which can't exist on + ;; the ANSI cross-compilation host. KLUDGE: This code will + ;; need to be tweaked by hand if the names of these types + ;; ever change, ugh! (if (consp target-type) (member (car target-type) '(sb!alien:alien)) @@ -120,11 +121,11 @@ funcallable-instance sb!alien-internals:alien-value))) (values nil t)) - (;; special case when TARGET-TYPE isn't a type spec, but instead - ;; a CLASS object + (;; special case when TARGET-TYPE isn't a type spec, but + ;; instead a CLASS object (typep target-type 'sb!xc::structure-class) - ;; SBCL-specific types which have an analogue specially created - ;; on the host system + ;; SBCL-specific types which have an analogue specially + ;; created on the host system (if (sb!xc:subtypep (sb!xc:class-name target-type) 'sb!kernel::structure!object) (values (typep host-object (sb!xc:class-name target-type)) t) @@ -162,31 +163,18 @@ ;; between any host ANSI Common Lisp and the target SBCL. ((integer member mod rational real signed-byte unsigned-byte) (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, too, but - ;; less exactly. + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. ((single-float double-float) (cond ((floatp host-object) (warn-about-possible-float-info-loss) (values (typep host-object target-type) t)) (t (values nil t)))) - ;; Some complex types have translations that are less trivial. - (and - ;; Note: This could be implemented as a real test, just the way - ;; that OR is; I just haven't bothered. -- WHN 19990706 - (warn-and-give-up)) - (or (let ((opinion nil) - (certain-p t)) - (dolist (i rest) - (multiple-value-bind (sub-opinion sub-certain-p) - (cross-typep host-object i) - (cond (sub-opinion (setf opinion t - certain-p t) - (return)) - ((not sub-certain-p) (setf certain-p nil)))) - (if certain-p - (values opinion t) - (warn-and-give-up))))) + ;; Some complex types have translations that are less + ;; trivial. + (and (every/type #'cross-typep host-object rest)) + (or (any/type #'cross-typep host-object rest)) ;; Some complex types are too hard to handle in the positive ;; case, but at least we can be confident in a large fraction of ;; the negative cases.. @@ -206,8 +194,8 @@ (if (functionp host-object) (warn-and-give-up) (values nil t))) - ;; And the Common Lisp type system is complicated, and we don't - ;; try to implement everything. + ;; And the Common Lisp type system is complicated, and + ;; we don't try to implement everything. (otherwise (warn-and-give-up))))) (t (case target-type @@ -228,11 +216,12 @@ ;; between any host ANSI Common Lisp and the target ;; Common Lisp. (Some array types are too, but they ;; were picked off earlier.) - ((bit character complex cons float function integer list nil - null number rational real signed-byte symbol t unsigned-byte) + ((bit character complex cons float function integer keyword + list nil null number rational real signed-byte symbol t + unsigned-byte) (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, too, but - ;; less exactly. + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. ((single-float double-float) (cond ((floatp host-object) (warn-about-possible-float-info-loss) @@ -243,9 +232,9 @@ ;; host Common Lisp and the target SBCL. (sb!xc:class (values (typep host-object 'sb!xc:class) t)) (fixnum (values (fixnump host-object) t)) - ;; Some types are too hard to handle in the positive case, but at - ;; least we can be confident in a large fraction of the negative - ;; cases.. + ;; Some types are too hard to handle in the positive + ;; case, but at least we can be confident in a large + ;; fraction of the negative cases.. ((base-string simple-base-string simple-string) (if (stringp host-object) (warn-and-give-up) @@ -258,19 +247,21 @@ (t (warn-and-give-up)))) ((stream instance) - ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE is - ;; implemented as a STRUCTURE-OBJECT, so they'll fall through the - ;; tests above. We don't want to assume too much about them here, - ;; but at least we know enough about them to say that neither T - ;; nor NIL nor indeed any other symbol in the cross-compilation - ;; host is one. That knowledge suffices to answer so many of the - ;; questions that the cross-compiler asks that it's well worth + ;; Neither target CL:STREAM nor target + ;; SB!KERNEL:INSTANCE is implemented as a + ;; STRUCTURE-OBJECT, so they'll fall through the tests + ;; above. We don't want to assume too much about them + ;; here, but at least we know enough about them to say + ;; that neither T nor NIL nor indeed any other symbol in + ;; the cross-compilation host is one. That knowledge + ;; suffices to answer so many of the questions that the + ;; cross-compiler asks that it's well worth ;; special-casing it here. (if (symbolp host-object) (values nil t) (warn-and-give-up))) - ;; And the Common Lisp type system is complicated, and we don't - ;; try to implement everything. + ;; And the Common Lisp type system is complicated, and we + ;; don't try to implement everything. (otherwise (warn-and-give-up))))))) ;;; An incomplete TYPEP which runs at cross-compile time to tell whether OBJECT diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index c36c1ac..d51f615 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -389,6 +389,31 @@ (lambda (x y) (funcall fun y x))) +;;;; utilities for two-VALUES predicates + +;;; sort of like ANY and EVERY, except: +;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And +;;; if the result is uncertain, then we return (VALUES NIL NIL), +;;; just like SUBTYPEP.) +;;; * THING is just an atom, and we apply OP (an arity-2 function) +;;; successively to THING and each element of LIST. +(defun any/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) +(defun every/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (if certain? (values t t) (values nil nil))) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) + ;;;; DEFPRINTER ;;; These functions are called by the expansion of the DEFPRINTER diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 57f432e..3d0c69f 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -88,30 +88,7 @@ (declare (type ctype type)) `(specifier-type ',(type-specifier type))) -;;;; utilities - -;;; sort of like ANY and EVERY, except: -;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And -;;; if the result is uncertain, then we return (VALUES NIL NIL), -;;; just like SUBTYPEP.) -;;; * THING is just an atom, and we apply OP (an arity-2 function) -;;; successively to THING and each element of LIST. -(defun any/type (op thing list) - (declare (type function op)) - (let ((certain? t)) - (dolist (i list (values nil certain?)) - (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) - (if sub-certain? - (when sub-value (return (values t t))) - (setf certain? nil)))))) -(defun every/type (op thing list) - (declare (type function op)) - (let ((certain? t)) - (dolist (i list (if certain? (values t t) (values nil nil))) - (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) - (if sub-certain? - (unless sub-value (return (values nil t))) - (setf certain? nil)))))) +;;;; miscellany ;;; Look for nice relationships for types that have nice relationships ;;; only when one is a hierarchical subtype of the other. diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index e123ae1..2ae2937 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -182,14 +182,22 @@ (assert (null (type-intersection2 (specifier-type 'symbol) (specifier-type '(satisfies foo))))) (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) -;; FIXME: As of sbcl-0.6.11.17, the system doesn't know how to do the -;; type simplifications which would let these tests work. (bug 88) -#| (let* ((type1 (specifier-type '(member :x86))) (type2 (specifier-type '(or keyword null))) (isect (type-intersection type1 type2))) + (assert (type= isect type1)) (assert (type= isect (type-intersection type2 type1))) + (assert (type= isect (type-intersection type2 type1 type2))) + (assert (type= isect (type-intersection type1 type1 type2 type1))) + (assert (type= isect (type-intersection type1 type2 type1 type2)))) +;;; FIXME: As of sbcl-0.6.11.19, the system doesn't know how to do the +;;; type simplifications which would let these tests work. (bug 89) +#| +(let* ((type1 (specifier-type 'keyword)) + (type2 (specifier-type '(or keyword null))) + (isect (type-intersection type1 type2))) (assert (type= isect type1)) + (assert (type= isect (type-intersection type2 type1))) (assert (type= isect (type-intersection type2 type1 type2))) (assert (type= isect (type-intersection type1 type1 type2 type1))) (assert (type= isect (type-intersection type1 type2 type1 type2)))) diff --git a/version.lisp-expr b/version.lisp-expr index 4db470b..834fe70 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.18" +"0.6.11.19" -- 1.7.10.4