(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (make-fun-type :args args
- :returns (coerce-to-values (values-specifier-type result))))
+ (let ((result (coerce-to-values (values-specifier-type result))))
+ (if (eq args '*)
+ (if (eq result *wild-type*)
+ (specifier-type 'function)
+ (make-fun-type :wild-args t :returns result))
+ (multiple-value-bind (required optional rest keyp keywords allowp)
+ (parse-args-types args)
+ (if (and (null required)
+ (null optional)
+ (eq rest *universal-type*)
+ (not keyp))
+ (if (eq result *wild-type*)
+ (specifier-type 'function)
+ (make-fun-type :wild-args t :returns result))
+ (make-fun-type :required required
+ :optional optional
+ :rest rest
+ :keyp keyp
+ :keywords keywords
+ :allowp allowp
+ :returns result))))))
(!def-type-translator values (&rest values)
- (make-values-type :args values))
+ (if (eq values '*)
+ *wild-type*
+ (multiple-value-bind (required optional rest keyp keywords allowp llk-p)
+ (parse-args-types values)
+ (declare (ignore keywords))
+ (cond (keyp
+ (error "&KEY appeared in a VALUES type specifier ~S."
+ `(values ,@values)))
+ (llk-p
+ (make-values-type :required required
+ :optional optional
+ :rest rest
+ :allowp allowp))
+ (t
+ (make-short-values-type required))))))
\f
;;;; VALUES types interfaces
;;;;
(values nil nil)))))
(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
- (invoke-complex-subtypep-arg1-method type1 type2))
+ (let ((specifier (hairy-type-specifier type2)))
+ (cond
+ ((and (consp specifier) (eql (car specifier) 'satisfies))
+ (case (cadr specifier)
+ ((keywordp) (if (type= type1 (specifier-type 'symbol))
+ (values nil t)
+ (invoke-complex-subtypep-arg1-method type1 type2)))
+ (t (invoke-complex-subtypep-arg1-method type1 type2))))
+ (t (invoke-complex-subtypep-arg1-method type1 type2)))))
(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
(declare (ignore type1 type2))