From 4909a9ef08ae1f03cf8b84fbdce337fe4e2bad9d Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Fri, 25 Jul 2008 17:46:34 -0700 Subject: [PATCH] fixed make-rectangular so that (make-rectangular 1.0 0.0) returns a cflonum 1.0+0.0i while (make-rectangular 1.0 0) returns 1.0. --- scheme/ikarus.numerics.ss | 65 +++++++++++++++++++------------------ scheme/ikarus.predicates.ss | 23 +++++++++++-- scheme/last-revision | 2 +- 3 files changed, 55 insertions(+), 35 deletions(-) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 16fb8fe..87f13d3 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -560,14 +560,14 @@ (binary+ y ($compnum-real x)) (inexact ($compnum-imag x)))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary+ ($compnum-real x) ($cflonum-real y)) (binary+ ($compnum-imag x) ($cflonum-imag y)))] [else (err '+ y)])] [(cflonum? x) (cond [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary+ ($cflonum-real x) ($cflonum-real y)) (binary+ ($cflonum-imag x) ($cflonum-imag y)))] [(flonum? y) @@ -579,7 +579,7 @@ (binary+ ($compnum-real x) y) ($compnum-imag x))] [(compnum? y) - ($make-rectangular + ($make-cflonum (binary+ ($cflonum-real x) ($compnum-real y)) (binary+ ($cflonum-imag x) ($compnum-imag y)))] [else (err '+ y)])] @@ -758,7 +758,7 @@ (binary- ($compnum-real x) ($compnum-real y)) (binary- ($compnum-imag x) ($compnum-imag y)))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary- ($compnum-real x) ($cflonum-real y)) (binary- ($compnum-imag x) ($cflonum-imag y)))] [else @@ -770,7 +770,7 @@ ($fl- ($cflonum-real x) y) ($cflonum-imag x))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary- ($cflonum-real x) ($cflonum-real y)) (binary- ($cflonum-imag x) ($cflonum-imag y)))] [(or (fixnum? y) (bignum? y) (ratnum? y)) @@ -778,7 +778,7 @@ (binary- ($cflonum-real x) y) ($cflonum-imag x))] [(compnum? y) - ($make-rectangular + ($make-cflonum (binary- ($cflonum-real x) ($compnum-real y)) (binary- ($cflonum-imag x) ($compnum-imag y)))] [else @@ -803,7 +803,7 @@ (binary* x ($compnum-real y)) (binary* x ($compnum-imag y)))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary* x ($cflonum-real y)) (binary* x ($cflonum-imag y)))] [else (err '* y)])] @@ -822,7 +822,7 @@ (binary* x ($compnum-real y)) (binary* x ($compnum-imag y)))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary* x ($cflonum-real y)) (binary* x ($cflonum-imag y)))] [else (err '* y)])] @@ -831,7 +831,7 @@ [(flonum? y) ($fl* x y)] [(cflonum? y) - ($make-rectangular + ($make-cflonum ($fl* x ($cflonum-real y)) ($fl* x ($cflonum-imag y)))] [(fixnum? y) @@ -841,7 +841,7 @@ [(ratnum? y) (binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))] [(compnum? y) - ($make-rectangular + ($make-cflonum (binary* x ($compnum-real y)) (binary* x ($compnum-imag y)))] [else (err '* y)])] @@ -855,22 +855,26 @@ (binary* x ($compnum-real y)) (binary* x ($compnum-imag y)))] [(cflonum? y) - ($make-rectangular + ($make-cflonum (binary* x ($cflonum-real y)) (binary* x ($cflonum-imag y)))] [else (binary* y x)])] [(compnum? x) (cond - [(or (fixnum? y) (bignum? y) (ratnum? y) (flonum? y)) + [(or (fixnum? y) (bignum? y) (ratnum? y)) ($make-rectangular (binary* ($compnum-real x) y) (binary* ($compnum-imag x) y))] + [(flonum? y) + ($make-cflonum + (binary* ($compnum-real x) y) + (binary* ($compnum-imag x) y))] [(compnum? y) (let ([r0 ($compnum-real x)] [r1 ($compnum-real y)] [i0 ($compnum-imag x)] [i1 ($compnum-imag y)]) - ($make-rectangular + (make-rectangular (- (* r0 r1) (* i0 i1)) (+ (* r0 i1) (* i0 r1))))] [(cflonum? y) @@ -878,14 +882,14 @@ [r1 ($cflonum-real y)] [i0 ($compnum-imag x)] [i1 ($cflonum-imag y)]) - ($make-rectangular + (make-rectangular (- (* r0 r1) (* i0 i1)) (+ (* r0 i1) (* i0 r1))))] [else (err '* y)])] [(cflonum? x) (cond [(flonum? y) - ($make-rectangular + ($make-cflonum ($fl* ($cflonum-real x) y) ($fl* ($cflonum-imag x) y))] [(cflonum? y) @@ -893,11 +897,11 @@ [r1 ($cflonum-real y)] [i0 ($cflonum-imag x)] [i1 ($cflonum-imag y)]) - ($make-rectangular + ($make-cflonum ($fl- ($fl* r0 r1) ($fl* i0 i1)) ($fl+ ($fl* r0 i1) ($fl* i0 r1))))] [(or (fixnum? y) (bignum? y) (ratnum? y)) - ($make-rectangular + ($make-cflonum (binary* ($compnum-real x) y) (binary* ($compnum-imag x) y))] [(compnum? y) @@ -905,7 +909,7 @@ [r1 ($compnum-real y)] [i0 ($compnum-imag x)] [i1 ($compnum-imag y)]) - ($make-rectangular + (make-rectangular (- (* r0 r1) (* i0 i1)) (+ (* r0 i1) (* i0 r1))))] [else (err '* y)])] @@ -1115,13 +1119,13 @@ (let ([yr (real-part y)] [yi (imag-part y)]) (let ([denom (+ (* yr yr) (* yi yi))]) - ($make-rectangular + (make-rectangular (binary/ (* x yr) denom) (binary/ (* (- x) yi) denom))))) (define (compx/y x y) (let ([xr (real-part x)] [xi (imag-part x)]) - ($make-rectangular + (make-rectangular (binary/ xr y) (binary/ xi y)))) (define (compx/compy x y) @@ -1130,7 +1134,7 @@ [yr (real-part y)] [yi (imag-part y)]) (let ([denom (+ (* yr yr) (* yi yi))]) - ($make-rectangular + (make-rectangular (binary/ (+ (* xr yr) (* xi yi)) denom) (binary/ (- (* xi yr) (* xr yi)) denom))))) (cond @@ -3672,12 +3676,10 @@ (except (ikarus system $compnums) $make-rectangular)) (define ($make-rectangular r i) - ;;; should be called with 2 exacts or two inexacts - (if (flonum? i) - (if (and (fl=? i 0.0) (fl=? (atan 0.0 i) 0.0)) - r - ($make-cflonum r i)) - (if (eqv? i 0) r ($make-compnum r i)))) + ;;; should be called with 2 exacts + (if (eqv? i 0) + r + ($make-compnum r i))) (define (make-rectangular r i) (define who 'make-rectangular) @@ -3686,16 +3688,17 @@ (cond [(flonum? i) (cond - [(flonum? r) ($make-rectangular r i)] + [(flonum? r) ($make-cflonum r i)] [(or (fixnum? r) (bignum? r) (ratnum? r)) - ($make-rectangular (inexact r) i)] + ($make-cflonum (inexact r) i)] [else (err r)])] + [(eqv? i 0) (if (number? r) r (err r))] [(or (fixnum? i) (bignum? i) (ratnum? i)) (cond [(or (fixnum? r) (bignum? r) (ratnum? r)) ($make-rectangular r i)] [(flonum? r) - ($make-rectangular r (inexact i))] + ($make-cflonum r (inexact i))] [else (err r)])] [else (err i)])) @@ -3772,7 +3775,7 @@ [(fixnum? x) 0] [(bignum? x) 0] [(ratnum? x) 0] - [(flonum? x) 0.0] + [(flonum? x) 0] [(compnum? x) ($compnum-imag x)] [(cflonum? x) ($cflonum-imag x)] [else diff --git a/scheme/ikarus.predicates.ss b/scheme/ikarus.predicates.ss index 819114e..264aaa8 100644 --- a/scheme/ikarus.predicates.ss +++ b/scheme/ikarus.predicates.ss @@ -105,7 +105,11 @@ (sys:ratnum? x)))) (define real-valued? - (lambda (x) (real? x))) + (lambda (x) + (cond + [(real? x) #t] + [(cflonum? x) (fl=? ($cflonum-imag x) 0.0)] + [else #f]))) (define rational? (lambda (x) @@ -117,7 +121,13 @@ [else #f]))) (define rational-valued? - (lambda (x) (rational? x))) + (lambda (x) + (cond + [(rational? x) #t] + [(cflonum? x) + (and (fl=? ($cflonum-imag x) 0.0) + ($flonum-rational? ($cflonum-real x)))] + [else #f]))) (define integer? (lambda (x) @@ -129,7 +139,14 @@ [else #f]))) (define integer-valued? - (lambda (x) (integer? x))) + (lambda (x) + (cond + [(integer? x) #t] + [(cflonum? x) + (and (fl=? ($cflonum-imag x) 0.0) + ($flonum-integer? ($cflonum-real x)))] + [else #f]))) + (define exact? (lambda (x) diff --git a/scheme/last-revision b/scheme/last-revision index c8db0f6..6b6c6e5 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1552 +1553