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