* Added floor

* exported negative?

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:

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<? 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)] 
+           [(ratnum? e) 
-           [else 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)] 
+           [(ratnum? e) (exact->inexact (ratnum-ceiling e))] 
-           [else e]))]
+           [else x]))]
       [(ratnum? x) (ratnum-ceiling x)]
       [(or (fixnum? x) (bignum? x)) x]
       [else (error 'ceiling "~s is not a number" x)]))

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)])

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]

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]