diff --git a/bin/ikarus b/bin/ikarus index 541421a..dc50a29 100755 Binary files a/bin/ikarus and b/bin/ikarus differ diff --git a/bin/ikarus-fasl.c b/bin/ikarus-fasl.c index 10372e2..0256805 100644 --- a/bin/ikarus-fasl.c +++ b/bin/ikarus-fasl.c @@ -274,11 +274,19 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ /* ascii string */ int len; fasl_read_buf(p, &len, sizeof(int)); - int size = align(len + disp_string_data + 1); + int size = align(len*string_char_size + disp_string_data); ikp str = ik_alloc(pcb, size) + string_tag; ref(str, off_string_length) = fix(len); fasl_read_buf(p, str+off_string_data, len); - str[off_string_data+len] = 0; + { + unsigned char* pi = (unsigned char*) (str+off_string_data); + ikp* pj = (ikp*) (str+off_string_data); + int i = len-1; + for(i=len-1; i >= 0; i--){ + pj[i] = integer_to_char(pi[i]); + } + } + //str[off_string_data+len] = 0; if(put_mark_index){ p->marks[put_mark_index] = str; } @@ -288,7 +296,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ /* string */ int len; fasl_read_buf(p, &len, sizeof(int)); - int size = align(len*string_char_size + disp_string_data + 1); + int size = align(len*string_char_size + disp_string_data); ikp str = ik_alloc(pcb, size) + string_tag; ref(str, off_string_length) = fix(len); int i; @@ -297,7 +305,7 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){ fasl_read_buf(p, &c, sizeof(int)); string_set(str, i, integer_to_char(c)); } - str[off_string_data+len*string_char_size] = 0; + //str[off_string_data+len*string_char_size] = 0; if(put_mark_index){ p->marks[put_mark_index] = str; } diff --git a/src/ikarus.boot b/src/ikarus.boot index c64bf48..1ae32e2 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.fasl.write.ss b/src/ikarus.fasl.write.ss index f6e0158..2883144 100644 --- a/src/ikarus.fasl.write.ss +++ b/src/ikarus.fasl.write.ss @@ -7,6 +7,8 @@ (ikarus system $io) (ikarus system $bytevectors) (ikarus system $fx) + (ikarus system $chars) + (ikarus system $strings) (ikarus code-objects) (except (ikarus) fasl-write)) @@ -40,6 +42,12 @@ [(eq? x (void)) (write-char #\U p)] [else (error 'fasl-write "~s is not a fasl-writable immediate" x)]))) + (define (ascii-string? s) + (let f ([s s] [i 0] [n (string-length s)]) + (or ($fx= i n) + (and ($char<= ($string-ref s i) ($fixnum->char 127)) + (f s ($fxadd1 i) n))))) + (define do-write (lambda (x p h m) (cond @@ -57,14 +65,22 @@ (f x (fxadd1 i) n (fasl-write-object (vector-ref x i) p h m))]))] [(string? x) - (write-char #\S p) - (write-int (string-length x) p) - (let f ([x x] [i 0] [n (string-length x)]) - (cond - [(fx= i n) m] - [else - (write-int (char->integer (string-ref x i)) p) - (f x (fxadd1 i) n)]))] + (cond + [(ascii-string? x) + (write-char #\s p) + (write-int (string-length x) p) + (let f ([x x] [i 0] [n (string-length x)]) + (unless (fx= i n) + (write-char (string-ref x i) p) + (f x (fxadd1 i) n)))] + [else + (write-char #\S p) + (write-int (string-length x) p) + (let f ([x x] [i 0] [n (string-length x)]) + (unless (= i n) + (write-int (char->integer (string-ref x i)) p) + (f x (fxadd1 i) n)))]) + m] [(gensym? x) (write-char #\G p) (fasl-write-object (gensym->unique-string x) p h diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index 665c1d2..bf7fdc2 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -28,7 +28,7 @@ (library (ikarus generic-arithmetic) (export + - * / zero? = < <= > >= add1 sub1 quotient remainder - positive? expt gcd lcm numerator denominator + positive? expt gcd lcm numerator denominator exact-integer-sqrt quotient+remainder number->string string->number) (import (ikarus system $fx) @@ -38,7 +38,8 @@ (ikarus system $strings) (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient remainder quotient+remainder number->string positive? - string->number expt gcd lcm numerator denominator)) + string->number expt gcd lcm numerator denominator + exact-integer-sqrt)) (define (fixnum->flonum x) (foreign-call "ikrt_fixnum_to_flonum" x)) @@ -1021,8 +1022,46 @@ (cond [(flonum? x) (foreign-call "ikrt_fl_sqrt" x)] [(fixnum? x) (foreign-call "ikrt_fx_sqrt" x)] + [(bignum? x) (error 'sqrt "BUG: bignum sqrt not implemented")] + [(ratnum? x) (/ (sqrt ($ratnum-n x)) (sqrt ($ratnum-d x)))] [else (error 'sqrt "unsupported ~s" x)]))) + (define exact-integer-sqrt + (lambda (x) + (define who 'exact-integer-sqrt) + (define (fxsqrt x i k) + (let ([j ($fxsra ($fx+ i k) 1)]) + (let ([j^2 ($fx* j j)]) + (if ($fx> j^2 x) + (fxsqrt x i j) + (if ($fx= i j) + (values j ($fx- x j^2)) + (fxsqrt x j k)))))) + (define (bnsqrt x i k) + (let ([j (quotient (+ i k) 2)]) + (let ([j^2 (* j j)]) + (if (> j^2 x) + (bnsqrt x i j) + (if (= i j) + (values j (- x j^2)) + (bnsqrt x j k)))))) + (cond + [(fixnum? x) + (cond + [($fx< x 0) (error who "invalid argument ~s" x)] + [($fx= x 0) (values 0 0)] + [($fx< x 4) (values 1 ($fx- x 1))] + [($fx< x 9) (values 2 ($fx- x 4))] + [($fx< x 46340) (fxsqrt x 3 ($fxsra x 1))] + [else (fxsqrt x 215 23171)])] + [(bignum? x) + (cond + [($bignum-positive? x) + (bnsqrt x 23170 (quotient x 23170))] + [else (error who "invalid argument ~s" x)])] + [else (error who "invalid argument ~s" x)]))) + + (define numerator (lambda (x) (cond diff --git a/src/makefile.ss b/src/makefile.ss index 05b4554..132dffc 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -383,6 +383,7 @@ [lcm i r] [numerator i r] [denominator i r] + [exact-integer-sqrt i r] [symbol? i r symbols] [gensym? i symbols] [gensym i symbols] diff --git a/src/run-tests.ss b/src/run-tests.ss index f8248aa..be2931e 100755 --- a/src/run-tests.ss +++ b/src/run-tests.ss @@ -4,6 +4,20 @@ (tests reader) (tests bytevectors)) +(define (test-exact-integer-sqrt) + (define (f i j inc) + (when (< i j) + (let-values ([(s r) (exact-integer-sqrt i)]) + (unless (and (= (+ (* s s) r) i) + (< i (* (+ s 1) (+ s 1)))) + (error 'exact-integer-sqrt "wrong result for ~s" i)) + (f (+ i inc) j inc)))) + (f 0 10000 1) + (f 0 536870911 10000) + (f 0 536870911000 536870911) + (printf "[exact-integer-sqrt] Happy Happy Joy Joy\n")) + (test-reader) (test-bytevectors) +(test-exact-integer-sqrt) (printf "Happy Happy Joy Joy\n")