\f
;;;; primitive type definitions
-(def-primitive-type t (descriptor-reg))
-(setf *backend-t-primitive-type* (primitive-type-or-lose 't))
+(/show0 "primtype.lisp 17")
+
+(!def-primitive-type t (descriptor-reg))
+(/show0 "primtype.lisp 20")
+(setf *backend-t-primitive-type* (primitive-type-or-lose t))
;;; primitive integer types that fit in registers
-(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
- :type (unsigned-byte 29))
+(/show0 "primtype.lisp 24")
+(!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
+ :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
+(/show0 "primtype.lisp 27")
#!-alpha
-(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 31))
+(/show0 "primtype.lisp 31")
#!-alpha
-(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
:type (unsigned-byte 32))
+(/show0 "primtype.lisp 35")
#!+alpha
-(def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 63))
#!+alpha
-(def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
:type (unsigned-byte 64))
-(def-primitive-type fixnum (any-reg signed-reg)
- :type (signed-byte 30))
+(!def-primitive-type fixnum (any-reg signed-reg)
+ :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
#!-alpha
-(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
+(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
:type (signed-byte 32))
#!+alpha
-(def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
+(!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
:type (signed-byte 64))
(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
-(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
-(def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
- #!-alpha unsigned-byte-31
- #!+alpha unsigned-byte-64
- #!+alpha unsigned-byte-63
- positive-fixnum))
-(def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
- #!+alpha signed-byte-64
- fixnum
- #!-alpha unsigned-byte-31
- #!+alpha unsigned-byte-63
- positive-fixnum))
+(/show0 "primtype.lisp 53")
+(!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
+(!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-64
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
+(!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
+ #!+alpha signed-byte-64
+ fixnum
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
;;; other primitive immediate types
-(def-primitive-type base-char (base-char-reg any-reg))
+(/show0 "primtype.lisp 68")
+(!def-primitive-type character (character-reg any-reg))
;;; primitive pointer types
-(def-primitive-type function (descriptor-reg))
-(def-primitive-type list (descriptor-reg))
-(def-primitive-type instance (descriptor-reg))
+(/show0 "primtype.lisp 73")
+(!def-primitive-type function (descriptor-reg))
+(!def-primitive-type list (descriptor-reg))
+(!def-primitive-type instance (descriptor-reg))
-(def-primitive-type funcallable-instance (descriptor-reg))
+(/show0 "primtype.lisp 77")
+(!def-primitive-type funcallable-instance (descriptor-reg))
;;; primitive other-pointer number types
-(def-primitive-type bignum (descriptor-reg))
-(def-primitive-type ratio (descriptor-reg))
-(def-primitive-type complex (descriptor-reg))
-(def-primitive-type single-float (single-reg descriptor-reg))
-(def-primitive-type double-float (double-reg descriptor-reg))
-#!+long-float
-(def-primitive-type long-float (long-reg descriptor-reg))
-(def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
+(/show0 "primtype.lisp 81")
+(!def-primitive-type bignum (descriptor-reg))
+(!def-primitive-type ratio (descriptor-reg))
+(!def-primitive-type complex (descriptor-reg))
+(/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
+(!def-primitive-type single-float (single-reg descriptor-reg))
+(/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
+(!def-primitive-type double-float (double-reg descriptor-reg))
+
+(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
+(!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
:type (complex single-float))
-(def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
+(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
+(!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
:type (complex double-float))
-#!+long-float
-(def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
- :type (complex long-float))
-;;; primitive other-pointer array types
-(def-primitive-type simple-string (descriptor-reg)
- :type simple-base-string)
-(def-primitive-type simple-bit-vector (descriptor-reg))
-(def-primitive-type simple-vector (descriptor-reg))
-(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
- :type (simple-array (unsigned-byte 2) (*)))
-(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
- :type (simple-array (unsigned-byte 4) (*)))
-(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
- :type (simple-array (unsigned-byte 8) (*)))
-(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
- :type (simple-array (unsigned-byte 16) (*)))
-(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
- :type (simple-array (unsigned-byte 32) (*)))
-(def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
- :type (simple-array (signed-byte 8) (*)))
-(def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
- :type (simple-array (signed-byte 16) (*)))
-(def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
- :type (simple-array (signed-byte 30) (*)))
-(def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
- :type (simple-array (signed-byte 32) (*)))
-(def-primitive-type simple-array-single-float (descriptor-reg)
- :type (simple-array single-float (*)))
-(def-primitive-type simple-array-double-float (descriptor-reg)
- :type (simple-array double-float (*)))
-#!+long-float
-(def-primitive-type simple-array-long-float (descriptor-reg)
- :type (simple-array long-float (*)))
-(def-primitive-type simple-array-complex-single-float (descriptor-reg)
- :type (simple-array (complex single-float) (*)))
-(def-primitive-type simple-array-complex-double-float (descriptor-reg)
- :type (simple-array (complex double-float) (*)))
-#!+long-float
-(def-primitive-type simple-array-complex-long-float (descriptor-reg)
- :type (simple-array (complex long-float) (*)))
-;;; Note: The complex array types are not included, 'cause it is pointless to
-;;; restrict VOPs to them.
+;;; primitive other-pointer array types
+(/show0 "primtype.lisp 96")
+(macrolet ((define-simple-array-primitive-types ()
+ `(progn
+ ,@(map 'list
+ (lambda (saetp)
+ `(!def-primitive-type
+ ,(saetp-primitive-type-name saetp)
+ (descriptor-reg)
+ :type (simple-array ,(saetp-specifier saetp) (*))))
+ *specialized-array-element-type-properties*))))
+ (define-simple-array-primitive-types))
+;;; Note: The complex array types are not included, 'cause it is
+;;; pointless to restrict VOPs to them.
;;; other primitive other-pointer types
-(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
-(def-primitive-type weak-pointer (descriptor-reg))
+(!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+(!def-primitive-type weak-pointer (descriptor-reg))
;;; miscellaneous primitive types that don't exist at the LISP level
-(def-primitive-type catch-block (catch-block) :type nil)
+(!def-primitive-type catch-block (catch-block) :type nil)
\f
;;;; PRIMITIVE-TYPE-OF and friends
-;;; Return the most restrictive primitive type that contains Object.
+;;; Return the most restrictive primitive type that contains OBJECT.
+(/show0 "primtype.lisp 147")
(!def-vm-support-routine primitive-type-of (object)
(let ((type (ctype-of object)))
(cond ((not (member-type-p type)) (primitive-type type))
(t
*backend-t-primitive-type*))))
-(defvar *simple-array-primitive-types*
- '((base-char . simple-string)
- (bit . simple-bit-vector)
- ((unsigned-byte 2) . simple-array-unsigned-byte-2)
- ((unsigned-byte 4) . simple-array-unsigned-byte-4)
- ((unsigned-byte 8) . simple-array-unsigned-byte-8)
- ((unsigned-byte 16) . simple-array-unsigned-byte-16)
- ((unsigned-byte 32) . simple-array-unsigned-byte-32)
- ((signed-byte 8) . simple-array-signed-byte-8)
- ((signed-byte 16) . simple-array-signed-byte-16)
- (fixnum . simple-array-signed-byte-30)
- ((signed-byte 32) . simple-array-signed-byte-32)
- (single-float . simple-array-single-float)
- (double-float . simple-array-double-float)
- #!+long-float (long-float . simple-array-long-float)
- ((complex single-float) . simple-array-complex-single-float)
- ((complex double-float) . simple-array-complex-double-float)
- #!+long-float
- ((complex long-float) . simple-array-complex-long-float)
- (t . simple-vector))
- #!+sb-doc
- "An a-list for mapping simple array element types to their
- corresponding primitive types.")
-
;;; Return the primitive type corresponding to a type descriptor
;;; structure. The second value is true when the primitive type is
;;; exactly equivalent to the argument Lisp type.
;;; correct values for the system parameters.
;;;
;;; We need an aux function because we need to use both
-;;; !DEF-VM-SUPPORT-ROUTINE and defun-cached.
+;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
+(/show0 "primtype.lisp 188")
(!def-vm-support-routine primitive-type (type)
(primitive-type-aux type))
+(/show0 "primtype.lisp 191")
(defun-cached (primitive-type-aux
:hash-function (lambda (x)
(logand (type-hash-value x) #x1FF))
(integer
(cond ((and hi lo)
(dolist (spec
- `((positive-fixnum 0 ,(1- (ash 1 29)))
+ `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
#!-alpha
(unsigned-byte-31 0 ,(1- (ash 1 31)))
#!-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)))
+ (fixnum ,sb!xc:most-negative-fixnum
+ ,sb!xc:most-positive-fixnum)
#!-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))))
+ (if (or (< hi sb!xc:most-negative-fixnum)
+ (> lo sb!xc:most-positive-fixnum))
(part-of bignum)
(any)))
(let ((type (car spec))
(return (values
(primitive-type-or-lose type)
(and (= lo min) (= hi max))))))))
- ((or (and hi (< hi most-negative-fixnum))
- (and lo (> lo most-positive-fixnum)))
+ ((or (and hi (< hi sb!xc:most-negative-fixnum))
+ (and lo (> lo sb!xc:most-positive-fixnum)))
(part-of bignum))
(t
(any))))
((short-float single-float)
(values (primitive-type-or-lose 'single-float)
exact))
- ((double-float #!-long-float long-float)
+ ((double-float)
(values (primitive-type-or-lose 'double-float)
exact))
- #!+long-float
- (long-float
- (values (primitive-type-or-lose 'long-float)
- exact))
(t
(any)))))
(t
((short-float single-float)
(values (primitive-type-or-lose 'complex-single-float)
exact))
- ((double-float #!-long-float long-float)
+ ((double-float long-float)
(values (primitive-type-or-lose 'complex-double-float)
exact))
- #!+long-float
- (long-float
- (values (primitive-type-or-lose 'complex-long-float)
- exact))
(t
(part-of complex))))
(part-of complex)))
(let* ((dims (array-type-dimensions type))
(etype (array-type-specialized-element-type type))
(type-spec (type-specifier etype))
+ ;; FIXME: We're _WHAT_? Testing for type equality
+ ;; with a specifier and #'EQUAL? *BOGGLE*. --
+ ;; CSR, 2003-06-24
(ptype (cdr (assoc type-spec *simple-array-primitive-types*
:test #'equal))))
(if (and (consp dims) (null (rest dims)) ptype)
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
((nil) (any))))
- (sb!xc:built-in-class
- (case (sb!xc:class-name type)
+ (built-in-classoid
+ (case (classoid-name type)
((complex function instance
system-area-pointer weak-pointer)
- (values (primitive-type-or-lose (sb!xc:class-name type)) t))
+ (values (primitive-type-or-lose (classoid-name type)) t))
(funcallable-instance
(part-of function))
- (base-char
- (exactly base-char))
+ (character
+ (exactly character))
(cons-type
(part-of list))
(t
(any))))
- (function-type
+ (fun-type
(exactly function))
- (sb!xc:class
+ (classoid
(if (csubtypep type (specifier-type 'function))
(part-of function)
(part-of instance)))
(ctype
- (any))))))
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (any)))))))
+
+(/show0 "primtype.lisp end of file")
projects / sbcl.git / blobdiff