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

* Added floor 

* exported negative?
This commit is contained in:
Abdulaziz Ghuloum 2007-08-28 17:45:54 -04:00
parent d1221276b9
commit bbe077cd5f
6 changed files with 80 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
BUGS
View File

@ -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:

BIN
src/ikarus.boot
View File

Binary file not shown.

18
src/ikarus.numerics.ss
View File

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

65
src/ikarus.strings.ss
View File

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

2
src/makefile.ss
View File

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

4
src/todo-r6rs.ss
View File

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