From 22217256264c3a7af7dc03b9ffb1dd72a0c25368 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 21 Mar 2001 12:29:12 +0000 Subject: [PATCH] 0.6.11.21: fixed T-to-AT typo in DEFUN LISTEN made CROSS-TYPEP understand SATISFIES types rewrote the TYPE-UNION method :SIMPLE-INTERSECTION2 (and :COMPLEX-INTERSECTION2) to return UNION-TYPE when that's simpler than the result of just punting; now bug 89 is fixed, (AND KEYWORD (OR KEYWORD NULL)=KEYWORD --- BUGS | 7 --- src/code/cross-type.lisp | 36 +++++++++++--- src/code/early-extensions.lisp | 101 +++++++++++++++++++++------------------- src/code/late-type.lisp | 68 +++++++++------------------ src/code/macros.lisp | 2 +- src/code/seq.lisp | 6 +-- src/code/stream.lisp | 2 +- stems-and-flags.lisp-expr | 4 +- tests/type.before-xc.lisp | 7 ++- version.lisp-expr | 2 +- 10 files changed, 114 insertions(+), 121 deletions(-) diff --git a/BUGS b/BUGS index 0ee92e1..30d25d5 100644 --- a/BUGS +++ b/BUGS @@ -832,13 +832,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0)) does not. -89: - The type system doesn't understand the the intersection of the types - KEYWORD and (OR KEYWORD NULL) is KEYWORD, perhaps because KEYWORD - is itself an intersection type and that causes technical problems - with the simplification. Thus, the optimizer can't make some useful - valid type inferences. - 90: a latent cross-compilation/bootstrapping bug: The cross-compilation host's CL:CHAR-CODE-LIMIT is used in target code in readtable.lisp diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index cb84278..40b785e 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -92,12 +92,22 @@ (t (error "can't handle TYPE-OF ~S in cross-compilation")))))) -;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE -;;; when instantiated on the target SBCL. Since this is hard to decide -;;; in some cases, and since in other cases we just haven't bothered -;;; to try, it needs to return two values, just like SUBTYPEP: the -;;; first value for its conservative opinion (never T unless it's -;;; certain) and the second value to tell whether it's certain. +;;; Is SYMBOL in the CL package? Note that we're testing this on the +;;; cross-compilation host, which could do things any old way. In +;;; particular, it might be in the CL package even though +;;; SYMBOL-PACKAGE is not (FIND-PACKAGE :CL). So we test things +;;; another way. +(defun in-cl-package-p (symbol) + (eql (find-symbol (symbol-name symbol) :cl) + symbol)) + +;;; This is like TYPEP, except that it asks whether HOST-OBJECT would +;;; be of TARGET-TYPE when instantiated on the target SBCL. Since this +;;; is hard to determine in some cases, and since in other cases we +;;; just haven't bothered to try, it needs to return two values, just +;;; like SUBTYPEP: the first value for its conservative opinion (never +;;; T unless it's certain) and the second value to tell whether it's +;;; certain. (defun cross-typep (host-object target-type) (flet ((warn-and-give-up () ;; We don't have to keep track of this as long as system performance @@ -175,6 +185,20 @@ ;; trivial. (and (every/type #'cross-typep host-object rest)) (or (any/type #'cross-typep host-object rest)) + ;; If we want to work with the KEYWORD type, we need + ;; to grok (SATISFIES KEYWORDP). + (satisfies + (destructuring-bind (predicate-name) rest + (if (and (in-cl-package-p predicate-name) + (fboundp predicate-name)) + ;; Many things like KEYWORDP, ODDP, PACKAGEP, + ;; and NULL correspond between host and target. + (values (not (null (funcall predicate-name host-object))) + t) + ;; For symbols not in the CL package, it's not + ;; in general clear how things correspond + ;; between host and target, so we punt. + (warn-and-give-up)))) ;; 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.. diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index d51f615..529844a 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -101,49 +101,40 @@ #!+sb-show (defvar *hash-caches-initialized-p*) -;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions -;;; so that caches will be created before top-level forms run. +;;; Define a hash cache that associates some number of argument values +;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME +;;; is used to compare the value for that arg in a cache entry with a +;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as +;;; its first arg, but need not return any particular value. +;;; TEST-FUNCTION may be any thing that can be placed in CAR position. +;;; +;;; NAME is used to define these functions: +;;; -CACHE-LOOKUP Arg* +;;; See whether there is an entry for the specified ARGs in the +;;; cache. If not present, the :DEFAULT keyword (default NIL) +;;; determines the result(s). +;;; -CACHE-ENTER Arg* Value* +;;; Encache the association of the specified args with VALUE. +;;; -CACHE-CLEAR +;;; Reinitialize the cache, invalidating all entries and allowing +;;; the arguments and result values to be GC'd. +;;; +;;; These other keywords are defined: +;;; :HASH-BITS +;;; The size of the cache as a power of 2. +;;; :HASH-FUNCTION function +;;; Some thing that can be placed in CAR position which will compute +;;; a value between 0 and (1- (expt 2 )). +;;; :VALUES +;;; the number of return values cached for each function call +;;; :INIT-WRAPPER +;;; The code for initializing the cache is wrapped in a form with +;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS +;;; in type system definitions so that caches will be created +;;; before top-level forms run.) (defmacro define-hash-cache (name args &key hash-function hash-bits default (init-wrapper 'progn) (values 1)) - #!+sb-doc - "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}* - Define a hash cache that associates some number of argument values to a - result value. The Test-Function paired with each Arg-Name is used to compare - the value for that arg in a cache entry with a supplied arg. The - Test-Function must not error when passed NIL as its first arg, but need not - return any particular value. Test-Function may be any thing that can be - placed in CAR position. - - Name is used to define these functions: - - -CACHE-LOOKUP Arg* - See whether there is an entry for the specified Args in the cache. If - not present, the :DEFAULT keyword (default NIL) determines the result(s). - - -CACHE-ENTER Arg* Value* - Encache the association of the specified args with Value. - - -CACHE-CLEAR - Reinitialize the cache, invalidating all entries and allowing the - arguments and result values to be GC'd. - - These other keywords are defined: - - :HASH-BITS - The size of the cache as a power of 2. - - :HASH-FUNCTION function - Some thing that can be placed in CAR position which will compute a value - between 0 and (1- (expt 2 )). - - :VALUES - The number of values cached. - - :INIT-WRAPPER - The code for initializing the cache is wrapped in a form with the - specified name. Default PROGN." - (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) (nargs (length args)) (entry-size (+ nargs values)) @@ -251,13 +242,11 @@ ,@(forms) ',name)))) +;;; some syntactic sugar for defining a function whose values are +;;; cached by DEFINE-HASH-CACHE (defmacro defun-cached ((name &rest options &key (values 1) default &allow-other-keys) args &body body-decls-doc) - #!+sb-doc - "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form* - Some syntactic sugar for defining a function whose values are cached by - DEFINE-HASH-CACHE." (let ((default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) @@ -388,13 +377,27 @@ (declare (type function fun)) (lambda (x y) (funcall fun y x))) + +;;; like CL:ASSERT, but lighter-weight +;;; +;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT +;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a +;;; significant amount of code when you multiply them by 400, so +;;; replacing them with this should reduce the size of the system +;;; by enough to be worthwhile.) +(defmacro aver (expr) + `(unless ,expr + (%failed-aver ,(let ((*package* (find-package :keyword))) + (format nil "~S" expr))))) +(defun %failed-aver (expr) + (error "~@" expr)) ;;;; 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.) +;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. +;;; (And if the result is uncertain, then we return (VALUES NIL NIL), +;;; as SUBTYPEP does.) ;;; * 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) @@ -451,7 +454,7 @@ ;;; keywords are defined: ;;; ;;; :PRIN1 Print the value of the expression instead of the slot value. -;;; :PRINC Like :PRIN1, only princ the value +;;; :PRINC Like :PRIN1, only PRINC the value ;;; :TEST Only print something if the test is true. ;;; ;;; If no printing thing is specified then the slot value is printed @@ -516,4 +519,4 @@ (if x x (cons y y))) -|# \ No newline at end of file +|# diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 98943af..bf6c079 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -615,17 +615,9 @@ ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish ;; between not finding a method and having a method return NIL. (flet ((1way (x y) - (let ((result (!invoke-type-method :simple-union2 :complex-union2 - x y - :default nil))) - ;; UNION2 type methods are supposed to return results - ;; which are better than just brute-forcibly smashing the - ;; terms together into UNION-TYPEs. But they're derived - ;; from old CMU CL UNION type methods which played by - ;; somewhat different rules. Here we check to make sure - ;; we don't get ambushed by diehard old-style code. - (assert (not (union-type-p result))) - result))) + (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) (declare (inline 1way)) (or (1way type1 type2) (1way type2 type1)))) @@ -675,20 +667,9 @@ ;; ;; (Why yes, CLOS probably *would* be nicer..) (flet ((1way (x y) - (let ((result - (!invoke-type-method :simple-intersection2 - :complex-intersection2 - x y - :default :no-type-method-found))) - ;; INTERSECTION2 type methods are supposed to return - ;; results which are better than just brute-forcibly - ;; smashing the terms together into INTERSECTION-TYPEs. - ;; But they're derived from old CMU CL INTERSECTION type - ;; methods which played by somewhat different rules. Here - ;; we check to make sure we don't get ambushed by diehard - ;; old-style code. - (assert (not (intersection-type-p result))) - result))) + (!invoke-type-method :simple-intersection2 :complex-intersection2 + x y + :default :no-type-method-found))) (declare (inline 1way)) (let ((xy (1way type1 type2))) (or (and (not (eql xy :no-type-method-found)) xy) @@ -1964,33 +1945,26 @@ ((union-complex-subtypep-arg1 type2 type1) type2) (t + ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 + ;; operations in a particular order, and gives up if any of + ;; the sub-unions turn out not to be simple. In other cases + ;; ca. sbcl-0.6.11.15, that approach to taking a union was a + ;; bad idea, since it can overlook simplifications which + ;; might occur if the terms were accumulated in a different + ;; order. It's possible that that will be a problem here too. + ;; However, I can't think of a good example to demonstrate + ;; it, and without an example to demonstrate it I can't write + ;; test cases, and without test cases I don't want to + ;; complicate the code to address what's still a hypothetical + ;; problem. So I punted. -- WHN 2001-03-20 (let ((accumulator *empty-type*)) (dolist (t2 (union-type-types type2) accumulator) (setf accumulator (type-union2 accumulator (type-intersection type1 t2))) - ;; When our result isn't simple any more - (when (or - ;; (TYPE-UNION2 couldn't find a sufficiently simple - ;; result, so we can't either.) - (null accumulator) - ;; (A result containing an intersection isn't - ;; sufficiently simple for us. FIXME: Maybe it - ;; should be sufficiently simple for us? - ;; UNION-TYPEs aren't supposed to be nested inside - ;; INTERSECTION-TYPEs, so if we punt with NIL, - ;; we're condemning the expression to become a - ;; HAIRY-TYPE. If it were possible for us to - ;; return an INTERSECTION-TYPE, then the - ;; INTERSECTION-TYPE-TYPES could be merged into - ;; the outer INTERSECTION-TYPE which may be under - ;; construction. E.g. if this function could - ;; return an intersection type, and the calling - ;; functions were smart enough to handle it, then - ;; we could simplify (AND (OR FIXNUM KEYWORD) - ;; SYMBOL) to KEYWORD, even though KEYWORD - ;; is an intersection type.) - (intersection-type-p accumulator)) + ;; When our result isn't simple any more (because + ;; TYPE-UNION2 was unable to give us a simple result) + (unless accumulator (return nil))))))) (!def-type-translator or (&rest type-specifiers) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 46865dd..b8fcd1b 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -28,7 +28,7 @@ #!+sb-doc "Signals an error if the value of test-form is nil. Continuing from this error using the CONTINUE restart will allow the user to alter the value of - some locations known to SETF, starting over with test-form. Returns nil." + some locations known to SETF, starting over with test-form. Returns NIL." `(do () (,test-form) (assert-error ',test-form ',places ,datum ,@arguments) ,@(mapcar #'(lambda (place) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 730aceb..ae5782a 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -2299,12 +2299,12 @@ (defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not (start1 0) end1 (start2 0) end2 key) #!+sb-doc - "The specified subsequences of Sequence1 and Sequence2 are compared + "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared element-wise. If they are of equal length and match in every element, the result is Nil. Otherwise, the result is a non-negative integer, the index - within Sequence1 of the leftmost position at which they fail to match; or, + within SEQUENCE1 of the leftmost position at which they fail to match; or, if one is shorter than and a matching prefix of the other, the index within - Sequence1 beyond the last position tested is returned. If a non-NIL + SEQUENCE1 beyond the last position tested is returned. If a non-NIL :FROM-END argument is given, then one plus the index of the rightmost position in which the sequences differ is returned." (declare (fixnum start1 start2)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f443853..76d33bb 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -366,7 +366,7 @@ (if (lisp-stream-p stream) (or (/= (the fixnum (lisp-stream-in-index stream)) +in-buffer-length+) ;; Test for T explicitly since misc methods return :EOF sometimes. - (eq (funcall (lisp-stream-misc stream) stream :listen) at)) + (eq (funcall (lisp-stream-misc stream) stream :listen) t)) ;; Fall through to Gray streams FUNDAMENTAL-STREAM case. (stream-listen stream)))) diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 15db07e..d8e9be1 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -569,8 +569,8 @@ ;; stuff for byte compilation. Note that although byte code is ;; "portable", it'd be hard to make it work on the cross-compilation ;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are - ;; implemented as FUNCALLABLE-INSTANCEs, and it's - ;; not obvious how to make those portable. + ;; implemented as FUNCALLABLE-INSTANCEs, and it's not obvious + ;; how to emulate those in a vanilla ANSI Common Lisp. ("code/byte-types" :not-host) ("compiler/byte-comp") ("compiler/target-byte-comp" :not-host) diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index 2ae2937..59d1d82 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -182,6 +182,9 @@ (assert (null (type-intersection2 (specifier-type 'symbol) (specifier-type '(satisfies foo))))) (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) +(assert (ctypep :x86 (specifier-type '(satisfies keywordp)))) +(assert (type= (specifier-type '(member :x86)) + (specifier-type '(and (member :x86) (satisfies keywordp))))) (let* ((type1 (specifier-type '(member :x86))) (type2 (specifier-type '(or keyword null))) (isect (type-intersection type1 type2))) @@ -190,9 +193,6 @@ (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))) @@ -201,6 +201,5 @@ (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)))) -|# (/show "done with tests/type.before-xc.lisp") diff --git a/version.lisp-expr b/version.lisp-expr index fd616d6..708ef80 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.20" +"0.6.11.21" -- 1.7.10.4