From a2f0af9423366107068a01df40d3eb59c7b03427 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Sat, 6 Jun 2015 17:42:15 -0700
Subject: [PATCH] Move more double-double items from float-tran to
 float-tran-dd.

---
 src/compiler/float-tran-dd.lisp | 78 +++++++++++++++++++++++++++++++++
 src/compiler/float-tran.lisp    |  8 ++--
 2 files changed, 82 insertions(+), 4 deletions(-)

diff --git a/src/compiler/float-tran-dd.lisp b/src/compiler/float-tran-dd.lisp
index 622bca780..4b5b1aafa 100644
--- a/src/compiler/float-tran-dd.lisp
+++ b/src/compiler/float-tran-dd.lisp
@@ -19,6 +19,84 @@
 (in-package "C")
 (intl:textdomain "cmucl")
 
+(defknown %double-double-float (real)
+  double-double-float
+  (movable foldable flushable))
+
+(deftransform float ((n prototype) (* double-double-float) * :when :both)
+  '(%double-double-float n))
+
+(deftransform %double-float ((n) (double-double-float) * :when :both)
+  '(double-double-hi n))
+
+(deftransform %single-float ((n) (double-double-float) * :when :both)
+  '(float (double-double-hi n) 1f0))
+
+(deftransform %double-double-float ((n) (double-double-float) * :when :both)
+  'n)
+
+#+nil
+(defun %double-double-float (n)
+  (make-double-double-float (float n 1d0) 0d0))
+
+;; Moved to code/float.lisp, because we need this relatively early in
+;; the build process to handle float and real types.
+#+nil
+(defun %double-double-float (n)
+  (typecase n
+    (fixnum
+     (%make-double-double-float (float n 1d0) 0d0))
+    (single-float
+     (%make-double-double-float (float n 1d0) 0d0))
+    (double-float
+     (%make-double-double-float (float n 1d0) 0d0))
+    (double-double-float
+     n)
+    (bignum
+     (bignum:bignum-to-float n 'double-double-float))
+    (ratio
+     (kernel::float-ratio n 'double-double-float))))
+
+#+double-double
+(progn
+(defknown double-double-float-p (t)
+  boolean
+  (movable foldable flushable))
+
+(defknown %make-double-double-float (double-float double-float)
+  double-double-float
+  (movable foldable flushable))
+
+
+(defknown double-double-hi (double-double-float)
+  double-float
+  (movable foldable flushable))
+
+(defknown double-double-lo (double-double-float)
+  double-float
+  (movable foldable flushable))
+
+) ; progn
+
+#+double-double
+(deftransform float-sign ((float &optional float2)
+			  (double-double-float &optional double-double-float) *)
+  (if float2
+      (let ((temp (gensym)))
+	`(let ((,temp (abs float2)))
+	   (if (minusp (float-sign (double-double-hi float)))
+	       (- ,temp)
+	       ,temp)))
+      '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0)))
+
+#+double-double
+(deftransform cis ((x) (double-double-float) *)
+  `(multiple-value-bind (s c)
+       (kernel::dd-%sincos x)
+     (complex c s)))
+
+
+
 (declaim (inline quick-two-sum))
 (defun quick-two-sum (a b)
   "Computes fl(a+b) and err(a+b), assuming |a| >= |b|"
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 83d4b33f4..5d4e03be7 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -38,7 +38,7 @@
 (deftransform %double-float ((n) (double-float) * :when :both)
   'n)
 
-#+double-double
+#+(and nil double-double)
 (progn
 (defknown %double-double-float (real)
   double-double-float
@@ -364,7 +364,7 @@
   (values (signed-byte 32) (unsigned-byte 32))
   (movable foldable flushable))
 
-#+double-double
+#+(and nil double-double)
 (progn
 (defknown double-double-float-p (t)
   boolean
@@ -401,7 +401,7 @@
 	  (if (minusp (double-float-high-bits float)) (- ,temp) ,temp)))
       '(if (minusp (double-float-high-bits float)) -1d0 1d0)))
 
-#+double-double
+#+(and nil double-double)
 (deftransform float-sign ((float &optional float2)
 			  (double-double-float &optional double-double-float) *)
   (if float2
@@ -778,7 +778,7 @@
        (%sincos x)
      (complex c s)))
 
-#+double-double
+#+(and nil double-double)
 (deftransform cis ((x) (double-double-float) *)
   `(multiple-value-bind (s c)
        (kernel::dd-%sincos x)
-- 
GitLab