conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

5
scheme/ikarus.compiler.ss
View File

@ -2450,6 +2450,11 @@
(define disp-compnum-imag (* 2 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-tag #b011)
(define bignum-sign-mask #b1000)

4
scheme/ikarus.fasl.write.ss
View File

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

124
scheme/ikarus.numerics.ss
View File

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

48
scheme/ikarus.predicates.ss
View File

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

2
scheme/last-revision
View File

@ -1 +1 @@
1485
1486

4
scheme/makefile.ss
View File

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

23
scheme/pass-specify-rep-primops.ss
View File

@ -1109,7 +1109,30 @@
/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

3
scheme/tests/fasl.ss
View File

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

12
src/ikarus-collect.c
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");
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 {
fprintf(stderr, "unhandled vector with fst=0x%016lx\n",
(long int)fst);

6
src/ikarus-data.h
View File

@ -397,6 +397,12 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size);
#define disp_compnum_unused (3 * 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 page_index(x) (((unsigned long int)(x)) >> pageshift)