Commit cd8bb0ad authored by rtoy's avatar rtoy
Browse files

o Rename MAKE-DOUBLE-DOUBLE-FLOAT to be %MAKE-DOUBLE-DOUBLE-FLOAT.

o Add %MAKE-DOUBLE-DOUBLE-FLOAT to be an internal function that
  creates a double-double with exactly the parts given.
o Add a new MAKE-DOUBLE-DOUBLE-FLOAT that adjusts the args
  appropriately before creating a double-double float, in case the
  args aren't split appropriately.
parent fcbc8a6e
Loading
Loading
Loading
Loading
+17 −6
Original line number Diff line number Diff line
@@ -11,10 +11,12 @@
;;; work.  For some reason, the cross-compile makes these known
;;; functions be infinite loops, but if we compile them here and setf
;;; fdefinition we get workingness.  
(defun foo (x y)
(defun %foo (x y)
  (declare (double-float x y))
  (kernel:make-double-double-float x y))
(compile 'foo)
  (kernel:%make-double-double-float x y))
(compile '%foo)



(defun foo-hi (x)
  (declare (type kernel:double-double-float x))
@@ -24,13 +26,22 @@
  (declare (type kernel:double-double-float x))
  (kernel:double-double-lo x))
(compile 'foo-lo)
(defun %foo (x)
(defun %coerce-foo (x)
  (if (typep x 'kernel:double-double-float)
      x
      (kernel:make-double-double-float (float x 1d0) 0d0)))
(compile '%foo)

(setf (fdefinition 'kernel::make-double-double-float) #'foo)
(setf (fdefinition 'kernel::%make-double-double-float) #'%foo)
(setf (fdefinition 'kernel::double-double-hi) #'foo-hi)
(setf (fdefinition 'kernel::double-double-lo) #'foo-lo)
(setf (fdefinition 'kernel::%double-double-float) #'%foo)
(setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo)

(in-package "KERNEL")
(defun make-double-double-float (hi lo)
  ;; Make sure the parts make sense for a double-double
  (if (or (float-infinity-p hi) (float-nan-p hi))
      (%make-double-double-float hi lo)
      (multiple-value-bind (s e)
	  (c::two-sum hi lo)
	(%make-double-double-float s e))))
+17 −6
Original line number Diff line number Diff line
@@ -11,10 +11,12 @@
;;; work.  For some reason, the cross-compile makes these known
;;; functions be infinite loops, but if we compile them here and setf
;;; fdefinition we get workingness.  
(defun foo (x y)
(defun %foo (x y)
  (declare (double-float x y))
  (kernel:make-double-double-float x y))
(compile 'foo)
  (kernel:%make-double-double-float x y))
(compile '%foo)



(defun foo-hi (x)
  (declare (type kernel:double-double-float x))
@@ -24,13 +26,22 @@
  (declare (type kernel:double-double-float x))
  (kernel:double-double-lo x))
(compile 'foo-lo)
(defun %foo (x)
(defun %coerce-foo (x)
  (if (typep x 'kernel:double-double-float)
      x
      (kernel:make-double-double-float (float x 1d0) 0d0)))
(compile '%foo)

(setf (fdefinition 'kernel::make-double-double-float) #'foo)
(setf (fdefinition 'kernel::%make-double-double-float) #'%foo)
(setf (fdefinition 'kernel::double-double-hi) #'foo-hi)
(setf (fdefinition 'kernel::double-double-lo) #'foo-lo)
(setf (fdefinition 'kernel::%double-double-float) #'%foo)
(setf (fdefinition 'kernel::%double-double-float) #'%coerce-foo)

(in-package "KERNEL")
(defun make-double-double-float (hi lo)
  ;; Make sure the parts make sense for a double-double
  (if (or (float-infinity-p hi) (float-nan-p hi))
      (%make-double-double-float hi lo)
      (multiple-value-bind (s e)
	  (c::two-sum hi lo)
	(%make-double-double-float s e))))
+2 −1
Original line number Diff line number Diff line
@@ -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/exports.lisp,v 1.251.2.1 2006/06/09 16:04:56 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.251.2.2 2006/06/12 16:16:18 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -2181,6 +2181,7 @@
	   "DOUBLE-DOUBLE-HI"
	   "DOUBLE-DOUBLE-LO"
	   "MAKE-DOUBLE-DOUBLE-FLOAT"
	   "%MAKE-DOUBLE-DOUBLE-FLOAT"
	   "%DOUBLE-DOUBLE-FLOAT"
	   "OBJECT-NOT-DOUBLE-DOUBLE-FLOAT-ERROR"))

+14 −2
Original line number Diff line number Diff line
@@ -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/kernel.lisp,v 1.15.4.1 2006/06/09 16:04:57 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/kernel.lisp,v 1.15.4.2 2006/06/12 16:16:18 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -142,9 +142,21 @@
(defun make-long-float (exp hi #+sparc mid lo)
  (make-long-float exp hi #+sparc mid lo))

#+double-double
(defun %make-double-double-float (hi lo)
  (%make-double-double-float hi lo))

#+double-double
(declaim (inline make-double-double-float))
#+double-double
(defun make-double-double-float (hi lo)
  (make-double-double-float hi lo))
  ;; Make sure the parts make sense for a double-double
  (if (or (float-infinity-p hi) (float-nan-p hi))
      (%make-double-double-float hi lo)
      (multiple-value-bind (s e)
	  (c::two-sum hi lo)
	(%make-double-double-float s e))))

#+double-double
(defun double-double-hi (x)
  (double-double-hi x))
+3 −2
Original line number Diff line number Diff line
@@ -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/float-tran.lisp,v 1.104.4.3 2006/06/11 04:52:42 rtoy Exp $")
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.104.4.4 2006/06/12 16:16:18 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -301,10 +301,11 @@
  boolean
  (movable foldable flushable))

(defknown make-double-double-float (double-float double-float)
(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))
Loading