X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flate-type.lisp;h=5a1e0e8f91ad79dc9d3851688938d4e77fabfc92;hb=069ca63d16c8de8742fc78b927dfa7b79a27c96d;hp=0c920c7a3735d83292fc07f2cb3cc12f033764d1;hpb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 0c920c7..5a1e0e8 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -307,6 +307,10 @@ ((csubtypep type1 (specifier-type 'function)) nil) (t :call-other-method))) (!define-type-method (function :complex-union2) (type1 type2) + (declare (ignore type2)) + ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming + ;; FUNCTION, then it is the union of the two; otherwise, there is no + ;; special union. (cond ((type= type1 (specifier-type 'function)) type1) (t nil))) @@ -1461,9 +1465,8 @@ (:real base+bounds) (:complex - (if (eq base+bounds 'real) - 'complex - `(complex ,base+bounds))) + (aver (neq base+bounds 'real)) + `(complex ,base+bounds)) ((nil) (aver (eq base+bounds 'real)) 'number))))) @@ -1699,68 +1702,40 @@ (!def-type-translator complex (&optional (typespec '*)) (if (eq typespec '*) - (make-numeric-type :complexp :complex) + (specifier-type '(complex real)) (labels ((not-numeric () (error "The component type for COMPLEX is not numeric: ~S" typespec)) (not-real () - (error "The component type for COMPLEX is not real: ~S" + (error "The component type for COMPLEX is not a subtype of REAL: ~S" typespec)) (complex1 (component-type) (unless (numeric-type-p component-type) (not-numeric)) (when (eq (numeric-type-complexp component-type) :complex) (not-real)) - (modified-numeric-type component-type :complexp :complex)) - (complex-union (component) - (unless (numberp component) - (not-numeric)) - ;; KLUDGE: This TYPECASE more or less does - ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)), - ;; (plus a small hack to treat (EQL COMPONENT 0) specially) - ;; but uses logic cut and pasted from the DEFUN of - ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because - ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE - ;; would tend to break the code here. Unfortunately, - ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here - ;; would cause another kind of fragility, because - ;; ANSI's definition of TYPE-OF is so weak that e.g. - ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could - ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL) - ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL). - ;; So using TYPE-OF would mean that ANSI-conforming - ;; maintenance changes in TYPE-OF could break the code here. - ;; It's not clear how best to fix this. -- WHN 2002-01-21, - ;; trying to summarize CSR's concerns in his patch - (typecase component - (complex (error "The component type for COMPLEX (EQL X) ~ - is complex: ~S" - component)) - ((eql 0) (specifier-type nil)) ; as required by ANSI - (single-float (specifier-type '(complex single-float))) - (double-float (specifier-type '(complex double-float))) - #!+long-float - (long-float (specifier-type '(complex long-float))) - (rational (specifier-type '(complex rational))) - (t (specifier-type '(complex real)))))) + (if (csubtypep component-type (specifier-type '(eql 0))) + *empty-type* + (modified-numeric-type component-type + :complexp :complex)))) (let ((ctype (specifier-type typespec))) - (typecase ctype - (numeric-type (complex1 ctype)) - (union-type (apply #'type-union - ;; FIXME: This code could suffer from - ;; (admittedly very obscure) cases of - ;; bug 145 e.g. when TYPE is - ;; (OR (AND INTEGER (SATISFIES ODDP)) - ;; (AND FLOAT (SATISFIES FOO)) - ;; and not even report the problem very well. - (mapcar #'complex1 - (union-type-types ctype)))) - ;; MEMBER-TYPE is almost the same as UNION-TYPE, but - ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to - ;; ANSI, equal to type NIL, the empty set. - (member-type (apply #'type-union - (mapcar #'complex-union - (member-type-members ctype)))) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((typep ctype 'numeric-type) (complex1 ctype)) + ((typep ctype 'union-type) + (apply #'type-union + ;; FIXME: This code could suffer from (admittedly + ;; very obscure) cases of bug 145 e.g. when TYPE + ;; is + ;; (OR (AND INTEGER (SATISFIES ODDP)) + ;; (AND FLOAT (SATISFIES FOO)) + ;; and not even report the problem very well. + (mapcar #'complex1 (union-type-types ctype)))) + ((typep ctype 'member-type) + (apply #'type-union + (mapcar (lambda (x) (complex1 (ctype-of x))) + (member-type-members ctype)))) (t (multiple-value-bind (subtypep certainly) (csubtypep ctype (specifier-type 'real)) @@ -2121,22 +2096,22 @@ (if (eq (car dims) '*) (case eltype (bit 'bit-vector) - (base-char 'base-string) + ((base-char character) 'base-string) (* 'vector) (t `(vector ,eltype))) (case eltype (bit `(bit-vector ,(car dims))) - (base-char `(base-string ,(car dims))) + ((base-char character) `(base-string ,(car dims))) (t `(vector ,eltype ,(car dims))))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) - (base-char 'simple-base-string) + ((base-char character) 'simple-base-string) ((t) 'simple-vector) (t `(simple-array ,eltype (*)))) (case eltype (bit `(simple-bit-vector ,(car dims))) - (base-char `(simple-base-string ,(car dims))) + ((base-char character) `(simple-base-string ,(car dims))) ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t @@ -2403,18 +2378,24 @@ (!def-type-translator member (&rest members) (if members - (let (ms numbers) + (let (ms numbers char-codes) (dolist (m (remove-duplicates members)) (typecase m (float (if (zerop m) (push m ms) (push (ctype-of m) numbers))) - (number (push (ctype-of m) numbers)) + (real (push (ctype-of m) numbers)) + (character (push (sb!xc:char-code m) char-codes)) (t (push m ms)))) (apply #'type-union (if ms (make-member-type :members ms) *empty-type*) + (if char-codes + (make-character-set-type + :pairs (mapcar (lambda (x) (cons x x)) + (sort char-codes #'<))) + *empty-type*) (nreverse numbers))) *empty-type*)) @@ -2586,6 +2567,8 @@ ((type= type (specifier-type 'bignum)) 'bignum) ((type= type (specifier-type 'simple-string)) 'simple-string) ((type= type (specifier-type 'string)) 'string) + ((type= type (specifier-type 'complex)) 'complex) + ((type= type (specifier-type 'standard-char)) 'standard-char) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2858,7 +2841,90 @@ (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) cdr-int2))))) - + +;;;; CHARACTER-SET types + +(!define-type-class character-set) + +(!def-type-translator character-set + (&optional (pairs '((0 . #.(1- sb!xc:char-code-limit))))) + (make-character-set-type :pairs pairs)) + +(!define-type-method (character-set :negate) (type) + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (make-negation-type :type type) + (let ((not-character + (make-negation-type + :type (make-character-set-type + :pairs '((0 . #.(1- sb!xc:char-code-limit))))))) + (type-union + not-character + (make-character-set-type + :pairs (let (not-pairs) + (when (> (caar pairs) 0) + (push (cons 0 (1- (caar pairs))) not-pairs)) + (do* ((tail pairs (cdr tail)) + (high1 (cdar tail)) + (low2 (caadr tail))) + ((null (cdr tail)) + (when (< (cdar tail) (1- sb!xc:char-code-limit)) + (push (cons (1+ (cdar tail)) + (1- sb!xc:char-code-limit)) + not-pairs)) + (nreverse not-pairs)) + (push (cons (1+ high1) (1- low2)) not-pairs))))))))) + +(!define-type-method (character-set :unparse) (type) + (cond + ((type= type (specifier-type 'character)) 'character) + ((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 + append (loop for code from low upto high + collect (sb!xc:code-char code)))))))) + +(!define-type-method (character-set :simple-=) (type1 type2) + (let ((pairs1 (character-set-type-pairs type1)) + (pairs2 (character-set-type-pairs type2))) + (values (equal pairs1 pairs2) t))) + +(!define-type-method (character-set :simple-subtypep) (type1 type2) + (values + (dolist (pair (character-set-type-pairs type1) t) + (unless (position pair (character-set-type-pairs type2) + :test (lambda (x y) (and (>= (car x) (car y)) + (<= (cdr x) (cdr y))))) + (return nil))) + t)) + +(!define-type-method (character-set :simple-union2) (type1 type2) + ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function + ;; actually does the union for us. It might be a little fragile to + ;; rely on it. + (make-character-set-type + :pairs (merge 'list + (copy-alist (character-set-type-pairs type1)) + (copy-alist (character-set-type-pairs type2)) + #'< :key #'car))) + +(!define-type-method (character-set :simple-intersection2) (type1 type2) + ;; KLUDGE: brute force. + (let (pairs) + (dolist (pair1 (character-set-type-pairs type1) + (make-character-set-type + :pairs (sort pairs #'< :key #'car))) + (dolist (pair2 (character-set-type-pairs type2)) + (cond + ((<= (car pair1) (car pair2) (cdr pair1)) + (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) + ((<= (car pair2) (car pair1) (cdr pair2)) + (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))) + ;;; Return the type that describes all objects that are in X but not ;;; in Y. If we can't determine this type, then return NIL. ;;;