From c6f1f20f3da30e24781efc145c213ae67a8a389b Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 15 Nov 1997 04:39:03 +0000
Subject: [PATCH] Add a complex-rational-p predicate. This test for a unique
 object type so can be implemented efficiently, and is handy for type
 dispatch. Cleanup the realpart and imagpart source transforms, exploiting the
 complex rational test.

---
 code/exports.lisp             |  9 +++++----
 code/interr.lisp              |  9 ++++++++-
 code/pred.lisp                |  3 ++-
 compiler/generic/interr.lisp  |  5 ++++-
 compiler/generic/vm-fndb.lisp |  4 ++--
 compiler/srctran.lisp         | 20 ++++++++++----------
 compiler/typetran.lisp        |  3 ++-
 compiler/x86/type-vops.lisp   |  8 ++++++--
 8 files changed, 39 insertions(+), 22 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index bb247b934..58cae4a15 100644
--- a/code/exports.lisp
+++ b/code/exports.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/code/exports.lisp,v 1.131 1997/11/07 17:11:16 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.132 1997/11/15 04:38:46 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1429,8 +1429,8 @@
 	   "BOOLEAN" "BYTE-SPECIFIER" "CALLABLE" "CHAR-INT"
 	   "CHECK-FOR-CIRCULARITY" "CODE-COMPONENT" "CODE-COMPONENT-P"
 	   "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
-	   "CODE-INSTRUCTIONS" "COMPLEX-FLOAT-P"
-	   "COMPLEX-SINGLE-FLOAT-P" "COMPLEX-DOUBLE-FLOAT-P"
+	   "CODE-INSTRUCTIONS" "COMPLEX-FLOAT-P" "COMPLEX-SINGLE-FLOAT-P"
+	   "COMPLEX-DOUBLE-FLOAT-P" "COMPLEX-RATIONAL-P"
 	   "CONSED-SEQUENCE" "CONSTANT-TYPE"
 	   "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE" "CONTAINING-INTEGER-TYPE"
 	   "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
@@ -1475,7 +1475,8 @@
 	   "OBJECT-NOT-COERCABLE-TO-FUNCTION-ERROR"
 	   "OBJECT-NOT-COMPLEX-ERROR" "OBJECT-NOT-COMPLEX-FLOAT-ERROR"
 	   "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR"
-	   "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-CONS-ERROR"
+	   "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR"
+	   "OBJECT-NOT-COMPLEX-RATIONAL-ERROR" "OBJECT-NOT-CONS-ERROR"
 	   "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
 	   "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
 	   "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR" "OBJECT-NOT-INSTANCE-ERROR"
diff --git a/code/interr.lisp b/code/interr.lisp
index bf0faa97a..b043d9df3 100644
--- a/code/interr.lisp
+++ b/code/interr.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/code/interr.lisp,v 1.31 1997/11/01 22:58:13 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.32 1997/11/15 04:38:49 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -417,6 +417,13 @@
 	 :datum object
 	 :expected-type 'complex))
 
+#+complex-float
+(deferr object-not-complex-rational-error (object)
+  (error 'type-error
+	 :function-name name
+	 :datum object
+	 :expected-type '(complex rational)))
+
 #+complex-float
 (deferr object-not-complex-single-float-error (object)
   (error 'type-error
diff --git a/code/pred.lisp b/code/pred.lisp
index c62c7a704..fbb32688a 100644
--- a/code/pred.lisp
+++ b/code/pred.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/code/pred.lisp,v 1.41 1997/11/07 17:11:19 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.42 1997/11/15 04:38:50 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -54,6 +54,7 @@
       consp
       compiled-function-p
       complexp
+      #+complex-float complex-rational-p
       #+complex-float complex-float-p
       #+complex-float complex-single-float-p
       #+complex-float complex-double-float-p
diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp
index a48e59e65..f43e9f1ac 100644
--- a/compiler/generic/interr.lisp
+++ b/compiler/generic/interr.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/generic/interr.lisp,v 1.7 1997/11/07 17:11:24 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.8 1997/11/15 04:39:00 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -162,6 +162,9 @@
   (object-not-complex
    "Object is not of type COMPLEX.")
   #+complex-float
+  (object-not-complex-rational
+   "Object is not of type (COMPLEX RATIONAL).")
+  #+complex-float
   (object-not-complex-float
    "Object is not of type (COMPLEX FLOAT).")
   #+complex-float
diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp
index 794fceeed..1641fcda8 100644
--- a/compiler/generic/vm-fndb.lisp
+++ b/compiler/generic/vm-fndb.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/generic/vm-fndb.lisp,v 1.56 1997/11/07 17:11:26 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.57 1997/11/15 04:39:01 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -48,7 +48,7 @@
 
 (defknown (fixnump bignump ratiop
 	   short-float-p single-float-p double-float-p long-float-p
-	   #+complex-float complex-float-p
+	   #+complex-float complex-rational-p #+complex-float complex-float-p
 	   #+complex-float complex-single-float-p
 	   #+complex-float complex-double-float-p
 	   base-char-p %string-char-p %standard-char-p %instancep
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 66ba2cd91..613310952 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.60 1997/11/01 22:58:24 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.61 1997/11/15 04:38:54 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -239,12 +239,12 @@
 #+complex-float
 (def-source-transform realpart (num)
   (once-only ((n-num num))
-    `(cond
-      ((kernel:complex-double-float-p ,n-num)
+    `(typecase ,n-num
+      ((complex double-float)
        (vm::complex-double-float-real ,n-num))
-      ((kernel:complex-single-float-p ,n-num)
+      ((complex single-float)
        (vm::complex-single-float-real ,n-num))
-      ((complexp ,n-num)
+      ((complex rational)
        (kernel:%realpart ,n-num))
       (t
        ,n-num))))
@@ -252,14 +252,14 @@
 #+complex-float
 (def-source-transform imagpart (num)
   (once-only ((n-num num))
-    `(cond
-      ((kernel:complex-double-float-p ,n-num)
+    `(typecase ,n-num
+      ((complex double-float)
        (vm::complex-double-float-imag ,n-num))
-      ((kernel:complex-single-float-p ,n-num)
+      ((complex single-float)
        (vm::complex-single-float-imag ,n-num))
-      ((complexp ,n-num)
+      ((complex rational)
        (kernel:%imagpart ,n-num))
-      ((floatp ,n-num)
+      (float
        (float 0 ,n-num))
       (t
        0))))
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index 3842d37b7..db6899ee0 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.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/typetran.lisp,v 1.30 1997/11/07 17:11:22 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.31 1997/11/15 04:38:57 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -134,6 +134,7 @@
   (define-type-predicate characterp character)
   (define-type-predicate compiled-function-p compiled-function)
   (define-type-predicate complexp complex)
+  #+complex-float (define-type-predicate complex-rational-p (complex rational))
   #+complex-float (define-type-predicate complex-float-p (complex float))
   (define-type-predicate consp cons)
   (define-type-predicate floatp float)
diff --git a/compiler/x86/type-vops.lisp b/compiler/x86/type-vops.lisp
index 945546263..94aa2a295 100644
--- a/compiler/x86/type-vops.lisp
+++ b/compiler/x86/type-vops.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/type-vops.lisp,v 1.5 1997/11/07 17:11:28 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/type-vops.lisp,v 1.6 1997/11/15 04:39:03 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -293,7 +293,11 @@
   #+complex-float complex-double-float-type)
 
 #+complex-float
-(def-type-vops complex-float-p check-complex-float-p nil
+(def-type-vops complex-rational-p check-complex-rational nil
+  object-not-complex-rational-error complex-type)
+
+#+complex-float
+(def-type-vops complex-float-p check-complex-float nil
   object-not-complex-float-error
   complex-single-float-type complex-double-float-type)
 
-- 
GitLab