* Added fx=?, fx<?, fx<=?, fx>?, and fx>=?

This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 16:39:13 -04:00
parent c552e0b3b1
commit 3facf76eff
4 changed files with 79 additions and 61 deletions

Binary file not shown.

View File

@ -2,14 +2,18 @@
(library (ikarus fixnums)
(export fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx* fxquotient
fxremainder fxmodulo fxlogor fxlogand fxlogxor fxsll fxsra
fx= fx< fx<= fx> fx>= fixnum->string)
fx= fx< fx<= fx> fx>=
fx=? fx<? fx<=? fx>? fx>=?
fixnum->string)
(import
(ikarus system $fx)
(ikarus system $chars)
(ikarus system $pairs)
(ikarus system $strings)
(except (ikarus) fxzero? fxadd1 fxsub1 fxlognot fx+ fx- fx*
fxquotient fxremainder fxmodulo fxlogor fxlogand
fxlogxor fxsll fxsra fx= fx< fx<= fx> fx>=
fx=? fx<? fx<=? fx>? fx>=?
fixnum->string))
(define fxzero?
@ -61,45 +65,54 @@
(error 'fx* "~s is not a fixnum" y))
($fx* x y)))
(define fx=
(lambda (x y)
(unless (fixnum? x)
(error 'fx= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx= "~s is not a fixnum" y))
($fx= x y)))
(define false-loop
(lambda (who ls)
(if (pair? ls)
(if (fixnum? ($car ls))
(false-loop who ($cdr ls))
(error who "~s is not a fixnum" ($car ls)))
#f)))
(define fx<
(lambda (x y)
(define-syntax fxcmp
(syntax-rules ()
[(_ who $op)
(case-lambda
[(x y)
(unless (fixnum? x)
(error 'fx< "~s is not a fixnum" x))
(error 'who "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx< "~s is not a fixnum" y))
($fx< x y)))
(error 'who "~s is not a fixnum" y))
($op x y)]
[(x y . ls)
(if (fixnum? x)
(if (fixnum? y)
(if ($op x y)
(let f ([x y] [ls ls])
(if (pair? ls)
(let ([y ($car ls)] [ls ($cdr ls)])
(if (fixnum? y)
(if ($op x y)
(f y ls)
(false-loop 'who ls))
(error 'who "~s is not a fixnum" y)))
#t))
(false-loop 'who ls))
(error 'who "~s is not a fixnum" y))
(error 'who "~s is not a fixnum" x))]
[(x)
(if (fixnum? x) #t (error 'who "~s is not a fixnum" x))])]))
(define fx<=
(lambda (x y)
(unless (fixnum? x)
(error 'fx<= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx<= "~s is not a fixnum" y))
($fx<= x y)))
(define fx= (fxcmp fx= $fx=))
(define fx< (fxcmp fx< $fx<))
(define fx<= (fxcmp fx<= $fx<=))
(define fx> (fxcmp fx> $fx>))
(define fx>= (fxcmp fx>= $fx>=))
(define fx=? (fxcmp fx=? $fx=))
(define fx<? (fxcmp fx<? $fx<))
(define fx<=? (fxcmp fx<=? $fx<=))
(define fx>? (fxcmp fx>? $fx>))
(define fx>=? (fxcmp fx>=? $fx>=))
(define fx>
(lambda (x y)
(unless (fixnum? x)
(error 'fx> "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx> "~s is not a fixnum" y))
($fx> x y)))
(define fx>=
(lambda (x y)
(unless (fixnum? x)
(error 'fx>= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx>= "~s is not a fixnum" y))
($fx>= x y)))
(define fxquotient
(lambda (x y)

View File

@ -452,6 +452,11 @@
[fx> i]
[fx>= i]
[fx= i]
[fx<? i]
[fx<=? i]
[fx>? i]
[fx>=? i]
[fx=? i]
[fx- i]
[fx+ i]
[fx* i]

View File

@ -256,21 +256,21 @@
[bitwise-rotate-bit-field D bw]
;;;
[fixnum? C fx]
[fx* D fx]
[fx* C fx]
[fx*/carry D fx]
[fx+ D fx]
[fx+ C fx]
[fx+/carry D fx]
[fx- D fx]
[fx- C fx]
[fx-/carry D fx]
[fx<=? D fx]
[fx<? D fx]
[fx=? D fx]
[fx>=? D fx]
[fx>? D fx]
[fxand D fx]
[fxarithmetic-shift D fx]
[fxarithmetic-shift-left D fx]
[fxarithmetic-shift-right D fx]
[fx<=? C fx]
[fx<? C fx]
[fx=? C fx]
[fx>=? C fx]
[fx>? C fx]
[fxand S fx]
[fxarithmetic-shift S fx]
[fxarithmetic-shift-left S fx]
[fxarithmetic-shift-right S fx]
[fxbit-count D fx]
[fxbit-field D fx]
[fxbit-set? D fx]
@ -280,23 +280,23 @@
[fxdiv-and-mod D fx]
[fxdiv0 D fx]
[fxdiv0-and-mod0 D fx]
[fxeven? D fx]
[fxeven? S fx]
[fxfirst-bit-set D fx]
[fxif D fx]
[fxior D fx]
[fxior S fx]
[fxlength D fx]
[fxmax D fx]
[fxmin D fx]
[fxmax S fx]
[fxmin S fx]
[fxmod D fx]
[fxmod0 D fx]
[fxmod0 S fx]
[fxnegative? D fx]
[fxnot D fx]
[fxodd? D fx]
[fxpositive? D fx]
[fxnot S fx]
[fxodd? S fx]
[fxpositive? S fx]
[fxreverse-bit-field D fx]
[fxrotate-bit-field D fx]
[fxxor D fx]
[fxzero? D fx]
[fxxor S fx]
[fxzero? C fx]
;;;
[fixnum->flonum C fl]
[fl* C fl]