0.7.1.28:

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 523f792..6ffd5c9 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -31,9 +31,9 @@
 ;;;
 ;;; RATIO and BIGNUM are not recognized as numeric types.
 
 ;;;
 ;;; RATIO and BIGNUM are not recognized as numeric types.
 

-;;; FIXME: It seems to me that this should be set to NIL by default,
-;;; and perhaps not even optionally set to T.
-(defvar *use-implementation-types* t
+;;; FIXME: This really should go away. Alas, it doesn't seem to be so
+;;; simple to make it go away.. (See bug 123 in BUGS file.)
+(defvar *use-implementation-types* t ; actually initialized in cold init

   #!+sb-doc
   "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
    restrictive we are in determining type membership. If two types are the
   #!+sb-doc
   "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
    restrictive we are in determining type membership. If two types are the

@@ -41,7 +41,6 @@
    this switch is on. When it is off, we try to be as restrictive as the
    language allows, allowing us to detect more errors. Currently, this only
    affects array types.")
    this switch is on. When it is off, we try to be as restrictive as the
    language allows, allowing us to detect more errors. Currently, this only
    affects array types.")

-

 (!cold-init-forms (setq *use-implementation-types* t))
 
 ;;; These functions are used as method for types which need a complex
 (!cold-init-forms (setq *use-implementation-types* t))
 
 ;;; These functions are used as method for types which need a complex

@@ -132,10 +131,10 @@
 ;;; the description of a &KEY argument
 (defstruct (key-info #-sb-xc-host (:pure t)
                     (:copier nil))
 ;;; the description of a &KEY argument
 (defstruct (key-info #-sb-xc-host (:pure t)
                     (:copier nil))

-  ;; the key (not necessarily a keyword in ANSI)
-  (name (required-argument) :type symbol)
+  ;; the key (not necessarily a keyword in ANSI Common Lisp)
+  (name (missing-arg) :type symbol)

   ;; the type of the argument value
   ;; the type of the argument value

-  (type (required-argument) :type ctype))
+  (type (missing-arg) :type ctype))

 
 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
                     (type1 type2)
 
 (!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
                     (type1 type2)

@@ -193,18 +192,18 @@
 ;;; a flag that we can bind to cause complex function types to be
 ;;; unparsed as FUNCTION. This is useful when we want a type that we
 ;;; can pass to TYPEP.
 ;;; a flag that we can bind to cause complex function types to be
 ;;; unparsed as FUNCTION. This is useful when we want a type that we
 ;;; can pass to TYPEP.

-(defvar *unparse-function-type-simplify*)
-(!cold-init-forms (setq *unparse-function-type-simplify* nil))
+(defvar *unparse-fun-type-simplify*)
+(!cold-init-forms (setq *unparse-fun-type-simplify* nil))

 
 (!define-type-method (function :unparse) (type)
 
 (!define-type-method (function :unparse) (type)

-  (if *unparse-function-type-simplify*
+  (if *unparse-fun-type-simplify*

       'function
       (list 'function
       'function
       (list 'function

-           (if (function-type-wild-args type)
+           (if (fun-type-wild-args type)

                '*
                (unparse-args-types type))
            (type-specifier
                '*
                (unparse-args-types type))
            (type-specifier

-            (function-type-returns type)))))
+            (fun-type-returns type)))))

 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.
 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.

@@ -230,12 +229,12 @@
 (!define-type-class constant :inherits values)
 
 (!define-type-method (constant :unparse) (type)
 (!define-type-class constant :inherits values)
 
 (!define-type-method (constant :unparse) (type)

-  `(constant-argument ,(type-specifier (constant-type-type type))))
+  `(constant-arg ,(type-specifier (constant-type-type type))))

 
 (!define-type-method (constant :simple-=) (type1 type2)
   (type= (constant-type-type type1) (constant-type-type type2)))
 
 
 (!define-type-method (constant :simple-=) (type1 type2)
   (type= (constant-type-type type1) (constant-type-type type2)))
 

-(!def-type-translator constant-argument (type)
+(!def-type-translator constant-arg (type)

   (make-constant-type :type (specifier-type type)))
 
 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
   (make-constant-type :type (specifier-type type)))
 
 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE

@@ -295,10 +294,9 @@
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))

-  (let ((res (make-function-type
-             :returns (values-specifier-type result))))
+  (let ((res (make-fun-type :returns (values-specifier-type result))))

     (if (eq args '*)
     (if (eq args '*)

-       (setf (function-type-wild-args res) t)
+       (setf (fun-type-wild-args res) t)

        (parse-args-types args res))
     res))
 
        (parse-args-types args res))
     res))
 

@@ -333,9 +331,9 @@
 ;;; Return the minimum number of arguments that a function can be
 ;;; called with, and the maximum number or NIL. If not a function
 ;;; type, return NIL, NIL.
 ;;; Return the minimum number of arguments that a function can be
 ;;; called with, and the maximum number or NIL. If not a function
 ;;; type, return NIL, NIL.

-(defun function-type-nargs (type)
+(defun fun-type-nargs (type)

   (declare (type ctype type))
   (declare (type ctype type))

-  (if (function-type-p type)
+  (if (fun-type-p type)

       (let ((fixed (length (args-type-required type))))
        (if (or (args-type-rest type)
                (args-type-keyp type)
       (let ((fixed (length (args-type-required type))))
        (if (or (args-type-rest type)
                (args-type-keyp type)

@@ -383,12 +381,12 @@
 (defun fixed-values-op (types1 types2 rest2 operation)
   (declare (list types1 types2) (type ctype rest2) (type function operation))
   (let ((exact t))
 (defun fixed-values-op (types1 types2 rest2 operation)
   (declare (list types1 types2) (type ctype rest2) (type function operation))
   (let ((exact t))

-    (values (mapcar #'(lambda (t1 t2)
-                       (multiple-value-bind (res win)
-                           (funcall operation t1 t2)
-                         (unless win
-                           (setq exact nil))
-                         res))
+    (values (mapcar (lambda (t1 t2)
+                     (multiple-value-bind (res win)
+                         (funcall operation t1 t2)
+                       (unless win
+                         (setq exact nil))
+                       res))

                    types1
                    (append types2
                            (make-list (- (length types1) (length types2))
                    types1
                    (append types2
                            (make-list (- (length types1) (length types2))

@@ -802,6 +800,7 @@
 (defun simplified-compound-types (input-types %compound-type-p simplify2)
   (let ((simplified-types (make-array (length input-types)
                                      :fill-pointer 0
 (defun simplified-compound-types (input-types %compound-type-p simplify2)
   (let ((simplified-types (make-array (length input-types)
                                      :fill-pointer 0

+                                     :adjustable t

                                      :element-type 'ctype
                                      ;; (This INITIAL-ELEMENT shouldn't
                                      ;; matter, but helps avoid type
                                      :element-type 'ctype
                                      ;; (This INITIAL-ELEMENT shouldn't
                                      ;; matter, but helps avoid type

@@ -876,7 +875,7 @@
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *wild-type*)
 (defvar *empty-type*)
 (defvar *universal-type*)

-
+(defvar *universal-fun-type*)

 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn
 (!cold-init-forms
  (macrolet ((frob (name var)
              `(progn

@@ -891,7 +890,10 @@
    ;; Ts and *UNIVERSAL-TYPE*s.
    (frob * *wild-type*)
    (frob nil *empty-type*)
    ;; Ts and *UNIVERSAL-TYPE*s.
    (frob * *wild-type*)
    (frob nil *empty-type*)

-   (frob t *universal-type*)))
+   (frob t *universal-type*))
+ (setf *universal-fun-type*
+       (make-fun-type :wild-args t
+                          :returns *wild-type*)))

 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in
 
 (!define-type-method (named :simple-=) (type1 type2)
   ;; FIXME: BUG 85: This assertion failed when I added it in

@@ -974,7 +976,75 @@
          (t
           (values nil nil)))))
 
          (t
           (values nil nil)))))
 

-(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
+  (let ((hairy-spec (hairy-type-specifier type1)))
+     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
+           ;; You may not believe this. I couldn't either. But then I
+           ;; sat down and drew lots of Venn diagrams. Comments
+           ;; involving a and b refer to the call (subtypep '(not a)
+           ;; 'b) -- CSR, 2002-02-27.
+           (block nil
+             ;; (Several logical truths in this block are true as
+             ;; long as b/=T. As of sbcl-0.7.1.28, it seems
+             ;; impossible to construct a case with b=T where we
+             ;; actually reach this type method, but we'll test for
+             ;; and exclude this case anyway, since future
+             ;; maintenance might make it possible for it to end up
+             ;; in this code.)
+             (multiple-value-bind (equal certain)
+                 (type= type2 (specifier-type t))
+               (unless certain
+                 (return (values nil nil)))
+               (when equal
+                 (return (values t t))))
+             (let ((complement-type1 (specifier-type (cadr hairy-spec))))
+               ;; Do the special cases first, in order to give us a
+               ;; chance if subtype/supertype relationships are hairy.
+               (multiple-value-bind (equal certain) 
+                   (type= complement-type1 type2)
+                 ;; If a = b, ~a is not a subtype of b (unless b=T,
+                 ;; which was excluded above).
+                 (unless certain
+                   (return (values nil nil)))
+                 (when equal
+                   (return (values nil t))))
+               ;; This (TYPE= TYPE1 TYPE2) branch would never be
+               ;; taken, as type1 and type2 will only be equal if
+               ;; they're both NOT types, and then the
+               ;; :SIMPLE-SUBTYPEP method would be used instead.
+               ;; ((type= type1 type2) (values t t))
+               (multiple-value-bind (equal certain)
+                   (csubtypep complement-type1 type2)
+                 ;; If a is a subtype of b, ~a is not a subtype of b
+                 ;; (unless b=T, which was excluded above).
+                 (unless certain
+                   (return (values nil nil)))
+                 (when equal
+                   (return (values nil t))))
+               (multiple-value-bind (equal certain)
+                   (csubtypep type2 complement-type1)
+                 ;; If b is a subtype of a, ~a is not a subtype of b.
+                 ;; (FIXME: That's not true if a=T. Do we know at
+                 ;; this point that a is not T?)
+                 (unless certain
+                   (return (values nil nil)))
+                 (when equal
+                   (return (values nil t))))
+               ;; Other cases here would rely on being able to catch
+               ;; all possible cases, which the fragility of this
+               ;; type system doesn't inspire me; for instance, if a
+               ;; is type= to ~b, then we want T, T; if this is not
+               ;; the case and the types are disjoint (have an
+               ;; intersection of *empty-type*) then we want NIL, T;
+               ;; else if the union of a and b is the
+               ;; *universal-type* then we want T, T. So currently we
+               ;; still claim to be unsure about e.g. (subtypep '(not
+               ;; fixnum) 'single-float).
+               )))
+          (t
+           (values nil nil)))))
+
+(!define-type-method (hairy :complex-=) (type1 type2)

   (declare (ignore type1 type2))
   (values nil nil))
 
   (declare (ignore type1 type2))
   (values nil nil))
 

@@ -994,9 +1064,11 @@
   ;; Check legality of arguments.
   (destructuring-bind (not typespec) whole
     (declare (ignore not))
   ;; Check legality of arguments.
   (destructuring-bind (not typespec) whole
     (declare (ignore not))

-    (specifier-type typespec)) ; must be legal typespec
-  ;; Create object.
-  (make-hairy-type :specifier whole))
+    (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec
+      (if (and (listp spec) (eq (car spec) 'not))
+         ;; canonicalize (not (not foo))
+         (specifier-type (cadr spec))
+         (make-hairy-type :specifier whole)))))

 
 (!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))
 
 (!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))

@@ -1276,34 +1348,80 @@
   (if (eq typespec '*)
       (make-numeric-type :complexp :complex)
       (labels ((not-numeric ()
   (if (eq typespec '*)
       (make-numeric-type :complexp :complex)
       (labels ((not-numeric ()

-                 ;; FIXME: should probably be TYPE-ERROR

                 (error "The component type for COMPLEX is not numeric: ~S"
                        typespec))
                 (error "The component type for COMPLEX is not numeric: ~S"
                        typespec))

+              (not-real ()
+                (error "The component type for COMPLEX is not real: ~S"
+                       typespec))

               (complex1 (component-type)
                 (unless (numeric-type-p component-type)
               (complex1 (component-type)
                 (unless (numeric-type-p component-type)

-                  ;; FIXME: As per the FIXME below, ANSI says we're
-                  ;; supposed to handle any subtype of REAL, not only
-                  ;; those which can be represented as NUMERIC-TYPE.

                   (not-numeric))
                 (when (eq (numeric-type-complexp component-type) :complex)
                   (not-numeric))
                 (when (eq (numeric-type-complexp component-type) :complex)

-                  (error "The component type for COMPLEX is complex: ~S"
-                         typespec))
-                (modified-numeric-type component-type :complexp :complex)))
-       (let ((type (specifier-type typespec)))
-         (typecase type
-           ;; This is all that CMU CL handled.
-           (numeric-type (complex1 type))
-           ;; We need to handle UNION-TYPEs in order to deal with
-           ;; REAL and FLOAT being represented as UNION-TYPEs of more
-           ;; primitive types.
+                  (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))))))
+       (let ((ctype (specifier-type typespec)))
+         (typecase ctype
+           (numeric-type (complex1 ctype))

            (union-type (apply #'type-union
            (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
                               (mapcar #'complex1

-                                      (union-type-types type))))
-           ;; FIXME: ANSI just says that TYPESPEC is a subtype of type
-           ;; REAL, not necessarily a NUMERIC-TYPE. E.g. TYPESPEC could
-           ;; legally be (AND REAL (SATISFIES ODDP))! But like the old
-           ;; CMU CL code, we're still not nearly that general.
-           (t (not-numeric)))))))
+                                      (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))))
+           (t
+            (multiple-value-bind (subtypep certainly)
+                (csubtypep ctype (specifier-type 'real))
+              (if (and (not subtypep) certainly)
+                  (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 
+                         used for a COMPLEX component.~:@>"
+                       typespec)))))))))

 
 ;;; If X is *, return NIL, otherwise return the bound, which must be a
 ;;; member of TYPE or a one-element list of a member of TYPE.
 
 ;;; If X is *, return NIL, otherwise return the bound, which must be a
 ;;; member of TYPE or a one-element list of a member of TYPE.

@@ -1713,8 +1831,8 @@
     ;; See whether dimensions are compatible.
     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
                    (and (= (length dims1) (length dims2))
     ;; See whether dimensions are compatible.
     (cond ((not (or (eq dims1 '*) (eq dims2 '*)
                    (and (= (length dims1) (length dims2))

-                        (every #'(lambda (x y)
-                                   (or (eq x '*) (eq y '*) (= x y)))
+                        (every (lambda (x y)
+                                 (or (eq x '*) (eq y '*) (= x y)))

                                dims1 dims2))))
           (values nil t))
          ;; See whether complexpness is compatible.
                                dims1 dims2))))
           (values nil t))
          ;; See whether complexpness is compatible.

@@ -1912,16 +2030,18 @@
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 
   (type=-set (intersection-type-types type1)
             (intersection-type-types type2)))
 

-(flet ((intersection-complex-subtypep-arg1 (type1 type2)
-         (any/type (swapped-args-fun #'csubtypep)
-                  type2
-                  (intersection-type-types type1))))
-  (!define-type-method (intersection :simple-subtypep) (type1 type2)
-    (every/type #'intersection-complex-subtypep-arg1
-               type1
-               (intersection-type-types type2)))
-  (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
-    (intersection-complex-subtypep-arg1 type1 type2)))
+(defun %intersection-complex-subtypep-arg1 (type1 type2)
+  (any/type (swapped-args-fun #'csubtypep)
+           type2
+           (intersection-type-types type1)))
+
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+  (every/type #'%intersection-complex-subtypep-arg1
+             type1
+             (intersection-type-types type2)))
+
+(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+  (%intersection-complex-subtypep-arg1 type1 type2))

 
 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
   (every/type #'csubtypep type1 (intersection-type-types type2)))
 
 (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
   (every/type #'csubtypep type1 (intersection-type-types type2)))

@@ -2152,7 +2272,7 @@
           ;; that an object of type FUNCTION doesn't satisfy it, so
           ;; we return success no matter what.
           t)
           ;; that an object of type FUNCTION doesn't satisfy it, so
           ;; we return success no matter what.
           t)

-         (;; Otherwise both of them must be FUNCTION-TYPE objects.
+         (;; Otherwise both of them must be FUN-TYPE objects.

           t
           ;; FIXME: For now we only check compatibility of the return
           ;; type, not argument types, and we don't even check the
           t
           ;; FIXME: For now we only check compatibility of the return
           ;; type, not argument types, and we don't even check the

@@ -2161,11 +2281,11 @@
           ;; compatibility of the arguments, we should (1) redo
           ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
           ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to
           ;; compatibility of the arguments, we should (1) redo
           ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
           ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to

-          ;; the ARGS-TYPE slices of the FUNCTION-TYPEs. (ARGS-TYPE
-          ;; is a base class both of VALUES-TYPE and of FUNCTION-TYPE.)
+          ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE
+          ;; is a base class both of VALUES-TYPE and of FUN-TYPE.)

           (values-types-equal-or-intersect
           (values-types-equal-or-intersect

-           (function-type-returns defined-ftype)
-           (function-type-returns declared-ftype))))))
+           (fun-type-returns defined-ftype)
+           (fun-type-returns declared-ftype))))))

           
 ;;; This messy case of CTYPE for NUMBER is shared between the
 ;;; cross-compiler and the target system.
           
 ;;; This messy case of CTYPE for NUMBER is shared between the
 ;;; cross-compiler and the target system.

@@ -2185,6 +2305,15 @@
                         :low low
                         :high high))))
 \f
                         :low low
                         :high high))))
 \f

-(!defun-from-collected-cold-init-forms !late-type-cold-init)
+(locally
+  ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type
+  ;; checking for declarations in structure accessors. Otherwise we
+  ;; can get caught in a chicken-and-egg bootstrapping problem, whose
+  ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal
+  ;; instruction trap. I haven't tracked it down, but I'm guessing it
+  ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set
+  ;; yet. -- WHN
+  (declare (optimize (safety 0)))
+  (!defun-from-collected-cold-init-forms !late-type-cold-init))

 
 (/show0 "late-type.lisp end of file")
 
 (/show0 "late-type.lisp end of file")