From 17e30810393e36b3530b47420cd66b06dfb47332 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Thu, 21 Feb 2013 21:43:50 -0800
Subject: [PATCH] Clean up one- and two-arg-derive-type.

srctran.lisp::
 * The optional convert-type arg is always true, so remove it and
   update the local functions to convert always.
 * Clean up some comments as well.

float-tran.lisp::
 * Fix up one place where we were supplying a value for the optional
   convert-type arg.
---
 src/compiler/float-tran.lisp |   2 +-
 src/compiler/srctran.lisp    | 122 +++++++++++++++--------------------
 2 files changed, 54 insertions(+), 70 deletions(-)

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 3a663a834..639ac8a4e 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -553,7 +553,7 @@
 ;;;
 (defoptimizer (scale-float derive-type) ((f ex))
   (two-arg-derive-type f ex #'scale-float-derive-type-aux
-		       #'scale-float t))
+		       #'scale-float))
 	     
 ;;; toy@rtp.ericsson.se:
 ;;;
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 8f5c134b4..7888eba74 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -1189,11 +1189,9 @@
 ;;; compute the result otherwise the member type is first converted to a
 ;;; numeric type and the derive-fcn is call.
 ;;;
-(defun one-arg-derive-type (arg derive-fcn member-fcn
-				&optional (convert-type t))
+(defun one-arg-derive-type (arg derive-fcn member-fcn)
   (declare (type function derive-fcn)
-	   (type (or null function) member-fcn)
-	   )
+	   (type (or null function) member-fcn))
   (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
     (when arg-list
       (flet ((deriver (x)
@@ -1203,18 +1201,14 @@
 		      (with-float-traps-masked
 			  (:underflow :overflow :divide-by-zero)
 			(specifier-type `(eql ,(funcall member-fcn
-					    (first (member-type-members x))))))
+							(first (member-type-members x))))))
 		      ;; Otherwise convert to a numeric type.
 		      (let ((result-type-list
 			     (funcall derive-fcn (convert-member-type x))))
-			(if convert-type
-			    (convert-back-numeric-type-list result-type-list)
-			    result-type-list))))
+			(convert-back-numeric-type-list result-type-list))))
 		 (numeric-type
-		  (if convert-type
-		      (convert-back-numeric-type-list
-		       (funcall derive-fcn (convert-numeric-type x)))
-		      (funcall derive-fcn x)))
+		  (convert-back-numeric-type-list
+		   (funcall derive-fcn (convert-numeric-type x))))
 		 (t
 		  *universal-type*))))
 	;; Run down the list of args and derive the type of each one, saving
@@ -1238,63 +1232,53 @@
 ;;; (* x x), which should always be positive.  If we didn't do this, we
 ;;; wouldn't be able to tell.
 ;;;
-;;; Without the negative-zero-is-not-zero feature, numeric types are first
-;;; converted to the negative-zero-is-not-zero conventions as expected by the
-;;; deriver function.
-;;;
-;;; For the case of two member types, the result may be derived by calling the
-;;; given function FCN but if a NaN is generated then an unbounded type is
-;;; returned. Alternatively a tighter, less conservative, type can often be
-;;; returned by converting to numeric types and calling the deriver function,
-;;; which is the default behavior without the conservative-float-type feature.
-;;;
-(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
-				 &optional (convert-type t))
-  (labels ((maybe-convert-numeric-type (type)
-	     (if convert-type (convert-numeric-type type) type))
-	   (maybe-convert-back-type-list (type)
-	     (if convert-type (convert-back-numeric-type-list type) type))
-	   (deriver (x y same-arg)
-	     (cond ((and (member-type-p x) (member-type-p y))
-		    (let* ((x (first (member-type-members x)))
-			   (y (first (member-type-members y)))
-			   (result (with-float-traps-masked
-				       (:underflow :overflow :divide-by-zero
-					:invalid)
-				     (funcall fcn x y))))
-		      (cond ((null result))
-			    ((and (floatp result) (float-nan-p result))
-			     (make-numeric-type :class 'float
-						:format (type-of result)
-						:complexp :real))
-			    (t
-			     (specifier-type `(eql ,result))))))
-		   ((and (member-type-p x) (numeric-type-p y))
-		    (let* ((x (convert-member-type x))
-			   (y (maybe-convert-numeric-type y))
-			   (result (funcall derive-fcn x y same-arg)))
-		      (maybe-convert-back-type-list result)))
-		   ((and (numeric-type-p x) (member-type-p y))
-		    (let* ((x (maybe-convert-numeric-type x))
-			   (y (convert-member-type y))
-			   (result (funcall derive-fcn x y same-arg)))
-		      (maybe-convert-back-type-list result)))
-		   ((and (numeric-type-p x) (numeric-type-p y))
-		    (let* ((x (maybe-convert-numeric-type x))
-			   (y (maybe-convert-numeric-type y))
-			   (result (funcall derive-fcn x y same-arg)))
-		      (maybe-convert-back-type-list result)))
-		   (t
-		    *universal-type*)))
-	   (non-const-same-leaf-ref-p (x y)
-	     ;; Just like same-leaf-ref-p, but we don't care if the
-	     ;; value of the leaf is constant or not.
-	     (declare (type continuation x y))
-	     (let ((x-use (continuation-use x))
-		   (y-use (continuation-use y)))
-	       (and (ref-p x-use)
-		    (ref-p y-use)
-		    (eq (ref-leaf x-use) (ref-leaf y-use))))))
+;;; Numeric types are first converted to the negative-zero-is-not-zero
+;;; conventions as expected by the deriver function.  See
+;;; CONVERT-NUMERIC-TYPE for the negative-zero-is-not-zero convention.
+;;;
+(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn)
+  (flet
+      ((deriver (x y same-arg)
+	 (cond ((and (member-type-p x) (member-type-p y))
+		(let* ((x (first (member-type-members x)))
+		       (y (first (member-type-members y)))
+		       (result (with-float-traps-masked
+				   (:underflow :overflow :divide-by-zero
+					       :invalid)
+				 (funcall fcn x y))))
+		  (cond ((null result))
+			((and (floatp result) (float-nan-p result))
+			 (make-numeric-type :class 'float
+					    :format (type-of result)
+					    :complexp :real))
+			(t
+			 (specifier-type `(eql ,result))))))
+	       ((and (member-type-p x) (numeric-type-p y))
+		(let* ((x (convert-member-type x))
+		       (y (convert-numeric-type y))
+		       (result (funcall derive-fcn x y same-arg)))
+		  (convert-back-numeric-type-list result)))
+	       ((and (numeric-type-p x) (member-type-p y))
+		(let* ((x (convert-numeric-type x))
+		       (y (convert-member-type y))
+		       (result (funcall derive-fcn x y same-arg)))
+		  (convert-back-numeric-type-list result)))
+	       ((and (numeric-type-p x) (numeric-type-p y))
+		(let* ((x (convert-numeric-type x))
+		       (y (convert-numeric-type y))
+		       (result (funcall derive-fcn x y same-arg)))
+		  (convert-back-numeric-type-list result)))
+	       (t
+		*universal-type*)))
+       (non-const-same-leaf-ref-p (x y)
+	 ;; Just like same-leaf-ref-p, but we don't care if the
+	 ;; value of the leaf is constant or not.
+	 (declare (type continuation x y))
+	 (let ((x-use (continuation-use x))
+	       (y-use (continuation-use y)))
+	   (and (ref-p x-use)
+		(ref-p y-use)
+		(eq (ref-leaf x-use) (ref-leaf y-use))))))
 
     (let ((same-arg (non-const-same-leaf-ref-p arg1 arg2))
 	  (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
-- 
GitLab