X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=147656e7a4e4efdf4e1f271faf8fc91acf0b743a;hb=568214ddf4c8ecc881caec98e20848d017974ec0;hp=d78c38bd6229aa70d0189d519e9fdf146ec97908;hpb=a6bda328d1a33a5ad328ec97bed83d5c49c530e0;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index d78c38b..147656e 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))) @@ -1031,11 +1035,6 @@ (!define-type-class named) -(defvar *wild-type*) -(defvar *empty-type*) -(defvar *universal-type*) -(defvar *universal-fun-type*) - (!cold-init-forms (macrolet ((frob (name var) `(progn @@ -1223,7 +1222,9 @@ (negation-type-type x)) (!define-type-method (negation :unparse) (x) - `(not ,(type-specifier (negation-type-type x)))) + (if (type= (negation-type-type x) (specifier-type 'cons)) + 'atom + `(not ,(type-specifier (negation-type-type x))))) (!define-type-method (negation :simple-subtypep) (type1 type2) (csubtypep (negation-type-type type2) (negation-type-type type1))) @@ -1464,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))))) @@ -1702,68 +1702,55 @@ (!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)))) + ((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)) @@ -1771,11 +1758,12 @@ (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))))))))) @@ -1848,38 +1836,92 @@ ;;; 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) @@ -2124,22 +2166,24 @@ (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 @@ -2406,18 +2450,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*)) @@ -2589,6 +2639,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 @@ -2861,7 +2913,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. ;;; @@ -2975,7 +3110,11 @@ (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))