diff --git a/BUGS b/BUGS index 2270511..a6bcd29 100644 --- a/BUGS +++ b/BUGS @@ -2,6 +2,7 @@ BUG: * symbol calls are not checking for non-procedure. * set! on global names is not working. +* Ensure immutable exports Email Will Clinger regarding: diff --git a/src/ikarus.boot b/src/ikarus.boot index 757f545..143e072 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.numerics.ss b/src/ikarus.numerics.ss index fe6b331..95c5664 100644 --- a/src/ikarus.numerics.ss +++ b/src/ikarus.numerics.ss @@ -127,7 +127,7 @@ (library (ikarus generic-arithmetic) (export + - * / zero? = < <= > >= add1 sub1 quotient remainder modulo even? odd? - positive? expt gcd lcm numerator denominator exact-integer-sqrt + positive? negative? expt gcd lcm numerator denominator exact-integer-sqrt quotient+remainder number->string string->number min max abs exact->inexact floor ceiling round log fl=? fl? @@ -143,7 +143,8 @@ (ikarus system $strings) (only (ikarus flonums) $flonum->exact $flzero? $flnegative?) (except (ikarus) + - * / zero? = < <= > >= add1 sub1 quotient - remainder modulo even? odd? quotient+remainder number->string positive? + remainder modulo even? odd? quotient+remainder number->string + positive? negative? string->number expt gcd lcm numerator denominator exact->inexact floor ceiling round log exact-integer-sqrt min max abs @@ -1500,14 +1501,18 @@ (lambda (x) (cond [(fixnum? x) ($fx> x 0)] + [(flonum? x) ($fl> x 0.0)] [(bignum? x) (positive-bignum? x)] + [(ratnum? x) (positive? ($ratnum-n x))] [else (error 'positive? "~s is not a number" x)]))) (define negative? (lambda (x) (cond [(fixnum? x) ($fx< x 0)] + [(flonum? x) ($fl< x 0.0)] [(bignum? x) (not (positive-bignum? x))] + [(ratnum? x) (negative? ($ratnum-n x))] [else (error 'negative? "~s is not a number" x)]))) (define sin @@ -1619,8 +1624,9 @@ (let ([e (or ($flonum->exact x) (error 'floor "~s has no real value" x))]) (cond - [(ratnum? e) (ratnum-floor e)] - [else e]))] + [(ratnum? e) + (exact->inexact (ratnum-floor e))] + [else x]))] [(ratnum? x) (ratnum-floor x)] [(or (fixnum? x) (bignum? x)) x] [else (error 'floor "~s is not a number" x)])) @@ -1635,8 +1641,8 @@ (let ([e (or ($flonum->exact x) (error 'ceiling "~s has no real value" x))]) (cond - [(ratnum? e) (ratnum-ceiling e)] - [else e]))] + [(ratnum? e) (exact->inexact (ratnum-ceiling e))] + [else x]))] [(ratnum? x) (ratnum-ceiling x)] [(or (fixnum? x) (bignum? x)) x] [else (error 'ceiling "~s is not a number" x)])) diff --git a/src/ikarus.strings.ss b/src/ikarus.strings.ss index a810f4f..7fbfe85 100644 --- a/src/ikarus.strings.ss +++ b/src/ikarus.strings.ss @@ -2,7 +2,7 @@ (library (ikarus strings) (export string-length string-ref string-set! make-string string->list string=? string-append substring string list->string uuid - string-copy) + string-copy string-for-each) (import (ikarus system $strings) (ikarus system $fx) @@ -11,7 +11,7 @@ (ikarus system $pairs) (except (ikarus) string-length string-ref string-set! make-string string->list string=? string-append substring string - list->string uuid string-copy)) + list->string uuid string-copy string-for-each)) (define string-length @@ -239,6 +239,67 @@ (fill-strings s s* 0)))))) + (module (string-for-each) + (define who 'string-for-each) + (define string-for-each + (case-lambda + [(p v) + (unless (procedure? p) + (error who "~s is not a procedure" p)) + (unless (string? v) + (error who "~s is not a string" v)) + (let f ([p p] [v v] [i 0] [n (string-length v)]) + (cond + [($fx= i n) (void)] + [else + (p (string-ref v i)) + (f p v ($fxadd1 i) n)]))] + [(p v0 v1) + (unless (procedure? p) + (error who "~s is not a procedure" p)) + (unless (string? v0) + (error who "~s is not a string" v0)) + (unless (string? v1) + (error who "~s is not a string" v1)) + (let ([n (string-length v0)]) + (unless ($fx= n ($string-length v1)) + (error who "length mismatch between ~s and ~s" v0 v1)) + (let f ([p p] [v0 v0] [v1 v1] [i 0] [n n]) + (cond + [($fx= i n) (void)] + [else + (p ($string-ref v0 i) ($string-ref v1 i)) + (f p v0 v1 ($fxadd1 i) n)])))] + [(p v0 v1 . v*) + (unless (procedure? p) + (error who "~s is not a procedure" p)) + (unless (string? v0) + (error who "~s is not a string" v0)) + (unless (string? v1) + (error who "~s is not a string" v1)) + (let ([n (string-length v0)]) + (unless ($fx= n ($string-length v1)) + (error who "length mismatch between ~s and ~s" v0 v1)) + (let f ([v* v*] [n n]) + (unless (null? v*) + (let ([a ($car v*)]) + (unless (string? a) + (error who "~s is not a string" a)) + (unless ($fx= ($string-length a) n) + (error who "length mismatch"))) + (f ($cdr v*) n))) + (let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n]) + (cond + [($fx= i n) (void)] + [else + (apply p ($string-ref v0 i) ($string-ref v1 i) + (let f ([i i] [v* v*]) + (if (null? v*) + '() + (cons ($string-ref ($car v*) i) + (f i ($cdr v*)))))) + (f p v0 v1 v* ($fxadd1 i) n)])))]))) + (define uuid (lambda () (let ([s ($make-bytevector 16)]) diff --git a/src/makefile.ss b/src/makefile.ss index 862c49e..b7e5895 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -337,6 +337,7 @@ [string->list i r] [list->string i r] [string-foldcase i unicode] + [string-for-each i r] [uuid i] [date-string i] [vector i r] @@ -441,6 +442,7 @@ [rational? i r] [flonum? i] [positive? i r] + [negative? i r] [even? i r] [odd? i r] [quotient i r] diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index a2521e8..889f7bc 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -148,7 +148,7 @@ [exp S ba] [expt C ba] [finite? S ba] - [floor S ba] + [floor C ba] [for-each S ba] [gcd C ba] [imag-part D ba] @@ -204,7 +204,7 @@ [string->symbol C ba] [string-append C ba] [string-copy C ba] - [string-for-each S ba] + [string-for-each C ba] [string-length C ba] [string-ref C ba] [string<=? C ba]