(in-package "SB!KERNEL")
-(file-comment
- "$Header$")
-
(!begin-collecting-cold-init-forms)
;;; ### Remaining incorrectnesses:
;;; Return the type of the first value indicated by Type. This is used
;;; by people who don't want to have to deal with values types.
-#!-sb-fluid (declaim (freeze-type values-type) (inline single-value-type))
+
+;;; MNA: fix-instance-typep-call patch
+#!-sb-fluid (declaim (freeze-type values-type))
+; (inline single-value-type))
(defun single-value-type (type)
(declare (type ctype type))
(cond ((values-type-p type)
(or (car (args-type-required type))
- (car (args-type-optional type))
+ (if (args-type-optional type)
+ (type-union (car (args-type-optional type)) (specifier-type 'null)))
(args-type-rest type)
- *universal-type*))
+ (specifier-type 'null)))
((eq type *wild-type*)
*universal-type*)
(t
(values (mapcar #'single-value-type req) (length req))))))
;;; Return two values:
+;;; MNA: fix-instance-typep-call patch
;;; 1. A list of all the positional (fixed and optional) types.
;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;; If no keywords or rest, *EMPTY-TYPE*.
-(defun values-type-types (type)
+;;; If no keywords or &REST, then the DEFAULT-TYPE.
+(defun values-type-types (type &optional (default-type *empty-type*))
(declare (type values-type type))
(values (append (args-type-required type)
(args-type-optional type))
(cond ((args-type-keyp type) *universal-type*)
((args-type-rest type))
(t
- *empty-type*))))
+ ;; MNA: fix-instance-typep-call patch
+ default-type))))
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
;;; OPERATION returned true as its second value each time we called
;;; it. Since we approximate the intersection of VALUES types, the
;;; second value being true doesn't mean the result is exact.
-(defun args-type-op (type1 type2 operation nreq)
- (declare (type ctype type1 type2) (type function operation nreq))
+;;; MNA: fix-instance-typep-call patch
+(defun args-type-op (type1 type2 operation nreq default-type)
+ ;;; MNA: fix-instance-typep-call patch
+ (declare (type ctype type1 type2 default-type)
+ (type function operation nreq))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
- (multiple-value-bind (types1 rest1) (values-type-types type1)
- (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (multiple-value-bind (types1 rest1)
+ ;;; MNA: fix-instance-typep-call patch
+ (values-type-types type1 default-type)
+ (multiple-value-bind (types2 rest2)
+ ;;; MNA: fix-instance-typep-call patch
+ (values-type-types type2 default-type)
(multiple-value-bind (rest rest-exact)
(funcall operation rest1 rest2)
(multiple-value-bind (res res-exact)
:optional (if opt-last
(subseq opt 0 (1+ opt-last))
())
- :rest (if (eq rest *empty-type*) nil rest))
+ ;; MNA fix-instance-typep-call patch
+ :rest (if (eq rest default-type) nil rest))
(and rest-exact res-exact)))))))))
(funcall operation type1 type2)))
((eq type1 *empty-type*) type2)
((eq type2 *empty-type*) type1)
(t
- (values (args-type-op type1 type2 #'type-union #'min)))))
+ ;;; MNA: fix-instance-typep-call patch
+ (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+;;;
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
:values 2
(cond ((eq type1 *wild-type*) (values type2 t))
((eq type2 *wild-type*) (values type1 t))
(t
- (args-type-op type1 type2 #'type-intersection #'max))))
+ (args-type-op type1 type2 #'type-intersection #'max (specifier-type 'null)))))
;;; This is like TYPES-INTERSECT, except that it sort of works on
;;; VALUES types. Note that due to the semantics of
;;; A list of all the float formats, in order of decreasing precision.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant float-formats
+ (defparameter *float-formats*
'(long-float double-float single-float short-float)))
;;; The type of a float format.
-(deftype float-format () `(member ,@float-formats))
+(deftype float-format () `(member ,@*float-formats*))
#!+negative-zero-is-not-zero
(defun make-numeric-type (&key class format (complexp :real) low high
;;; either one is null, return NIL.
(defun float-format-max (f1 f2)
(when (and f1 f2)
- (dolist (f float-formats (error "Bad float format: ~S." f1))
+ (dolist (f *float-formats* (error "bad float format: ~S" f1))
(when (or (eq f f1) (eq f f2))
(return f)))))
-;;; Return the result of an operation on Type1 and Type2 according to
+;;; Return the result of an operation on TYPE1 and TYPE2 according to
;;; the rules of numeric contagion. This is always NUMBER, some float
;;; format (possibly complex) or RATIONAL. Due to rational
;;; canonicalization, there isn't much we can do here with integers or
;;; rational complex numbers.
;;;
-;;; If either argument is not a Numeric-Type, then return NUMBER. This
+;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
;;; is useful mainly for allowing types that are technically numbers,
-;;; but not a Numeric-Type.
+;;; but not a NUMERIC-TYPE.
(defun numeric-contagion (type1 type2)
(if (and (numeric-type-p type1) (numeric-type-p type2))
(let ((class1 (numeric-type-class type1))
projects / sbcl.git / blobdiff