1 /*
2 Extension that defines fmod, modulo on floating-point numbers.
3 The extension is equivalent to Scheme source of them form:
4 (define (fmod a b) ...)
5 */
6
7 #include "escheme.h"
8 #include <math.h>
9
10 /**************************************************/
11
12 /* Every C implementation of a Scheme function takes argc and an array
13 of Scheme_Object* values for argv, and returns a Scheme_Object*: */
sch_fmod(int argc,Scheme_Object ** argv)14 static Scheme_Object *sch_fmod(int argc, Scheme_Object **argv)
15 {
16 /* Because we'll use scheme_make_prim_w_arity, Racket will
17 have already checked that we're getting the right number of
18 arguments. */
19 Scheme_Object *a = argv[0], *b = argv[1];
20 double v;
21
22 /* Make sure we got real numbers, and complain if not: */
23 if (!SCHEME_REALP(a))
24 scheme_wrong_type("fmod", "real number", 0, argc, argv);
25 /* 1st arg wrong ----^ */
26 if (!SCHEME_REALP(b))
27 scheme_wrong_type("fmod", "real number", 1, argc, argv);
28 /* 2nd arg wrong ----^ */
29
30 /* Convert the Scheme numbers to double-precision floating point
31 numbers, and compute fmod: */
32 v = fmod(scheme_real_to_double(a),
33 scheme_real_to_double(b));
34
35 /* Return the result, packaging it as a Scheme value: */
36 return scheme_make_double(v);
37 }
38
39 /**************************************************/
40
scheme_reload(Scheme_Env * env)41 Scheme_Object *scheme_reload(Scheme_Env *env)
42 {
43 Scheme_Object *proc;
44
45 /* The MZ_GC... lines are for for 3m, because env is live across an
46 allocating call. They're not needed for plain old (conservatively
47 collected) Mzscheme. See makeadder3m.c for more info. */
48 MZ_GC_DECL_REG(1);
49 MZ_GC_VAR_IN_REG(0, env);
50 MZ_GC_REG();
51
52 /* Package the C implementation of fmod into a Scheme procedure
53 value: */
54 proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2);
55 /* Requires at least two args ------^ ^ */
56 /* Accepts no more than two args ---| */
57
58 /* Define `fmod' as a global :*/
59 scheme_add_global("fmod", proc, env);
60
61 MZ_GC_UNREG();
62
63 return scheme_void;
64 }
65
scheme_initialize(Scheme_Env * env)66 Scheme_Object *scheme_initialize(Scheme_Env *env)
67 {
68 /* First load is same as every load: */
69 return scheme_reload(env);
70 }
71
scheme_module_name()72 Scheme_Object *scheme_module_name()
73 {
74 /* This extension doesn't define a module: */
75 return scheme_false;
76 }
77