From 1bdc658b910e7dcc76f606b2c7c9c64012b6ee11 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 7 Feb 2001 03:35:08 +0000 Subject: [PATCH] 0.6.10.10: defined methods for INTERSECTION-TYPE by analogy with UNION-TYPE methods added a few tests for the type system --- BUGS | 14 --- package-data-list.lisp-expr | 2 +- src/code/cold-init.lisp | 10 +-- src/code/late-type.lisp | 188 +++++++++++++++++++++++++++++----------- src/code/load.lisp | 4 +- src/code/pred.lisp | 6 ++ src/code/target-alieneval.lisp | 2 + src/code/type-class.lisp | 1 + src/code/typedefs.lisp | 15 +++- src/compiler/ir1util.lisp | 28 +++--- src/compiler/ltn.lisp | 4 +- tests/type.impure.lisp | 26 ++++++ version.lisp-expr | 2 +- 13 files changed, 213 insertions(+), 89 deletions(-) create mode 100644 tests/type.impure.lisp diff --git a/BUGS b/BUGS index 31c575a..ddd6bf7 100644 --- a/BUGS +++ b/BUGS @@ -406,20 +406,6 @@ returning an array as first value always. accepting &REST even when it's not followed by an argument name: (DEFMETHOD FOO ((X T) &REST) NIL) -39: - On the CMU CL mailing list 26 June 2000, Douglas Crosher wrote - - Hannu Rummukainen wrote: - ... - > There's something weird going on with the compilation of the attached - > code. Compiling and loading the file in a fresh lisp, then invoking - > (test-it) gives - Thanks for the bug report, nice to have this one fixed. It was a bug - in the x86 backend, the < VOP. A fix has been committed to the main - source, see the file compiler/x86/float.lisp. - - Probably the same bug exists in SBCL. - 40: TYPEP treats the result of UPGRADED-ARRAY-ELEMENT-TYPE as gospel, so that (TYPEP (MAKE-ARRAY 3) '(VECTOR SOMETHING-NOT-DEFINED-YET)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 762ce26..94610cb 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1377,7 +1377,7 @@ definitely not guaranteed to be present in later versions of SBCL." necessary for system interfacing\" (said cmu-user.tex at the time of the SBCL code fork). That probably was and is a good idea, but in practice, the distinctions between this package and SB-KERNEL -and even SB-VM have become somewhat blurred over the years." +and even SB-VM seem to have become somewhat blurred over the years." :use ("CL" "SB!EXT" "SB!INT") :export ("%ASSEMBLER-CODE-TYPE" "%BIND-ALIGNED-SAP" ;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index d3417f2..7bcaca1 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -315,20 +315,20 @@ instead (which is another name for the same thing).")) ;;; available early in cold init. #!+sb-show (defun hexstr (thing) - (/show0 "entering HEXSTR") + (/noshow0 "entering HEXSTR") (let ((addr (sb!kernel:get-lisp-obj-address thing)) (str (make-string 10))) - (/show0 "ADDR and STR calculated") + (/noshow0 "ADDR and STR calculated") (setf (char str 0) #\0 (char str 1) #\x) - (/show0 "CHARs 0 and 1 set") + (/noshow0 "CHARs 0 and 1 set") (dotimes (i 8) - (/show0 "at head of DOTIMES loop") + (/noshow0 "at head of DOTIMES loop") (let* ((nibble (ldb (byte 4 0) addr)) (chr (char "0123456789abcdef" nibble))) (declare (type (unsigned-byte 4) nibble) (base-char chr)) - (/show0 "NIBBLE and CHR calculated") + (/noshow0 "NIBBLE and CHR calculated") (setf (char str (- 9 i)) chr addr (ash addr -4)))) str)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 24e54db..8706017 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -242,7 +242,7 @@ (multiple-value-bind (required optional restp rest keyp keys allowp aux) (parse-lambda-list lambda-list) (when aux - (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) + (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)) @@ -253,7 +253,8 @@ (error "Keyword type description is not a two-list: ~S." key)) (let ((kwd (first key))) (when (find kwd (key-info) :key #'key-info-name) - (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) + (error "~@" + kwd lambda-list)) (key-info (make-key-info :name kwd :type (specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) @@ -1545,9 +1546,9 @@ (make-member-type :members (members)))) t)))) -;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union -;;; type, and the member/union interaction is handled by the union type -;;; method. +;;; We don't need a :COMPLEX-UNION, since the only interesting case is +;;; a union type, and the member/union interaction is handled by the +;;; union type method. (!define-type-method (member :simple-union) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) @@ -1559,7 +1560,8 @@ (!define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) - (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) + (values (and (subsetp mem1 mem2) + (subsetp mem2 mem1)) t))) (!define-type-method (member :complex-=) (type1 type2) @@ -1586,7 +1588,9 @@ ;;;; ;; reasonable behavior ;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL)) ;;;; Without understanding a little about the semantics of AND, we'd -;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL, which is unreasonable.) +;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely +;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's +;;;; not so good..) ;;;; ;;;; We still follow the example of CMU CL to some extent, by punting ;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types @@ -1597,6 +1601,7 @@ ;;; the intersection type in some other way. (defun make-intersection-type-or-something (types) (declare (list types)) + (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING") (cond ((null types) *universal-type*) ((null (cdr types)) @@ -1617,6 +1622,118 @@ (%make-intersection-type (some #'type-enumerable types) types)))) (!define-type-class intersection) + +;;; A few intersection types have special names. The others just get +;;; mechanically unparsed. +(!define-type-method (intersection :unparse) (type) + (declare (type ctype type)) + (/show0 "entering INTERSECTION :UNPARSE") + (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=) + `(and ,@(mapcar #'type-specifier (intersection-type-types type))))) + +;;; shared machinery for type equality: true if every type in the set +;;; TYPES1 matches a type in the set TYPES2 and vice versa +(defun type=-set (types1 types2) + (/show0 "entering TYPE=-SET") + (flet (;; true if every type in the set X matches a type in the set Y + (type<=-set (x y) + (declare (type list x y)) + (every (lambda (xelement) + (position xelement y :test #'type=)) + x))) + (values (and (type<=-set types1 types2) + (type<=-set types2 types1)) + t))) + +;;; Two intersection types are equal if their subtypes are equal sets. +;;; +;;; FIXME: Might it be better to use +;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X)) +;;; instead, since SUBTYPEP is the usual relationship that we care +;;; most about, so it would be good to leverage any ingenuity there +;;; in this more obscure method? +(!define-type-method (intersection :simple-=) (type1 type2) + (/show0 "entering INTERSECTION :SIMPLE-=") + (type=-set (intersection-type-types type1) + (intersection-type-types type2))) + +(!define-type-method (intersection :simple-subtypep) (type1 type2) + (declare (type list type1 type2)) + (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP") + (some (lambda (t1) + (every (lambda (t2) + (csubtypep t1 t2)) + type2)) + type1)) + +(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1") + (values (any-type-op csubtypep + type2 + (intersection-type-types type1) + :list-first t) + t)) + +(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2") + (values (every-type-op csubtypep type1 (intersection-type-types type2)) + t)) + +;;; Return a new type list where pairs of types whose intersections +;;; can be represented simply have been replaced by the simple +;;; representation. +(defun simplify-intersection-type-types (%types) + (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES") + (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below) + (i-types types (cdr i-types)) + (i-type (car i-types) (car i-types))) + ((null i-types)) + (do* ((pre-j-types i-types (cdr pre-j-types)) + (j-types (cdr pre-j-types) (cdr pre-j-types)) + (j-type (car j-types) (car j-types))) + ((null j-types)) + (multiple-value-bind (isect win) (type-intersection i-type j-type) + (when win + ;; Overwrite I-TYPES with the intersection, and delete + ;; J-TYPES from the list. + (setf (car i-types) isect + (cdr pre-j-types) (cdr j-types))))) + (/show0 "leaving SIMPLE-INTERSECTION-TYPE-TYPES") + types)) + +(!define-type-method (intersection :simple-intersection :complex-intersection) + (type1 type2) + (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION") + (let ((type1types (intersection-type-types type1)) + (type2types (if (intersection-type-p type2) + (intersection-type-types type2) + (list type2)))) + (make-intersection-type-or-something + (simplify-intersection-type-types + (append type1types type2types))))) + +#| +(!def-type-translator and (&rest type-specifiers) + ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which + ;; will reduce to a 1-element list any list of types which CMU CL + ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING + ;; (which knows to treat a 1-element intersection as the element + ;; itself) we should recover CMU CL's behavior for anything which it + ;; could handle usefully (i.e. could without punting to HAIRY-TYPE). + (/show0 "entering type translator for AND") + (make-intersection-type-or-something + (simplify-intersection-type-types + (mapcar #'specifier-type type-specifiers)))) +|# +;;; (REMOVEME once INTERSECTION-TYPE works.) +(!def-type-translator and (&whole spec &rest types) + (let ((res *wild-type*)) + (dolist (type types res) + (let ((ctype (specifier-type type))) + (multiple-value-bind (int win) (type-intersection res ctype) + (unless win + (return (make-hairy-type :specifier spec))) + (setq res int)))))) ;;;; union types @@ -1628,28 +1745,30 @@ (!define-type-class union) -;;; If LIST, then return that, otherwise the OR of the component types. +;;; The LIST type has a special name. Other union types +;;; just get mechanically unparsed. (!define-type-method (union :unparse) (type) (declare (type ctype type)) (if (type= type (specifier-type 'list)) 'list `(or ,@(mapcar #'type-specifier (union-type-types type))))) -;;; Two union types are equal if every type in one is equal to some -;;; type in the other. +;;; Two union types are equal if their subtypes are equal sets. (!define-type-method (union :simple-=) (type1 type2) - (let ((types1 (union-type-types type1)) - (types2 (union-type-types type2))) - (values (and (dolist (type1 types1 t) - (unless (any-type-op type= type1 types2) - (return nil))) - (dolist (type2 types2 t) - (unless (any-type-op type= type2 types1) - (return nil)))) - t))) + (type=-set (union-type-types type1) + (union-type-types type2))) ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. +;;; +;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and +;;; similarly in INTERSECTION-TYPE, with the logic in the +;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2 +;;; methods. Ideally there's probably some way to make the +;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO +;;; methods in such a way that this definition could go away, but I +;;; don't grok the system well enough to tell whether it's simple to +;;; arrange this. -- WHN 2000-02-03 (!define-type-method (union :simple-subtypep) (type1 type2) (let ((types2 (union-type-types type2))) (values (dolist (type1 (union-type-types type1) t) @@ -1695,7 +1814,7 @@ (setq res (type-union res t2))))) (!define-type-method (union :simple-intersection :complex-intersection) - (type1 type2) + (type1 type2) (let ((res *empty-type*) (win t)) (dolist (type (union-type-types type2) (values res win)) @@ -1707,35 +1826,6 @@ (reduce #'type-union (mapcar #'specifier-type type-specifiers) :initial-value *empty-type*)) - -;;; (Destructively) replace pairs of types which have simple -;;; intersections with their simple intersection. -(defun simplify-intersection-type-types (types) - (do* ((i-types types (cdr i-types)) - (i-type (car i-types) (car i-types))) - ((null i-types)) - (do* ((pre-j-types i-types (cdr pre-j-types)) - (j-types (cdr pre-j-types) (cdr pre-j-types)) - (j-type (car j-types) (car j-types))) - ((null j-types)) - (multiple-value-bind (isect win) (type-intersection i-type j-type) - (when win - ;; Overwrite I-TYPES with the intersection, and delete - ;; J-TYPES from the list. - (setf (car i-types) isect - (cdr pre-j-types) (cdr j-types)))))) - types) - -(!def-type-translator and (&rest type-specifiers) - ;; Note: Between the behavior of SIMPLIFY-INTERSECTION-TYPE (which - ;; will reduce to a 1-element list any list of types which CMU CL - ;; could've represented) and MAKE-INTERSECTION-TYPE-OR-SOMETHING - ;; (which knows to treat a 1-element intersection as the element - ;; itself) we should recover CMU CL's behavior for anything which it - ;; could handle usefully (i.e. could without punting to HAIRY-TYPE). - (make-intersection-type-or-something - (simplify-intersection-type-types - (mapcar #'specifier-type type-specifiers)))) ;;;; CONS types diff --git a/src/code/load.lisp b/src/code/load.lisp index 75fe074..098933e 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -294,8 +294,8 @@ (flet ((check-version (variant possible-implementation needed-version) (when (string= possible-implementation implementation) (unless (= version needed-version) - (error "~S was compiled for ~A fasl file format version ~ - ~S, but we need version ~S." + (error "~@<~S was compiled for ~A fasl file format ~ + version ~D, but we need version ~D.~:@>" stream variant version diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 559c641..86bad39 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -255,6 +255,8 @@ (equalp x-el y-el)) (return nil)))))) (t nil))) + +(/show0 "about to do test cases in pred.lisp") #!+sb-test (let ((test-cases '((0.0 -0.0 t) (0.0 1.0 nil) @@ -263,10 +265,14 @@ ("Hello" "hello" t) ("Hello" #(#\h #\E #\l #\l #\o) t) ("Hello" "goodbye" nil)))) + (/show0 "TEST-CASES bound in pred.lisp") (dolist (test-case test-cases) + (/show0 "about to do a TEST-CASE in pred.lisp") (destructuring-bind (x y expected-result) test-case (let* ((result (equalp x y)) (bresult (if result 1 0)) (expected-bresult (if expected-result 1 0))) (unless (= bresult expected-bresult) + (/show0 "failing test in pred.lisp") (error "failed test (EQUALP ~S ~S)" x y)))))) +(/show0 "done with test cases in pred.lisp") diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 054e282..b59b99e 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -11,6 +11,8 @@ ;;;; files for more information. (in-package "SB!ALIEN") + +(/show0 "target-alieneval.lisp 15") ;;;; alien variables diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index b6cdc07..e4a1b6b 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -23,6 +23,7 @@ (error "~S is not a defined type class." name))) (defun must-supply-this (&rest foo) + (/show0 "failing in MUST-SUPPLY-THIS") (error "missing type method for ~S" foo)) ;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 0d76fe9..241732c 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -91,10 +91,17 @@ ;;;; utilities -;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates. -;;; If the result is uncertain, then we return Default from the block PUNT. -;;; If LIST-FIRST is true, then the list element is the first arg, otherwise -;;; the second. +;;; Like ANY and EVERY, except that we handle two-arg uncertain +;;; predicates. If the result is uncertain, then we return DEFAULT +;;; from the block PUNT-TYPE-METHOD. If LIST-FIRST is true, then the +;;; list element is the first arg, otherwise the second. +;;; +;;; FIXME: The way that we return from PUNT-TYPE-METHOD rather ruins +;;; the analogy with SOME and EVERY, and completely surprised me (WHN) +;;; when I was trying to maintain code which uses these macros. I +;;; think it would be a good idea to redo these so that they really +;;; are analogous to EVERY and SOME. And then, while we're at it, we +;;; could also make them functions (perhaps inline) instead of macros. (defmacro any-type-op (op thing list &key (default '(values nil nil)) list-first) (let ((n-this (gensym)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 66d35aa..0705907 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1272,8 +1272,13 @@ (declaim (special *current-path*)) -;;; We bind print level and length when printing out messages so that we don't -;;; dump huge amounts of garbage. +;;; We bind print level and length when printing out messages so that +;;; we don't dump huge amounts of garbage. +;;; +;;; FIXME: It's not possible to get the defaults right for everyone. +;;; So: Should these variables be in the SB-EXT package? Or should we +;;; just get rid of them completely and just use the bare +;;; CL:*PRINT-FOO* variables instead? (declaim (type (or unsigned-byte null) *compiler-error-print-level* *compiler-error-print-length* @@ -1512,10 +1517,10 @@ (setq *last-message-count* 0)) ;;; Print out the message, with appropriate context if we can find it. -;;; If If the context is different from the context of the last -;;; message we printed, then we print the context. If the original -;;; source is different from the source we are working on, then we -;;; print the current source in addition to the original source. +;;; If the context is different from the context of the last message +;;; we printed, then we print the context. If the original source is +;;; different from the source we are working on, then we print the +;;; current source in addition to the original source. ;;; ;;; We suppress printing of messages identical to the previous, but ;;; record the number of times that the message is repeated. @@ -1607,9 +1612,10 @@ (defun print-compiler-condition (condition) (declare (type condition condition)) - (let (;; These different classes of conditions have different effects - ;; on the return codes of COMPILE-FILE, so it's nice for users to be - ;; able to pick them out by lexical search through the output. + (let (;; These different classes of conditions have different + ;; effects on the return codes of COMPILE-FILE, so it's nice + ;; for users to be able to pick them out by lexical search + ;; through the output. (what (etypecase condition (style-warning 'style-warning) (warning 'warning) @@ -1696,8 +1702,8 @@ (defvar *warnings-p*) ;;; condition handlers established by the compiler. We re-signal the -;;; condition, if it is not handled, we increment our warning counter -;;; and print the error message. +;;; condition, then if it isn't handled, we increment our warning +;;; counter and print the error message. (defun compiler-error-handler (condition) (signal condition) (incf *compiler-error-count*) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index 438102b..8b1ce48 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -903,8 +903,8 @@ (ir1-attributep (function-info-attributes info) recursive))))) (let ((*compiler-error-context* call)) - (compiler-warning "recursion in known function definition~2I ~ - ~_policy=~S ~_arg types=~S" + (compiler-warning "~@" (lexenv-policy (node-lexenv call)) (mapcar (lambda (arg) (type-specifier (continuation-type diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp new file mode 100644 index 0000000..33b3f0c --- /dev/null +++ b/tests/type.impure.lisp @@ -0,0 +1,26 @@ +(in-package :cl-user) + +(let ((types '(character + integer fixnum (integer 0 10) + single-float (single-float -1.0 1.0) (single-float 0.1) + (real 4 8) (real -1 7) (real 2 11) + (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3)))) + (dolist (i types) + (format t "type I=~S~%" i) + (dolist (j types) + (format t " type J=~S~%" j) + (assert (subtypep i `(or ,i ,j))) + (assert (subtypep i `(or ,j ,i))) + (assert (subtypep i `(or ,i ,i ,j))) + (assert (subtypep i `(or ,j ,i)))))) + +(defun type-evidently-= (x y) + (and (subtypep x y) + (subtypep y x))) + +(assert (subtypep 'single-float 'float)) + +(assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10)))) + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index cf58450..ae34e49 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.10.9" +"0.6.10.10" -- 1.7.10.4