;; 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
(type-specifier
(fun-type-returns type)))))
-;;; Since all function types are equivalent to FUNCTION, they are all
-;;; subtypes of each other.
+;;; The meaning of this is a little confused. On the one hand, all
+;;; function objects are represented the same way regardless of the
+;;; arglists and return values, and apps don't get to ask things like
+;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
+;;; other hand, Python wants to reason about function types. So...
(!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 (and win2 (not val2)))))))))
+ (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)
+ (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 (3and (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))
+ (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
+ (multiple-value-bind (min2 max2) (fun-type-nargs type2)
+ (cond ((or (> max1 max2) (< min1 min2))
+ (values nil t))
+ ((and (= min1 min2) (= max1 max2))
+ (3and (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)
+ (fun-type-optional type1))
+ (concatenate 'list
+ (fun-type-required type2)
+ (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)
- (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))
- (setf (args-type-rest result) (if restp (specifier-type rest) nil))
+ (setf (args-type-required result)
+ (mapcar #'single-value-specifier-type required))
+ (setf (args-type-optional result)
+ (mapcar #'single-value-specifier-type optional))
+ (setf (args-type-rest result)
+ (if restp (single-value-specifier-type rest) nil))
(setf (args-type-keyp result) keyp)
(collect ((key-info))
(dolist (key keys)
(error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
kwd lambda-list))
(key-info (make-key-info :name kwd
- :type (specifier-type (second key))))))
+ :type (single-value-specifier-type (second key))))))
(setf (args-type-keywords result) (key-info)))
(setf (args-type-allowp result) allowp)
(values)))
res))
(!def-type-translator values (&rest values)
- (let ((res (make-values-type)))
+ (let ((res (%make-values-type)))
(parse-args-types values res)
res))
\f
:initial-element rest2)))
exact)))
-;;; If Type isn't a values type, then make it into one:
+;;; If TYPE isn't a values type, then make it into one:
;;; <type> ==> (values type &rest t)
(defun coerce-to-values (type)
(declare (type ctype type))
(defun args-type-op (type1 type2 operation nreq default-type)
(declare (type ctype type1 type2 default-type)
(type function operation nreq))
+ (when (eq type1 type2)
+ (values type1 t))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
(let ((res (specifier-type spec)))
(unless (unknown-type-p res)
(setf (info :type :builtin spec) res)
- (setf (info :type :kind spec) :primitive))))
+ ;; KLUDGE: the three copies of this idiom in this file (and
+ ;; the one in class.lisp as at sbcl-0.7.4.1x) should be
+ ;; coalesced, or perhaps the error-detecting code that
+ ;; disallows redefinition of :PRIMITIVE types should be
+ ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than
+ ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to
+ ;; cause redefinition errors when precompute-types is called
+ ;; for a second time while building the target compiler using
+ ;; the cross-compiler. -- CSR, trying to explain why this
+ ;; isn't completely wrong, 2002-06-07
+ (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive))))
(values))
\f
;;;; general TYPE-UNION and TYPE-INTERSECTION operations
(defun accumulate1-compound-type (type types %compound-type-p simplify2)
(declare (type ctype type))
(declare (type (vector ctype) types))
- (declare (type function simplify2))
+ (declare (type function %compound-type-p simplify2))
;; Any input object satisfying %COMPOUND-TYPE-P should've been
;; broken into components before it reached us.
(aver (not (funcall %compound-type-p type)))
#+sb-xc-host (coerce types 'list)
#-sb-xc-host (coerce-to-list types)))))
+(defun maybe-distribute-one-union (union-type types)
+ (let* ((intersection (apply #'type-intersection types))
+ (union (mapcar (lambda (x) (type-intersection x intersection))
+ (union-type-types union-type))))
+ (if (notany (lambda (x) (or (hairy-type-p x)
+ (intersection-type-p x)))
+ union)
+ union
+ nil)))
+
(defun type-intersection (&rest input-types)
+ (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
#'type-intersection2)))
;; always achieve that by the distributive rule. But we don't want
;; to just apply the distributive rule, since it would be too easy
;; to end up with unreasonably huge type expressions. So instead
- ;; we punt to HAIRY-TYPE when this comes up.
+ ;; we try to generate a simple type by distributing the union; if
+ ;; the type can't be made simple, we punt to HAIRY-TYPE.
(if (and (> (length simplified-types) 1)
(some #'union-type-p simplified-types))
- (make-hairy-type
- :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
+ (let* ((first-union (find-if #'union-type-p simplified-types))
+ (other-types (coerce (remove first-union simplified-types)
+ 'list))
+ (distributed (maybe-distribute-one-union first-union
+ other-types)))
+ (if distributed
+ (apply #'type-union distributed)
+ (make-hairy-type
+ :specifier `(and ,@(map 'list
+ #'type-specifier
+ simplified-types)))))
(make-compound-type-or-something #'%make-intersection-type
simplified-types
(some #'type-enumerable
*universal-type*))))
(defun type-union (&rest input-types)
+ (%type-union input-types))
+(defun-cached (%type-union :hash-bits 8
+ :hash-function (lambda (x)
+ (logand (sxhash x) #xff)))
+ ((input-types equal))
(let ((simplified-types (simplified-compound-types input-types
#'union-type-p
#'type-union2)))
- (make-compound-type-or-something #'%make-union-type
+ (make-compound-type-or-something #'make-union-type
simplified-types
(every #'type-enumerable simplified-types)
*empty-type*)))
(macrolet ((frob (name var)
`(progn
(setq ,var (make-named-type :name ',name))
- (setf (info :type :kind ',name) :primitive)
+ (setf (info :type :kind ',name)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin ',name) ,var))))
;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
;; special symbol which can be stuck in some places where an
\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)))
(error 'simple-type-error
:datum predicate-name
:expected-type 'symbol
- :format-control "~S is not a symbol."
+ :format-control "The SATISFIES predicate name is not a symbol: ~S"
:format-arguments (list predicate-name))))
;; Create object.
(make-hairy-type :specifier whole))
(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.
>= > t)))))))
(!cold-init-forms
- (setf (info :type :kind 'number) :primitive)
+ (setf (info :type :kind 'number)
+ #+sb-xc-host :defined #-sb-xc-host :primitive)
(setf (info :type :builtin 'number)
(make-numeric-type :complexp 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)
- (make-numeric-type :class ',class :format ',format :low lb :high hb)))))
+ *empty-type*
+ (make-numeric-type :class ',class
+ :format ',format
+ :low lb
+ :high hb)))))
(!def-bounded-type rational rational nil)
(array-type-element-type type)))
(!define-type-method (array :simple-=) (type1 type2)
- (values (and (equal (array-type-dimensions type1)
- (array-type-dimensions type2))
- (eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t))
+ (if (or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (multiple-value-bind (equalp certainp)
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ ;; by its nature, the call to TYPE= should never return NIL,
+ ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
+ ;; be. -- CSR, 2002-08-19
+ (aver (not (and (not equalp) certainp)))
+ (values equalp certainp))
+ (values (and (equal (array-type-dimensions type1)
+ (array-type-dimensions type2))
+ (eq (array-type-complexp type1)
+ (array-type-complexp type2))
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+ t)))
(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eq complexp2 :maybe)
(eq complexp1 complexp2)))
(values nil t))
- ;; If either element type is wild, then they intersect.
- ;; Otherwise, the types must be identical.
- ((or (eq (array-type-element-type type1) *wild-type*)
- (eq (array-type-element-type type2) *wild-type*)
+ ;; Old comment:
+ ;;
+ ;; If either element type is wild, then they intersect.
+ ;; Otherwise, the types must be identical.
+ ;;
+ ;; FIXME: There seems to have been a fair amount of
+ ;; confusion about the distinction between requested element
+ ;; type and specialized element type; here is one of
+ ;; them. If we request an array to hold objects of an
+ ;; unknown type, we can do no better than represent that
+ ;; type as an array specialized on wild-type. We keep the
+ ;; requested element-type in the -ELEMENT-TYPE slot, and
+ ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
+ ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
+ ;; not just the ELEMENT-TYPE slot. Maybe the return value
+ ;; in that specific case should be T, NIL? Or maybe this
+ ;; function should really be called
+ ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
+ ;; was responsible for bug #123, and this whole issue could
+ ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
+ ((or (eq (array-type-specialized-element-type type1) *wild-type*)
+ (eq (array-type-specialized-element-type type2) *wild-type*)
(type= (specialized-element-type-maybe type1)
(specialized-element-type-maybe type2)))
(!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))
*empty-type*))))))
(!define-type-method (member :complex-intersection2) (type1 type2)
- (block punt
+ (block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
(dolist (member mem2)
(!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)
+ (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
(values nil certain?))))))
(!define-type-method (union :complex-=) (type1 type2)
+ (declare (ignore type1))
(if (some #'hairy-type-p (union-type-types type2))
(values nil nil)
(values nil t)))
(dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :complexp :maybe
:element-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)
- :element-type (specifier-type element-type)
- :complexp nil)))
+ :complexp nil
+ :element-type (specifier-type element-type))))
\f
;;;; utilities shared between cross-compiler and target system