((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)))
(: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)))))
(!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))
(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
(!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*))
\f
((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
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
-\f
+\f
+;;;; 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)))))))
+\f
;;; 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.
;;;
projects / sbcl.git / blobdiff