primtype.lisp

开源跨平台Lisp编译器

                            (32 'unsigned-byte-31)
                            (64 'unsigned-byte-63)))
                      t1))
                 (#.(ecase sb!vm::n-machine-word-bits
                      (32 'unsigned-byte-31)
                      (64 'unsigned-byte-63))
                    (if (eq t2-name
                            (ecase sb!vm::n-machine-word-bits
                              (32 'unsigned-byte-32)
                              (64 '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 ,sb!xc:most-positive-fixnum)
                                    ,@(ecase sb!vm::n-machine-word-bits
                                        (32
                                         `((unsigned-byte-31
                                            0 ,(1- (ash 1 31)))
                                           (unsigned-byte-32
                                            0 ,(1- (ash 1 32)))))
                                        (64
                                         `((unsigned-byte-63
                                            0 ,(1- (ash 1 63)))
                                           (unsigned-byte-64
                                            0 ,(1- (ash 1 64))))))
                                    (fixnum ,sb!xc:most-negative-fixnum
                                            ,sb!xc:most-positive-fixnum)
                                    ,(ecase sb!vm::n-machine-word-bits
                                       (32
                                        `(signed-byte-32 ,(ash -1 31)
                                                         ,(1- (ash 1 31))))
                                       (64
                                        `(signed-byte-64 ,(ash -1 63)
                                                         ,(1- (ash 1 63))))))
                                 (if (or (< hi sb!xc:most-negative-fixnum)
                                         (> lo sb!xc:most-positive-fixnum))
                                     (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)
                                       (and (= lo min) (= hi max))))))))
                       ((or (and hi (< hi sb!xc:most-negative-fixnum))
                            (and lo (> lo sb!xc: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)
                              exact))
                     ((double-float)
                      (values (primitive-type-or-lose 'double-float)
                              exact))
                     (t
                      (any)))))
                (t
                 (any))))
             (:complex
              (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)
                               exact))
                      ((double-float long-float)
                       (values (primitive-type-or-lose 'complex-double-float)
                               exact))
                      (t
                       (part-of complex))))
                  (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))
                    ;; 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)
                   (values (primitive-type-or-lose ptype)
                           (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)))))))))))
        (intersection-type
         (let ((types (intersection-type-types type))
               (res (any)))
           ;; why NIL for the exact?  Well, we assume that the
           ;; intersection type is in fact doing something for us:
           ;; that is, that each of the types in the intersection is
           ;; in fact cutting off some of the type lattice.  Since no
           ;; intersection type is represented by a primitive type and
           ;; primitive types are mutually exclusive, it follows that
           ;; no intersection type can represent the entirety of the
           ;; primitive type.  (And NIL is the conservative answer,
           ;; anyway).  -- CSR, 2006-09-14
           (dolist (type types (values res nil))
             (multiple-value-bind (ptype)
                 (primitive-type type)
               (cond
                 ;; if the result so far is (any), any improvement on
                 ;; the specificity of the primitive type is valid.
                 ((eq res (any))
                  (setq res ptype))
                 ;; if the primitive type returned is (any), the
                 ;; result so far is valid.  Likewise, if the
                 ;; primitive type is the same as the result so far,
                 ;; everything is fine.
                 ((or (eq ptype (any)) (eq ptype res)))
                 ;; otherwise, we have something hairy and confusing,
                 ;; such as (and condition funcallable-instance).
                 ;; Punt.
                 (t (return (any))))))))
        (member-type
         (let (res)
           (block nil
             (mapc-member-type-members
              (lambda (member)
                (let ((ptype (primitive-type-of member)))
                  (if res
                      (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)))))
                      (setf res ptype))))
              type))
           res))
        (named-type
         (ecase (named-type-name type)
           ((t *) (values *backend-t-primitive-type* t))
           ((instance) (exactly instance))
           ((funcallable-instance) (part-of function))
           ((extended-sequence) (any))
           ((nil) (any))))
        (character-set-type
         (let ((pairs (character-set-type-pairs type)))
           (if (and (= (length pairs) 1)
                    (= (caar pairs) 0)
                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
               (exactly character)
               (part-of character))))
        (built-in-classoid
         (case (classoid-name type)
           ((complex function system-area-pointer weak-pointer)
            (values (primitive-type-or-lose (classoid-name type)) t))
           (cons-type
            (part-of list))
           (t
            (any))))
        (fun-type
         (exactly function))
        (classoid
         (if (csubtypep type (specifier-type 'function))
             (part-of function)
             (part-of instance)))
        (ctype
         (if (csubtypep type (specifier-type 'function))
             (part-of function)
             (any)))))))

(/show0 "primtype.lisp end of file")