summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am2
-rw-r--r--module/rnrs/6/base.scm21
-rw-r--r--module/rnrs/arithmetic/6/fixnums.scm255
-rw-r--r--module/rnrs/arithmetic/6/flonums.scm216
4 files changed, 492 insertions, 2 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 45161200f..a44753562 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -273,6 +273,8 @@ RNRS_SOURCES = \
rnrs/6/syntax-case.scm \
rnrs/6/unicode.scm \
rnrs/arithmetic/6/bitwise.scm \
+ rnrs/arithmetic/6/fixnums.scm \
+ rnrs/arithmetic/6/flonums.scm \
rnrs/bytevector.scm \
rnrs/io/6/simple.scm \
rnrs/io/ports.scm \
diff --git a/module/rnrs/6/base.scm b/module/rnrs/6/base.scm
index e7f52c4a3..4358aa4f7 100644
--- a/module/rnrs/6/base.scm
+++ b/module/rnrs/6/base.scm
@@ -71,7 +71,24 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (guile)
+ (import (rename (guile) (quotient div) (modulo mod))
(rename (only (guile) for-each map)
(for-each vector-for-each) (map vector-map))
- (srfi srfi-11)))
+ (srfi srfi-11))
+
+ (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r)))
+
+ (define (div0 x y)
+ (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q)))
+
+ (define (mod0 x y)
+ (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r)))
+
+ (define (div0-and-mod0 x y)
+ (call-with-values (lambda () (div-and-mod x y))
+ (lambda (q r)
+ (cond ((< r (abs (/ y 2))) (values q r))
+ ((negative? y) (values (- q 1) (+ r y)))
+ (else (values (+ q 1) (+ r y)))))))
+
+)
diff --git a/module/rnrs/arithmetic/6/fixnums.scm b/module/rnrs/arithmetic/6/fixnums.scm
new file mode 100644
index 000000000..2c8b716da
--- /dev/null
+++ b/module/rnrs/arithmetic/6/fixnums.scm
@@ -0,0 +1,255 @@
+;;; fixnums.scm --- The R6RS fixnums arithmetic library
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs arithmetic fixnums (6))
+ (export fixnum?
+
+ fixnum-width
+ least-fixnum
+ greatest-fixnum
+
+ fx=?
+ fx>?
+ fx<?
+ fx>=?
+ fx<=?
+
+ fxzero?
+ fxpositive?
+ fxnegative?
+ fxodd?
+ fxeven?
+
+ fxmax
+ fxmin
+
+ fx+
+ fx*
+ fx-
+
+ fxdiv-and-mod
+ fxdiv
+ fxmod
+ fxdiv0-and-mod0
+ fxdiv0
+ fxmod0
+
+ fx+/carry
+ fx-/carry
+ fx*/carry
+
+ fxand
+ fxior
+ fxxor
+ fxif
+
+ fxbit-count
+ fxlength
+ fxfirst-bit-set
+ fxbit-set?
+ fxcopy-bit
+ fxbit-field
+ fxcopy-bit-field
+
+ fxarithmetic-shift
+ fxarithmetic-shift-left
+ fxarithmetic-shift-right
+
+ fxrotate-bit-field
+ fxreverse-bit-field)
+ (import (rename (only (guile) logand
+ logbit?
+ logcount
+ logior
+ lognot
+ most-positive-fixnum
+ most-negative-fixnum)
+ (most-positive-fixnum greatest-fixnum)
+ (most-negative-fixnum least-fixnum))
+ (ice-9 optargs)
+ (rnrs base (6))
+ (rnrs arithmetic bitwise (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6)))
+
+ (define fixnum-width (round (/ (log (+ greatest-fixnum 1)) (log 2))))
+
+ (define (fixnum? obj)
+ (and (exact? obj)
+ (integer? obj)
+ (>= obj least-fixnum)
+ (<= obj greatest-fixnum)))
+
+ (define (assert-fixnum . args)
+ (or (every fixnum? args) (raise (make-assertion-violation))))
+ (define (assert-fixnum-result . args)
+ (or (every fixnum? args)
+ (raise (make-implementation-restriction-violation))))
+
+ (define (fx=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply = args)))
+
+ (define (fx>? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum args)
+ (apply > args)))
+
+ (define (fx<? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply < args)))
+
+ (define (fx>=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply >= args)))
+
+ (define (fx<=? fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (apply assert-fixnum rst)
+ (apply <= args)))
+
+ (define (fxzero? fx) (assert-fixnum fx) (zero? fx))
+ (define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
+ (define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
+ (define (fxodd? fx) (assert-fixnum fx) (odd? fx))
+ (define (fxeven? fx) (assert-fixnum fx) (even? fx))
+
+ (define (fxmax fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (assert-fixnum args)
+ (apply max args)))
+
+ (define (fxmin fx1 fx2 . rst)
+ (let ((args (cons* fx1 fx2 rst)))
+ (assert-fixnum args)
+ (apply min args)))
+
+ (define (fx+ fx1 fx2)
+ (assert-fixnum fx1 fx2) (let ((r (+ fx1 fx2))) (assert-fixnum-result r) r))
+
+ (define (fx* fx1 fx2)
+ (assert-fixnum fx1 fx2) (let ((r (* fx1 fx2))) (assert-fixnum-result r) r))
+
+ (define* (fx- fx1 #:optional fx2)
+ (assert-fixnum fx1)
+ (if fx2
+ (begin
+ (assert-fixnum fx2)
+ (let ((r (- fx1 fx2))) (assert-fixnum-result r) r))
+ (let ((r (- fx1))) (assert-fixnum-result r) r)))
+
+ (define (fxdiv x1 x2)
+ (assert-fixnum x1 x2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (quotient x1 x2))) (assert-fixnum-result r) r))
+
+ (define (fxmod x1 x2)
+ (assert-fixnum x1 x2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (modulo x1 x2))) (assert-fixnum-result r) r))
+
+ (define (fxdiv-and-mod fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((q (quotient fx1 fx2))
+ (m (modulo fx1 fx2)))
+ (assert-fixnum-result q m)
+ (values q m)))
+
+ (define (fxdiv0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (div0 fx1 fx2))) (assert-fixnum-result r) r))
+
+ (define (fxmod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (let ((r (mod0 fx1 fx2))) (assert-fixnum-result r) r))
+
+ (define (fxdiv0-and-mod0 fx1 fx2)
+ (assert-fixnum fx1 fx2)
+ (if (zero? fx2) (raise (make-assertion-violation)))
+ (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
+ (lambda (q r) (assert-fixnum-result q r) (values q r))))
+
+ (define (fx+/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ fx1 fx2 fx3))
+ (s0 (mod0 s (expt 2 (fixnum-width))))
+ (s1 (div0 s (expt 2 (fixnum-width)))))
+ (values s0 s1)))
+
+ (define (fx-/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((d (- fx1 fx2 fx3))
+ (d0 (mod0 d (expt 2 (fixnum-width))))
+ (d1 (div0 d (expt 2 (fixnum-width)))))
+ (values d0 d1)))
+
+ (define (fx*/carry fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (let* ((s (+ (* fx1 fx2) fx3))
+ (s0 (mod0 s (expt 2 (fixnum-width))))
+ (s1 (div0 s (expt 2 (fixnum-width)))))
+ (values s0 s1)))
+
+ (define (fxnot fx) (assert-fixnum fx) (lognot fx))
+ (define (fxand . args) (apply assert-fixnum args) (apply logand args))
+ (define (fxior . args) (apply assert-fixnum args) (apply logior args))
+ (define (fxxor . args) (apply assert-fixnum args) (apply logxor args))
+
+ (define (fxif fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-if fx1 fx2 fx2))
+
+ (define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
+ (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
+ (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
+ (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx1 fx2))
+
+ (define (fxcopy-bit fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-copy-bit fx1 fx2 fx3))
+
+ (define (fxbit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-bit-field fx1 fx2 fx3))
+
+ (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (bitwise-copy-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
+ (define fxarithmetic-shift-left fxarithmetic-shift)
+
+ (define (fxarithmetic-shift-right fx1 fx2)
+ (assert-fixnum fx1 fx2) (ash fx2 (- fx2)))
+
+ (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
+ (assert-fixnum fx1 fx2 fx3 fx4)
+ (bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
+
+ (define (fxreverse-bit-field fx1 fx2 fx3)
+ (assert-fixnum fx1 fx2 fx3)
+ (bitwise-reverse-bit-field fx1 fx2 fx3))
+
+)
diff --git a/module/rnrs/arithmetic/6/flonums.scm b/module/rnrs/arithmetic/6/flonums.scm
new file mode 100644
index 000000000..4fadbd00a
--- /dev/null
+++ b/module/rnrs/arithmetic/6/flonums.scm
@@ -0,0 +1,216 @@
+;;; flonums.scm --- The R6RS flonums arithmetic library
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs arithmetic flonums (6))
+ (export flonum?
+ real->flonum
+
+ fl=? fl<? fl<=? fl>? fl>=?
+
+ flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
+ flinfinite? flnan?
+
+ flmax flmin
+
+ fl+ fl* fl- fl/
+
+ flabs
+
+ fldiv-and-mod
+ fldiv
+ flmod
+ fldiv0-and-mod0
+ fldiv0
+ flmod0
+
+ flnumerator
+ fldenominator
+
+ flfloor flceiling fltruncate flround
+
+ flexp fllog flsin flcos fltan flacos flasin flatan
+
+ flsqrt flexpt
+
+ &no-infinities
+ make-no-infinities-violation
+ no-infinities-violation?
+
+ &no-nans
+ make-no-nans-violation
+ no-nans-violation?
+
+ fixnum->flonum)
+ (import (ice-9 optargs)
+ (only (guile) inf?)
+ (rnrs arithmetic fixnums (6))
+ (rnrs base (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6))
+ (rnrs r5rs (6)))
+
+ (define (flonum? obj) (and (number? obj) (inexact? obj)))
+ (define (assert-flonum . args)
+ (or (for-all flonum? args) (raise (make-assertion-violation))))
+ (define (assert-iflonum . args)
+ (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
+ (raise (make-assertion-violation))))
+
+ (define (real->flonum x)
+ (or (real? x) (raise (make-assertion-violation)))
+ (exact->inexact x))
+
+ (define (fl=? . args) (apply assert-flonum args) (apply = args))
+ (define (fl<? . args) (apply assert-flonum args) (apply < args))
+ (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
+ (define (fl>? . args) (apply assert-flonum args) (apply > args))
+ (define (fl>=? . args) (apply assert-flonum args) (apply >= args))
+
+ (define (flinteger? fl) (assert-flonum fl) (integer? fl))
+ (define (flzero? fl) (assert-flonum fl) (zero? fl))
+ (define (flpositive? fl) (assert-flonum fl) (positive? fl))
+ (define (flnegative? fl) (assert-flonum fl) (negative? fl))
+ (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
+ (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
+ (define (flfinite? fl) (assert-flonum fl) (not (inf? fl)))
+ (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
+ (define (flnan? fl) (assert-flonum fl) (nan? fl))
+
+ (define (flmax fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply max flargs)))
+
+ (define (flmin fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply min flargs)))
+
+ (define (fl+ fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply + flargs)))
+
+ (define (fl* fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply * flargs)))
+
+ (define (fl- fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply - flargs)))
+
+ (define (fl/ fl1 . args)
+ (let ((flargs (cons fl1 args)))
+ (apply assert-flonum flargs)
+ (apply / flargs)))
+
+ (define (flabs fl) (assert-flonum fl) (abs fl))
+
+ (define (fldiv-and-mod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (call-with-values (lambda () (div-and-mod fx1 fx2))
+ (lambda (div mod) (values (exact->inexact div)
+ (exact->inexact mod))))))
+
+ (define (fldiv fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (exact->inexact (quotient fx1 fx2))))
+
+ (define (flmod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (exact->inexact (modulo fx1 fx2))))
+
+ (define (fldiv0-and-mod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (if (zero? fl2) (raise (make-assertion-violation)))
+ (let* ((fx1 (inexact->exact fl1))
+ (fx2 (inexact->exact fl2)))
+ (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
+ (lambda (q r) (values (real->flonum q) (real->flonum r))))))
+
+ (define (fldiv0 fl1 fl2)
+ (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q)))
+
+ (define (flmod0 fl1 fl2)
+ (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r)))
+
+ (define (flnumerator fl)
+ (assert-flonum fl)
+ (case fl
+ ((+inf.0) +inf.0)
+ ((-inf.0) -inf.0)
+ (else (numerator fl))))
+
+ (define (fldenominator fl)
+ (assert-flonum fl)
+ (case fl
+ ((+inf.0) 1.0)
+ ((-inf.0) 1.0)
+ (else (denominator fl))))
+
+ (define (flfloor fl) (assert-flonum fl) (floor fl))
+ (define (flceiling fl) (assert-flonum fl) (ceiling fl))
+ (define (fltruncate fl) (assert-flonum fl) (truncate fl))
+ (define (flround fl) (assert-flonum fl) (round fl))
+
+ (define (flexp fl) (assert-flonum fl) (exp fl))
+ (define* (fllog fl #:optional fl2)
+ (assert-flonum fl)
+ (cond ((fl=? fl -inf.0) +nan.0)
+ (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
+ (else (log fl))))
+
+ (define (flsin fl) (assert-flonum fl) (sin fl))
+ (define (flcos fl) (assert-flonum fl) (cos fl))
+ (define (fltan fl) (assert-flonum fl) (tan fl))
+ (define (flasin fl) (assert-flonum fl) (asin fl))
+ (define (flacos fl) (assert-flonum fl) (acos fl))
+ (define* (flatan fl #:optional fl2)
+ (assert-flonum fl)
+ (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))
+
+ (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
+ (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))
+
+ (define-condition-type &no-infinities
+ &implementation-restriction
+ make-no-infinities-violation
+ no-infinities-violation?)
+
+ (define-condition-type &no-nans
+ &implementation-restriction
+ make-no-nans-violation
+ no-nans-violation?)
+
+ (define (fixnum->flonum fx)
+ (or (fixnum? fx) (raise (make-assertion-violation)))
+ (exact->inexact fx))
+)