X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=697b7754ab7293625e2ed640dd7398598d6a862f;hb=ed18d662d473336285e2594ad21239afe1bca105;hp=16b605d7dc8b4e174ad849a0daa20fb938475bd5;hpb=49319a8c7f3527b0d452b8f07bdabe02283e8ff7;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 16b605d..697b775 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -432,8 +432,9 @@ 1 (values-type-max-value-count type))) +;;; VALUES type with a single value. (defun type-single-value-p (type) - (and (values-type-p type) + (and (%values-type-p type) (not (values-type-rest type)) (null (values-type-optional type)) (singleton-p (values-type-required type)))) @@ -653,6 +654,19 @@ :rest rest) exactp))) +(defun compare-key-args (type1 type2) + (let ((keys1 (args-type-keywords type1)) + (keys2 (args-type-keywords type2))) + (and (= (length keys1) (length keys2)) + (eq (args-type-allowp type1) + (args-type-allowp type2)) + (loop for key1 in keys1 + for match = (find (key-info-name key1) + keys2 :key #'key-info-name) + always (and match + (type= (key-info-type key1) + (key-info-type match))))))) + (defun type=-args (type1 type2) (macrolet ((compare (comparator field) (let ((reader (symbolicate '#:args-type- field))) @@ -667,7 +681,7 @@ (and/type (and/type (compare type=-list required) (compare type=-list optional)) (if (or (args-type-keyp type1) (args-type-keyp type2)) - (values nil nil) + (values (compare-key-args type1 type2) t) (values t t)))))) ;;; Do a union or intersection operation on types that might be values @@ -1731,7 +1745,7 @@ (eql low high) (eql (numeric-type-complexp type) :real) (member (numeric-type-class type) '(integer rational - #!-sb-xc-host float))) + #-sb-xc-host float))) (values t (numeric-type-low type)) (values nil nil)))) @@ -1883,10 +1897,12 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; Old comment, probably no longer applicable: -;;; -;;; ### Note: we give up early to keep from dropping lots of -;;; information on the floor by returning overly general types. +;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent +;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128), +;;; the compiler does this occasionally during type-derivation to avoid +;;; creating absurdly complex unions of numeric types. +(defvar *approximate-numeric-unions* nil) + (!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) @@ -1902,7 +1918,8 @@ ((and (eq class1 class2) (eq format1 format2) (eq complexp1 complexp2) - (or (numeric-types-intersect type1 type2) + (or *approximate-numeric-unions* + (numeric-types-intersect type1 type2) (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type @@ -1924,7 +1941,8 @@ (integerp (numeric-type-low type2)) (integerp (numeric-type-high type2)) (= (numeric-type-low type2) (numeric-type-high type2)) - (or (numeric-types-adjacent type1 type2) + (or *approximate-numeric-unions* + (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type :class 'rational @@ -1943,7 +1961,8 @@ (integerp (numeric-type-low type1)) (integerp (numeric-type-high type1)) (= (numeric-type-low type1) (numeric-type-high type1)) - (or (numeric-types-adjacent type1 type2) + (or *approximate-numeric-unions* + (numeric-types-adjacent type1 type2) (numeric-types-adjacent type2 type1))) (make-numeric-type :class 'rational @@ -2398,14 +2417,8 @@ used for a COMPLEX component.~:@>" (values nil t)) ((or (unknown-type-p (array-type-element-type type1)) (unknown-type-p (array-type-element-type type2))) - (multiple-value-bind (equalp certainp) - (type= (array-type-element-type type1) - (array-type-element-type type2)) - ;; By its nature, the call to TYPE= should never return - ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow - ;; up to be. -- CSR, 2002-08-19 - (aver (not (and (not equalp) certainp))) - (values equalp certainp))) + (type= (array-type-element-type type1) + (array-type-element-type type2))) (t (values (type= (array-type-specialized-element-type type1) (array-type-specialized-element-type type2)) @@ -2904,11 +2917,12 @@ used for a COMPLEX component.~:@>" :high (if (null (numeric-type-high type1)) nil (list (1+ (numeric-type-high type1))))))) - (type-union type1 - (apply #'type-intersection - (remove (specifier-type '(not integer)) - (intersection-type-types type2) - :test #'type=)))) + (let* ((intersected (intersection-type-types type2)) + (remaining (remove (specifier-type '(not integer)) + intersected + :test #'type=))) + (and (not (equal intersected remaining)) + (type-union type1 (apply #'type-intersection remaining))))) (t (let ((accumulator *universal-type*)) (do ((t2s (intersection-type-types type2) (cdr t2s))) @@ -3296,10 +3310,20 @@ used for a COMPLEX component.~:@>" ((type= type (specifier-type 'base-char)) 'base-char) ((type= type (specifier-type 'extended-char)) 'extended-char) ((type= type (specifier-type 'standard-char)) 'standard-char) - (t (let ((pairs (character-set-type-pairs type))) - `(member ,@(loop for (low . high) in pairs + (t + ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there + ;; are at most as many characters than there are character code ranges. + (let* ((pairs (character-set-type-pairs type)) + (count (length pairs)) + (chars (loop named outer + for (low . high) in pairs nconc (loop for code from low upto high - collect (sb!xc:code-char code)))))))) + collect (sb!xc:code-char code) + when (minusp (decf count)) + do (return-from outer t))))) + (if (eq chars t) + `(character-set ,pairs) + `(member ,@chars)))))) (!define-type-method (character-set :singleton-p) (type) (let* ((pairs (character-set-type-pairs type))