X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=34b5f0d9f435372216dc1b22ceee9369d5f2c724;hb=d335afdcf50b641a0aafd32741e0777d4e12a59b;hp=bf4630a5335a3baf022c5ae0df7130f08a5b7453;hpb=751e312b3f7cf6a1134f25e3f760c4599e5c4b39;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index bf4630a..34b5f0d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -978,6 +978,20 @@ (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.) @@ -1378,36 +1392,35 @@ (hairy-spec2 (hairy-type-specifier type2))) (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) (values t t)) + ((maybe-reparse-specifier! type1) + (csubtypep type1 type2)) + ((maybe-reparse-specifier! type2) + (csubtypep type1 type2)) (t (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (let ((specifier (hairy-type-specifier type2))) - (cond - ((and (consp specifier) (eql (car specifier) 'satisfies)) - (case (cadr specifier) - ((keywordp) (if (type= type1 (specifier-type 'symbol)) - (values nil t) - (invoke-complex-subtypep-arg1-method type1 type2))) - (t (invoke-complex-subtypep-arg1-method type1 type2)))) - (t (invoke-complex-subtypep-arg1-method type1 type2))))) + (if (maybe-reparse-specifier! type2) + (csubtypep type1 type2) + (let ((specifier (hairy-type-specifier type2))) + (cond ((and (consp specifier) (eql (car specifier) 'satisfies)) + (case (cadr specifier) + ((keywordp) (if (type= type1 (specifier-type 'symbol)) + (values nil t) + (invoke-complex-subtypep-arg1-method type1 type2))) + (t (invoke-complex-subtypep-arg1-method type1 type2)))) + (t + (invoke-complex-subtypep-arg1-method type1 type2)))))) (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) - (declare (ignore type1 type2)) - (values nil nil)) + (if (maybe-reparse-specifier! type1) + (csubtypep type1 type2) + (values nil nil))) (!define-type-method (hairy :complex-=) (type1 type2) - (if (and (unknown-type-p type2) - (let* ((specifier2 (unknown-type-specifier type2)) - (name2 (if (consp specifier2) - (car specifier2) - specifier2))) - (info :type :kind name2))) - (let ((type2 (specifier-type (unknown-type-specifier type2)))) - (if (unknown-type-p type2) - (values nil nil) - (type= type1 type2))) - (values nil nil))) + (if (maybe-reparse-specifier! type2) + (type= type1 type2) + (values nil nil))) (!define-type-method (hairy :simple-intersection2 :complex-intersection2) (type1 type2) @@ -1711,6 +1724,17 @@ (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 @@ -1859,10 +1883,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) @@ -1878,7 +1904,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 @@ -1900,7 +1927,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 @@ -1919,7 +1947,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 @@ -2657,6 +2686,11 @@ used for a COMPLEX component.~:@>" ((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)) @@ -3272,6 +3306,14 @@ used for a COMPLEX component.~:@>" nconc (loop for code from low upto high collect (sb!xc:code-char code)))))))) +(!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)) (pairs2 (character-set-type-pairs type2)))