Skip to content
Snippets Groups Projects
Commit 23f8e9ce authored by gerd's avatar gerd
Browse files

Make the type system more forgiving wrt to unknown types.

	Temporary fix for -0d0/0d0 and member types.

	* src/code/type.lisp (reparse-unknown-type): New function.
	(type-union2, type-intersection2): Use it.
	(hierarchical-intersection2, hierarchical-union2): Moved to
	typedef.lisp.
	(member): Temporary fix for -0d0/0d0 problem; Christophe Rhodes is
	working on the real fix.

	* src/code/typedefs.lisp (type-class): Use hierachical-union2
	and hierachical-intersection2 as inits for slots simple-union
	and simple-intersection, like SBCL does.
	(hierarchical-intersection2, hierarchical-union2): Moved
	here from type.lisp.
parent e805dcfe
No related branches found
No related tags found
No related merge requests found
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.56 2003/04/17 21:19:04 toy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.57 2003/04/23 15:19:41 gerd Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -446,6 +446,12 @@
); eval-when (compile eval)
(declaim (inline reparse-unknown-type))
(defun reparse-unknown-type (type)
(if (unknown-type-p type)
(specifier-type (type-specifier type))
type))
(declaim (inline swapped-args-fun))
(defun swapped-args-fun (fun)
(declare (type function fun))
......@@ -461,19 +467,6 @@
(equal-but-no-car-recursion (cdr x) (cdr y))))
(t nil)))
(defun hierarchical-intersection2 (type1 type2)
(multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
(multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
(cond (subtypep1 type1)
(subtypep2 type2)
((and win1 win2) *empty-type*)
(t nil)))))
(defun hierarchical-union2 (type1 type2)
(cond ((csubtypep type1 type2) type2)
((csubtypep type2 type1) type1)
(t nil)))
(defun any/type (op thing list)
(declare (type function op))
(let ((certain? t))
......@@ -1137,6 +1130,8 @@
:init-form cold-load-init)
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(setq type1 (reparse-unknown-type type1))
(setq type2 (reparse-unknown-type type2))
(cond ((eq type1 type2) type1)
((csubtypep type1 type2) type2)
((csubtypep type2 type1) type1)
......@@ -1214,6 +1209,8 @@
:init-form cold-load-init)
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
(setq type1 (reparse-unknown-type type1))
(setq type2 (reparse-unknown-type type2))
(cond ((eq type1 type2)
;; FIXME: For some reason, this doesn't catch e.g. type1 =
;; type2 = (SPECIFIER-TYPE
......@@ -2840,16 +2837,17 @@
(def-type-translator member (&rest members)
(if members
(let (ms numbers)
(collect ((non-numbers) (numbers))
(dolist (m (remove-duplicates members))
(typecase m
(number (push (ctype-of m) numbers))
(t (push m ms))))
(if (and (numberp m)
(not (and (floatp m) (zerop m))))
(numbers (ctype-of m))
(non-numbers m)))
(apply #'type-union
(if ms
(make-member-type :members ms)
(if (non-numbers)
(make-member-type :members (non-numbers))
*empty-type*)
(nreverse numbers)))
(numbers)))
*empty-type*))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.12 2001/03/04 20:12:44 pw Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.13 2003/04/23 15:19:41 gerd Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -161,12 +161,12 @@
;; that class. If the result is a two-type union, then return NIL.
;; VANILLA-UNION returns whichever argument is a supertype of the other, or
;; NIL.
(simple-union #'vanilla-union :type function)
(simple-union #'hierarchical-union2 :type function)
(complex-union nil :type (or function null))
;;
;; The default intersection methods assume that if one type is a subtype of
;; the other, then that type is the intersection.
(simple-intersection #'vanilla-intersection :type function)
(simple-intersection #'hierarchical-intersection2 :type function)
(complex-intersection nil :type (or function null))
;;
(simple-= #'must-supply-this :type function)
......@@ -389,6 +389,18 @@
((csubtypep type2 type1) type1)
(t nil)))
(defun hierarchical-intersection2 (type1 type2)
(multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
(multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
(cond (subtypep1 type1)
(subtypep2 type2)
((and win1 win2) *empty-type*)
(t nil)))))
(defun hierarchical-union2 (type1 type2)
(cond ((csubtypep type1 type2) type2)
((csubtypep type2 type1) type1)
(t nil)))
;;; TYPE-CACHE-HASH -- Interface
;;;
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment