From 23f8e9ceab1920526552bb8d9f68f68bd1ec80b0 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Wed, 23 Apr 2003 15:19:41 +0000 Subject: [PATCH] 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. --- code/type.lisp | 40 +++++++++++++++++++--------------------- code/typedefs.lisp | 18 +++++++++++++++--- 2 files changed, 34 insertions(+), 24 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index be46ff82f..31cc801b6 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -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*)) diff --git a/code/typedefs.lisp b/code/typedefs.lisp index 6809683d5..49df20422 100644 --- a/code/typedefs.lisp +++ b/code/typedefs.lisp @@ -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 ;;; -- GitLab