diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index 6345995..8bdf635 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index f09931a..6803da3 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -2445,9 +2445,14 @@ (define disp-ratnum-den (* 2 wordsize)) (define ratnum-size (* 4 wordsize)) + (define compnum-tag #x37) + (define disp-compnum-real (* 1 wordsize)) + (define disp-compnum-imag (* 2 wordsize)) + (define compnum-size (* 4 wordsize)) + (define bignum-mask #b111) (define bignum-tag #b011) - (define bignum-sign-mask #b1000) + (define bignum-sign-mask #b1000) (define bignum-sign-shift 3) (define bignum-length-shift 4) (define disp-bignum-data wordsize) diff --git a/scheme/ikarus.not-yet-implemented.ss b/scheme/ikarus.not-yet-implemented.ss index 06cdd89..8384b06 100644 --- a/scheme/ikarus.not-yet-implemented.ss +++ b/scheme/ikarus.not-yet-implemented.ss @@ -1,7 +1,7 @@ (library (ikarus not-yet-implemented) (export - make-rectangular angle make-polar + angle make-polar bitwise-copy-bit-field bitwise-reverse-bit-field bitwise-rotate-bit-field bitwise-if fxreverse-bit-field fxrotate-bit-field bytevector->string string->bytevector @@ -17,7 +17,7 @@ string-upcase) (import (except (ikarus) - make-rectangular angle make-polar + angle make-polar bitwise-copy-bit-field bitwise-reverse-bit-field bitwise-rotate-bit-field bitwise-if fxreverse-bit-field fxrotate-bit-field bytevector->string string->bytevector @@ -31,8 +31,6 @@ string-downcase string-normalize-nfc string-normalize-nfd string-normalize-nfkc string-normalize-nfkd string-titlecase string-upcase)) - - (define-syntax not-yet (syntax-rules () @@ -57,20 +55,25 @@ ...)])) (not-yet - make-rectangular angle make-polar + ;;; should be implemented + bytevector->string string->bytevector + string-downcase string-titlecase string-upcase + angle make-polar bitwise-if bitwise-rotate-bit-field bitwise-copy-bit-field bitwise-reverse-bit-field fxreverse-bit-field fxrotate-bit-field - bytevector->string string->bytevector + ;;; not top priority at the moment + make-eqv-hashtable make-hashtable equal-hash + hashtable-hash-function hashtable-equivalence-function + string-normalize-nfc string-normalize-nfd + string-normalize-nfkc string-normalize-nfkd + ;;; won't be implemented make-custom-binary-input/output-port make-custom-textual-input/output-port - open-file-input/output-port output-port-buffer-mode - port-has-port-position? port-has-set-port-position!? - port-position set-port-position! make-eqv-hashtable - hashtable-hash-function make-hashtable - hashtable-equivalence-function equal-hash - string-downcase string-normalize-nfc string-normalize-nfd - string-normalize-nfkc string-normalize-nfkd string-titlecase - string-upcase)) + open-file-input/output-port + output-port-buffer-mode + port-has-set-port-position!? set-port-position! + port-has-port-position? port-position + )) diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 214b725..a14a229 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -1300,7 +1300,7 @@ [(bignum? x) (even-bignum? x)] [(flonum? x) (die 'odd? "BUG" x)] [else (die 'odd? "not an integer" x)]))) - + (module (number->string) (module (bignum->string) (define (bignum->decimal-string x) @@ -1353,8 +1353,15 @@ ($number->string ($ratnum-n x) r) "/" ($number->string ($ratnum-d x) r)))) + (define (imag x r) + (cond + [(eqv? x 1) "+"] + [(eqv? x -1) "-"] + [(< x 0) ($number->string x r)] + [else (string-append "+" ($number->string x r))])) (define $number->string (lambda (x r) + (import (ikarus system $compnums)) (cond [(fixnum? x) (fixnum->string x r)] [(bignum? x) (bignum->string x r)] @@ -1365,6 +1372,11 @@ r x)) (flonum->string x)] [(ratnum? x) (ratnum->string x r)] + [(compnum? x) + (string-append + ($number->string ($compnum-real x) r) + (imag ($compnum-imag x) r) + "i")] [else (die 'number->string "not a number" x)]))) (define number->string (case-lambda @@ -3354,3 +3366,34 @@ ) +(library (ikarus complex-numbers) + (export make-rectangular $make-rectangular) + (import + (except (ikarus) make-rectangular) + (except (ikarus system $compnums) $make-rectangular)) + + (define ($make-rectangular r i) + (cond + [(eqv? i 0) r] + [else ($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)])) +) + + + diff --git a/scheme/ikarus.predicates.ss b/scheme/ikarus.predicates.ss index 0ce28af..c6aac3c 100644 --- a/scheme/ikarus.predicates.ss +++ b/scheme/ikarus.predicates.ss @@ -16,14 +16,16 @@ (library (ikarus predicates) - (export fixnum? flonum? bignum? ratnum? number? complex? real? rational? + (export fixnum? flonum? bignum? ratnum? compnum? + number? complex? real? rational? integer? exact? inexact? eof-object? bwp-object? immediate? boolean? char? vector? bytevector? string? procedure? null? pair? symbol? code? not weak-pair? eq? eqv? equal? boolean=? symbol=? finite? infinite? nan? real-valued? rational-valued? integer-valued? transcoder?) (import - (except (ikarus) fixnum? flonum? bignum? ratnum? number? complex? real? + (except (ikarus) fixnum? flonum? bignum? ratnum? compnum? + number? complex? real? rational? integer? exact? inexact? eof-object? bwp-object? immediate? boolean? char? vector? bytevector? string? procedure? null? pair? weak-pair? symbol? code? not eq? eqv? equal? @@ -36,7 +38,9 @@ (ikarus system $chars) (ikarus system $strings) (ikarus system $vectors) - (rename (only (ikarus) fixnum? flonum? bignum? ratnum? eof-object? + ;(ikarus system $compnums) + (rename (only (ikarus) fixnum? flonum? bignum? ratnum? compnum? + eof-object? bwp-object? immediate? boolean? char? vector? string? bytevector? procedure? null? pair? symbol? code? eq? transcoder?) @@ -44,6 +48,7 @@ (flonum? sys:flonum?) (bignum? sys:bignum?) (ratnum? sys:ratnum?) + (compnum? sys:compnum?) (eof-object? sys:eof-object?) (bwp-object? sys:bwp-object?) (immediate? sys:immediate?) @@ -73,21 +78,29 @@ (define flonum? (lambda (x) (sys:flonum? x))) + (define compnum? + (lambda (x) (sys:compnum? x))) + (define number? (lambda (x) (or (sys:fixnum? x) (sys:bignum? x) (sys:flonum? x) - (sys:ratnum? x)))) + (sys:ratnum? x) + (sys:compnum? x)))) (define complex? (lambda (x) (number? x))) (define real? - (lambda (x) (number? x))) + (lambda (x) + (or (sys:fixnum? x) + (sys:bignum? x) + (sys:flonum? x) + (sys:ratnum? x)))) (define real-valued? - (lambda (x) (number? x))) + (lambda (x) (real? x))) (define rational? (lambda (x) @@ -120,6 +133,7 @@ [(sys:bignum? x) #t] [(sys:ratnum? x) #t] [(sys:flonum? x) #f] + [(sys:compnum? x) #t] [else (die 'exact? "not a number" x)]))) @@ -131,6 +145,7 @@ [(sys:fixnum? x) #f] [(sys:bignum? x) #f] [(sys:ratnum? x) #f] + [(sys:compnum? x) #f] [else (die 'inexact? "not a number" x)]))) @@ -141,6 +156,7 @@ [(sys:fixnum? x) #t] [(sys:bignum? x) #t] [(sys:ratnum? x) #t] + [(sys:compnum? x) #t] [else (die 'finite? "not a number" x)]))) @@ -151,6 +167,7 @@ [(sys:fixnum? x) #f] [(sys:bignum? x) #f] [(sys:ratnum? x) #f] + [(sys:compnum? x) #f] [else (die 'infinite? "not a number" x)]))) @@ -161,6 +178,7 @@ [(sys:fixnum? x) #f] [(sys:bignum? x) #f] [(sys:ratnum? x) #f] + [(sys:compnum? x) #f] [else (die 'nan? "not a number" x)]))) diff --git a/scheme/last-revision b/scheme/last-revision index 1c61ae4..9c39429 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1480 +1481 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index c5fd101..e85dc06 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -252,6 +252,7 @@ [$transc (ikarus system $transcoders) #f #t] [$fx (ikarus system $fx) #f #t] [$rat (ikarus system $ratnums) #f #t] + [$comp (ikarus system $compnums) #f #t] [$symbols (ikarus system $symbols) #f #t] [$structs (ikarus system $structs) #f #t] ;[$ports (ikarus system $ports) #f #t] @@ -314,6 +315,7 @@ [sub1 i] [bignum? i] [ratnum? i] + [compnum? i] [flonum-parts i] [flonum-bytes i] [quotient+remainder i] @@ -454,6 +456,9 @@ [$make-ratnum $rat] [$ratnum-n $rat] [$ratnum-d $rat] + [$make-compnum $comp] + [$compnum-real $comp] + [$compnum-imag $comp] [$make-vector $vectors] [$vector-length $vectors] [$vector-ref $vectors] @@ -696,6 +701,7 @@ [magnitude i r ba se] [make-polar i r ba se] [make-rectangular i r ba se] + [$make-rectangular $comp] [make-string i r ba se] [make-vector i r ba se] [map i r ba se] diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss index 9170717..2318395 100644 --- a/scheme/pass-specify-rep-primops.ss +++ b/scheme/pass-specify-rep-primops.ss @@ -1083,6 +1083,34 @@ /section) +(section ;;; complnums + +(define-primop compnum? safe + [(P x) (sec-tag-test (T x) vector-mask vector-tag #f compnum-tag)] + [(E x) (nop)]) + +(define-primop $make-compnum unsafe + [(V real imag) + (with-tmp ([x (prm 'alloc (K (align compnum-size)) (K vector-tag))]) + (prm 'mset x (K (- vector-tag)) (K compnum-tag)) + (prm 'mset x (K (- disp-compnum-real vector-tag)) (T real)) + (prm 'mset x (K (- disp-compnum-imag vector-tag)) (T imag)) + x)] + [(P str) (K #t)] + [(E str) (nop)]) + + +(define-primop $compnum-real unsafe + [(V x) (prm 'mref (T x) (K (- disp-compnum-real vector-tag)))]) + +(define-primop $compnum-imag unsafe + [(V x) (prm 'mref (T x) (K (- disp-compnum-imag vector-tag)))]) + +/section) + + + + (section ;;; generic arithmetic (define (non-fixnum? x) diff --git a/src/ikarus-collect.c b/src/ikarus-collect.c index 670d7e5..128a7d0 100644 --- a/src/ikarus-collect.c +++ b/src/ikarus-collect.c @@ -1224,6 +1224,18 @@ add_object_proc(gc_t* gc, ikptr x) ref(y, disp_ratnum_den-vector_tag) = add_object(gc, den, "den"); return y; } + else if(fst == compnum_tag){ + ikptr y = gc_alloc_new_data(compnum_size, gc) + vector_tag; + ikptr rl = ref(x, disp_compnum_real-vector_tag); + ikptr im = ref(x, disp_compnum_imag-vector_tag); + ref(x, -vector_tag) = forward_ptr; + ref(x, wordsize-vector_tag) = y; + ref(y, -vector_tag) = fst; + ref(y, disp_compnum_real-vector_tag) = add_object(gc, rl, "real"); + ref(y, disp_compnum_imag-vector_tag) = add_object(gc, im, "imag"); + return y; + } + else { fprintf(stderr, "unhandled vector with fst=0x%016lx\n", (long int)fst); diff --git a/src/ikarus-data.h b/src/ikarus-data.h index f666c9a..178986a 100644 --- a/src/ikarus-data.h +++ b/src/ikarus-data.h @@ -391,6 +391,12 @@ ikptr ik_safe_alloc(ikpcb* pcb, int size); #define disp_ratnum_unused (3 * wordsize) #define ratnum_size (4 * wordsize) +#define compnum_tag ((ikptr) 0x37) +#define disp_compnum_real (1 * wordsize) +#define disp_compnum_imag (2 * wordsize) +#define disp_compnum_unused (3 * wordsize) +#define compnum_size (4 * wordsize) + #define ik_eof_p(x) ((x) == ik_eof_object) #define page_index(x) (((unsigned long int)(x)) >> pageshift)