summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Price <ianprice90@googlemail.com>2011-04-06 01:53:38 +0100
committerAndy Wingo <wingo@pobox.com>2011-04-11 17:58:12 +0200
commitcf9d4a82146556ff45d40d6eec8579082287900e (patch)
tree589111de8861be1b9049b2b7d9fac659c22d1e95
parent62ef23cbb828accf1f5b9622ff17775aa539d354 (diff)
downloadguile-cf9d4a82146556ff45d40d6eec8579082287900e.tar.gz
Added optional second arg to R6RS log function
* module/rnrs/base.scm (log): now takes a base argument, using the change of base formula for logs. * test-suite/tests/r6rs-base.test ("log (2nd arg)"): Add test cases.
-rw-r--r--module/rnrs/base.scm9
-rw-r--r--test-suite/tests/r6rs-base.test16
2 files changed, 25 insertions, 0 deletions
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index b9dddab0b..b867929fe 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -74,6 +74,7 @@
syntax-rules identifier-syntax)
(import (rename (except (guile) error raise)
+ (log log-internal)
(euclidean-quotient div)
(euclidean-remainder mod)
(euclidean/ div-and-mod)
@@ -85,6 +86,14 @@
(inexact->exact exact))
(srfi srfi-11))
+ (define log
+ (case-lambda
+ ((n)
+ (log-internal n))
+ ((n base)
+ (/ (log n)
+ (log base)))))
+
(define (boolean=? . bools)
(define (boolean=?-internal lst last)
(or (null? lst)
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index 1509b04ed..dfddf7c34 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -21,6 +21,22 @@
:use-module ((rnrs base) :version (6))
:use-module (test-suite lib))
+
+;; numbers are considered =? if their difference is less than a set
+;; tolerance
+(define (=? alpha beta)
+ (< (abs (- alpha beta)) 1e-10))
+
+(with-test-prefix "log (2nd arg)"
+ (pass-if "log positive-base" (=? (log 8 2) 3))
+ (pass-if "log negative-base" (=? (real-part (log 256 -4))
+ 0.6519359443))
+ (pass-if "log base-one" (= (log 10 1) +inf.0))
+ (pass-if "log base-zero"
+ (catch #t
+ (lambda () (log 10 0) #f)
+ (lambda args #t))))
+
(with-test-prefix "boolean=?"
(pass-if "boolean=? null" (boolean=?))
(pass-if "boolean=? unary" (boolean=? #f))