diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp index 9199586d51df7e433f3f482c7c07a73e11dba2c9..f0b3e8437dcd237c45143063c1c887f35b6b192a 100644 --- a/compiler/generic/primtype.lisp +++ b/compiler/generic/primtype.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.16 1997/11/01 22:58:36 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.17 1997/12/13 11:57:57 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -208,132 +208,170 @@ `(values (primitive-type-or-lose ',type *backend*) t)) (part-of (type) `(values (primitive-type-or-lose ',type *backend*) nil))) - (etypecase type - (numeric-type - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (case (numeric-type-complexp type) - (:real - (case (numeric-type-class type) - (integer - (cond ((and hi lo) - (dolist (spec - '((positive-fixnum 0 #.(1- (ash 1 29))) - #-alpha - (unsigned-byte-31 0 #.(1- (ash 1 31))) - #-alpha - (unsigned-byte-32 0 #.(1- (ash 1 32))) - #+alpha - (unsigned-byte-63 0 #.(1- (ash 1 63))) - #+alpha - (unsigned-byte-64 0 #.(1- (ash 1 64))) - (fixnum #.(ash -1 29) #.(1- (ash 1 29))) - #-alpha - (signed-byte-32 #.(ash -1 31) - #.(1- (ash 1 31))) - #+alpha - (signed-byte-64 #.(ash -1 63) - #.(1- (ash 1 63)))) - (if (or (< hi (ash -1 29)) - (> lo (1- (ash 1 29)))) - (part-of bignum) - (any))) - (let ((type (car spec)) - (min (cadr spec)) - (max (caddr spec))) - (when (<= min lo hi max) - (return (values (primitive-type-or-lose type - *backend*) - (and (= lo min) (= hi max)))))))) - ((or (and hi (< hi most-negative-fixnum)) - (and lo (> lo most-positive-fixnum))) - (part-of bignum)) + (flet ((maybe-numeric-type-union (t1 t2) + (let ((t1-name (c::primitive-type-name t1)) + (t2-name (c::primitive-type-name t2))) + (case t1-name + (positive-fixnum + (if (or (eq t2-name 'fixnum) + (eq t2-name #-alpha 'signed-byte-32 + #+alpha 'signed-byte-64) + (eq t2-name #-alpha 'unsigned-byte-31 + #+alpha 'unsigned-byte-63) + (eq t2-name #-alpha 'unsigned-byte-32 + #+alpha 'unsigned-byte-64)) + t2)) + (fixnum + (case t2-name + (#-alpha signed-byte-32 #+alpha signed-byte-64 t2) + (#-alpha unsigned-byte-31 #+alpha unsigned-byte-63 + (primitive-type-or-lose + #-alpha 'signed-byte-32 #+alpha 'signed-byte-64 + *backend*)))) + (#-alpha signed-byte-32 #+alpha signed-byte-64 + (if (eq t2-name #-alpha 'unsigned-byte-31 + #+alpha 'unsigned-byte-63) + t1)) + (#-alpha unsigned-byte-31 #+alpha unsigned-byte-63 + (if (eq t2-name #-alpha 'unsigned-byte-32 + #+alpha 'unsigned-byte-64) + t2)))))) + (etypecase type + (numeric-type + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (case (numeric-type-complexp type) + (:real + (case (numeric-type-class type) + (integer + (cond ((and hi lo) + (dolist (spec + '((positive-fixnum 0 #.(1- (ash 1 29))) + #-alpha + (unsigned-byte-31 0 #.(1- (ash 1 31))) + #-alpha + (unsigned-byte-32 0 #.(1- (ash 1 32))) + #+alpha + (unsigned-byte-63 0 #.(1- (ash 1 63))) + #+alpha + (unsigned-byte-64 0 #.(1- (ash 1 64))) + (fixnum #.(ash -1 29) #.(1- (ash 1 29))) + #-alpha + (signed-byte-32 #.(ash -1 31) + #.(1- (ash 1 31))) + #+alpha + (signed-byte-64 #.(ash -1 63) + #.(1- (ash 1 63)))) + (if (or (< hi (ash -1 29)) + (> lo (1- (ash 1 29)))) + (part-of bignum) + (any))) + (let ((type (car spec)) + (min (cadr spec)) + (max (caddr spec))) + (when (<= min lo hi max) + (return (values + (primitive-type-or-lose type *backend*) + (and (= lo min) (= hi max)))))))) + ((or (and hi (< hi most-negative-fixnum)) + (and lo (> lo most-positive-fixnum))) + (part-of bignum)) + (t + (any)))) + (float + (let ((exact (and (null lo) (null hi)))) + (case (numeric-type-format type) + ((short-float single-float) + (values (primitive-type-or-lose 'single-float *backend*) + exact)) + ((double-float long-float) + (values (primitive-type-or-lose 'double-float *backend*) + exact)) (t - (any)))) - (float - (let ((exact (and (null lo) (null hi)))) - (case (numeric-type-format type) - ((short-float single-float) - (values (primitive-type-or-lose 'single-float *backend*) - exact)) - ((double-float long-float) - (values (primitive-type-or-lose 'double-float *backend*) - exact)) - (t - (any))))) - (t - (any)))) - (:complex - #+complex-float - (if (eq (numeric-type-class type) 'float) - (let ((exact (and (null lo) (null hi)))) - (case (numeric-type-format type) - ((short-float single-float) - (values (primitive-type-or-lose 'complex-single-float - *backend*) - exact)) - ((double-float long-float) - (values (primitive-type-or-lose 'complex-double-float - *backend*) - exact)) - (t - (part-of complex)))) - (part-of complex)) - #-complex-float - (part-of complex)) + (any))))) + (t + (any)))) + (:complex + #+complex-float + (if (eq (numeric-type-class type) 'float) + (let ((exact (and (null lo) (null hi)))) + (case (numeric-type-format type) + ((short-float single-float) + (values (primitive-type-or-lose 'complex-single-float + *backend*) + exact)) + ((double-float long-float) + (values (primitive-type-or-lose 'complex-double-float + *backend*) + exact)) + (t + (part-of complex)))) + (part-of complex)) + #-complex-float + (part-of complex)) + (t + (any))))) + (array-type + (if (array-type-complexp type) + (any) + (let* ((dims (array-type-dimensions type)) + (etype (array-type-specialized-element-type type)) + (type-spec (type-specifier etype)) + (ptype (cdr (assoc type-spec *simple-array-primitive-types* + :test #'equal)))) + (if (and (consp dims) (null (rest dims)) ptype) + (values (primitive-type-or-lose ptype *backend*) + (eq (first dims) '*)) + (any))))) + (union-type + (if (type= type (specifier-type 'list)) + (exactly list) + (let ((types (union-type-types type))) + (multiple-value-bind (res exact) + (primitive-type (first types)) + (dolist (type (rest types) (values res exact)) + (multiple-value-bind (ptype ptype-exact) + (primitive-type type) + (unless ptype-exact (setq exact nil)) + (unless (eq ptype res) + (let ((new-ptype + (or (maybe-numeric-type-union res ptype) + (maybe-numeric-type-union ptype res)))) + (if new-ptype + (setq res new-ptype) + (return (any))))))))))) + (member-type + (let* ((members (member-type-members type)) + (res (primitive-type-of (first members)))) + (dolist (mem (rest members) (values res nil)) + (let ((ptype (primitive-type-of mem))) + (unless (eq ptype res) + (let ((new-ptype (or (maybe-numeric-type-union res ptype) + (maybe-numeric-type-union ptype res)))) + (if new-ptype + (setq res new-ptype) + (return (any))))))))) + (named-type + (ecase (named-type-name type) + ((t *) (values *any-primitive-type* t)) + ((nil) (any)))) + (built-in-class + (case (class-name type) + ((complex function instance system-area-pointer weak-pointer) + (values (primitive-type-or-lose (class-name type) *backend*) t)) + (funcallable-instance + (part-of function)) + (base-char + (exactly base-char)) + (cons + (part-of list)) (t - (any))))) - (array-type - (if (array-type-complexp type) - (any) - (let* ((dims (array-type-dimensions type)) - (etype (array-type-specialized-element-type type)) - (type-spec (type-specifier etype)) - (ptype (cdr (assoc type-spec *simple-array-primitive-types* - :test #'equal)))) - (if (and (consp dims) (null (rest dims)) ptype) - (values (primitive-type-or-lose ptype *backend*) - (eq (first dims) '*)) - (any))))) - (union-type - (if (type= type (specifier-type 'list)) - (exactly list) - (let ((types (union-type-types type))) - (multiple-value-bind (res exact) - (primitive-type (first types)) - (dolist (type (rest types) (values res exact)) - (multiple-value-bind (ptype ptype-exact) - (primitive-type type) - (unless ptype-exact (setq exact nil)) - (unless (eq ptype res) - (return (any))))))))) - (member-type - (let* ((members (member-type-members type)) - (res (primitive-type-of (first members)))) - (dolist (mem (rest members) (values res nil)) - (unless (eq (primitive-type-of mem) res) - (return (values *any-primitive-type* nil)))))) - (named-type - (ecase (named-type-name type) - ((t *) (values *any-primitive-type* t)) - ((nil) (values *any-primitive-type* nil)))) - (built-in-class - (case (class-name type) - ((complex function instance system-area-pointer weak-pointer) - (values (primitive-type-or-lose (class-name type) *backend*) t)) - (funcallable-instance - (part-of function)) - (base-char - (exactly base-char)) - (cons - (part-of list)) - (t - (any)))) - (function-type - (exactly function)) - (class - (if (csubtypep type (specifier-type 'function)) - (part-of function) - (part-of instance))) - (ctype - (any))))) + (any)))) + (function-type + (exactly function)) + (class + (if (csubtypep type (specifier-type 'function)) + (part-of function) + (part-of instance))) + (ctype + (any))))))