X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=863f2487fff50a861c7cd692d3cd57c37670be62;hb=3aff5655417da74a19ce576f55b2cb6999cda6c5;hp=0a51a0b5bf30179dc542a58738ac397d1d757fb2;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 0a51a0b..863f248 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -16,9 +16,6 @@ (in-package "SB!KERNEL") -(file-comment - "$Header$") - (!begin-collecting-cold-init-forms) ;;; ### Remaining incorrectnesses: @@ -314,14 +311,18 @@ ;;; 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 @@ -361,17 +362,19 @@ (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 @@ -423,13 +426,20 @@ ;;; 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) @@ -450,7 +460,8 @@ :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))) @@ -471,7 +482,9 @@ ((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 @@ -482,7 +495,7 @@ (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 @@ -777,11 +790,11 @@ ;;; 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 @@ -1254,19 +1267,19 @@ ;;; 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))