From: Joe Marshall <eval.apply@gmail.com>
Date: Thu, 2 Aug 2012 17:34:45 +0000 (-0700)
Subject: Add fmod as primitive FLONUM-MODULO.
X-Git-Tag: release-9.2.0~235
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4ad597b04b5edc1fd5f593e07a0cf22b04c932c0;p=mit-scheme.git

Add fmod as primitive FLONUM-MODULO.
---

diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac
index 3e2e3a32b..bd05c00cf 100644
--- a/src/microcode/configure.ac
+++ b/src/microcode/configure.ac
@@ -524,8 +524,8 @@ AC_CHECK_FUNCS([expm1])
 AC_CHECK_FUNCS([fcntl fdatasync feclearexcept fedisableexcept feenableexcept])
 AC_CHECK_FUNCS([fegetenv fegetexcept fegetexceptflag fegetround feholdexcept])
 AC_CHECK_FUNCS([feraiseexcept fesetenv fesetexceptflag fesetround])
-AC_CHECK_FUNCS([fetestexcept feupdateenv floor fpathconf frexp fpgetround])
-AC_CHECK_FUNCS([fpsetround fsync fsync_range ftruncate])
+AC_CHECK_FUNCS([fetestexcept feupdateenv floor fmod fpathconf fpgetround])
+AC_CHECK_FUNCS([fpsetround frexp fsync fsync_range ftruncate])
 AC_CHECK_FUNCS([getcwd gethostbyname gethostname getlogin getpagesize getpgrp])
 AC_CHECK_FUNCS([getpt gettimeofday getwd grantpt])
 AC_CHECK_FUNCS([kill])
diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index 0c2ad1b57..26c45a183 100644
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -81,6 +81,24 @@ DEFINE_PRIMITIVE ("FLONUM-DIVIDE", Prim_flonum_divide, 2, 2, 0)
   }
 }
 
+DEFINE_PRIMITIVE ("FLONUM-MODULO", Prim_flonum_modulo, 2, 2, 0)
+#ifdef HAVE_FMOD
+{
+  PRIMITIVE_HEADER (2);
+  {
+    double denominator = (arg_flonum (2));
+    if (denominator == 0)
+      error_bad_range_arg (2);
+    FLONUM_RESULT (fmod ((arg_flonum (1)), denominator));
+  }
+}
+#else
+{
+  error_unimplemented_primitive ();
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
+#endif
+
 DEFINE_PRIMITIVE ("FLONUM-NEGATE", Prim_flonum_negate, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
diff --git a/src/microcode/ntutl/config.h b/src/microcode/ntutl/config.h
index ba3744058..57e38fca1 100644
--- a/src/microcode/ntutl/config.h
+++ b/src/microcode/ntutl/config.h
@@ -121,6 +121,9 @@ typedef unsigned char cc_t;
 /* Define if you have the floor function.  */
 #define HAVE_FLOOR 1
 
+/* Define if you have the fmod function.  */
+#define HAVE_FMOD 1
+
 /* Define if you have the frexp function.  */
 #define HAVE_FREXP 1
 
diff --git a/src/microcode/os2utl/config.h b/src/microcode/os2utl/config.h
index 086300649..cbe17f5e8 100644
--- a/src/microcode/os2utl/config.h
+++ b/src/microcode/os2utl/config.h
@@ -57,6 +57,9 @@ typedef unsigned char cc_t;
 /* Define if you have the floor function.  */
 #define HAVE_FLOOR 1
 
+/* Define if you have the fmod function.  */
+#define HAVE_FMOD 1
+
 /* Define if you have the frexp function.  */
 #define HAVE_FREXP 1