From f0670f28705c01e79fb23cb2a582074d3e51ec98 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Fri, 16 Mar 2001 20:52:40 +0000 Subject: [PATCH] 0.6.11.15: some cleanups related to the type hackathon in 0.6.11.13.. ..restored :TYPE declaration for FORMAT slot in NUMERIC-TYPE ..restored :TYPE declaration for TYPES slot in COMPOUND-TYPE ..moved LIST, CONS, and NULL to a more logical point in *BUILT-IN-CLASSES* ..rearranged CTYPE, ANY/TYPE, and EVERY/TYPE to share code ..added tests related to CTYPE of COMPOUND-TYPE ..redid INTERSECTION :SIMPLE-SUBTYPEP to share EVERY/TYPE too added tests for ANY/TYPE and EVERY/TYPE, fixed EVERY/TYPE moved SWAPPED-ARGS-FUN earlier to facilitate inlining, putting it in SB!INT so it can go in early-extensions.lisp deleted unused LETF and LETF* --- BUGS | 27 +++++++++++++++++++++++++-- package-data-list.lisp-expr | 11 +++++++---- src/code/class.lisp | 38 ++++++++++++++++---------------------- src/code/early-extensions.lisp | 8 ++++++++ src/code/early-type.lisp | 12 ++---------- src/code/late-type.lisp | 30 ++++++++++++------------------ src/code/target-type.lisp | 22 +++++++++++++--------- src/code/typedefs.lisp | 34 ++++++++++++---------------------- tests/type.before-xc.lisp | 30 +++++++++++++++++++++++++++++- tests/type.pure.lisp | 30 ++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 11 files changed, 155 insertions(+), 89 deletions(-) create mode 100644 tests/type.pure.lisp diff --git a/BUGS b/BUGS index fe2c696..82e95d2 100644 --- a/BUGS +++ b/BUGS @@ -525,8 +525,18 @@ Error in function C::GET-LAMBDA-TO-COMPILE: # was defined in a non-null environment. 58: - (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH) - => NIL, NIL + (SUBTYPEP '(AND ZILCH INTEGER) 'ZILCH) => NIL, NIL + Note: I looked into fixing this in 0.6.11.15, but gave up. The + problem seems to be that there are two relevant type methods for + the subtypep operation, HAIRY :COMPLEX-SUBTYPEP-ARG2 and + INTERSECTION :COMPLEX-SUBTYPEP-ARG1, and only the first is + called. This could be fixed, but type dispatch is messy and + confusing enough already, I don't want to complicate it further. + Perhaps someday we can make CLOS cross-compiled (instead of compiled + after bootstrapping) so that we don't need to have the type system + available before CLOS, and then we can rewrite the type methods to + CLOS methods, and then expressing the solutions to stuff like this + should become much more straightforward. -- WHN 2001-03-14 59: CL:*DEFAULT-PATHNAME-DEFAULTS* doesn't behave as ANSI suggests (reflecting @@ -815,6 +825,19 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (I haven't tried to investigate this bug enough to guess whether there might be any user-level symptoms.) +86: + The system doesn't know how to reduce + (specifier-type '(intersection (or number vector) real)), + it just ends up as a HAIRY-TYPE. Smarter INTERSECTION2 methods for + UNION-TYPE might help. + +87: + Despite what the manual says, (DECLAIM (SPEED 0)) doesn't cause + things to be byte compiled. This seems to be true in cmucl-2.4.19, + too: (COMPILE-FILE .. :BYTE-COMPILE T) causes byte-compilation, + but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0)) + does not. + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 9b6e890..59b9764 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -678,22 +678,25 @@ retained, possibly temporariliy, because it might be used internally." "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING" "STYLE-WARN" - ;; miscellaneous non-standard but widely useful user-level - ;; functions.. + ;; bootstrapping magic, to make things happen both in + ;; the cross-compilation host compiler's environment and + ;; in the cross-compiler's environment + "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE" + + ;; miscellaneous non-standard but handy user-level functions.. "ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ" "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" "SANE-PACKAGE" "CIRCULAR-LIST-P" + "SWAPPED-ARGS-FUN" ;; ..and macros.. "COLLECT" "DO-ANONYMOUS" "DOHASH" "DOVECTOR" "NAMED-LET" - "LETF" "LETF*" "ONCE-ONLY" "DEFENUM" "DEFPRINTER" - "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE" ;; ..and DEFTYPEs.. "INDEX" diff --git a/src/code/class.lisp b/src/code/class.lisp index f63e6b9..5db094a 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -995,6 +995,22 @@ array sequence generic-string generic-vector generic-array mutable-sequence mutable-collection generic-sequence collection)) + (list + :translation (or cons (member nil)) + :inherits (sequence mutable-sequence mutable-collection + generic-sequence collection)) + (cons + :codes (#.sb!vm:list-pointer-type) + :translation cons + :inherits (list sequence + mutable-sequence mutable-collection + generic-sequence collection)) + (null + :translation (member nil) + :inherits (list sequence + mutable-sequence mutable-collection + generic-sequence collection symbol) + :direct-superclasses (list symbol)) (generic-number :state :read-only) (number :translation number :inherits (generic-number)) (complex @@ -1034,28 +1050,6 @@ (rational :translation rational :inherits (real number generic-number)) - - ;; FIXME: moved LIST, CONS, and NULL here to help with translation - ;; of RATIO now that sbcl-0.6.11.13 has real INTERSECTION-TYPE; - ;; but it would be tidier to move them further back, if possible, - ;; so that all the numeric types are in an uninterrupted sequence - (list - :translation (or cons (member nil)) - :inherits (sequence mutable-sequence mutable-collection - generic-sequence collection)) - (cons - :codes (#.sb!vm:list-pointer-type) - :translation cons - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection)) - (null - :translation (member nil) - :inherits (list sequence - mutable-sequence mutable-collection - generic-sequence collection symbol) - :direct-superclasses (list symbol)) - (ratio :translation (and rational (not integer)) :inherits (rational real number generic-number) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 91b9d00..c36c1ac 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -380,6 +380,14 @@ ;; a constant as long as the new value is EQL to the old ;; value.) )) + +;;; Return a function like FUN, but expecting its (two) arguments in +;;; the opposite order that FUN does. +(declaim (inline swapped-args-fun)) +(defun swapped-args-fun (fun) + (declare (type function fun)) + (lambda (x y) + (funcall fun y x))) ;;;; DEFPRINTER diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 664e6ab..4042453 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -202,10 +202,7 @@ ;; to do with #'FORMAT), or NIL if not specified or not a float. ;; Formats which don't exist in a given implementation don't appear ;; here. - (format nil - ;; FIXME: suppressed because of cold init problems under - ;; hacked type system in sbcl-0.6.11.13, should be restored - #+nil :type #+nil (or float-format null)) + (format nil :type (or float-format null)) ;; Is this a complex numeric type? Null if unknown (only in NUMBER). ;; ;; FIXME: I'm bewildered by FOO-P names for things not intended to @@ -248,12 +245,7 @@ (defstruct (compound-type (:include ctype) (:constructor nil) (:copier nil)) - (types nil - ;; FIXME: This type declaration was suppresed as a temporary - ;; hack to work around sbcl-0.6.11.13 cold init problems. - ;; Restore it. - #+nil :type #+nil list - :read-only t)) + (types nil :type list :read-only t)) ;;; A UNION-TYPE represents a use of the OR type specifier which we ;;; couldn't canonicalize to something simpler. Canonical form: diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 0b9ae5f..20da765 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1781,25 +1781,19 @@ (type=-set (intersection-type-types type1) (intersection-type-types type2))) -(!define-type-method (intersection :simple-subtypep) (type1 type2) - (let ((certain? t)) - (dolist (t1 (intersection-type-types type1) (values nil certain?)) - (multiple-value-bind (subtypep validp) - (intersection-complex-subtypep-arg2 t1 type2) - (cond ((not validp) - (setf certain? nil)) - (subtypep - (return (values t t)))))))) - -(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1))) - -(defun intersection-complex-subtypep-arg2 (type1 type2) - (every/type #'csubtypep type1 (intersection-type-types type2))) +(flet ((intersection-complex-subtypep-arg1 (type1 type2) + (any/type (swapped-args-fun #'csubtypep) + type2 + (intersection-type-types type1)))) + (!define-type-method (intersection :simple-subtypep) (type1 type2) + (every/type #'intersection-complex-subtypep-arg1 + type1 + (intersection-type-types type2))) + (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (intersection-complex-subtypep-arg1 type1 type2))) + (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) - (intersection-complex-subtypep-arg2 type1 type2)) + (every/type #'csubtypep type1 (intersection-type-types type2))) (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 7ebfccf..de27d70 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -32,6 +32,11 @@ ;;; types. For STRUCTURE- types, we require that the type be defined ;;; in both the current and compiler environments, and that the ;;; INCLUDES be the same. +;;; +;;; KLUDGE: This should probably be a type method instead of a big +;;; ETYPECASE. But then the type method system should probably be CLOS +;;; too, and until that happens wedging more stuff into it might be +;;; messy. So I've left it a big ETYPECASE. -- 2001-03-16 (defun ctypep (obj type) (declare (type ctype type)) (etypecase type @@ -52,16 +57,10 @@ (values nil nil)) (values nil t))) (compound-type + ;; REMOVEME: old version + #| (let ((certain? t)) (etypecase type - ;; FIXME: The cases here are very similar to #'EVERY/TYPE and - ;; #'ANY/TYPE. It would be good to fix them so that they - ;; share the same code. (That will require making sure that - ;; the two-value return convention for CTYPEP really is - ;; exactly compatible with the two-value convention the - ;; quantifier/TYPE functions operate on, and probably also - ;; making sure that things are inlined and defined early - ;; enough that consing can be avoided.) (union-type (dolist (mem (union-type-types type) (values nil certain?)) (multiple-value-bind (val win) (ctypep obj mem) @@ -74,7 +73,12 @@ (multiple-value-bind (val win) (ctypep obj mem) (if win (unless val (return (values nil t))) - (setf certain? nil)))))))) + (setf certain? nil))))))) + |# + (let ((types (compound-type-types type))) + (etypecase type + (intersection-type (every/type #'ctypep obj types)) + (union-type (any/type #'ctypep obj types))))) (function-type (values (functionp obj) t)) (unknown-type diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index c849983..cc6a4a7 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -92,36 +92,26 @@ ;;; 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).) +;;; 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) - (unless sub-certain? (setf certain? nil)) - (when sub-value (return (values t t))))))) + (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)) - (dolist (i list (values t t)) - (multiple-value-bind (sub-value sub-certain?) - (funcall op thing i) - (unless sub-certain? (return (values nil nil))) - (unless sub-value (return (values nil t)))))) - -;;; Return a function like FUN, but expecting its (two) arguments in -;;; the opposite order that FUN does. -;;; -;;; (This looks like a sort of general utility, but currently it's -;;; used only in the implementation of the type system, so it's -;;; internal to SB-KERNEL. -- WHN 2001-02-13) -(declaim (inline swapped-args-fun)) -(defun swapped-args-fun (fun) - (declare (type function fun)) - (lambda (x y) - (funcall fun y x))) + (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)))))) ;;; Look for a nice intersection for types that intersect 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 c08085d..5dc0ca3 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -106,7 +106,7 @@ (assert (csubtypep *empty-type* ctype)) (assert (csubtypep ctype *universal-type*)))) -(/show "done with identities-should-be-identities block") +(/show "finished with identities-should-be-identities block") (assert (sb-xc:subtypep 'simple-vector 'vector)) (assert (sb-xc:subtypep 'simple-vector 'simple-array)) @@ -127,6 +127,34 @@ nil)) |#) +;;; tests of 2-value quantifieroids FOO/TYPE +(macrolet ((2= (v1 v2 expr2) + (let ((x1 (gensym)) + (x2 (gensym))) + `(multiple-value-bind (,x1 ,x2) ,expr2 + (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2)) + (error "mismatch for EXPR2=~S" ',expr2)))))) + (flet (;; SUBTYPEP running in the cross-compiler + (xsubtypep (x y) + (csubtypep (specifier-type x) + (specifier-type y)))) + (2= t t (any/type #'xsubtypep 'fixnum '(real integer))) + (2= t t (any/type #'xsubtypep 'fixnum '(real cons))) + (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector))) + (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo))) + (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons))) + (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real))) + (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo))) + (2= nil t (any/type #'xsubtypep 'fixnum '())) + (2= t t (every/type #'xsubtypep 'fixnum '())) + (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo))) + (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real))) + (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons))) + (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo))) + (2= t t (every/type #'xsubtypep 'fixnum '(real integer))) + (2= nil t (every/type #'xsubtypep 'fixnum '(real cons))) + (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector))))) + ;;; various dead bugs (assert (union-type-p (type-intersection (specifier-type 'list) (specifier-type '(or list vector))))) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp new file mode 100644 index 0000000..a2c63ff --- /dev/null +++ b/tests/type.pure.lisp @@ -0,0 +1,30 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +(locally + (declare (notinline mapcar)) + (mapcar (lambda (args) + (destructuring-bind (obj type-spec result) args + (flet ((matches-result? (x) + (eq (if x t nil) result))) + (assert (matches-result? (typep obj type-spec))) + (assert (matches-result? (sb-kernel:ctypep + obj + (sb-kernel:specifier-type + type-spec))))))) + '((nil (or null vector) t) + (nil (or number vector) nil) + (12 (or null vector) nil) + (12 (and (or number vector) real) t)))) + + \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index fe1a06f..2e65f70 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.14" +"0.6.11.15" -- 1.7.10.4