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

* Added fxdiv, fxmod, fxdiv-and-mod.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-11 20:43:59 -05:00
parent 0d2e1f4246
commit e48c2e17c1
5 changed files with 102 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
scheme/ikarus.fixnums.ss
View File

@ -417,3 +417,64 @@
)
(library (ikarus fixnums div-and-mod)
(export fxdiv fxmod fxdiv-and-mod)
(import
(ikarus system $fx)
(except (ikarus) fxdiv fxmod fxdiv-and-mod))
(define ($fxdiv-and-mod n m)
(let ([d0 ($fxquotient n m)])
(let ([m0 ($fx- n ($fx* d0 m))])
(if ($fx>= m0 0)
(values d0 m0)
(if ($fx>= m 0)
(values ($fx- d0 1) ($fx+ m0 m))
(values ($fx+ d0 1) ($fx- m0 m)))))))
(define ($fxdiv n m)
(let ([d0 ($fxquotient n m)])
(if ($fx>= n ($fx* d0 m))
d0
(if ($fx>= m 0)
($fx- d0 1)
($fx+ d0 1)))))
(define ($fxmod n m)
(let ([d0 ($fxquotient n m)])
(let ([m0 ($fx- n ($fx* d0 m))])
(if ($fx>= m0 0)
m0
(if ($fx>= m 0)
($fx+ m0 m)
($fx- m0 m))))))
(define (fxdiv-and-mod x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv-and-mod "division by 0")
($fxdiv-and-mod x y))
(error 'fxdiv-and-mod "not a fixnum" y))
(error 'fxdiv-and-mod "not a fixnum" x)))
(define (fxdiv x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxdiv "division by 0")
($fxdiv x y))
(error 'fxdiv "not a fixnum" y))
(error 'fxdiv "not a fixnum" x)))
(define (fxmod x y)
(if (fixnum? x)
(if (fixnum? y)
(if ($fx= y 0)
(error 'fxmod "modision by 0")
($fxmod x y))
(error 'fxmod "not a fixnum" y))
(error 'fxmod "not a fixnum" x)))
)

6
scheme/makefile.ss
View File

@ -788,8 +788,8 @@
[fxbit-set? r fx]
[fxcopy-bit r fx]
[fxcopy-bit-field r fx]
[fxdiv r fx]
[fxdiv-and-mod r fx]
[fxdiv i r fx]
[fxdiv-and-mod i r fx]
[fxdiv0 r fx]
[fxdiv0-and-mod0 r fx]
[fxeven? i r fx]
@ -799,7 +799,7 @@
[fxlength r fx]
[fxmax i r fx]
[fxmin i r fx]
[fxmod r fx]
[fxmod i r fx]
[fxmod0 r fx]
[fxnegative? i r fx]
[fxnot i r fx]

2
scheme/run-tests.ss
View File

@ -24,6 +24,7 @@
(tests hashtables)
;(tests numbers)
(tests bignums)
(tests fixnums)
(tests fxcarry)
(tests bignum-to-flonum)
(tests string-to-number)
@ -60,4 +61,5 @@
(test-bignum-conversion)
(test-fldiv-and-mod)
(test-fldiv0-and-mod0)
(test-fxdiv-and-mod)
(printf "Happy Happy Joy Joy\n")

32
scheme/tests/fixnums.ss Normal file
View File

@ -0,0 +1,32 @@
(library (tests fixnums)
(export test-fxdiv-and-mod)
(import (ikarus))
(define (test-fxdiv-and-mod)
(define (test x1 x2)
(let-values ([(d m) (fxdiv-and-mod x1 x2)])
(printf "(fxdiv-and-mod ~s ~s) = ~s ~s\n" x1 x2 d m)
(assert (= d (fxdiv x1 x2)))
(assert (= m (fxmod x1 x2)))
(assert (<= 0 m))
(assert (< m (abs x2)))
(assert (= x1 (+ (* d x2) m)))))
(test +17 +3)
(test +17 -3)
(test -17 +3)
(test -17 -3)
(test +16 +3)
(test +16 -3)
(test -16 +3)
(test -16 -3)
(test +15 +3)
(test +15 -3)
(test -15 +3)
(test -15 -3)
(test +10 +4)
(test +10 -4)
(test -10 +4)
(test -10 -4)))

8
scheme/todo-r6rs.ss
View File

@ -1,4 +1,4 @@
#!/usr/bin/env ikarus --r6rs-script
#!/usr/bin/env scheme-script
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
;;;
@ -293,8 +293,8 @@
[fxbit-set? S fx]
[fxcopy-bit S fx]
[fxcopy-bit-field S fx]
[fxdiv S fx]
[fxdiv-and-mod S fx]
[fxdiv C fx]
[fxdiv-and-mod C fx]
[fxdiv0 S fx]
[fxdiv0-and-mod0 S fx]
[fxeven? C fx]
@ -304,7 +304,7 @@
[fxlength S fx]
[fxmax C fx]
[fxmin C fx]
[fxmod S fx]
[fxmod C fx]
[fxmod0 S fx]
[fxnegative? C fx]
[fxnot C fx]