Added inexact complex numbers.

This commit is contained in:
Abdulaziz Ghuloum 2008-05-24 10:13:01 -07:00
parent 8827b98972
commit ab2e05e8b0
11 changed files with 178 additions and 53 deletions

Binary file not shown.

View File

@ -2450,6 +2450,11 @@
(define disp-compnum-imag (* 2 wordsize)) (define disp-compnum-imag (* 2 wordsize))
(define compnum-size (* 4 wordsize)) (define compnum-size (* 4 wordsize))
(define cflonum-tag #x47)
(define disp-cflonum-real (* 1 wordsize))
(define disp-cflonum-imag (* 2 wordsize))
(define cflonum-size (* 4 wordsize))
(define bignum-mask #b111) (define bignum-mask #b111)
(define bignum-tag #b011) (define bignum-tag #b011)
(define bignum-sign-mask #b1000) (define bignum-sign-mask #b1000)

View File

@ -281,7 +281,7 @@
(write-byte ($bignum-byte-ref x i) p) (write-byte ($bignum-byte-ref x i) p)
(f (fxadd1 i))))) (f (fxadd1 i)))))
m] m]
[(compnum? x) [(or (compnum? x) (cflonum? x))
(put-tag #\i p) (put-tag #\i p)
(fasl-write-object (imag-part x) p h (fasl-write-object (imag-part x) p h
(fasl-write-object (real-part x) p h m))] (fasl-write-object (real-part x) p h m))]
@ -377,7 +377,7 @@
[(ratnum? x) [(ratnum? x)
(make-graph (numerator x) h) (make-graph (numerator x) h)
(make-graph (denominator x) h)] (make-graph (denominator x) h)]
[(compnum? x) [(or (compnum? x) (cflonum? x))
(make-graph (real-part x) h) (make-graph (real-part x) h)
(make-graph (imag-part x) h)] (make-graph (imag-part x) h)]
[else (die 'fasl-write "not fasl-writable" x)])])))) [else (die 'fasl-write "not fasl-writable" x)])]))))

View File

@ -1463,6 +1463,11 @@
($number->string ($compnum-real x) r) ($number->string ($compnum-real x) r)
(imag ($compnum-imag x) r) (imag ($compnum-imag x) r)
"i")] "i")]
[(cflonum? x)
(string-append
($number->string ($cflonum-real x) r)
(imag ($cflonum-imag x) r)
"i")]
[else (die 'number->string "not a number" x)]))) [else (die 'number->string "not a number" x)])))
(define number->string (define number->string
(case-lambda (case-lambda
@ -1924,8 +1929,8 @@
(if (fxfl= x y) (if (fxfl= x y)
(flloopt y (car ls) (cdr ls)) (flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))] (loopf (car ls) (cdr ls))))]
[(ratnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] [(or (ratnum? y) (compnum? y) (cflonum? y))
[(compnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] (and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)]))) [else (err y)])))
(define bnloopt (define bnloopt
(lambda (x y ls) (lambda (x y ls)
@ -1943,8 +1948,8 @@
(if (bnfl= x y) (if (bnfl= x y)
(flloopt y (car ls) (cdr ls)) (flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))] (loopf (car ls) (cdr ls))))]
[(ratnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] [(or (ratnum? y) (compnum? y) (cflonum? y))
[(compnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] (and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)]))) [else (err y)])))
(define flloopt (define flloopt
(lambda (x y ls) (lambda (x y ls)
@ -1973,13 +1978,12 @@
(if (flrt= x y) (if (flrt= x y)
(rtloopt y (car ls) (cdr ls)) (rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))] (loopf (car ls) (cdr ls))))]
[(compnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] [(or (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)]))) [else (err y)])))
(define rtloopt (define rtloopt
(lambda (x y ls) (lambda (x y ls)
(cond (cond
[(fixnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))]
[(bignum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))]
[(flonum? y) [(flonum? y)
(if (null? ls) (if (null? ls)
(rtfl= x y) (rtfl= x y)
@ -1992,7 +1996,8 @@
(if (rtrt= x y) (if (rtrt= x y)
(rtloopt y (car ls) (cdr ls)) (rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))] (loopf (car ls) (cdr ls))))]
[(compnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] [(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)]))) [else (err y)])))
(define cnloopt (define cnloopt
(lambda (x y ls) (lambda (x y ls)
@ -2003,10 +2008,32 @@
(if (cncn= x y) (if (cncn= x y)
(cnloopt y (car ls) (cdr ls)) (cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))] (loopf (car ls) (cdr ls))))]
[(fixnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] [(cflonum? y)
[(bignum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] (if (null? ls)
[(flonum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] (cncf= x y)
[(ratnum? y) (and (pair? ls) (loopf (car ls) (cdr ls)))] (if (cncf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define cfloopt
(lambda (x y ls)
(cond
[(cflonum? y)
(if (null? ls)
(cfcf= x y)
(if (cfcf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(compnum? y)
(if (null? ls)
(cncf= y x)
(if (cncf= y x)
(cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)]))) [else (err y)])))
(define loopf (define loopf
(lambda (x ls) (lambda (x ls)
@ -2020,6 +2047,14 @@
(and (and
(= ($compnum-real x) ($compnum-real y)) (= ($compnum-real x) ($compnum-real y))
(= ($compnum-imag x) ($compnum-imag y)))) (= ($compnum-imag x) ($compnum-imag y))))
(define (cncf= x y)
(and
(= ($compnum-real x) ($cflonum-real y))
(= ($compnum-imag x) ($cflonum-imag y))))
(define (cfcf= x y)
(and
(= ($cflonum-real x) ($cflonum-real y))
(= ($cflonum-imag x) ($cflonum-imag y))))
(define = (define =
(case-lambda (case-lambda
[(x y) [(x y)
@ -2027,18 +2062,14 @@
[(fixnum? x) [(fixnum? x)
(cond (cond
[(fixnum? y) ($fx= x y)] [(fixnum? y) ($fx= x y)]
[(bignum? y) #f]
[(flonum? y) (fxfl= x y)] [(flonum? y) (fxfl= x y)]
[(ratnum? y) #f] [(or (bignum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f]
[(compnum? y) #f]
[else (err y)])] [else (err y)])]
[(bignum? x) [(bignum? x)
(cond (cond
[(fixnum? y) #f]
[(bignum? y) (bnbn= x y)] [(bignum? y) (bnbn= x y)]
[(flonum? y) (bnfl= x y)] [(flonum? y) (bnfl= x y)]
[(ratnum? y) #f] [(or (fixnum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f]
[(compnum? y) #f]
[else (err y)])] [else (err y)])]
[(flonum? x) [(flonum? x)
(cond (cond
@ -2046,23 +2077,25 @@
[(bignum? y) (flbn= x y)] [(bignum? y) (flbn= x y)]
[(flonum? y) (flfl= x y)] [(flonum? y) (flfl= x y)]
[(ratnum? y) (flrt= x y)] [(ratnum? y) (flrt= x y)]
[(compnum? y) #f] [(or (compnum? y) (cflonum? y)) #f]
[else (err y)])] [else (err y)])]
[(ratnum? x) [(ratnum? x)
(cond (cond
[(fixnum? y) #f]
[(bignum? y) #f]
[(flonum? y) (rtfl= x y)] [(flonum? y) (rtfl= x y)]
[(ratnum? y) (rtrt= x y)] [(ratnum? y) (rtrt= x y)]
[(compnum? y) #f] [(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])] [else (err y)])]
[(compnum? x) [(compnum? x)
(cond (cond
[(compnum? y) (cncn= x y)] [(compnum? y) (cncn= x y)]
[(fixnum? y) #f] [(cflonum? y) (cncf= x y)]
[(bignum? y) #f] [(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[(flonum? y) #f] [else (err y)])]
[(ratnum? y) #f] [(cflonum? x)
(cond
[(cflonum? y) (cfcf= x y)]
[(compnum? y) (cncf= y x)]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[else (err y)])] [else (err y)])]
[else (err x)])] [else (err x)])]
[(x y z) (and (= x y) (= y z))] [(x y z) (and (= x y) (= y z))]
@ -2074,6 +2107,7 @@
[(flonum? x) (flloopt x y ls)] [(flonum? x) (flloopt x y ls)]
[(ratnum? x) (rtloopt x y ls)] [(ratnum? x) (rtloopt x y ls)]
[(compnum? x) (cnloopt x y ls)] [(compnum? x) (cnloopt x y ls)]
[(cflonum? x) (cfloopt x y ls)]
[else (err x)])])) [else (err x)])]))
=)) =))
@ -3626,26 +3660,30 @@
(except (ikarus system $compnums) $make-rectangular)) (except (ikarus system $compnums) $make-rectangular))
(define ($make-rectangular r i) (define ($make-rectangular r i)
(cond ;;; should be called with 2 exacts or two inexacts
[(eqv? i 0) r] (if (flonum? i)
[else ($make-compnum r i)])) (if (fl=? i 0.0) r ($make-cflonum r i))
(if (eqv? i 0) r ($make-compnum r i))))
(define (make-rectangular r i) (define (make-rectangular r i)
(define who 'make-rectangular) (define who 'make-rectangular)
(define (err x) (define (err x)
(die who "invalid argument" x)) (die who "invalid argument" x))
(define (valid-part? x)
(or (fixnum? x)
(bignum? x)
(ratnum? x)))
(cond (cond
[(eqv? i 0) [(flonum? i)
(if (valid-part? r) r (err r))] (cond
[(valid-part? i) [(flonum? r) ($make-rectangular r i)]
(if (valid-part? r) [(or (fixnum? r) (bignum? r) (ratnum? r))
($make-compnum r i) ($make-rectangular (inexact r) i)]
(err i))] [else (err r)])]
[else (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))]
[else (err r)])]
[else (err i)]))
(define magnitude (define magnitude
(lambda (x) (lambda (x)
@ -3656,6 +3694,10 @@
(let ([r ($compnum-real x)] (let ([r ($compnum-real x)]
[i ($compnum-imag x)]) [i ($compnum-imag x)])
(sqrt (+ (* r r) (* i i))))] (sqrt (+ (* r r) (* i i))))]
[(cflonum? x)
(let ([r ($cflonum-real x)]
[i ($cflonum-imag x)])
(sqrt (+ (* r r) (* i i))))]
[else [else
(die 'magnitude "not a number" x)]))) (die 'magnitude "not a number" x)])))
@ -3667,6 +3709,7 @@
[(ratnum? x) x] [(ratnum? x) x]
[(flonum? x) x] [(flonum? x) x]
[(compnum? x) ($compnum-real x)] [(compnum? x) ($compnum-real x)]
[(cflonum? x) ($cflonum-real x)]
[else [else
(die 'real-part "not a number" x)]))) (die 'real-part "not a number" x)])))
@ -3678,6 +3721,7 @@
[(ratnum? x) 0] [(ratnum? x) 0]
[(flonum? x) 0.0] [(flonum? x) 0.0]
[(compnum? x) ($compnum-imag x)] [(compnum? x) ($compnum-imag x)]
[(cflonum? x) ($cflonum-imag x)]
[else [else
(die 'imag-part "not a number" x)]))) (die 'imag-part "not a number" x)])))
) )

View File

@ -16,7 +16,7 @@
(library (ikarus predicates) (library (ikarus predicates)
(export fixnum? flonum? bignum? ratnum? compnum? (export fixnum? flonum? bignum? ratnum? compnum? cflonum?
number? complex? real? rational? number? complex? real? rational?
integer? exact? inexact? eof-object? bwp-object? immediate? integer? exact? inexact? eof-object? bwp-object? immediate?
boolean? char? vector? bytevector? string? procedure? null? pair? boolean? char? vector? bytevector? string? procedure? null? pair?
@ -24,7 +24,7 @@
symbol=? finite? infinite? nan? real-valued? symbol=? finite? infinite? nan? real-valued?
rational-valued? integer-valued? transcoder?) rational-valued? integer-valued? transcoder?)
(import (import
(except (ikarus) fixnum? flonum? bignum? ratnum? compnum? (except (ikarus) fixnum? flonum? bignum? ratnum? compnum? cflonum?
number? complex? real? number? complex? real?
rational? integer? exact? inexact? eof-object? bwp-object? rational? integer? exact? inexact? eof-object? bwp-object?
immediate? boolean? char? vector? bytevector? string? procedure? immediate? boolean? char? vector? bytevector? string? procedure?
@ -38,8 +38,8 @@
(ikarus system $chars) (ikarus system $chars)
(ikarus system $strings) (ikarus system $strings)
(ikarus system $vectors) (ikarus system $vectors)
;(ikarus system $compnums) (only (ikarus system $compnums) $cflonum-real $cflonum-imag)
(rename (only (ikarus) fixnum? flonum? bignum? ratnum? compnum? (rename (only (ikarus) fixnum? flonum? bignum? ratnum? compnum? cflonum?
eof-object? eof-object?
bwp-object? immediate? boolean? char? vector? string? bwp-object? immediate? boolean? char? vector? string?
bytevector? procedure? null? pair? symbol? code? eq? bytevector? procedure? null? pair? symbol? code? eq?
@ -49,6 +49,7 @@
(bignum? sys:bignum?) (bignum? sys:bignum?)
(ratnum? sys:ratnum?) (ratnum? sys:ratnum?)
(compnum? sys:compnum?) (compnum? sys:compnum?)
(cflonum? sys:cflonum?)
(eof-object? sys:eof-object?) (eof-object? sys:eof-object?)
(bwp-object? sys:bwp-object?) (bwp-object? sys:bwp-object?)
(immediate? sys:immediate?) (immediate? sys:immediate?)
@ -81,13 +82,17 @@
(define compnum? (define compnum?
(lambda (x) (sys:compnum? x))) (lambda (x) (sys:compnum? x)))
(define cflonum?
(lambda (x) (sys:cflonum? x)))
(define number? (define number?
(lambda (x) (lambda (x)
(or (sys:fixnum? x) (or (sys:fixnum? x)
(sys:bignum? x) (sys:bignum? x)
(sys:flonum? x) (sys:flonum? x)
(sys:ratnum? x) (sys:ratnum? x)
(sys:compnum? x)))) (sys:compnum? x)
(sys:cflonum? x))))
(define complex? (define complex?
(lambda (x) (number? x))) (lambda (x) (number? x)))
@ -134,6 +139,7 @@
[(sys:ratnum? x) #t] [(sys:ratnum? x) #t]
[(sys:flonum? x) #f] [(sys:flonum? x) #f]
[(sys:compnum? x) #t] [(sys:compnum? x) #t]
[(sys:cflonum? x) #f]
[else [else
(die 'exact? "not a number" x)]))) (die 'exact? "not a number" x)])))
@ -146,6 +152,7 @@
[(sys:bignum? x) #f] [(sys:bignum? x) #f]
[(sys:ratnum? x) #f] [(sys:ratnum? x) #f]
[(sys:compnum? x) #f] [(sys:compnum? x) #f]
[(sys:cflonum? x) #t]
[else [else
(die 'inexact? "not a number" x)]))) (die 'inexact? "not a number" x)])))
@ -157,6 +164,10 @@
[(sys:bignum? x) #t] [(sys:bignum? x) #t]
[(sys:ratnum? x) #t] [(sys:ratnum? x) #t]
[(sys:compnum? x) #t] [(sys:compnum? x) #t]
[(sys:cflonum? x)
(and
(flfinite? ($cflonum-real x))
(flfinite? ($cflonum-imag x)))]
[else [else
(die 'finite? "not a number" x)]))) (die 'finite? "not a number" x)])))
@ -168,6 +179,10 @@
[(sys:bignum? x) #f] [(sys:bignum? x) #f]
[(sys:ratnum? x) #f] [(sys:ratnum? x) #f]
[(sys:compnum? x) #f] [(sys:compnum? x) #f]
[(sys:cflonum? x)
(or
(flinfinite? ($cflonum-real x))
(flinfinite? ($cflonum-imag x)))]
[else [else
(die 'infinite? "not a number" x)]))) (die 'infinite? "not a number" x)])))
@ -179,6 +194,10 @@
[(sys:bignum? x) #f] [(sys:bignum? x) #f]
[(sys:ratnum? x) #f] [(sys:ratnum? x) #f]
[(sys:compnum? x) #f] [(sys:compnum? x) #f]
[(sys:cflonum? x)
(or
(nan? ($cflonum-real x))
(nan? ($cflonum-imag x)))]
[else [else
(die 'nan? "not a number" x)]))) (die 'nan? "not a number" x)])))
@ -212,8 +231,21 @@
(define eqv? (define eqv?
(lambda (x y) (lambda (x y)
(or (sys:eq? x y) (import (ikarus))
(and (number? x) (number? y) (= x y))))) (cond
[(eq? x y) #t]
[(flonum? x) (and (flonum? y) (fl=? x y))]
[(bignum? x) (and (bignum? y) (= x y))]
[(ratnum? x) (and (ratnum? y) (= x y))]
[(compnum? x)
(and (compnum? y)
(= (real-part x) (real-part y))
(= (imag-part x) (imag-part y)))]
[(cflonum? x)
(and (cflonum? y)
(= (real-part x) (real-part y))
(= (imag-part x) (imag-part y)))]
[else #f])))
(define boolean=? (define boolean=?
(lambda (x y) (lambda (x y)
@ -265,9 +297,9 @@
(let ([n ($string-length x)]) (let ([n ($string-length x)])
(and ($fx= n ($string-length y)) (and ($fx= n ($string-length y))
(string-loop x y 0 n))))] (string-loop x y 0 n))))]
[(number? x) (and (number? y) (= x y))]
[(sys:bytevector? x) [(sys:bytevector? x)
(and (sys:bytevector? y) (bytevector=? x y))] (and (sys:bytevector? y) (bytevector=? x y))]
[(number? x) (eqv? x y)]
[else #f])))) [else #f]))))

View File

@ -1 +1 @@
1485 1486

View File

@ -317,6 +317,7 @@
[bignum? i] [bignum? i]
[ratnum? i] [ratnum? i]
[compnum? i] [compnum? i]
[cflonum? i]
[flonum-parts i] [flonum-parts i]
[flonum-bytes i] [flonum-bytes i]
[quotient+remainder i] [quotient+remainder i]
@ -461,6 +462,9 @@
[$make-compnum $comp] [$make-compnum $comp]
[$compnum-real $comp] [$compnum-real $comp]
[$compnum-imag $comp] [$compnum-imag $comp]
[$make-cflonum $comp]
[$cflonum-real $comp]
[$cflonum-imag $comp]
[$make-vector $vectors] [$make-vector $vectors]
[$vector-length $vectors] [$vector-length $vectors]
[$vector-ref $vectors] [$vector-ref $vectors]

View File

@ -1109,7 +1109,30 @@
/section) /section)
(section ;;; cflonums
(define-primop cflonum? safe
[(P x) (sec-tag-test (T x) vector-mask vector-tag #f cflonum-tag)]
[(E x) (nop)])
(define-primop $make-cflonum unsafe
[(V real imag)
(with-tmp ([x (prm 'alloc (K (align cflonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K cflonum-tag))
(prm 'mset x (K (- disp-cflonum-real vector-tag)) (T real))
(prm 'mset x (K (- disp-cflonum-imag vector-tag)) (T imag))
x)]
[(P str) (K #t)]
[(E str) (nop)])
(define-primop $cflonum-real unsafe
[(V x) (prm 'mref (T x) (K (- disp-cflonum-real vector-tag)))])
(define-primop $cflonum-imag unsafe
[(V x) (prm 'mref (T x) (K (- disp-cflonum-imag vector-tag)))])
/section)
(section ;;; generic arithmetic (section ;;; generic arithmetic

View File

@ -27,7 +27,8 @@
(test 2389478923749872389723894/23498739874892379482374) (test 2389478923749872389723894/23498739874892379482374)
(test -2389478923749872389723894/23498739874892379482374) (test -2389478923749872389723894/23498739874892379482374)
(test 127487384734.4) (test 127487384734.4)
(test (make-rectangular 12 13))) (test (make-rectangular 12 13))
(test (make-rectangular 12.0 13.0)))
) )

View File

@ -1235,7 +1235,17 @@ add_object_proc(gc_t* gc, ikptr x)
ref(y, disp_compnum_imag-vector_tag) = add_object(gc, im, "imag"); ref(y, disp_compnum_imag-vector_tag) = add_object(gc, im, "imag");
return y; return y;
} }
else if(fst == cflonum_tag){
ikptr y = gc_alloc_new_data(cflonum_size, gc) + vector_tag;
ikptr rl = ref(x, disp_cflonum_real-vector_tag);
ikptr im = ref(x, disp_cflonum_imag-vector_tag);
ref(x, -vector_tag) = forward_ptr;
ref(x, wordsize-vector_tag) = y;
ref(y, -vector_tag) = fst;
ref(y, disp_cflonum_real-vector_tag) = add_object(gc, rl, "real");
ref(y, disp_cflonum_imag-vector_tag) = add_object(gc, im, "imag");
return y;
}
else { else {
fprintf(stderr, "unhandled vector with fst=0x%016lx\n", fprintf(stderr, "unhandled vector with fst=0x%016lx\n",
(long int)fst); (long int)fst);

View File

@ -397,6 +397,12 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size);
#define disp_compnum_unused (3 * wordsize) #define disp_compnum_unused (3 * wordsize)
#define compnum_size (4 * wordsize) #define compnum_size (4 * wordsize)
#define cflonum_tag ((ikptr) 0x47)
#define disp_cflonum_real (1 * wordsize)
#define disp_cflonum_imag (2 * wordsize)
#define disp_cflonum_unused (3 * wordsize)
#define cflonum_size (4 * wordsize)
#define ik_eof_p(x) ((x) == ik_eof_object) #define ik_eof_p(x) ((x) == ik_eof_object)
#define page_index(x) (((unsigned long int)(x)) >> pageshift) #define page_index(x) (((unsigned long int)(x)) >> pageshift)