Fix bug: (FUNCTION (&REST T)) = (FUNCTION *).
but this first return value is not suitable for input to FUNCTION or
COMPILE, as required by ANSI.
but this first return value is not suitable for input to FUNCTION or
COMPILE, as required by ANSI.
+229:
+ (subtypep 'function '(function)) => nil, t.
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
"SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-INT-EXPONENT"
"SINGLE-FLOAT-SIGNIFICAND"
"SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
"SINGLE-FLOAT-INT-EXPONENT"
"SINGLE-FLOAT-SIGNIFICAND"
- "SINGLE-VALUE-TYPE" "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
+ "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE"
+ "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
"SPECIFIER-TYPE" "STACK-REF"
"STREAMLIKE" "STRINGABLE"
"STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"
"SPECIFIER-TYPE" "STACK-REF"
"STREAMLIKE" "STRINGABLE"
"STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"
(error "VALUES type illegal in this context:~% ~S" x))
res))
(error "VALUES type illegal in this context:~% ~S" x))
res))
+(defun single-value-specifier-type (x)
+ (let ((res (specifier-type x)))
+ (if (eq res *wild-type*)
+ *universal-type*
+ res)))
+
;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
;;; returning a second value.
(defun type-expand (form)
;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
;;; returning a second value.
(defun type-expand (form)
(3and (values-subtypep (fun-type-returns type1)
(fun-type-returns type2))
(cond ((fun-type-wild-args type2) (values t t))
(3and (values-subtypep (fun-type-returns type1)
(fun-type-returns type2))
(cond ((fun-type-wild-args type2) (values t t))
- ((fun-type-wild-args type1) (values nil t))
+ ((fun-type-wild-args type1)
+ (cond ((fun-type-keyp type2) (values nil nil))
+ ((not (fun-type-rest type2)) (values nil t))
+ ((not (null (fun-type-required type2))) (values nil t))
+ (t (3and (type= *universal-type* (fun-type-rest type2))
+ (every/type #'type= *universal-type*
+ (fun-type-optional type2))))))
((not (and (fun-type-simple-p type1)
(fun-type-simple-p type2)))
(values nil nil))
((not (and (fun-type-simple-p type1)
(fun-type-simple-p type2)))
(values nil nil))
(declare (ignore aux)) ; since we require AUXP=NIL
(when auxp
(error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
(declare (ignore aux)) ; since we require AUXP=NIL
(when auxp
(error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
- (setf (args-type-required result) (mapcar #'specifier-type required))
- (setf (args-type-optional result) (mapcar #'specifier-type optional))
- (setf (args-type-rest result) (if restp (specifier-type rest) nil))
+ (setf (args-type-required result)
+ (mapcar #'single-value-specifier-type required))
+ (setf (args-type-optional result)
+ (mapcar #'single-value-specifier-type optional))
+ (setf (args-type-rest result)
+ (if restp (single-value-specifier-type rest) nil))
(setf (args-type-keyp result) keyp)
(collect ((key-info))
(dolist (key keys)
(setf (args-type-keyp result) keyp)
(collect ((key-info))
(dolist (key keys)
(error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
kwd lambda-list))
(key-info (make-key-info :name kwd
(error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
kwd lambda-list))
(key-info (make-key-info :name kwd
- :type (specifier-type (second key))))))
+ :type (single-value-specifier-type (second key))))))
(setf (args-type-keywords result) (key-info)))
(setf (args-type-allowp result) allowp)
(values)))
(setf (args-type-keywords result) (key-info)))
(setf (args-type-allowp result) allowp)
(values)))
:initial-element rest2)))
exact)))
:initial-element rest2)))
exact)))
-;;; If Type isn't a values type, then make it into one:
+;;; If TYPE isn't a values type, then make it into one:
;;; <type> ==> (values type &rest t)
(defun coerce-to-values (type)
(declare (type ctype type))
;;; <type> ==> (values type &rest t)
(defun coerce-to-values (type)
(declare (type ctype type))
(assert (not (equal (multiple-value-list
(subtypep '(function ()) '(function (&rest t))))
'(nil t))))
(assert (not (equal (multiple-value-list
(subtypep '(function ()) '(function (&rest t))))
'(nil t))))
(assert (not (equal (multiple-value-list
(subtypep '(function (&rest t)) '(function ())))
'(t t))))
(assert (not (equal (multiple-value-list
(subtypep '(function (&rest t)) '(function ())))
'(t t))))
+
+(assert (subtypep '(function)
+ '(function (&optional * &rest t))))
+(assert (equal (multiple-value-list
+ (subtypep '(function)
+ '(function (t &rest t))))
+ '(nil t)))
+#+nil
+(assert (and (subtypep 'function '(function))
+ (subtypep '(function) 'function)))
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)