From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 14 Apr 2003 18:59:08 +0000 (+0000)
Subject: Fix bug: EXPT wasn't handling complex zero right.
X-Git-Tag: 20090517-FFI~1929
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6aabcef17f345805edb50e25e9d74dca8aba079a;p=mit-scheme.git
Fix bug: EXPT wasn't handling complex zero right.
Rather than using DEFINE to make exported aliases of many arithmetic
procedures, use the renaming mechanism of the package system.
Export FLO:SIGNIFICAND-DIGITS-BASE-2 and
FLO:SIGNIFICAND-DIGITS-BASE-10 to global environment.
---
diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm
index 2bb457f56..a32047493 100644
--- a/v7/src/runtime/arith.scm
+++ b/v7/src/runtime/arith.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: arith.scm,v 1.56 2003/02/14 18:28:32 cph Exp $
+$Id: arith.scm,v 1.57 2003/04/14 18:59:05 cph Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,1997,1999,2001,2002 Massachusetts Institute of Technology
@@ -1673,39 +1673,39 @@ USA.
((copy real:sqrt) z))))
(define (complex:expt z1 z2)
- (let ((general-case
- (lambda ()
- (complex:exp (complex:* (complex:log z1) z2)))))
- (cond ((recnum? z1)
- (if (and (rec:exact? z1)
- (int:integer? z2))
- (let ((exact-method
- (lambda (z2)
- (if (int:= 1 z2)
- z1
- (let loop ((z1 z1) (z2 z2) (answer 1))
- (let ((qr (int:divide z2 2)))
- (let ((z1 (complex:* z1 z1))
- (z2 (integer-divide-quotient qr))
- (answer
- (if (int:zero?
- (integer-divide-remainder qr))
- answer
- (complex:* answer z1))))
- (if (int:= 1 z2)
- (complex:* answer z1)
- (loop z1 z2 answer)))))))))
- (cond ((int:positive? z2) (exact-method z2))
- ((int:negative? z2)
- (complex:/ 1 (exact-method (int:negate z2))))
- (else 1)))
- (general-case)))
- ((or (recnum? z2)
- (and (real:negative? z1)
- (not (real:integer? z2))))
- (general-case))
- (else
- (real:expt z1 z2)))))
+ (cond ((complex:zero? z1)
+ (cond ((complex:zero? z2) (if (complex:exact? z2) 1 1.0))
+ ((complex:positive? z2) (real:0 (complex:exact? z1)))
+ (else (error:divide-by-zero 'EXPT (list z1 z2)))))
+ ((and (recnum? z1)
+ (int:integer? z2))
+ (let ((exact-method
+ (lambda (z2)
+ (if (int:= 1 z2)
+ z1
+ (let loop ((z1 z1) (z2 z2) (answer 1))
+ (let ((qr (int:divide z2 2)))
+ (let ((z1 (complex:* z1 z1))
+ (z2 (integer-divide-quotient qr))
+ (answer
+ (if (int:zero?
+ (integer-divide-remainder qr))
+ answer
+ (complex:* answer z1))))
+ (if (int:= 1 z2)
+ (complex:* answer z1)
+ (loop z1 z2 answer)))))))))
+ (cond ((int:positive? z2) (exact-method z2))
+ ((int:negative? z2)
+ (complex:/ 1 (exact-method (int:negate z2))))
+ (else 1))))
+ ((or (recnum? z1)
+ (recnum? z2)
+ (and (real:negative? z1)
+ (not (real:integer? z2))))
+ (complex:exp (complex:* (complex:log z1) z2)))
+ (else
+ (real:expt z1 z2))))
(define (complex:make-rectangular real imag)
(let ((check-arg
@@ -1774,15 +1774,6 @@ USA.
(define imaginary-unit-j? #f)
-(define number? complex:complex?)
-(define complex? complex:complex?)
-(define real? complex:real?)
-(define rational? complex:rational?)
-(define integer? complex:integer?)
-(define exact? complex:exact?)
-(define exact-rational? rat:rational?)
-(define exact-integer? int:integer?)
-
(define (inexact? z)
(not (complex:exact? z)))
@@ -1816,8 +1807,44 @@ USA.
(define-guarantee inexact "inexact number")
(define-guarantee exact-nonnegative-integer "exact non-negative integer")
(define-guarantee exact-positive-integer "exact positive integer")
+
+;;; The following three procedures were originally just renamings of
+;;; their COMPLEX: equivalents. They have been rewritten this way to
+;;; cause the compiler to generate better code for them.
+
+(define (quotient n d)
+ ((ucode-primitive quotient 2) n d))
+
+(define (remainder n d)
+ ((ucode-primitive remainder 2) n d))
+
+(define (modulo n d)
+ (let ((r ((ucode-primitive remainder 2) n d)))
+ (if (or (zero? r)
+ (if (negative? n)
+ (negative? d)
+ (not (negative? d))))
+ r
+ (+ r d))))
+
+(define-integrable integer-divide-quotient car)
+(define-integrable integer-divide-remainder cdr)
+
+(define (gcd . integers)
+ (fold-left complex:gcd 0 integers))
+
+(define (lcm . integers)
+ (fold-left complex:lcm 1 integers))
+
+(define (atan z #!optional x)
+ (if (default-object? x)
+ (complex:atan z)
+ (complex:atan2 z x)))
+
+(define (square z)
+ (complex:* z z))
-;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE!
+;;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE!.
(define =)
(define <)
@@ -1839,17 +1866,10 @@ USA.
(and (binary-comparator x y)
(loop y (cdr rest)))))))))
-(define zero? complex:zero?)
-(define positive? complex:positive?)
-(define negative? complex:negative?)
-
(define (odd? n)
(not (complex:even? n)))
-(define even? complex:even?)
-
-
-;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE!
+;;; Replaced with arity-dispatched version in INITIALIZE-PACKAGE!.
(define +)
(define *)
@@ -1871,87 +1891,6 @@ USA.
(if (null? xs)
x1
(loop x1 xs))))))
-
-(define 1+ complex:1+)
-(define -1+ complex:-1+)
-
-(define conjugate complex:conjugate)
-
-(define abs complex:abs)
-
-;;; The following three procedures were originally just renamings of
-;;; their COMPLEX: equivalents. They have been rewritten this way to
-;;; cause the compiler to generate better code for them.
-
-(define (quotient n d)
- ((ucode-primitive quotient 2) n d))
-
-(define (remainder n d)
- ((ucode-primitive remainder 2) n d))
-
-(define (modulo n d)
- (let ((r ((ucode-primitive remainder 2) n d)))
- (if (or (zero? r)
- (if (negative? n)
- (negative? d)
- (not (negative? d))))
- r
- (+ r d))))
-
-(define integer-floor complex:integer-floor)
-(define integer-ceiling complex:integer-ceiling)
-(define integer-truncate complex:quotient)
-(define integer-round complex:integer-round)
-(define integer-divide complex:divide)
-(define-integrable integer-divide-quotient car)
-(define-integrable integer-divide-remainder cdr)
-
-(define (gcd . integers)
- (fold-left complex:gcd 0 integers))
-
-(define (lcm . integers)
- (fold-left complex:lcm 1 integers))
-
-(define numerator complex:numerator)
-(define denominator complex:denominator)
-(define floor complex:floor)
-(define ceiling complex:ceiling)
-(define truncate complex:truncate)
-(define round complex:round)
-(define floor->exact complex:floor->exact)
-(define ceiling->exact complex:ceiling->exact)
-(define truncate->exact complex:truncate->exact)
-(define round->exact complex:round->exact)
-(define rationalize complex:rationalize)
-(define rationalize->exact complex:rationalize->exact)
-(define simplest-rational complex:simplest-rational)
-(define simplest-exact-rational complex:simplest-exact-rational)
-(define exp complex:exp)
-(define log complex:log)
-(define sin complex:sin)
-(define cos complex:cos)
-(define tan complex:tan)
-(define asin complex:asin)
-(define acos complex:acos)
-
-(define (atan z #!optional x)
- (if (default-object? x)
- (complex:atan z)
- (complex:atan2 z x)))
-
-(define sqrt complex:sqrt)
-(define expt complex:expt)
-(define make-rectangular complex:make-rectangular)
-(define make-polar complex:make-polar)
-(define real-part complex:real-part)
-(define imag-part complex:imag-part)
-(define magnitude complex:magnitude)
-(define angle complex:angle)
-(define exact->inexact complex:exact->inexact)
-(define inexact->exact complex:inexact->exact)
-
-(define (square z)
- (complex:* z z))
(define (number->string z #!optional radix)
(complex:->string
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index e27c284fb..98bec5e2b 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.441 2003/04/14 18:19:26 cph Exp $
+$Id: runtime.pkg,v 14.442 2003/04/14 18:59:08 cph Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -173,6 +173,7 @@ USA.
(files "fixart")
(parent (runtime))
(export ()
+ (exact-integer? int:integer?)
->flonum
fix:*
fix:+
@@ -2207,43 +2208,75 @@ USA.
(files "arith" "dragon4")
(parent (runtime))
(export ()
+ (-1+ complex:-1+)
+ (1+ complex:1+)
+ (abs complex:abs)
+ (acos complex:acos)
+ (angle complex:angle)
+ (asin complex:asin)
+ (ceiling complex:ceiling)
+ (ceiling->exact complex:ceiling->exact)
+ (complex? complex:complex?)
+ (conjugate complex:conjugate)
+ (cos complex:cos)
+ (denominator complex:denominator)
+ (even? complex:even?)
+ (exact->inexact complex:exact->inexact)
+ (exact-rational? rat:rational?)
+ (exact? complex:exact?)
+ (exp complex:exp)
+ (expt complex:expt)
+ (floor complex:floor)
+ (floor->exact complex:floor->exact)
+ (imag-part complex:imag-part)
+ (inexact->exact complex:inexact->exact)
+ (integer-ceiling complex:integer-ceiling)
+ (integer-divide complex:divide)
+ (integer-floor complex:integer-floor)
+ (integer-round complex:integer-round)
+ (integer-truncate complex:quotient)
+ (integer? complex:integer?)
+ (log complex:log)
+ (magnitude complex:magnitude)
+ (make-polar complex:make-polar)
+ (make-rectangular complex:make-rectangular)
+ (negative? complex:negative?)
+ (number? complex:complex?)
+ (numerator complex:numerator)
+ (positive? complex:positive?)
+ (rational? complex:rational?)
+ (rationalize complex:rationalize)
+ (rationalize->exact complex:rationalize->exact)
+ (real-part complex:real-part)
+ (real? complex:real?)
+ (round complex:round)
+ (round->exact complex:round->exact)
+ (simplest-exact-rational complex:simplest-exact-rational)
+ (simplest-rational complex:simplest-rational)
+ (sin complex:sin)
+ (sqrt complex:sqrt)
+ (tan complex:tan)
+ (truncate complex:truncate)
+ (truncate->exact complex:truncate->exact)
+ (zero? complex:zero?)
*
+
-
- -1+
/
- 1+
<
<=
=
>
>=
- abs
- acos
- angle
- asin
atan
- ceiling
- ceiling->exact
- complex?
- conjugate
- cos
- denominator
- even?
- exact->inexact
- exact-integer?
exact-nonnegative-integer?
exact-positive-integer?
- exact-rational?
- exact?
- exp
- expt
+ flo:significand-digits-base-10
+ flo:significand-digits-base-2
flonum-unparser-cutoff
flonum-unparser:engineering-output
flonum-unparser:normal-output
flonum-unparser:scientific-output
- floor
- floor->exact
gcd
guarantee-complex
guarantee-exact
@@ -2256,49 +2289,18 @@ USA.
guarantee-number
guarantee-rational
guarantee-real
- imag-part
- inexact->exact
inexact?
- integer-ceiling
- integer-divide
integer-divide-quotient
integer-divide-remainder
- integer-floor
- integer-round
- integer-truncate
- integer?
lcm
- log
- magnitude
- make-polar
- make-rectangular
max
min
modulo
- negative?
number->string
- number?
- numerator
odd?
- positive?
quotient
- rational?
- rationalize
- rationalize->exact
- real-part
- real?
remainder
- round
- round->exact
- simplest-exact-rational
- simplest-rational
- sin
- square
- sqrt
- tan
- truncate
- truncate->exact
- zero?)
+ square)
(initialization
(begin
(initialize-package!)