From 70753d57bf1fb2f5e6379fce007b90bde937f41a Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 16 Nov 1997 14:00:05 +0000
Subject: [PATCH] No longer source transform realpart and imagpart with the
 complex-float support. The realpart and imagpart functions now need to do
 some type dispatch. The VOPs are now direct translations of realpart and
 imagpart; remove the hack accessor functions.

---
 code/numbers.lisp       | 34 ++++++++++++++++++++++++++++++++--
 code/x86-vm.lisp        | 21 +--------------------
 compiler/srctran.lisp   | 30 +-----------------------------
 compiler/x86/float.lisp | 38 ++++++++++++++++++--------------------
 4 files changed, 52 insertions(+), 71 deletions(-)

diff --git a/code/numbers.lisp b/code/numbers.lisp
index f8e508ee2..053f6f535 100644
--- a/code/numbers.lisp
+++ b/code/numbers.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.30 1997/11/05 14:59:45 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.31 1997/11/16 13:59:56 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.30 1997/11/05 14:59:45 dtc Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.31 1997/11/16 13:59:56 dtc Exp $
 ;;;
 ;;; This file contains the definitions of most number functions.
 ;;;
@@ -290,14 +290,44 @@
      (canonical-complex realpart imagpart))
     (float-contagion %%make-complex realpart imagpart (rational)))))
 
+#-complex-float
 (defun realpart (number)
   "Extracts the real part of a number."
   (realpart number))
 
+#-complex-float
 (defun imagpart (number)
   "Extracts the imaginary part of a number."
   (imagpart number))
 
+#+complex-float
+(defun realpart (number)
+  "Extracts the real part of a number."
+  (typecase number
+    ((complex double-float)
+     (truly-the double-float (realpart number)))
+    ((complex single-float)
+     (truly-the single-float (realpart number)))
+    ((complex rational)
+     (kernel:%realpart number))
+    (t
+     number)))
+
+#+complex-float
+(defun imagpart (number)
+  "Extracts the imaginary part of a number."
+  (typecase number
+    ((complex double-float)
+     (truly-the double-float (imagpart number)))
+    ((complex single-float)
+     (truly-the single-float (imagpart number)))
+    ((complex rational)
+     (kernel:%imagpart number))
+    (float
+     (float 0 number))
+    (t
+     0)))
+
 (defun conjugate (number)
   "Returns the complex conjugate of NUMBER.  For non-complex numbers, this is
   an identity."
diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp
index f8b6655ce..f4e1161d3 100644
--- a/code/x86-vm.lisp
+++ b/code/x86-vm.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.9 1997/11/16 13:53:01 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.10 1997/11/16 13:59:57 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -432,22 +432,3 @@
   "Atomically compare object's slot value to test-value and if EQ store
    new-value in the slot. The original value of the slot is returned."
   (kernel::%instance-set-conditional object slot test-value new-value))
-
-#+complex-float
-(progn
-(defun complex-single-float-real (x)
-  (declare (type (complex single-float) x))
-  (the single-float (complex-single-float-real x)))
-
-(defun complex-double-float-real (x)
-  (declare (type (complex double-float) x))
-  (the double-float (complex-double-float-real x)))
-
-(defun complex-single-float-imag (x)
-  (declare (type (complex single-float) x))
-  (the single-float (complex-single-float-imag x)))
-
-(defun complex-double-float-imag (x)
-  (declare (type (complex double-float) x))
-  (the double-float (complex-double-float-imag x)))
-) ; complex-float
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 613310952..46fde871e 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.61 1997/11/15 04:38:54 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.62 1997/11/16 14:00:01 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -235,34 +235,6 @@
 	    (float 0 ,n-num))
 	   (t
 	    0))))
-;;;
-#+complex-float
-(def-source-transform realpart (num)
-  (once-only ((n-num num))
-    `(typecase ,n-num
-      ((complex double-float)
-       (vm::complex-double-float-real ,n-num))
-      ((complex single-float)
-       (vm::complex-single-float-real ,n-num))
-      ((complex rational)
-       (kernel:%realpart ,n-num))
-      (t
-       ,n-num))))
-;;;
-#+complex-float
-(def-source-transform imagpart (num)
-  (once-only ((n-num num))
-    `(typecase ,n-num
-      ((complex double-float)
-       (vm::complex-double-float-imag ,n-num))
-      ((complex single-float)
-       (vm::complex-single-float-imag ,n-num))
-      ((complex rational)
-       (kernel:%imagpart ,n-num))
-      (float
-       (float 0 ,n-num))
-      (t
-       0))))
 
 
 ;;;; Interval arithmetic for computing bounds
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index e73daae0e..717750e5a 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.14 1997/11/08 15:32:05 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.15 1997/11/16 14:00:05 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2560,9 +2560,6 @@
 
 #+complex-float
 (progn
-(eval-when (compile load eval)
-  (export '(complex-single-float-real complex-double-float-real
-	    complex-single-float-imag complex-double-float-imag)))
 
 (define-vop (make-complex-float)
   (:args (x :target r)
@@ -2597,7 +2594,8 @@
 	 (y :scs (single-reg) :to :save))
   (:arg-types single-float single-float)
   (:results (r :scs (complex-single-reg) :from (:argument 0)))
-  (:result-types complex-single-float))
+  (:result-types complex-single-float)
+  (:note "inline complex single-float creation"))
 
 (define-vop (make-complex-double-float make-complex-float)
   (:translate complex)
@@ -2605,13 +2603,8 @@
 	 (y :scs (double-reg) :to :save))
   (:arg-types double-float double-float)
   (:results (r :scs (complex-double-reg) :from (:argument 0)))
-  (:result-types complex-double-float))
-
-;;; Real and imaginary part accessors.
-(defknown (complex-single-float-real complex-single-float-imag)
-  ((complex single-float)) single-float (flushable))
-(defknown (complex-double-float-real complex-double-float-imag)
-  ((complex double-float)) double-float (flushable))
+  (:result-types complex-double-float)
+  (:note "inline complex double-float creation"))
 
 (define-vop (complex-float-value)
   (:args (x :target r))
@@ -2658,39 +2651,44 @@
 	       (inst fldd ea))))
 	  (t (error "Complex-float-value VOP failure")))))
 
-(define-vop (complex-single-float-real complex-float-value)
-  (:translate complex-single-float-real)
+(define-vop (realpart/complex-single-float complex-float-value)
+  (:translate realpart)
   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
 	    :target r))
   (:arg-types complex-single-float)
   (:results (r :scs (single-reg)))
   (:result-types single-float)
+  (:note "complex float realpart")
   (:variant 0))
 
-(define-vop (complex-double-float-real complex-float-value)
-  (:translate complex-double-float-real)
+(define-vop (realpart/complex-double-float complex-float-value)
+  (:translate realpart)
   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
 	    :target r))
   (:arg-types complex-double-float)
   (:results (r :scs (double-reg)))
   (:result-types double-float)
+  (:note "complex float realpart")
   (:variant 0))
 
-(define-vop (complex-single-float-imag complex-float-value)
-  (:translate complex-single-float-imag)
+(define-vop (imagpart/complex-single-float complex-float-value)
+  (:translate imagpart)
   (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
 	    :target r))
   (:arg-types complex-single-float)
   (:results (r :scs (single-reg)))
   (:result-types single-float)
+  (:note "complex float imagpart")
   (:variant 1))
 
-(define-vop (complex-double-float-imag complex-float-value)
-  (:translate complex-double-float-imag)
+(define-vop (imagpart/complex-double-float complex-float-value)
+  (:translate imagpart)
   (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
 	    :target r))
   (:arg-types complex-double-float)
   (:results (r :scs (double-reg)))
   (:result-types double-float)
+  (:note "complex float imagpart")
   (:variant 1))
+
 ) ; complex-float
-- 
GitLab