(apply #'type-union
(mapcar (lambda (x) (complex1 (ctype-of x)))
(member-type-members ctype))))
+ ((and (typep ctype 'intersection-type)
+ ;; FIXME: This is very much a
+ ;; not-quite-worst-effort, but we are required to do
+ ;; something here because of our representation of
+ ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
+ ;; allow users to ask about (COMPLEX RATIO). This
+ ;; will of course fail to work right on such types
+ ;; as (AND INTEGER (SATISFIES ZEROP))...
+ (let ((numbers (remove-if-not
+ #'numeric-type-p
+ (intersection-type-types ctype))))
+ (and (car numbers)
+ (null (cdr numbers))
+ (eq (numeric-type-complexp (car numbers)) :real)
+ (complex1 (car numbers))))))
(t
(multiple-value-bind (subtypep certainly)
(csubtypep ctype (specifier-type 'real))
(not-real)
;; ANSI just says that TYPESPEC is any subtype of
;; type REAL, not necessarily a NUMERIC-TYPE. In
- ;; particular, at this point TYPESPEC could legally be
- ;; an intersection type like (AND REAL (SATISFIES ODDP)),
- ;; in which case we fall through the logic above and
- ;; end up here, stumped.
- (bug "~@<(known bug #145): The type ~S is too hairy to be
+ ;; particular, at this point TYPESPEC could legally
+ ;; be a hairy type like (AND NUMBER (SATISFIES
+ ;; REALP) (SATISFIES ZEROP)), in which case we fall
+ ;; through the logic above and end up here,
+ ;; stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be ~
used for a COMPLEX component.~:@>"
typespec)))))))))
;;; FIXME: It's probably necessary to do something to fix the
;;; analogous problem with INTEGER and RATIONAL types. Perhaps
;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
-(defun coerce-bound (bound type inner-coerce-bound-fun)
+(defun coerce-bound (bound type upperp inner-coerce-bound-fun)
(declare (type function inner-coerce-bound-fun))
- (cond ((eql bound '*)
- bound)
- ((consp bound)
- (destructuring-bind (inner-bound) bound
- (list (funcall inner-coerce-bound-fun inner-bound type))))
- (t
- (funcall inner-coerce-bound-fun bound type))))
-(defun inner-coerce-real-bound (bound type)
- (ecase type
- (rational (rationalize bound))
- (float (if (floatp bound)
- bound
- ;; Coerce to the widest float format available, to
- ;; avoid unnecessary loss of precision:
- (coerce bound 'long-float)))))
-(defun coerced-real-bound (bound type)
- (coerce-bound bound type #'inner-coerce-real-bound))
-(defun coerced-float-bound (bound type)
- (coerce-bound bound type #'coerce))
+ (if (eql bound '*)
+ bound
+ (funcall inner-coerce-bound-fun bound type upperp)))
+(defun inner-coerce-real-bound (bound type upperp)
+ #+sb-xc-host (declare (ignore upperp))
+ (let #+sb-xc-host ()
+ #-sb-xc-host
+ ((nl (load-time-value (symbol-value 'sb!xc:most-negative-long-float)))
+ (pl (load-time-value (symbol-value 'sb!xc:most-positive-long-float))))
+ (let ((nbound (if (consp bound) (car bound) bound))
+ (consp (consp bound)))
+ (ecase type
+ (rational
+ (if consp
+ (list (rational nbound))
+ (rational nbound)))
+ (float
+ (cond
+ ((floatp nbound) bound)
+ (t
+ ;; Coerce to the widest float format available, to avoid
+ ;; unnecessary loss of precision, but don't coerce
+ ;; unrepresentable numbers, except on the host where we
+ ;; shouldn't be making these types (but KLUDGE: can't even
+ ;; assert portably that we're not).
+ #-sb-xc-host
+ (ecase upperp
+ ((nil)
+ (when (< nbound nl) (return-from inner-coerce-real-bound nl)))
+ ((t)
+ (when (> nbound pl) (return-from inner-coerce-real-bound pl))))
+ (let ((result (coerce nbound 'long-float)))
+ (if consp (list result) result)))))))))
+(defun inner-coerce-float-bound (bound type upperp)
+ #+sb-xc-host (declare (ignore upperp))
+ (let #+sb-xc-host ()
+ #-sb-xc-host
+ ((nd (load-time-value (symbol-value 'sb!xc:most-negative-double-float)))
+ (pd (load-time-value (symbol-value 'sb!xc:most-positive-double-float)))
+ (ns (load-time-value (symbol-value 'sb!xc:most-negative-single-float)))
+ (ps (load-time-value
+ (symbol-value 'sb!xc:most-positive-single-float))))
+ (let ((nbound (if (consp bound) (car bound) bound))
+ (consp (consp bound)))
+ (ecase type
+ (single-float
+ (cond
+ ((typep nbound 'single-float) bound)
+ (t
+ #-sb-xc-host
+ (ecase upperp
+ ((nil)
+ (when (< nbound ns) (return-from inner-coerce-float-bound ns)))
+ ((t)
+ (when (> nbound ps) (return-from inner-coerce-float-bound ps))))
+ (let ((result (coerce nbound 'single-float)))
+ (if consp (list result) result)))))
+ (double-float
+ (cond
+ ((typep nbound 'double-float) bound)
+ (t
+ #-sb-xc-host
+ (ecase upperp
+ ((nil)
+ (when (< nbound nd) (return-from inner-coerce-float-bound nd)))
+ ((t)
+ (when (> nbound pd) (return-from inner-coerce-float-bound pd))))
+ (let ((result (coerce nbound 'double-float)))
+ (if consp (list result) result)))))))))
+(defun coerced-real-bound (bound type upperp)
+ (coerce-bound bound type upperp #'inner-coerce-real-bound))
+(defun coerced-float-bound (bound type upperp)
+ (coerce-bound bound type upperp #'inner-coerce-float-bound))
(!def-type-translator real (&optional (low '*) (high '*))
- (specifier-type `(or (float ,(coerced-real-bound low 'float)
- ,(coerced-real-bound high 'float))
- (rational ,(coerced-real-bound low 'rational)
- ,(coerced-real-bound high 'rational)))))
+ (specifier-type `(or (float ,(coerced-real-bound low 'float nil)
+ ,(coerced-real-bound high 'float t))
+ (rational ,(coerced-real-bound low 'rational nil)
+ ,(coerced-real-bound high 'rational t)))))
(!def-type-translator float (&optional (low '*) (high '*))
(specifier-type
- `(or (single-float ,(coerced-float-bound low 'single-float)
- ,(coerced-float-bound high 'single-float))
- (double-float ,(coerced-float-bound low 'double-float)
- ,(coerced-float-bound high 'double-float))
+ `(or (single-float ,(coerced-float-bound low 'single-float nil)
+ ,(coerced-float-bound high 'single-float t))
+ (double-float ,(coerced-float-bound low 'double-float nil)
+ ,(coerced-float-bound high 'double-float t))
#!+long-float ,(error "stub: no long float support yet"))))
(defmacro !define-float-format (f)
(if (eq (car dims) '*)
(case eltype
(bit 'bit-vector)
- (base-char 'base-string)
+ ((base-char #!-sb-unicode character) 'base-string)
(* 'vector)
(t `(vector ,eltype)))
(case eltype
(bit `(bit-vector ,(car dims)))
- (base-char `(base-string ,(car dims)))
+ ((base-char #!-sb-unicode 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 #!-sb-unicode 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 #!-sb-unicode 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)))
(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 '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.
;;;
(values :complex (min num imag) (max num imag)))
(values :real num num))
(make-numeric-type :class (etypecase num
- (integer 'integer)
+ (integer (if (complexp x)
+ (if (integerp (imagpart x))
+ 'integer
+ 'rational)
+ 'integer))
(rational 'rational)
(float 'float))
:format (and (floatp num) (float-format-name num))
projects / sbcl.git / blobdiff