mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
ff62c16828
* libguile/numbers.c (scm_euclidean_quo_and_rem, scm_euclidean_quotient, scm_euclidean_remainder, scm_centered_quo_and_rem, scm_centered_quotient, scm_centered_remainder): New extensible procedures `euclidean/', `euclidean-quotient', `euclidean-remainder', `centered/', `centered-quotient', `centered-remainder'. * libguile/numbers.h: Add function prototypes. * module/rnrs/base.scm: Remove incorrect stub implementations of `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. Instead do renaming imports of `euclidean-quotient', `euclidean-remainder', `euclidean/', `centered-quotient', `centered-remainder', and `centered/', which are equivalent to the R6RS operators. * module/rnrs/arithmetic/fixnums.scm (fxdiv, fxmod, fxdiv-and-mod, fxdiv0, fxmod0, fxdiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. (fx+/carry): Remove unneeded calls to `inexact->exact'. * module/rnrs/arithmetic/flonums.scm (fldiv, flmod, fldiv-and-mod, fldiv0, flmod0, fldiv0-and-mod0): Remove redundant checks for division by zero and unnecessary complexity. Remove unneeded calls to `inexact->exact' and `exact->inexact' * test-suite/tests/numbers.test: (test-eqv?): New internal predicate for comparing numerical outputs with expected values. Add extensive test code for `euclidean/', `euclidean-quotient', `euclidean-remainder', `centered/', `centered-quotient', `centered-remainder'. * test-suite/tests/r6rs-arithmetic-fixnums.test: Fix some broken test cases, and remove `unresolved' test markers for `fxdiv', `fxmod', `fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'. * test-suite/tests/r6rs-arithmetic-flonums.test: Remove `unresolved' test markers for `fldiv', `flmod', `fldiv-and-mod', `fldiv0', `flmod0', and `fldiv0-and-mod0'. * doc/ref/api-data.texi (Arithmetic): Document `euclidean/', `euclidean-quotient', `euclidean-remainder', `centered/', `centered-quotient', and `centered-remainder'. (Operations on Integer Values): Add cross-references to `euclidean/' et al, from `quotient', `remainder', and `modulo'. * doc/ref/r6rs.texi (rnrs base): Improve documentation for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. Add cross-references to `euclidean/' et al. * NEWS: Add NEWS entry.
203 lines
5.7 KiB
Scheme
203 lines
5.7 KiB
Scheme
;;; flonums.scm --- The R6RS flonums arithmetic library
|
||
|
||
;; Copyright (C) 2010, 2011 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)
|
||
(div-and-mod fl1 fl2))
|
||
|
||
(define (fldiv fl1 fl2)
|
||
(assert-iflonum fl1 fl2)
|
||
(div fl1 fl2))
|
||
|
||
(define (flmod fl1 fl2)
|
||
(assert-iflonum fl1 fl2)
|
||
(mod fl1 fl2))
|
||
|
||
(define (fldiv0-and-mod0 fl1 fl2)
|
||
(assert-iflonum fl1 fl2)
|
||
(div0-and-mod0 fl1 fl2))
|
||
|
||
(define (fldiv0 fl1 fl2)
|
||
(assert-iflonum fl1 fl2)
|
||
(div0 fl1 fl2))
|
||
|
||
(define (flmod0 fl1 fl2)
|
||
(assert-iflonum fl1 fl2)
|
||
(mod0 fl1 fl2))
|
||
|
||
(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))
|
||
)
|