X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=f3f7f0d77526d5dc63e145cfdf7bcaf1180a00a0;hb=f3b213e5fea9992b3a9a1f2a6c482239a1aff3c1;hp=8a4e03b81c480dfd10a9038d7f9329dea1cb056d;hpb=4dbc52ee4f9a4f566701f1d33e7916e8491b918b;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 8a4e03b..f3f7f0d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -69,7 +69,7 @@ ;; 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 @@ -213,11 +213,46 @@ (type-specifier (fun-type-returns type))))) -;;; 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 (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)) + ((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) @@ -250,9 +285,10 @@ ;;; 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) - (parse-lambda-list lambda-list) - (when aux + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) + (parse-lambda-list-like-thing 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)) @@ -1007,8 +1043,9 @@ ;;;; 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))) @@ -1351,7 +1388,7 @@ (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. @@ -1531,7 +1568,7 @@ ;; 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))) @@ -1546,7 +1583,7 @@ ;; 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) @@ -2017,9 +2054,10 @@ (!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)) @@ -2172,13 +2210,17 @@ (!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