From 90c37c33801a27ede6cdc2b8db60f322d13a06c6 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Wed, 7 Jan 1998 06:22:17 +0000 Subject: [PATCH] Add a new function, Make-Canonical-Union-Type, to cleanup the results of one and two-arg-derive-type. --- compiler/srctran.lisp | 51 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 47 insertions(+), 4 deletions(-) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index f251b2d7d..5749edf1a 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.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/compiler/srctran.lisp,v 1.72 1998/01/05 23:05:04 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.73 1998/01/07 06:22:17 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -826,7 +826,7 @@ ;; member types. (dolist (member (member-type-members arg)) (push (if (numberp member) - (specifier-type `(member ,member)) + (make-member-type :members (list member)) *empty-type*) new-args)) (push arg new-args))) @@ -982,6 +982,49 @@ (t type-list))) +;;; Make-Canonical-Union-Type +;;; +;;; Take a list of types and return a canonical type specifier, +;;; combining any members types together. If both positive and +;;; negative members types are present they are converted to a float +;;; type. X This would be far simpler if the type-union methods could +;;; handle member/number unions. +;;; +(defun make-canonical-union-type (type-list) + (let ((members '()) + (misc-types '())) + (dolist (type type-list) + (if (member-type-p type) + (setf members (union members (member-type-members type))) + (push type misc-types))) + (when (null (set-difference '(-0d0 0d0) members)) + #-negative-zero-is-not-zero + (push (specifier-type '(double-float 0d0 0d0)) misc-types) + #+negative-zero-is-not-zero + (push (specifier-type '(double-float -0d0 0d0)) misc-types) + (setf members (set-difference members '(-0d0 0d0)))) + (when (null (set-difference '(-0f0 0f0) members)) + #-negative-zero-is-not-zero + (push (specifier-type '(single-float 0f0 0f0)) misc-types) + #+negative-zero-is-not-zero + (push (specifier-type '(single-float -0f0 0f0)) misc-types) + (setf members (set-difference members '(-0f0 0f0)))) + (cond ((null members) + (let ((res (first misc-types))) + (dolist (type (rest misc-types)) + (setq res (type-union res type))) + res)) + ((null misc-types) + (make-member-type :members members)) + (t + (let ((res (first misc-types))) + (dolist (type (rest misc-types)) + (setq res (type-union res type))) + (dolist (type members) + (setq res (type-union + res (make-member-type :members (list type))))) + res))))) + ;;; ONE-ARG-DERIVE-TYPE ;;; ;;; This is used in defoptimizers for computing the resulting type of @@ -1026,7 +1069,7 @@ (setf results (append results result)) (push result results)))) (if (rest results) - (make-union-type results) + (make-canonical-union-type results) (first results))))))) ;;; TWO-ARG-DERIVE-TYPE @@ -1130,7 +1173,7 @@ (setf results (append results result)) (push result results)))))) (if (rest results) - (make-union-type results) + (make-canonical-union-type results) (first results))))))) ) ; end progn -- GitLab