New procedures FLO:EXPM1 and FLO:LOG1P just like libm's.

Defined only on an interval about 0 of radius 1/log 2 and 1/sqrt 2,
respectively; intended for computing (exp x) - 1 and log (1 + x) for
very small x with high precision, unlike FLO:EXP and FLO:LOG.

diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm
index 7af378e691a7ab16db3f57ddd34b383f2003f122..e0e591daa06ca31288696770e4f4fa00924c34ab 100644 (file)
--- a/src/compiler/base/utils.scm
+++ b/src/compiler/base/utils.scm
@@ -234,8 +234,9 @@ USA.
 
     INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS
     INT:1+ INT:-1+ INT:NEGATE
-    FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS
-    FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR
+    FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS
+    FLO:EXP FLO:EXPM1 FLO:LOG FLO:LOG1P FLO:SIN FLO:COS FLO:TAN
+    FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR
     FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT
     FLO:TRUNCATE->EXACT FLO:ROUND->EXACT
 

diff --git a/src/compiler/machines/C/rulflo.scm b/src/compiler/machines/C/rulflo.scm
index c7a071c042fbf1e89d9c02c654e70a440b1d7cfd..99ff99915befbb68dee18fecee827ba56e42a83d 100644 (file)
--- a/src/compiler/machines/C/rulflo.scm
+++ b/src/compiler/machines/C/rulflo.scm
@@ -170,8 +170,10 @@ USA.
   (define-use-function 'FLONUM-CEILING "DOUBLE_CEILING")
   (define-use-function 'FLONUM-COS "DOUBLE_COS")
   (define-use-function 'FLONUM-EXP "DOUBLE_EXP")
+  (define-use-function 'FLONUM-EXPM1 "DOUBLE_EXPM1")
   (define-use-function 'FLONUM-FLOOR "DOUBLE_FLOOR")
   (define-use-function 'FLONUM-LOG "DOUBLE_LOG")
+  (define-use-function 'FLONUM-LOG1P "DOUBLE_LOG1P")
   (define-use-function 'FLONUM-ROUND "DOUBLE_ROUND")
   (define-use-function 'FLONUM-SIN "DOUBLE_SIN")
   (define-use-function 'FLONUM-SQRT "DOUBLE_SQRT")

diff --git a/src/compiler/machines/alpha/machin.scm b/src/compiler/machines/alpha/machin.scm
index d7442c7e8d88e9c9ccdb3e7729795674067c65f9..f298564c0e1095377fcef792afd5426e2830ddcb 100644 (file)
--- a/src/compiler/machines/alpha/machin.scm
+++ b/src/compiler/machines/alpha/machin.scm
@@ -458,4 +458,4 @@ USA.
     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT
     FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR
     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
-    FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
+    FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file

diff --git a/src/compiler/machines/bobcat/machin.scm b/src/compiler/machines/bobcat/machin.scm
index a62ca85cb2fbbf3e6afa3bf94b466ade19c7662d..f3619759223f5e654c52c2299f7554d842e214ad 100644 (file)
--- a/src/compiler/machines/bobcat/machin.scm
+++ b/src/compiler/machines/bobcat/machin.scm
@@ -394,4 +394,4 @@ USA.
 (define compiler:primitives-with-no-open-coding
   '(DIVIDE-FIXNUM GCD-FIXNUM &/
     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
-    FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2))
\ No newline at end of file
+    FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2 FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file

diff --git a/src/compiler/machines/i386/rulflo.scm b/src/compiler/machines/i386/rulflo.scm
index c4ec20e4b1801fd79bba65bd1cc7db032914d67e..04eea3493f672cc8155a06c7677ca4a7f681948c 100644 (file)
--- a/src/compiler/machines/i386/rulflo.scm
+++ b/src/compiler/machines/i386/rulflo.scm
@@ -319,6 +319,24 @@ USA.
          (FXCH (ST 0) (ST 1))
          (FYL2X)))))
 
+(define-arithmetic-method 'FLONUM-LOG1P flonum-methods/1-arg
+  ;; Computes LOG(X+1).
+  ;; X must be in the range: (- (SQRT 1/2) 1) <= X <= (- 1 (SQRT 1/2))
+  (flonum-unary-operation/stack-top
+   (lambda ()
+     (LAP (FLDLN2)
+         (FXCH (ST 0) (ST 1))
+         (FYL2XP1)))))
+
+(define-arithmetic-method 'FLONUM-EXPM1 flonum-methods/1-arg
+  ;; Computes EXP(X)-1.
+  ;; X must be in the range: (- (LOG 2)) <= X <= (LOG 2)
+  (flonum-unary-operation/stack-top
+   (lambda ()
+     (LAP (FLDL2E)
+         (FMULP (ST 1) (ST 0))
+         (F2XM1)))))
+
 (define-arithmetic-method 'FLONUM-EXP flonum-methods/1-arg
   (flonum-unary-operation/stack-top
    (lambda ()

diff --git a/src/compiler/machines/mips/machin.scm b/src/compiler/machines/mips/machin.scm
index a2a4fc1ebe0bffeaa6fa2287f2d71339881e4dae..5d8f7bb947511d176774caa6c5f2828b6e3817d2 100644 (file)
--- a/src/compiler/machines/mips/machin.scm
+++ b/src/compiler/machines/mips/machin.scm
@@ -392,4 +392,5 @@ USA.
     FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS FLONUM-ATAN2
     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-REMAINDER FLONUM-SQRT
     FLONUM-TRUNCATE FLONUM-ROUND FLONUM-CEILING FLONUM-FLOOR
-    VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ No newline at end of file
+    VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
+    FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file

diff --git a/src/compiler/machines/sparc/machin.scm b/src/compiler/machines/sparc/machin.scm
index 12ace79a262c0e4c6786902dd94bd80c41062832..2a3630f481a1596b04bb0ebf1fd50e29297f2a16 100644 (file)
--- a/src/compiler/machines/sparc/machin.scm
+++ b/src/compiler/machines/sparc/machin.scm
@@ -400,6 +400,6 @@ USA.
     INTEGER-QUOTIENT INTEGER-REMAINDER &/ QUOTIENT REMAINDER
     FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN FLONUM-ACOS
     FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-TRUNCATE FLONUM-ROUND
-    FLONUM-REMAINDER FLONUM-SQRT
+    FLONUM-REMAINDER FLONUM-SQRT FLONUM-EXPM1 FLONUM-LOG1P
     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
     FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file

diff --git a/src/compiler/machines/spectrum/machin.scm b/src/compiler/machines/spectrum/machin.scm
index 0ea94caddd34240ff4d045421d8d13a7f4df327f..36eff339d5256757d119c746564fc60f83d68f28 100644 (file)
--- a/src/compiler/machines/spectrum/machin.scm
+++ b/src/compiler/machines/spectrum/machin.scm
@@ -410,4 +410,4 @@ USA.
   true)
 
 (define compiler:primitives-with-no-open-coding
-  '(DIVIDE-FIXNUM GCD-FIXNUM &/))
\ No newline at end of file
+  '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file

diff --git a/src/compiler/machines/svm/machine.scm b/src/compiler/machines/svm/machine.scm
index 994cad264e597cbb3d63c9a53d877dfdc68001b1..5bdb8604a5ce858cc6e19ed9fa9c09002c41e437 100644 (file)
--- a/src/compiler/machines/svm/machine.scm
+++ b/src/compiler/machines/svm/machine.scm
@@ -508,7 +508,7 @@ USA.
   #t)
 
 (define compiler:primitives-with-no-open-coding
-  '(DIVIDE-FIXNUM GCD-FIXNUM &/
+  '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P
                  VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
 \f
 ;;;; Closure format

diff --git a/src/compiler/machines/vax/machin.scm b/src/compiler/machines/vax/machin.scm
index a397cc557c7a13ae05bfe3e75c8b5f65e1576b6a..f73a73afa6f9ae412fe99bdc568bf8766c92ca28 100644 (file)
--- a/src/compiler/machines/vax/machin.scm
+++ b/src/compiler/machines/vax/machin.scm
@@ -295,4 +295,4 @@ USA.
 (define compiler:primitives-with-no-open-coding
   '(DIVIDE-FIXNUM GCD-FIXNUM &/
     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
-    FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file
+    FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-EXPM1 FLONUM-LOG1P))
\ No newline at end of file

diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm
index 96e03c6038280725d5124be7220c2ef4c398029a..06a340edbe2a436301765832fbb805fde959fc17 100644 (file)
--- a/src/compiler/machines/x86-64/machin.scm
+++ b/src/compiler/machines/x86-64/machin.scm
@@ -414,6 +414,6 @@ USA.
   '(DIVIDE-FIXNUM
     &/
     FLOATING-VECTOR-CONS FLONUM-ACOS FLONUM-ASIN FLONUM-ATAN
-    FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-FLOOR
-    FLONUM-LOG FLONUM-ROUND FLONUM-SIN FLONUM-TAN FLONUM-TRUNCATE
-    GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS))
\ No newline at end of file
+    FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-EXPM1
+    FLONUM-FLOOR FLONUM-LOG FLONUM-LOG1P FLONUM-ROUND FLONUM-SIN
+    FLONUM-TAN FLONUM-TRUNCATE GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS))
\ No newline at end of file

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index 4cfbce1506ce6fb4d60f4e419303f70552eeeeb9..23964e9781f38b6956920984c01f134e00cd39ad 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -1404,8 +1404,8 @@ USA.
       '(0)
       internal-close-coding-for-type-checks)))
  '(FLONUM-NEGATE FLONUM-ABS FLONUM-SIN FLONUM-COS FLONUM-TAN FLONUM-ASIN
-   FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-LOG FLONUM-SQRT FLONUM-ROUND
-   FLONUM-TRUNCATE FLONUM-CEILING FLONUM-FLOOR))
+   FLONUM-ACOS FLONUM-ATAN FLONUM-EXP FLONUM-EXPM1 FLONUM-LOG FLONUM-LOG1P
+   FLONUM-SQRT FLONUM-ROUND FLONUM-TRUNCATE FLONUM-CEILING FLONUM-FLOOR))
 
 (for-each
  (lambda (flonum-operator)

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index 0418ecfbc3d38ef878c410716397bef3617a7eba..e191bb492c5527e185bcd2d01180dffc54fe8081 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -146,6 +146,13 @@ DEFINE_PRIMITIVE ("FLONUM-NEGATIVE?", Prim_flonum_negative_p, 1, 1, 0)
   FLONUM_RESULT (result);                                              \
 }
 
+DEFINE_PRIMITIVE ("FLONUM-EXPM1", Prim_flonum_expm1, 1, 1, 0)
+     RESTRICTED_TRANSCENDENTAL_FUNCTION
+       (expm1, ((x >= - M_LN2) && (x <= M_LN2)))
+DEFINE_PRIMITIVE ("FLONUM-LOG1P", Prim_flonum_log1p, 1, 1, 0)
+     RESTRICTED_TRANSCENDENTAL_FUNCTION
+       (log1p, ((x >= (M_SQRT1_2 - 1.0)) && (x <= (1.0 - M_SQRT1_2))))
+
 DEFINE_PRIMITIVE ("FLONUM-EXP", Prim_flonum_exp, 1, 1, 0)
      SIMPLE_TRANSCENDENTAL_FUNCTION (exp)
 DEFINE_PRIMITIVE ("FLONUM-LOG", Prim_flonum_log, 1, 1, 0)

diff --git a/src/microcode/liarc.h b/src/microcode/liarc.h
index a50f8a4914ae0c819ef2e75baae58f994e4a9393..8b01192dea81fc9125f8e34168a4ec5e65866a4c 100644 (file)
--- a/src/microcode/liarc.h
+++ b/src/microcode/liarc.h
@@ -469,8 +469,10 @@ extern int multiply_with_overflow (long, long, long *);
 #define DOUBLE_CEILING ceil
 #define DOUBLE_COS cos
 #define DOUBLE_EXP exp
+#define DOUBLE_EXPM1 expm1
 #define DOUBLE_FLOOR floor
 #define DOUBLE_LOG log
+#define DOUBLE_LOG1P log1p
 #define DOUBLE_SIN sin
 #define DOUBLE_SQRT sqrt
 #define DOUBLE_TAN tan

diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index eb0d8ce843b74d5a5ddde37fa92eeec9943d03bf..0674952ce30db147fe26a7fbf524c0c4b97ee492 100644 (file)
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -85,7 +85,9 @@ USA.
   (flo:negate flonum-negate 1)
   (flo:abs flonum-abs 1)
   (flo:exp flonum-exp 1)
+  (flo:expm1 flonum-expm1 1)
   (flo:log flonum-log 1)
+  (flo:log1p flonum-log1p 1)
   (flo:sin flonum-sin 1)
   (flo:cos flonum-cos 1)
   (flo:tan flonum-tan 1)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 47a222cbab52b622f67d07484d3dcd68f5b2163b..e34b060445b3e3f3af9f4098c36bd3aabcd1e259 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -227,12 +227,14 @@ USA.
          flo:ceiling->exact
          flo:cos
          flo:exp
+         flo:expm1
          flo:expt
          flo:finite?
          flo:flonum?
          flo:floor
          flo:floor->exact
          flo:log
+         flo:log1p
          flo:max
          flo:min
          flo:negate

diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm
index fe126251415d16050fa200082c37a4f2d27a66a2..0add2e241bbd7f7d74c4d69b2c33a2d6f5e58b0c 100644 (file)
--- a/src/sf/gconst.scm
+++ b/src/sf/gconst.scm
@@ -117,11 +117,13 @@ USA.
     (FLO:CEILING->EXACT FLONUM-CEILING->EXACT)
     (FLO:COS FLONUM-COS)
     (FLO:EXP FLONUM-EXP)
+    (FLO:EXPM1 FLONUM-EXPM1)
     (FLO:EXPT FLONUM-EXPT)
     (FLO:FLONUM? FLONUM?)
     (FLO:FLOOR FLONUM-FLOOR)
     (FLO:FLOOR->EXACT FLONUM-FLOOR->EXACT)
     (FLO:LOG FLONUM-LOG)
+    (FLO:LOG1P FLONUM-LOG1P)
     (FLO:NEGATE FLONUM-NEGATE)
     (FLO:NEGATIVE? FLONUM-NEGATIVE?)
     (FLO:POSITIVE? FLONUM-POSITIVE?)