(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
;;;;
(hairy-spec2 (hairy-type-specifier type2)))
(cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
(values t t))
+ ((maybe-reparse-specifier! type1)
+ (csubtypep type1 type2))
+ ((maybe-reparse-specifier! type2)
+ (csubtypep type1 type2))
(t
(values nil nil)))))
(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
- (invoke-complex-subtypep-arg1-method type1 type2))
+ (if (maybe-reparse-specifier! type2)
+ (csubtypep 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))
- (values nil nil))
+ (if (maybe-reparse-specifier! type1)
+ (csubtypep type1 type2)
+ (values nil nil)))
(!define-type-method (hairy :complex-=) (type1 type2)
- (if (and (unknown-type-p type2)
- (let* ((specifier2 (unknown-type-specifier type2))
- (name2 (if (consp specifier2)
- (car specifier2)
- specifier2)))
- (info :type :kind name2)))
- (let ((type2 (specifier-type (unknown-type-specifier type2))))
- (if (unknown-type-p type2)
- (values nil nil)
- (type= type1 type2)))
- (values nil nil)))
+ (if (maybe-reparse-specifier! type2)
+ (type= type1 type2)
+ (values nil nil)))
(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
(type1 type2)
(aver (not (eq (type-union not1 not2) *universal-type*)))
nil))))
+(defun maybe-complex-array-refinement (type1 type2)
+ (let* ((ntype (negation-type-type type2))
+ (ndims (array-type-dimensions ntype))
+ (ncomplexp (array-type-complexp ntype))
+ (nseltype (array-type-specialized-element-type ntype))
+ (neltype (array-type-element-type ntype)))
+ (if (and (eql ndims '*) (null ncomplexp)
+ (eql neltype *wild-type*) (eql nseltype *wild-type*))
+ (make-array-type :dimensions (array-type-dimensions type1)
+ :complexp t
+ :element-type (array-type-element-type type1)
+ :specialized-element-type (array-type-specialized-element-type type1)))))
+
(!define-type-method (negation :complex-intersection2) (type1 type2)
(cond
((csubtypep type1 (negation-type-type type2)) *empty-type*)
((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
type1)
+ ((and (array-type-p type1) (array-type-p (negation-type-type type2)))
+ (maybe-complex-array-refinement type1 type2))
(t nil)))
(!define-type-method (negation :simple-union2) (type1 type2)
(complexp (array-type-complexp type)))
(cond ((eq dims '*)
(if (eq eltype '*)
- (if complexp 'array 'simple-array)
- (if complexp `(array ,eltype) `(simple-array ,eltype))))
+ (ecase complexp
+ ((t) '(and array (not simple-array)))
+ ((:maybe) 'array)
+ ((nil) 'simple-array))
+ (ecase complexp
+ ((t) `(and (array ,eltype) (not simple-array)))
+ ((:maybe) `(array ,eltype))
+ ((nil) `(simple-array ,eltype)))))
((= (length dims) 1)
(if complexp
- (if (eq (car dims) '*)
- (case eltype
- (bit 'bit-vector)
- ((base-char #!-sb-unicode character) 'base-string)
- (* 'vector)
- (t `(vector ,eltype)))
- (case eltype
- (bit `(bit-vector ,(car dims)))
- ((base-char #!-sb-unicode character)
- `(base-string ,(car dims)))
- (t `(vector ,eltype ,(car dims)))))
+ (let ((answer
+ (if (eq (car dims) '*)
+ (case eltype
+ (bit 'bit-vector)
+ ((base-char #!-sb-unicode character) 'base-string)
+ (* 'vector)
+ (t `(vector ,eltype)))
+ (case eltype
+ (bit `(bit-vector ,(car dims)))
+ ((base-char #!-sb-unicode character)
+ `(base-string ,(car dims)))
+ (t `(vector ,eltype ,(car dims)))))))
+ (if (eql complexp :maybe)
+ answer
+ `(and ,answer (not simple-array))))
(if (eq (car dims) '*)
(case eltype
(bit 'simple-bit-vector)
((t) `(simple-vector ,(car dims)))
(t `(simple-array ,eltype ,dims))))))
(t
- (if complexp
- `(array ,eltype ,dims)
- `(simple-array ,eltype ,dims))))))
+ (ecase complexp
+ ((t) `(and (array ,eltype ,dims) (not simple-array)))
+ ((:maybe) `(array ,eltype ,dims))
+ ((nil) `(simple-array ,eltype ,dims)))))))
(!define-type-method (array :simple-subtypep) (type1 type2)
(let ((dims1 (array-type-dimensions type1))
;;; type without that particular element. This seems too hairy to be
;;; worthwhile, given its low utility.
(defun type-difference (x y)
- (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
- (y-types (if (union-type-p y) (union-type-types y) (list y))))
- (collect ((res))
- (dolist (x-type x-types)
- (if (member-type-p x-type)
- (let ((xset (alloc-xset))
- (fp-zeroes nil))
- (mapc-member-type-members
- (lambda (elt)
- (multiple-value-bind (ok sure) (ctypep elt y)
- (unless sure
- (return-from type-difference nil))
- (unless ok
- (if (fp-zero-p elt)
- (pushnew elt fp-zeroes)
- (add-to-xset elt xset)))))
- x-type)
- (unless (and (xset-empty-p xset) (not fp-zeroes))
- (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
- (dolist (y-type y-types (res x-type))
- (multiple-value-bind (val win) (csubtypep x-type y-type)
- (unless win (return-from type-difference nil))
- (when val (return))
- (when (types-equal-or-intersect x-type y-type)
- (return-from type-difference nil))))))
- (let ((y-mem (find-if #'member-type-p y-types)))
- (when y-mem
+ (if (and (numeric-type-p x) (numeric-type-p y))
+ ;; Numeric types are easy. Are there any others we should handle like this?
+ (type-intersection x (type-negation y))
+ (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
+ (y-types (if (union-type-p y) (union-type-types y) (list y))))
+ (collect ((res))
(dolist (x-type x-types)
- (unless (member-type-p x-type)
- (mapc-member-type-members
- (lambda (member)
- (multiple-value-bind (ok sure) (ctypep member x-type)
- (when (or (not sure) ok)
- (return-from type-difference nil))))
- y-mem)))))
- (apply #'type-union (res)))))
+ (if (member-type-p x-type)
+ (let ((xset (alloc-xset))
+ (fp-zeroes nil))
+ (mapc-member-type-members
+ (lambda (elt)
+ (multiple-value-bind (ok sure) (ctypep elt y)
+ (unless sure
+ (return-from type-difference nil))
+ (unless ok
+ (if (fp-zero-p elt)
+ (pushnew elt fp-zeroes)
+ (add-to-xset elt xset)))))
+ x-type)
+ (unless (and (xset-empty-p xset) (not fp-zeroes))
+ (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
+ (dolist (y-type y-types (res x-type))
+ (multiple-value-bind (val win) (csubtypep x-type y-type)
+ (unless win (return-from type-difference nil))
+ (when val (return))
+ (when (types-equal-or-intersect x-type y-type)
+ (return-from type-difference nil))))))
+ (let ((y-mem (find-if #'member-type-p y-types)))
+ (when y-mem
+ (dolist (x-type x-types)
+ (unless (member-type-p x-type)
+ (mapc-member-type-members
+ (lambda (member)
+ (multiple-value-bind (ok sure) (ctypep member x-type)
+ (when (or (not sure) ok)
+ (return-from type-difference nil))))
+ y-mem)))))
+ (apply #'type-union (res))))))
\f
(!def-type-translator array (&optional (element-type '*)
(dimensions '*))
projects / sbcl.git / blobdiff