;; If TYPE2 might be concealing something related to our class
;; hierarchy
(if (type-might-contain-other-types-p type2)
- ;; too confusing, gotta punt
+ ;; too confusing, gotta punt
(values nil nil)
;; ordinary case expected by old CMU CL code, where the taxonomy
;; of TYPE2's representation accurately reflects the taxonomy of
;;; Since all function types are equivalent to FUNCTION, they are all
;;; subtypes of each other.
(!define-type-method (function :simple-subtypep) (type1 type2)
- (declare (ignore type1 type2))
- (values t t))
+ (flet ((fun-type-simple-p (type)
+ (not (or (fun-type-rest type)
+ (fun-type-keyp type))))
+ (every-csubtypep (types1 types2)
+ (loop
+ for a1 in types1
+ for a2 in types2
+ do (multiple-value-bind (res sure-p)
+ (csubtypep a1 a2)
+ (unless res (return (values res sure-p))))
+ finally (return (values t t)))))
+ (macrolet ((3and (x y)
+ `(multiple-value-bind (val1 win1)
+ ,x
+ (if (and (not val1) win1)
+ (values nil t)
+ (multiple-value-bind (val2 win2)
+ ,y
+ (if (and val1 val2)
+ (values t t)
+ (values nil (or win1 win2))))))))
+ (3and (csubtypep (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))
+ ((not (or (fun-type-simple-p type1)
+ (fun-type-simple-p type2)))
+ (values nil nil))
+ ((not (and (= (length (fun-type-required type1))
+ (length (fun-type-required type2)))
+ (= (length (fun-type-optional type1))
+ (length (fun-type-optional type2)))))
+ (values nil t))
+ (t (3and (every-csubtypep (fun-type-required type1)
+ (fun-type-required type2))
+ (every-csubtypep (fun-type-optional type1)
+ (fun-type-optional type2)))))))))
(!define-superclasses function ((function)) !cold-init-forms)
;;; used for both FUNCTION and VALUES types.
(declaim (ftype (function (list args-type) (values)) parse-args-types))
(defun parse-args-types (lambda-list result)
- (multiple-value-bind (required optional restp rest keyp keys allowp aux)
+ (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
(parse-lambda-list-like-thing lambda-list)
- (when aux
+ (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))
\f
;;;; hairy and unknown types
-(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
-
+(!define-type-method (hairy :unparse) (x)
+ (hairy-type-specifier x))
+
(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
(t
(values nil t)))))
-(!define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((number)) !cold-init-forms)
;;; If the high bound of LOW is adjacent to the low bound of HIGH,
;;; then return true, otherwise NIL.
;; previously we threw an error here:
;; (error "Lower bound ~S is greater than upper bound ~S." l h))
;; but ANSI doesn't say anything about that, so:
- (specifier-type 'nil)
+ *empty-type*
(make-numeric-type :class 'integer
:complexp :real
:enumerable (not (null (and l h)))
;; as above, previously we did
;; (error "Lower bound ~S is not less than upper bound ~S." low high))
;; but it is correct to do
- (specifier-type 'nil)
+ *empty-type*
(make-numeric-type :class ',class :format ',format :low lb :high hb)))))
(!def-bounded-type rational rational nil)
(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
- (if (equal members '(nil))
- 'null
- `(member ,@members))))
+ (cond
+ ((equal members '(nil)) 'null)
+ ((type= type (specifier-type 'standard-char)) 'standard-char)
+ (t `(member ,@members)))))
(!define-type-method (member :simple-subtypep) (type1 type2)
(values (subsetp (member-type-members type1) (member-type-members type2))
(!define-type-class union)
-;;; The LIST type has a special name. Other union types just get
-;;; mechanically unparsed.
+;;; The LIST, FLOAT and REAL types have special names. Other union
+;;; types just get mechanically unparsed.
(!define-type-method (union :unparse) (type)
(declare (type ctype type))
- (if (type= type (specifier-type 'list))
- 'list
- `(or ,@(mapcar #'type-specifier (union-type-types type)))))
+ (cond
+ ((type= type (specifier-type 'list)) 'list)
+ ((type= type (specifier-type 'float)) 'float)
+ ((type= type (specifier-type 'real)) 'real)
+ ((type= type (specifier-type 'sequence)) 'sequence)
+ ((type= type (specifier-type 'string-stream)) 'string-stream)
+ (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
;;; Two union types are equal if they are each subtypes of each
;;; other. We need to be this clever because our complex subtypep
projects / sbcl.git / blobdiff