(error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2)))
(!define-type-method (values :unparse) (type)
- (cons 'values (unparse-args-types type)))
+ (cons 'values
+ (let ((unparsed (unparse-args-types type)))
+ (if (or (values-type-optional type)
+ (values-type-rest type)
+ (values-type-allowp type))
+ unparsed
+ (nconc unparsed '(&optional))))))
;;; Return true if LIST1 and LIST2 have the same elements in the same
;;; positions according to TYPE=. We return NIL, NIL if there is an
((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 (and/type (type= *universal-type* (fun-type-rest type2))
- (every/type #'type= *universal-type*
- (fun-type-optional type2))))))
+ ((not (null (fun-type-required type2)))
+ (values nil t))
+ (t (and/type (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))
(cond ((or (> max1 max2) (< min1 min2))
(values nil t))
((and (= min1 min2) (= max1 max2))
- (and/type (every-csubtypep (fun-type-required type1)
- (fun-type-required type2))
- (every-csubtypep (fun-type-optional type1)
- (fun-type-optional type2))))
+ (and/type (every-csubtypep
+ (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep
+ (fun-type-optional type1)
+ (fun-type-optional type2))))
(t (every-csubtypep
(concatenate 'list
(fun-type-required type1)
((type= type1 (specifier-type 'function)) type1)
(t nil)))
-;;; ### Not very real, but good enough for redefining transforms
-;;; according to type:
(!define-type-method (function :simple-=) (type1 type2)
- (values (equalp type1 type2) t))
+ (macrolet ((compare (comparator field)
+ (let ((reader (symbolicate '#:fun-type- field)))
+ `(,comparator (,reader type1) (,reader type2)))))
+ (and/type (compare type= returns)
+ (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2))
+ (values nil t))
+ ((eq (fun-type-wild-args type1) t)
+ (values t t))
+ (t (and/type
+ (cond ((null (fun-type-rest type1))
+ (values (null (fun-type-rest type2)) t))
+ ((null (fun-type-rest type2))
+ (values nil t))
+ (t
+ (compare type= rest)))
+ (labels ((type-list-= (l1 l2)
+ (cond ((null l1)
+ (values (null l2) t))
+ ((null l2)
+ (values nil t))
+ (t (multiple-value-bind (res winp)
+ (type= (first l1) (first l2))
+ (cond ((not winp)
+ (values nil nil))
+ ((not res)
+ (values nil t))
+ (t
+ (type-list-= (rest l1)
+ (rest l2)))))))))
+ (and/type (and/type (compare type-list-= required)
+ (compare type-list-= optional))
+ (if (or (fun-type-keyp type1) (fun-type-keyp type2))
+ (values nil nil)
+ (values t t))))))))))
(!define-type-class constant :inherits values)
(type= (constant-type-type type1) (constant-type-type type2)))
(!def-type-translator constant-arg (type)
- (make-constant-type :type (specifier-type type)))
+ (make-constant-type :type (single-value-specifier-type type)))
;;; Return the lambda-list-like type specification corresponding
;;; to an ARGS-TYPE.
;;; If COUNT values are supplied, which types should they have?
(defun values-type-start (type count)
- (declare (ctype type) (unsigned-byte count))
+ (declare (type ctype type) (type unsigned-byte count))
(if (eq type *wild-type*)
(make-list count :initial-element *universal-type*)
(collect ((res))
(defvar *empty-type*)
(defvar *universal-type*)
(defvar *universal-fun-type*)
+
(!cold-init-forms
(macrolet ((frob (name var)
`(progn
- (setq ,var (make-named-type :name ',name))
+ (setq ,var (make-named-type :name ',name))
(setf (info :type :kind ',name)
#+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin ',name) ,var))))
((consp low-bound)
(let ((low-value (car low-bound)))
(or (eql low-value high-bound)
- (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
- (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
- (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql high-bound 0f0))
+ (and (eql low-value 0f0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql low-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql high-bound 0d0))
+ (and (eql low-value 0d0)
+ (eql high-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((consp high-bound)
(let ((high-value (car high-bound)))
(or (eql high-value low-bound)
- (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
- (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
- (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
- (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero)))
+ (eql low-bound 0f0))
+ (and (eql high-value 0f0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :single-float-negative-zero))))
+ (and (eql high-value
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))
+ (eql low-bound 0d0))
+ (and (eql high-value 0d0)
+ (eql low-bound
+ (load-time-value (make-unportable-float
+ :double-float-negative-zero)))))))
((and (eq (numeric-type-class low) 'integer)
(eq (numeric-type-class high) 'integer))
(eql (1+ low-bound) high-bound))
(mapcar (lambda (x y) (if (eq x '*) y x))
dims1 dims2)))
:complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+ :element-type (cond
+ ((eq eltype1 *wild-type*) eltype2)
+ ((eq eltype2 *wild-type*) eltype1)
+ (t (type-intersection eltype1 eltype2))))))
*empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
(!define-type-class cons)
(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
- (let ((car-type (specifier-type car-type-spec))
- (cdr-type (specifier-type cdr-type-spec)))
+ (let ((car-type (single-value-specifier-type car-type-spec))
+ (cdr-type (single-value-specifier-type cdr-type-spec)))
(make-cons-type car-type cdr-type)))
(!define-type-method (cons :unparse) (type)
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
:complexp :maybe
- :element-type (specifier-type element-type))))
+ :element-type (if (eq element-type '*)
+ *wild-type*
+ (specifier-type element-type)))))
(!def-type-translator simple-array (&optional (element-type '*)
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
:complexp nil
- :element-type (specifier-type element-type))))
+ :element-type (if (eq element-type '*)
+ *wild-type*
+ (specifier-type element-type)))))
\f
;;;; utilities shared between cross-compiler and target system
projects / sbcl.git / blobdiff