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))))
(declare (type ctype type))
(funcall (type-class-negate (type-class-info type)) type))
+(defun-cached (type-singleton-p :hash-function (lambda (type)
+ (logand (type-hash-value type)
+ #xff))
+ :hash-bits 8
+ :values 2
+ :default (values nil t)
+ :init-wrapper !cold-init-forms)
+ ((type eq))
+ (declare (type ctype type))
+ (let ((function (type-class-singleton-p (type-class-info type))))
+ (if function
+ (funcall function type)
+ (values nil nil))))
+
;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
;;; early-type.lisp by WHN ca. 19990201.)
(aver (eq base+bounds 'real))
'number)))))
+(!define-type-method (number :singleton-p) (type)
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (if (and low
+ (eql low high)
+ (eql (numeric-type-complexp type) :real)
+ (member (numeric-type-class type) '(integer rational
+ #-sb-xc-host float)))
+ (values t (numeric-type-low type))
+ (values nil nil))))
+
;;; Return true if X is "less than or equal" to Y, taking open bounds
;;; into consideration. CLOSED is the predicate used to test the bound
;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
;;; 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)
((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
(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
(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
(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))
((type= type (specifier-type 'standard-char)) 'standard-char)
(t `(member ,@members)))))
+(!define-type-method (member :singleton-p) (type)
+ (if (eql 1 (member-type-size type))
+ (values t (first (member-type-members type)))
+ (values nil nil)))
+
(!define-type-method (member :simple-subtypep) (type1 type2)
(values (and (xset-subset-p (member-type-xset type1)
(member-type-xset type2))
: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)))
((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))
+ (pair (first pairs)))
+ (if (and (typep pairs '(cons t null))
+ (eql (car pair) (cdr pair)))
+ (values t (code-char (car pair)))
+ (values nil nil))))
(!define-type-method (character-set :simple-=) (type1 type2)
(let ((pairs1 (character-set-type-pairs type1))
projects / sbcl.git / blobdiff