mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 02:40:17 +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.
164 lines
5.6 KiB
Scheme
164 lines
5.6 KiB
Scheme
;;; base.scm --- The R6RS base 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 base (6))
|
||
(export boolean? symbol? char? vector? null? pair? number? string? procedure?
|
||
|
||
define define-syntax syntax-rules lambda let let* let-values
|
||
let*-values letrec letrec* begin
|
||
|
||
quote lambda if set! cond case
|
||
|
||
or and not
|
||
|
||
eqv? equal? eq?
|
||
|
||
+ - * / max min abs numerator denominator gcd lcm floor ceiling
|
||
truncate round rationalize real-part imag-part make-rectangular angle
|
||
div mod div-and-mod div0 mod0 div0-and-mod0
|
||
|
||
expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan
|
||
make-polar magnitude angle
|
||
|
||
complex? real? rational? integer? exact? inexact? real-valued?
|
||
rational-valued? integer-valued? zero? positive? negative? odd? even?
|
||
nan? finite? infinite?
|
||
|
||
exact inexact = < > <= >=
|
||
|
||
number->string string->number
|
||
|
||
boolean=?
|
||
|
||
cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr
|
||
cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr
|
||
cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
|
||
|
||
list? list length append reverse list-tail list-ref map for-each
|
||
|
||
symbol->string string->symbol symbol=?
|
||
|
||
char->integer integer->char char=? char<? char>? char<=? char>=?
|
||
|
||
make-string string string-length string-ref string=? string<? string>?
|
||
string<=? string>=? substring string-append string->list list->string
|
||
string-for-each string-copy
|
||
|
||
vector? make-vector vector vector-length vector-ref vector-set!
|
||
vector->list list->vector vector-fill! vector-map vector-for-each
|
||
|
||
error assertion-violation assert
|
||
|
||
call-with-current-continuation call/cc call-with-values dynamic-wind
|
||
values apply
|
||
|
||
quasiquote unquote unquote-splicing
|
||
|
||
let-syntax letrec-syntax
|
||
|
||
syntax-rules identifier-syntax)
|
||
(import (rename (except (guile) error raise)
|
||
(euclidean-quotient div)
|
||
(euclidean-remainder mod)
|
||
(euclidean/ div-and-mod)
|
||
(centered-quotient div0)
|
||
(centered-remainder mod0)
|
||
(centered/ div0-and-mod0)
|
||
(inf? infinite?)
|
||
(exact->inexact inexact)
|
||
(inexact->exact exact))
|
||
(srfi srfi-11))
|
||
|
||
(define (boolean=? . bools)
|
||
(define (boolean=?-internal lst last)
|
||
(or (null? lst)
|
||
(let ((bool (car lst)))
|
||
(and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
|
||
(or (null? bools)
|
||
(let ((bool (car bools)))
|
||
(and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
|
||
|
||
(define (symbol=? . syms)
|
||
(define (symbol=?-internal lst last)
|
||
(or (null? lst)
|
||
(let ((sym (car lst)))
|
||
(and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
|
||
(or (null? syms)
|
||
(let ((sym (car syms)))
|
||
(and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
|
||
|
||
(define (exact-integer-sqrt x)
|
||
(let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
|
||
|
||
(define (real-valued? x)
|
||
(and (complex? x)
|
||
(zero? (imag-part x))))
|
||
|
||
(define (rational-valued? x)
|
||
(and (real-valued? x)
|
||
(rational? (real-part x))))
|
||
|
||
(define (integer-valued? x)
|
||
(and (rational-valued? x)
|
||
(= x (floor (real-part x)))))
|
||
|
||
(define (vector-for-each proc . vecs)
|
||
(apply for-each (cons proc (map vector->list vecs))))
|
||
(define (vector-map proc . vecs)
|
||
(list->vector (apply map (cons proc (map vector->list vecs)))))
|
||
|
||
(define raise
|
||
(@ (rnrs exceptions) raise))
|
||
(define condition
|
||
(@ (rnrs conditions) condition))
|
||
(define make-error
|
||
(@ (rnrs conditions) make-error))
|
||
(define make-assertion-violation
|
||
(@ (rnrs conditions) make-assertion-violation))
|
||
(define make-who-condition
|
||
(@ (rnrs conditions) make-who-condition))
|
||
(define make-message-condition
|
||
(@ (rnrs conditions) make-message-condition))
|
||
(define make-irritants-condition
|
||
(@ (rnrs conditions) make-irritants-condition))
|
||
|
||
(define (error who message . irritants)
|
||
(raise (apply condition
|
||
(append (list (make-error))
|
||
(if who (list (make-who-condition who)) '())
|
||
(list (make-message-condition message)
|
||
(make-irritants-condition irritants))))))
|
||
|
||
(define (assertion-violation who message . irritants)
|
||
(raise (apply condition
|
||
(append (list (make-assertion-violation))
|
||
(if who (list (make-who-condition who)) '())
|
||
(list (make-message-condition message)
|
||
(make-irritants-condition irritants))))))
|
||
|
||
(define-syntax assert
|
||
(syntax-rules ()
|
||
((_ expression)
|
||
(if (not expression)
|
||
(raise (condition
|
||
(make-assertion-violation)
|
||
(make-message-condition
|
||
(format #f "assertion failed: ~s" 'expression))))))))
|
||
|
||
)
|