1 #include "schpriv.h"
2 #include "nummacs.h"
3 #include <math.h>
4
5 READ_ONLY Scheme_Object *scheme_unsafe_fx_plus_proc;
6 READ_ONLY Scheme_Object *scheme_unsafe_fx_minus_proc;
7 READ_ONLY Scheme_Object *scheme_unsafe_fx_times_proc;
8
9 static Scheme_Object *plus (int argc, Scheme_Object *argv[]);
10 static Scheme_Object *minus (int argc, Scheme_Object *argv[]);
11 static Scheme_Object *mult (int argc, Scheme_Object *argv[]);
12 static Scheme_Object *div_prim (int argc, Scheme_Object *argv[]);
13 static Scheme_Object *quotient (int argc, Scheme_Object *argv[]);
14 static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]);
15 static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
16
17 static Scheme_Object *fx_plus (int argc, Scheme_Object *argv[]);
18 static Scheme_Object *fx_plus_wrap (int argc, Scheme_Object *argv[]);
19 static Scheme_Object *fx_minus (int argc, Scheme_Object *argv[]);
20 static Scheme_Object *fx_minus_wrap (int argc, Scheme_Object *argv[]);
21 static Scheme_Object *fx_mult (int argc, Scheme_Object *argv[]);
22 static Scheme_Object *fx_mult_wrap (int argc, Scheme_Object *argv[]);
23 static Scheme_Object *fx_div (int argc, Scheme_Object *argv[]);
24 static Scheme_Object *fx_rem (int argc, Scheme_Object *argv[]);
25 static Scheme_Object *fx_mod (int argc, Scheme_Object *argv[]);
26 static Scheme_Object *fx_abs (int argc, Scheme_Object *argv[]);
27
28 static Scheme_Object *unsafe_fx_plus (int argc, Scheme_Object *argv[]);
29 static Scheme_Object *unsafe_fx_plus_wrap (int argc, Scheme_Object *argv[]);
30 static Scheme_Object *unsafe_fx_minus (int argc, Scheme_Object *argv[]);
31 static Scheme_Object *unsafe_fx_minus_wrap (int argc, Scheme_Object *argv[]);
32 static Scheme_Object *unsafe_fx_mult (int argc, Scheme_Object *argv[]);
33 static Scheme_Object *unsafe_fx_mult_wrap (int argc, Scheme_Object *argv[]);
34 static Scheme_Object *unsafe_fx_div (int argc, Scheme_Object *argv[]);
35 static Scheme_Object *unsafe_fx_rem (int argc, Scheme_Object *argv[]);
36 static Scheme_Object *unsafe_fx_mod (int argc, Scheme_Object *argv[]);
37 static Scheme_Object *unsafe_fx_abs (int argc, Scheme_Object *argv[]);
38
39 static Scheme_Object *fl_plus (int argc, Scheme_Object *argv[]);
40 static Scheme_Object *fl_minus (int argc, Scheme_Object *argv[]);
41 static Scheme_Object *fl_mult (int argc, Scheme_Object *argv[]);
42 static Scheme_Object *fl_div (int argc, Scheme_Object *argv[]);
43 static Scheme_Object *fl_abs (int argc, Scheme_Object *argv[]);
44 static Scheme_Object *fl_sqrt (int argc, Scheme_Object *argv[]);
45
46 static Scheme_Object *unsafe_fl_plus (int argc, Scheme_Object *argv[]);
47 static Scheme_Object *unsafe_fl_minus (int argc, Scheme_Object *argv[]);
48 static Scheme_Object *unsafe_fl_mult (int argc, Scheme_Object *argv[]);
49 static Scheme_Object *unsafe_fl_div (int argc, Scheme_Object *argv[]);
50 static Scheme_Object *unsafe_fl_abs (int argc, Scheme_Object *argv[]);
51 static Scheme_Object *unsafe_fl_sqrt (int argc, Scheme_Object *argv[]);
52
53 static Scheme_Object *extfl_plus (int argc, Scheme_Object *argv[]);
54 static Scheme_Object *extfl_minus (int argc, Scheme_Object *argv[]);
55 static Scheme_Object *extfl_mult (int argc, Scheme_Object *argv[]);
56 static Scheme_Object *extfl_div (int argc, Scheme_Object *argv[]);
57 static Scheme_Object *extfl_abs (int argc, Scheme_Object *argv[]);
58 static Scheme_Object *extfl_sqrt (int argc, Scheme_Object *argv[]);
59
60 static Scheme_Object *unsafe_extfl_plus (int argc, Scheme_Object *argv[]);
61 static Scheme_Object *unsafe_extfl_minus (int argc, Scheme_Object *argv[]);
62 static Scheme_Object *unsafe_extfl_mult (int argc, Scheme_Object *argv[]);
63 static Scheme_Object *unsafe_extfl_div (int argc, Scheme_Object *argv[]);
64 static Scheme_Object *unsafe_extfl_abs (int argc, Scheme_Object *argv[]);
65 static Scheme_Object *unsafe_extfl_sqrt (int argc, Scheme_Object *argv[]);
66
67 #define zeroi scheme_exact_zero
68
69 #if defined(__POWERPC__) || defined(powerpc)
70 # define SQRT_MACHINE_CODE_AVAILABLE 0
71 #else
72 # define SQRT_MACHINE_CODE_AVAILABLE 1
73 #endif
74
scheme_init_numarith(Scheme_Startup_Env * env)75 void scheme_init_numarith(Scheme_Startup_Env *env)
76 {
77 Scheme_Object *p;
78
79 p = scheme_make_folding_prim(scheme_add1, "add1", 1, 1, 1);
80 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
81 | SCHEME_PRIM_WANTS_NUMBER
82 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
83 | SCHEME_PRIM_PRODUCES_NUMBER
84 | SCHEME_PRIM_CLOSED_ON_REALS);
85 scheme_addto_prim_instance("add1", p, env);
86
87 p = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1);
88 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
89 | SCHEME_PRIM_WANTS_NUMBER
90 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
91 | SCHEME_PRIM_PRODUCES_NUMBER
92 | SCHEME_PRIM_CLOSED_ON_REALS);
93 scheme_addto_prim_instance("sub1", p, env);
94
95 p = scheme_make_folding_prim(plus, "+", 0, -1, 1);
96 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
97 | SCHEME_PRIM_IS_NARY_INLINED
98 | SCHEME_PRIM_WANTS_NUMBER
99 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
100 | SCHEME_PRIM_PRODUCES_NUMBER
101 | SCHEME_PRIM_CLOSED_ON_REALS);
102 scheme_addto_prim_instance("+", p, env);
103
104 p = scheme_make_folding_prim(minus, "-", 1, -1, 1);
105 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
106 | SCHEME_PRIM_IS_UNARY_INLINED
107 | SCHEME_PRIM_IS_NARY_INLINED
108 | SCHEME_PRIM_WANTS_NUMBER
109 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
110 | SCHEME_PRIM_PRODUCES_NUMBER
111 | SCHEME_PRIM_CLOSED_ON_REALS);
112 scheme_addto_prim_instance("-", p, env);
113
114 p = scheme_make_folding_prim(mult, "*", 0, -1, 1);
115 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
116 | SCHEME_PRIM_IS_NARY_INLINED
117 | SCHEME_PRIM_WANTS_NUMBER
118 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
119 | SCHEME_PRIM_PRODUCES_NUMBER
120 | SCHEME_PRIM_CLOSED_ON_REALS);
121 scheme_addto_prim_instance("*", p, env);
122
123 p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1);
124 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
125 | SCHEME_PRIM_IS_NARY_INLINED
126 | SCHEME_PRIM_WANTS_NUMBER
127 | SCHEME_PRIM_PRODUCES_NUMBER
128 | SCHEME_PRIM_CLOSED_ON_REALS);
129 scheme_addto_prim_instance("/", p, env);
130
131 p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1);
132 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
133 | SCHEME_PRIM_WANTS_REAL
134 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
135 | SCHEME_PRIM_PRODUCES_REAL
136 | SCHEME_PRIM_CLOSED_ON_REALS);
137 scheme_addto_prim_instance("abs", p, env);
138
139 p = scheme_make_folding_prim(quotient, "quotient", 2, 2, 1);
140 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
141 | SCHEME_PRIM_WANTS_REAL
142 | SCHEME_PRIM_PRODUCES_REAL);
143 scheme_addto_prim_instance("quotient", p, env);
144
145 p = scheme_make_folding_prim(rem_prim, "remainder", 2, 2, 1);
146 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
147 | SCHEME_PRIM_WANTS_REAL
148 | SCHEME_PRIM_PRODUCES_REAL);
149 scheme_addto_prim_instance("remainder", p, env);
150
151 scheme_addto_prim_instance("quotient/remainder",
152 scheme_make_prim_w_arity2(quotient_remainder,
153 "quotient/remainder",
154 2, 2,
155 2, 2),
156 env);
157
158 p = scheme_make_folding_prim(scheme_modulo, "modulo", 2, 2, 1);
159 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
160 | SCHEME_PRIM_WANTS_REAL
161 | SCHEME_PRIM_PRODUCES_REAL);
162 scheme_addto_prim_instance("modulo", p, env);
163 }
164
scheme_init_flfxnum_numarith(Scheme_Startup_Env * env)165 void scheme_init_flfxnum_numarith(Scheme_Startup_Env *env)
166 {
167 Scheme_Object *p;
168 int flags;
169
170 p = scheme_make_folding_prim(fx_plus, "fx+", 0, -1, 1);
171 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
172 | SCHEME_PRIM_IS_NARY_INLINED
173 | SCHEME_PRIM_PRODUCES_FIXNUM
174 | SCHEME_PRIM_AD_HOC_OPT);
175 scheme_addto_prim_instance("fx+", p, env);
176
177 p = scheme_make_folding_prim(fx_plus_wrap, "fx+/wraparound", 2, 2, 1);
178 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
179 | SCHEME_PRIM_IS_NARY_INLINED
180 | SCHEME_PRIM_PRODUCES_FIXNUM
181 | SCHEME_PRIM_AD_HOC_OPT);
182 scheme_addto_prim_instance("fx+/wraparound", p, env);
183
184 p = scheme_make_folding_prim(fx_minus, "fx-", 1, -1, 1);
185 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
186 | SCHEME_PRIM_IS_BINARY_INLINED
187 | SCHEME_PRIM_IS_NARY_INLINED
188 | SCHEME_PRIM_PRODUCES_FIXNUM
189 | SCHEME_PRIM_AD_HOC_OPT);
190 scheme_addto_prim_instance("fx-", p, env);
191
192 p = scheme_make_folding_prim(fx_minus_wrap, "fx-/wraparound", 2, 2, 1);
193 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
194 | SCHEME_PRIM_IS_BINARY_INLINED
195 | SCHEME_PRIM_IS_NARY_INLINED
196 | SCHEME_PRIM_PRODUCES_FIXNUM
197 | SCHEME_PRIM_AD_HOC_OPT);
198 scheme_addto_prim_instance("fx-/wraparound", p, env);
199
200 p = scheme_make_folding_prim(fx_mult, "fx*", 0, -1, 1);
201 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
202 | SCHEME_PRIM_IS_NARY_INLINED
203 | SCHEME_PRIM_PRODUCES_FIXNUM
204 | SCHEME_PRIM_AD_HOC_OPT);
205 scheme_addto_prim_instance("fx*", p, env);
206
207 p = scheme_make_folding_prim(fx_mult_wrap, "fx*/wraparound", 2, 2, 1);
208 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
209 | SCHEME_PRIM_IS_NARY_INLINED
210 | SCHEME_PRIM_PRODUCES_FIXNUM
211 | SCHEME_PRIM_AD_HOC_OPT);
212 scheme_addto_prim_instance("fx*/wraparound", p, env);
213
214 p = scheme_make_folding_prim(fx_div, "fxquotient", 2, 2, 1);
215 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
216 | SCHEME_PRIM_PRODUCES_FIXNUM);
217 scheme_addto_prim_instance("fxquotient", p, env);
218
219 p = scheme_make_folding_prim(fx_rem, "fxremainder", 2, 2, 1);
220 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
221 | SCHEME_PRIM_PRODUCES_FIXNUM);
222 scheme_addto_prim_instance("fxremainder", p, env);
223
224 p = scheme_make_folding_prim(fx_mod, "fxmodulo", 2, 2, 1);
225 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
226 | SCHEME_PRIM_PRODUCES_FIXNUM);
227 scheme_addto_prim_instance("fxmodulo", p, env);
228
229 p = scheme_make_folding_prim(fx_abs, "fxabs", 1, 1, 1);
230 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED)
231 | SCHEME_PRIM_PRODUCES_FIXNUM;
232 scheme_addto_prim_instance("fxabs", p, env);
233
234 p = scheme_make_folding_prim(fl_plus, "fl+", 0, -1, 1);
235 if (scheme_can_inline_fp_op())
236 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
237 else
238 flags = SCHEME_PRIM_SOMETIMES_INLINED;
239 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
240 | SCHEME_PRIM_PRODUCES_FLONUM
241 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
242 scheme_addto_prim_instance("fl+", p, env);
243
244 p = scheme_make_folding_prim(fl_minus, "fl-", 1, -1, 1);
245 if (scheme_can_inline_fp_op())
246 flags = (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED
247 | SCHEME_PRIM_IS_NARY_INLINED);
248 else
249 flags = SCHEME_PRIM_SOMETIMES_INLINED;
250 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
251 | SCHEME_PRIM_PRODUCES_FLONUM
252 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
253 scheme_addto_prim_instance("fl-", p, env);
254
255 p = scheme_make_folding_prim(fl_mult, "fl*", 0, -1, 1);
256 if (scheme_can_inline_fp_op())
257 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
258 else
259 flags = SCHEME_PRIM_SOMETIMES_INLINED;
260 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
261 | SCHEME_PRIM_PRODUCES_FLONUM
262 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
263 scheme_addto_prim_instance("fl*", p, env);
264
265 p = scheme_make_folding_prim(fl_div, "fl/", 1, -1, 1);
266 if (scheme_can_inline_fp_op())
267 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
268 else
269 flags = SCHEME_PRIM_SOMETIMES_INLINED;
270 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
271 | SCHEME_PRIM_PRODUCES_FLONUM
272 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
273 scheme_addto_prim_instance("fl/", p, env);
274
275 p = scheme_make_folding_prim(fl_abs, "flabs", 1, 1, 1);
276 if (scheme_can_inline_fp_op())
277 flags = SCHEME_PRIM_IS_UNARY_INLINED;
278 else
279 flags = SCHEME_PRIM_SOMETIMES_INLINED;
280 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
281 | SCHEME_PRIM_PRODUCES_FLONUM
282 | SCHEME_PRIM_WANTS_FLONUM_FIRST);
283 scheme_addto_prim_instance("flabs", p, env);
284
285 p = scheme_make_folding_prim(fl_sqrt, "flsqrt", 1, 1, 1);
286 if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)
287 flags = SCHEME_PRIM_IS_UNARY_INLINED;
288 else
289 flags = SCHEME_PRIM_SOMETIMES_INLINED;
290 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
291 | SCHEME_PRIM_PRODUCES_FLONUM
292 | SCHEME_PRIM_WANTS_FLONUM_FIRST);
293 scheme_addto_prim_instance("flsqrt", p, env);
294
295 }
296
scheme_init_extfl_numarith(Scheme_Startup_Env * env)297 void scheme_init_extfl_numarith(Scheme_Startup_Env *env)
298 {
299 Scheme_Object *p;
300 int flags;
301
302 p = scheme_make_folding_prim(extfl_plus, "extfl+", 2, 2, 1);
303 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
304 flags = SCHEME_PRIM_IS_BINARY_INLINED;
305 else
306 flags = SCHEME_PRIM_SOMETIMES_INLINED;
307 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
308 | SCHEME_PRIM_PRODUCES_EXTFLONUM
309 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
310 scheme_addto_prim_instance("extfl+", p, env);
311
312 p = scheme_make_folding_prim(extfl_minus, "extfl-", 2, 2, 1);
313 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
314 flags = SCHEME_PRIM_IS_BINARY_INLINED;
315 else
316 flags = SCHEME_PRIM_SOMETIMES_INLINED;
317 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
318 | SCHEME_PRIM_PRODUCES_EXTFLONUM
319 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
320 scheme_addto_prim_instance("extfl-", p, env);
321
322 p = scheme_make_folding_prim(extfl_mult, "extfl*", 2, 2, 1);
323 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
324 flags = SCHEME_PRIM_IS_BINARY_INLINED;
325 else
326 flags = SCHEME_PRIM_SOMETIMES_INLINED;
327 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
328 | SCHEME_PRIM_PRODUCES_EXTFLONUM
329 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
330 scheme_addto_prim_instance("extfl*", p, env);
331
332 p = scheme_make_folding_prim(extfl_div, "extfl/", 2, 2, 1);
333 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
334 flags = SCHEME_PRIM_IS_BINARY_INLINED;
335 else
336 flags = SCHEME_PRIM_SOMETIMES_INLINED;
337 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
338 | SCHEME_PRIM_PRODUCES_EXTFLONUM
339 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
340 scheme_addto_prim_instance("extfl/", p, env);
341
342 p = scheme_make_folding_prim(extfl_abs, "extflabs", 1, 1, 1);
343 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
344 flags = SCHEME_PRIM_IS_UNARY_INLINED;
345 else
346 flags = SCHEME_PRIM_SOMETIMES_INLINED;
347 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
348 | SCHEME_PRIM_PRODUCES_EXTFLONUM
349 | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
350 scheme_addto_prim_instance("extflabs", p, env);
351
352 p = scheme_make_folding_prim(extfl_sqrt, "extflsqrt", 1, 1, 1);
353 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
354 flags = SCHEME_PRIM_IS_UNARY_INLINED;
355 else
356 flags = SCHEME_PRIM_SOMETIMES_INLINED;
357 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
358 | SCHEME_PRIM_PRODUCES_EXTFLONUM
359 | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
360 scheme_addto_prim_instance("extflsqrt", p, env);
361 }
362
scheme_init_unsafe_numarith(Scheme_Startup_Env * env)363 void scheme_init_unsafe_numarith(Scheme_Startup_Env *env)
364 {
365 Scheme_Object *p;
366 int flags;
367
368 REGISTER_SO(scheme_unsafe_fx_plus_proc);
369 p = scheme_make_folding_prim(unsafe_fx_plus, "unsafe-fx+", 0, -1, 1);
370 scheme_unsafe_fx_plus_proc = p;
371 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
372 | SCHEME_PRIM_IS_NARY_INLINED
373 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
374 | SCHEME_PRIM_PRODUCES_FIXNUM);
375 scheme_addto_prim_instance("unsafe-fx+", p, env);
376
377 p = scheme_make_folding_prim(unsafe_fx_plus_wrap, "unsafe-fx+/wraparound", 2, 2, 1);
378 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
379 | SCHEME_PRIM_IS_NARY_INLINED
380 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
381 | SCHEME_PRIM_PRODUCES_FIXNUM);
382 scheme_addto_prim_instance("unsafe-fx+/wraparound", p, env);
383
384 REGISTER_SO(scheme_unsafe_fx_minus_proc);
385 p = scheme_make_folding_prim(unsafe_fx_minus, "unsafe-fx-", 1, -2, 1);
386 scheme_unsafe_fx_minus_proc = p;
387 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
388 | SCHEME_PRIM_IS_BINARY_INLINED
389 | SCHEME_PRIM_IS_NARY_INLINED
390 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
391 | SCHEME_PRIM_PRODUCES_FIXNUM);
392 scheme_addto_prim_instance("unsafe-fx-", p, env);
393
394 p = scheme_make_folding_prim(unsafe_fx_minus_wrap, "unsafe-fx-/wraparound", 2, 2, 1);
395 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
396 | SCHEME_PRIM_IS_NARY_INLINED
397 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
398 | SCHEME_PRIM_PRODUCES_FIXNUM);
399 scheme_addto_prim_instance("unsafe-fx-/wraparound", p, env);
400
401 REGISTER_SO(scheme_unsafe_fx_times_proc);
402 p = scheme_make_folding_prim(unsafe_fx_mult, "unsafe-fx*", 0, -1, 1);
403 scheme_unsafe_fx_times_proc = p;
404 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
405 | SCHEME_PRIM_IS_NARY_INLINED
406 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
407 | SCHEME_PRIM_PRODUCES_FIXNUM);
408 scheme_addto_prim_instance("unsafe-fx*", p, env);
409
410 p = scheme_make_folding_prim(unsafe_fx_mult_wrap, "unsafe-fx*/wraparound", 2, 2, 1);
411 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
412 | SCHEME_PRIM_IS_NARY_INLINED
413 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
414 | SCHEME_PRIM_PRODUCES_FIXNUM);
415 scheme_addto_prim_instance("unsafe-fx*/wraparound", p, env);
416
417 p = scheme_make_folding_prim(unsafe_fx_div, "unsafe-fxquotient", 2, 2, 1);
418 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
419 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
420 | SCHEME_PRIM_PRODUCES_FIXNUM);
421 scheme_addto_prim_instance("unsafe-fxquotient", p, env);
422
423 p = scheme_make_folding_prim(unsafe_fx_rem, "unsafe-fxremainder", 2, 2, 1);
424 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
425 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
426 | SCHEME_PRIM_PRODUCES_FIXNUM);
427 scheme_addto_prim_instance("unsafe-fxremainder", p, env);
428
429 p = scheme_make_folding_prim(unsafe_fx_mod, "unsafe-fxmodulo", 2, 2, 1);
430 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
431 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
432 | SCHEME_PRIM_PRODUCES_FIXNUM);
433 scheme_addto_prim_instance("unsafe-fxmodulo", p, env);
434
435 p = scheme_make_folding_prim(unsafe_fx_abs, "unsafe-fxabs", 1, 1, 1);
436 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
437 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
438 | SCHEME_PRIM_PRODUCES_FIXNUM);
439 scheme_addto_prim_instance("unsafe-fxabs", p, env);
440
441
442 p = scheme_make_folding_prim(unsafe_fl_plus, "unsafe-fl+", 0, -1, 1);
443 if (scheme_can_inline_fp_op())
444 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
445 else
446 flags = SCHEME_PRIM_SOMETIMES_INLINED;
447 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
448 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
449 | SCHEME_PRIM_PRODUCES_FLONUM
450 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
451 scheme_addto_prim_instance("unsafe-fl+", p, env);
452
453 p = scheme_make_folding_prim(unsafe_fl_minus, "unsafe-fl-", 1, -1, 1);
454 if (scheme_can_inline_fp_op())
455 flags = (SCHEME_PRIM_IS_UNARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED
456 | SCHEME_PRIM_IS_NARY_INLINED);
457 else
458 flags = SCHEME_PRIM_SOMETIMES_INLINED;
459 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
460 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
461 | SCHEME_PRIM_PRODUCES_FLONUM
462 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
463 scheme_addto_prim_instance("unsafe-fl-", p, env);
464
465 p = scheme_make_folding_prim(unsafe_fl_mult, "unsafe-fl*", 0, -1, 1);
466 if (scheme_can_inline_fp_op())
467 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_BINARY_INLINED);
468 else
469 flags = SCHEME_PRIM_SOMETIMES_INLINED;
470 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
471 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
472 | SCHEME_PRIM_PRODUCES_FLONUM
473 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
474 scheme_addto_prim_instance("unsafe-fl*", p, env);
475
476 p = scheme_make_folding_prim(unsafe_fl_div, "unsafe-fl/", 1, -2, 1);
477 if (scheme_can_inline_fp_op())
478 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
479 else
480 flags = SCHEME_PRIM_SOMETIMES_INLINED;
481 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
482 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
483 | SCHEME_PRIM_PRODUCES_FLONUM
484 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
485 scheme_addto_prim_instance("unsafe-fl/", p, env);
486
487 p = scheme_make_folding_prim(unsafe_fl_abs, "unsafe-flabs", 1, 1, 1);
488 if (scheme_can_inline_fp_op())
489 flags = SCHEME_PRIM_IS_UNARY_INLINED;
490 else
491 flags = SCHEME_PRIM_SOMETIMES_INLINED;
492 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
493 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
494 | SCHEME_PRIM_PRODUCES_FLONUM
495 | SCHEME_PRIM_WANTS_FLONUM_FIRST);
496 scheme_addto_prim_instance("unsafe-flabs", p, env);
497
498 p = scheme_make_folding_prim(unsafe_fl_sqrt, "unsafe-flsqrt", 1, 1, 1);
499 if (scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE)
500 flags = SCHEME_PRIM_IS_UNARY_INLINED;
501 else
502 flags = SCHEME_PRIM_SOMETIMES_INLINED;
503 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
504 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
505 | SCHEME_PRIM_PRODUCES_FLONUM
506 | SCHEME_PRIM_WANTS_FLONUM_FIRST);
507 scheme_addto_prim_instance("unsafe-flsqrt", p, env);
508 }
509
scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env * env)510 void scheme_init_extfl_unsafe_numarith(Scheme_Startup_Env *env)
511 {
512 Scheme_Object *p;
513 int flags;
514
515 p = scheme_make_folding_prim(unsafe_extfl_plus, "unsafe-extfl+", 2, 2, 1);
516 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
517 flags = SCHEME_PRIM_IS_BINARY_INLINED;
518 else
519 flags = SCHEME_PRIM_SOMETIMES_INLINED;
520 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
521 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
522 | SCHEME_PRIM_PRODUCES_EXTFLONUM
523 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
524 scheme_addto_prim_instance("unsafe-extfl+", p, env);
525
526 p = scheme_make_folding_prim(unsafe_extfl_minus, "unsafe-extfl-", 2, 2, 1);
527 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
528 flags = SCHEME_PRIM_IS_BINARY_INLINED;
529 else
530 flags = SCHEME_PRIM_SOMETIMES_INLINED;
531 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
532 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
533 | SCHEME_PRIM_PRODUCES_EXTFLONUM
534 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
535 scheme_addto_prim_instance("unsafe-extfl-", p, env);
536
537 p = scheme_make_folding_prim(unsafe_extfl_mult, "unsafe-extfl*", 2, 2, 1);
538 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
539 flags = SCHEME_PRIM_IS_BINARY_INLINED;
540 else
541 flags = SCHEME_PRIM_SOMETIMES_INLINED;
542 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
543 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
544 | SCHEME_PRIM_PRODUCES_EXTFLONUM
545 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
546 scheme_addto_prim_instance("unsafe-extfl*", p, env);
547
548 p = scheme_make_folding_prim(unsafe_extfl_div, "unsafe-extfl/", 2, 2, 1);
549 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
550 flags = SCHEME_PRIM_IS_BINARY_INLINED;
551 else
552 flags = SCHEME_PRIM_SOMETIMES_INLINED;
553 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
554 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
555 | SCHEME_PRIM_PRODUCES_EXTFLONUM
556 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
557 scheme_addto_prim_instance("unsafe-extfl/", p, env);
558
559 p = scheme_make_folding_prim(unsafe_extfl_abs, "unsafe-extflabs", 1, 1, 1);
560 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
561 flags = SCHEME_PRIM_IS_UNARY_INLINED;
562 else
563 flags = SCHEME_PRIM_SOMETIMES_INLINED;
564 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
565 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
566 | SCHEME_PRIM_PRODUCES_EXTFLONUM
567 | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
568 scheme_addto_prim_instance("unsafe-extflabs", p, env);
569
570 p = scheme_make_folding_prim(unsafe_extfl_sqrt, "unsafe-extflsqrt", 1, 1, 1);
571 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op() && SQRT_MACHINE_CODE_AVAILABLE))
572 flags = SCHEME_PRIM_IS_UNARY_INLINED;
573 else
574 flags = SCHEME_PRIM_SOMETIMES_INLINED;
575 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
576 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
577 | SCHEME_PRIM_PRODUCES_EXTFLONUM
578 | SCHEME_PRIM_WANTS_EXTFLONUM_FIRST);
579 scheme_addto_prim_instance("unsafe-extflsqrt", p, env);
580 }
581
582 Scheme_Object *
scheme_add1(int argc,Scheme_Object * argv[])583 scheme_add1 (int argc, Scheme_Object *argv[])
584 {
585 Scheme_Type t;
586 Scheme_Object *o = argv[0];
587
588 if (SCHEME_INTP(o)) {
589 intptr_t v;
590 v = SCHEME_INT_VAL(o);
591 if (v < 0x3FFFFFFF)
592 return scheme_make_integer(v + 1);
593 else {
594 Small_Bignum b;
595 return scheme_bignum_add1(scheme_make_small_bignum(v, &b));
596 }
597 }
598 t = _SCHEME_TYPE(o);
599 #ifdef MZ_USE_SINGLE_FLOATS
600 if (t == scheme_float_type)
601 return scheme_make_float(SCHEME_FLT_VAL(o) + 1.0f);
602 #endif
603 if (t == scheme_double_type)
604 return scheme_make_double(SCHEME_DBL_VAL(o) + 1.0);
605 if (t == scheme_bignum_type)
606 return scheme_bignum_add1(o);
607 if (t == scheme_rational_type)
608 return scheme_rational_add1(o);
609 if (t == scheme_complex_type)
610 return scheme_complex_add1(o);
611
612 NEED_NUMBER(add1);
613
614 ESCAPED_BEFORE_HERE;
615 }
616
617 Scheme_Object *
scheme_sub1(int argc,Scheme_Object * argv[])618 scheme_sub1 (int argc, Scheme_Object *argv[])
619 {
620 Scheme_Type t;
621 Scheme_Object *o = argv[0];
622
623 if (SCHEME_INTP(o)) {
624 intptr_t v;
625 v = SCHEME_INT_VAL(o);
626 if (v > -(0x3FFFFFFF))
627 return scheme_make_integer(SCHEME_INT_VAL(o) - 1);
628 else {
629 Small_Bignum b;
630 return scheme_bignum_sub1(scheme_make_small_bignum(v, &b));
631 }
632 }
633 t = _SCHEME_TYPE(o);
634 #ifdef MZ_USE_SINGLE_FLOATS
635 if (t == scheme_float_type)
636 return scheme_make_float(SCHEME_FLT_VAL(o) - 1.0f);
637 #endif
638 if (t == scheme_double_type)
639 return scheme_make_double(SCHEME_DBL_VAL(o) - 1.0);
640 if (t == scheme_bignum_type)
641 return scheme_bignum_sub1(o);
642 if (t == scheme_rational_type)
643 return scheme_rational_sub1(o);
644 if (t == scheme_complex_type)
645 return scheme_complex_sub1(o);
646
647 NEED_NUMBER(sub1);
648
649 ESCAPED_BEFORE_HERE;
650 }
651
652 #define F_ADD(x,y) scheme_make_double(x + y)
653 #define F_SUBTRACT(x,y) scheme_make_double(x - y)
654 #define F_MULTIPLY(x,y) scheme_make_double(x * y)
655 #define DIVIDE(x,y) scheme_make_fixnum_rational(x, y)
656 #define F_DIVIDE(x,y) scheme_make_double((double)x / (double)y)
657
658 #define FS_ADD(x,y) scheme_make_float(x + y)
659 #define FS_SUBTRACT(x,y) scheme_make_float(x - y)
660 #define FS_MULTIPLY(x,y) scheme_make_float(x * y)
661 #define FS_DIVIDE(x,y) scheme_make_float((float)x / (float)y)
662
ADD_slow(intptr_t a,intptr_t b)663 static Scheme_Object *ADD_slow(intptr_t a, intptr_t b)
664 {
665 Small_Bignum sa, sb;
666 return scheme_bignum_add(scheme_make_small_bignum(a, &sa),
667 scheme_make_small_bignum(b, &sb));
668 }
669
ADD(intptr_t a,intptr_t b)670 static Scheme_Object *ADD(intptr_t a, intptr_t b)
671 {
672 intptr_t r;
673 Scheme_Object *o;
674
675 r = (uintptr_t)a + (uintptr_t)b;
676
677 o = scheme_make_integer(r);
678 r = SCHEME_INT_VAL(o);
679
680 if (b == (uintptr_t)r - (uintptr_t)a)
681 return o;
682 else
683 return ADD_slow(a, b);
684 }
685
SUBTRACT_slow(intptr_t a,intptr_t b)686 static Scheme_Object *SUBTRACT_slow(intptr_t a, intptr_t b)
687 {
688 Small_Bignum sa, sb;
689 return scheme_bignum_subtract(scheme_make_small_bignum(a, &sa),
690 scheme_make_small_bignum(b, &sb));
691 }
692
SUBTRACT(intptr_t a,intptr_t b)693 static Scheme_Object *SUBTRACT(intptr_t a, intptr_t b)
694 {
695 intptr_t r;
696 Scheme_Object *o;
697
698 r = (uintptr_t)a - (uintptr_t)b;
699
700 o = scheme_make_integer(r);
701 r = SCHEME_INT_VAL(o);
702
703 if (a == (uintptr_t)r + (uintptr_t)b)
704 return o;
705 else
706 return SUBTRACT_slow(a, b);
707 }
708
MULTIPLY(intptr_t a,intptr_t b)709 static Scheme_Object *MULTIPLY(intptr_t a, intptr_t b)
710 {
711 intptr_t r;
712 Scheme_Object *o;
713
714 if (!b)
715 return zeroi;
716
717 r = (uintptr_t)a * (uintptr_t)b;
718
719 o = scheme_make_integer(r);
720 r = SCHEME_INT_VAL(o);
721
722 /* if b == -1, division could overflow; otherwise, division is defined */
723 if ((b == -1)
724 ? (a == (uintptr_t)r * (uintptr_t)-1)
725 : (a == r / b))
726 return o;
727 else {
728 Small_Bignum sa, sb;
729 return scheme_bignum_multiply(scheme_make_small_bignum(a, &sa),
730 scheme_make_small_bignum(b, &sb));
731 }
732 }
733
unary_minus(const Scheme_Object * n)734 static Scheme_Object *unary_minus(const Scheme_Object *n)
735 {
736 Scheme_Object *a[1];
737 a[0] = (Scheme_Object *)n;
738 return minus(1, a);
739 }
740
741 #define ret_other(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(0))) return (Scheme_Object *)n2
742 #define ret_1other(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(1))) return (Scheme_Object *)n2
743 #define ret_zero(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(0))) return scheme_make_integer(0)
744
745 GEN_BIN_OP(scheme_bin_plus, "+", ADD, F_ADD, FS_ADD, scheme_bignum_add, scheme_rational_add, scheme_complex_add, GEN_RETURN_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, ret_other, cx_NO_CHECK, ret_other, cx_NO_CHECK)
746 GEN_BIN_OP(scheme_bin_minus, "-", SUBTRACT, F_SUBTRACT, FS_SUBTRACT, scheme_bignum_subtract, scheme_rational_subtract, scheme_complex_subtract, GEN_SINGLE_SUBTRACT_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, cx_NO_CHECK, cx_NO_CHECK, ret_other, cx_NO_CHECK)
747 GEN_BIN_OP(scheme_bin_mult, "*", MULTIPLY, F_MULTIPLY, FS_MULTIPLY, scheme_bignum_multiply, scheme_rational_multiply, scheme_complex_multiply, GEN_RETURN_0, GEN_RETURN_0, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, NO_NAN_CHECK, ret_zero, ret_1other, ret_zero, ret_1other)
748 GEN_BIN_DIV_OP(scheme_bin_div, "/", DIVIDE, F_DIVIDE, FS_DIVIDE, scheme_make_rational, scheme_rational_divide, scheme_complex_divide, ret_zero, cx_NO_CHECK, cx_NO_CHECK, ret_1other)
749
750 GEN_NARY_OP(static, plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number?", GEN_IDENT)
751 GEN_NARY_OP(static, mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number?", GEN_IDENT)
752
753 static MZ_INLINE Scheme_Object *
minus_slow(Scheme_Object * ret,int argc,Scheme_Object * argv[])754 minus_slow (Scheme_Object *ret, int argc, Scheme_Object *argv[])
755 {
756 int i;
757 for (i = 1; i < argc; i++) {
758 Scheme_Object *o = argv[i];
759 if (!SCHEME_NUMBERP(o)) {
760 scheme_wrong_contract("-", "number?", i, argc, argv);
761 ESCAPED_BEFORE_HERE;
762 }
763 ret = scheme_bin_minus(ret, o);
764 }
765 return ret;
766 }
767
768 static Scheme_Object *
minus(int argc,Scheme_Object * argv[])769 minus (int argc, Scheme_Object *argv[])
770 {
771 Scheme_Object *ret, *v;
772
773 ret = argv[0];
774 if (!SCHEME_NUMBERP(ret)) {
775 scheme_wrong_contract("-", "number?", 0, argc, argv);
776 ESCAPED_BEFORE_HERE;
777 }
778 if (argc == 1) {
779 if (SCHEME_FLOATP(ret)) {
780 #ifdef MZ_USE_SINGLE_FLOATS
781 if (SCHEME_FLTP(ret))
782 return scheme_make_float(-SCHEME_FLT_VAL(ret));
783 #endif
784 return scheme_make_double(-SCHEME_DBL_VAL(ret));
785 }
786 return scheme_bin_minus(zeroi, ret);
787 }
788 if (argc == 2) {
789 v = argv[1];
790 if (!SCHEME_NUMBERP(v)) {
791 scheme_wrong_contract("-", "number?", 1, argc, argv);
792 ESCAPED_BEFORE_HERE;
793 }
794 return scheme_bin_minus(ret, v);
795 }
796 return minus_slow(ret, argc, argv);
797 }
798
799 static Scheme_Object *
div_prim(int argc,Scheme_Object * argv[])800 div_prim (int argc, Scheme_Object *argv[])
801 {
802 Scheme_Object *ret;
803 int i;
804
805 ret = argv[0];
806 if (!SCHEME_NUMBERP(ret)) {
807 scheme_wrong_contract("/", "number?", 0, argc, argv);
808 ESCAPED_BEFORE_HERE;
809 }
810 if (argc == 1) {
811 if (ret != zeroi)
812 return scheme_bin_div(scheme_make_integer(1), ret);
813 else {
814 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
815 "/: division by zero");
816 ESCAPED_BEFORE_HERE;
817 }
818 }
819 for (i = 1; i < argc; i++) {
820 Scheme_Object *o = argv[i];
821
822 if (!SCHEME_NUMBERP(o)) {
823 scheme_wrong_contract("/", "number?", i, argc, argv);
824 ESCAPED_BEFORE_HERE;
825 }
826
827 if (o != zeroi)
828 ret = scheme_bin_div(ret, o);
829 else {
830 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
831 "/: division by zero");
832 ESCAPED_BEFORE_HERE;
833 }
834 }
835 return ret;
836 }
837
838 #define ABS(n) ((n>0) ? n : -n)
839
840 Scheme_Object *
scheme_abs(int argc,Scheme_Object * argv[])841 scheme_abs(int argc, Scheme_Object *argv[])
842 {
843 Scheme_Type t;
844 Scheme_Object *o;
845
846 o = argv[0];
847
848 if (SCHEME_INTP(o)) {
849 intptr_t n = SCHEME_INT_VAL(o);
850 return scheme_make_integer_value(ABS(n));
851 }
852 t = _SCHEME_TYPE(o);
853 #ifdef MZ_USE_SINGLE_FLOATS
854 if (t == scheme_float_type)
855 return scheme_make_float(fabs(SCHEME_FLT_VAL(o)));
856 #endif
857 if (t == scheme_double_type)
858 return scheme_make_double(fabs(SCHEME_DBL_VAL(o)));
859 if (t == scheme_bignum_type) {
860 if (SCHEME_BIGPOS(o))
861 return o;
862 return scheme_bignum_negate(o);
863 }
864 if (t == scheme_rational_type) {
865 if (scheme_is_rational_positive(o))
866 return o;
867 else
868 return scheme_rational_negate(o);
869 }
870
871 NEED_REAL(abs);
872
873 ESCAPED_BEFORE_HERE;
874 }
875
876 Scheme_Object *
do_bin_quotient(const char * name,const Scheme_Object * n1,const Scheme_Object * n2,Scheme_Object ** bn_rem)877 do_bin_quotient(const char *name, const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **bn_rem)
878 {
879 Scheme_Object *q;
880
881 if (!scheme_is_integer(n1)) {
882 Scheme_Object *a[2];
883 a[0] = (Scheme_Object *)n1;
884 a[1] = (Scheme_Object *)n2;
885 scheme_wrong_contract(name, "integer?", 0, 2, a);
886 }
887 if (!scheme_is_integer(n2)) {
888 Scheme_Object *a[2];
889 a[0] = (Scheme_Object *)n1;
890 a[1] = (Scheme_Object *)n2;
891 scheme_wrong_contract(name, "integer?", 1, 2, a);
892 }
893
894 if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
895 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
896 "%s: undefined for 0", name);
897 if (
898 #ifdef MZ_USE_SINGLE_FLOATS
899 (SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
900 #endif
901 (SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0)))
902 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
903 "%s: undefined for 0.0", name);
904
905 if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
906 /* Beware that most negative fixnum divided by -1
907 isn't a fixnum: */
908 return (scheme_make_integer_value(SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
909 }
910 if (SCHEME_DBLP(n1) || SCHEME_DBLP(n2)) {
911 Scheme_Object *r;
912 double d, d2;
913
914 r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
915 if (SCHEME_DBLP(r)) {
916 d = SCHEME_DBL_VAL(r);
917
918 if (d > 0)
919 d2 = floor(d);
920 else
921 d2 = ceil(d);
922
923 if (d2 == d)
924 return r;
925 else
926 return scheme_make_double(d2);
927 } else
928 return r;
929 }
930 #ifdef MZ_USE_SINGLE_FLOATS
931 if (SCHEME_FLTP(n1) || SCHEME_FLTP(n2)) {
932 Scheme_Object *r;
933 float d, d2;
934
935 r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
936 if (SCHEME_FLTP(r)) {
937 d = SCHEME_FLT_VAL(r);
938
939 if (d > 0)
940 d2 = floor(d);
941 else
942 d2 = ceil(d);
943
944 if (d2 == d)
945 return r;
946 else
947 return scheme_make_float(d2);
948 } else
949 return r;
950 }
951 #endif
952
953 #if 0
954 /* I'm pretty sure this isn't needed, but I'm keeping the code just
955 in case... 03/19/2000 */
956 if (SCHEME_RATIONALP(n1))
957 wrong_contract(name, "integer?", n1);
958 if (SCHEME_RATIONALP(n2))
959 wrong_contract(name, "integer?", n2);
960 #endif
961
962 n1 = scheme_to_bignum(n1);
963 n2 = scheme_to_bignum(n2);
964
965 scheme_bignum_divide(n1, n2, &q, bn_rem, 1);
966 return q;
967 }
968
969 Scheme_Object *
scheme_bin_quotient(const Scheme_Object * n1,const Scheme_Object * n2)970 scheme_bin_quotient (const Scheme_Object *n1, const Scheme_Object *n2)
971 {
972 return do_bin_quotient("quotient", n1, n2, NULL);
973 }
974
975 static Scheme_Object *
quotient(int argc,Scheme_Object * argv[])976 quotient (int argc, Scheme_Object *argv[])
977 {
978 return do_bin_quotient("quotient", argv[0], argv[1], NULL);
979 }
980
981 /* Declaration is for FARPROC: */
982 static Scheme_Object *
983 rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign);
984
985 static Scheme_Object *
rem_mod(int argc,Scheme_Object * argv[],char * name,int first_sign)986 rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign)
987 {
988 Scheme_Object *n1, *n2, *r;
989 int negate;
990
991 n1 = argv[0];
992 n2 = argv[1];
993
994 if (!scheme_is_integer(n1))
995 scheme_wrong_contract(name, "integer?", 0, argc, argv);
996 if (!scheme_is_integer(n2))
997 scheme_wrong_contract(name, "integer?", 1, argc, argv);
998
999 if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
1000 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
1001 "%s: undefined for 0", name);
1002 if (
1003 #ifdef MZ_USE_SINGLE_FLOATS
1004 (SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
1005 #endif
1006 (SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0))) {
1007 int neg;
1008 neg = scheme_minus_zero_p(SCHEME_FLOAT_VAL(n2));
1009 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
1010 "%s: undefined for %s0.0",
1011 name,
1012 neg ? "-" : "");
1013 }
1014
1015 if (SCHEME_INTP(n1) && !SCHEME_INT_VAL(n1))
1016 return zeroi;
1017
1018 if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
1019 intptr_t a, b, na, nb, v;
1020 int neg1, neg2;
1021
1022 a = SCHEME_INT_VAL(n1);
1023 b = SCHEME_INT_VAL(n2);
1024 na = (a < 0) ? -a : a;
1025 nb = (b < 0) ? -b : b;
1026
1027 v = na % nb;
1028
1029 if (v) {
1030 if (first_sign) {
1031 if (a < 0)
1032 v = -v;
1033 } else {
1034 neg1 = (a < 0);
1035 neg2 = (b < 0);
1036
1037 if (neg1 != neg2)
1038 v = nb - v;
1039
1040 if (neg2)
1041 v = -v;
1042 }
1043 }
1044
1045 return scheme_make_integer(v);
1046 }
1047
1048 if (SCHEME_FLOATP(n1) || SCHEME_FLOATP(n2)) {
1049 double a, b, na, nb, v;
1050 #ifdef MZ_USE_SINGLE_FLOATS
1051 int was_single = !(SCHEME_DBLP(n1) || SCHEME_DBLP(n2));
1052 #endif
1053
1054 if (SCHEME_INTP(n1))
1055 a = SCHEME_INT_VAL(n1);
1056 #ifdef MZ_USE_SINGLE_FLOATS
1057 else if (SCHEME_FLTP(n1))
1058 a = SCHEME_FLT_VAL(n1);
1059 #endif
1060 else if (SCHEME_DBLP(n1))
1061 a = SCHEME_DBL_VAL(n1);
1062 else
1063 a = scheme_bignum_to_double(n1);
1064
1065 if (SCHEME_INTP(n2))
1066 b = SCHEME_INT_VAL(n2);
1067 #ifdef MZ_USE_SINGLE_FLOATS
1068 else if (SCHEME_FLTP(n2))
1069 b = SCHEME_FLT_VAL(n2);
1070 #endif
1071 else if (SCHEME_DBLP(n2))
1072 b = SCHEME_DBL_VAL(n2);
1073 else
1074 b = scheme_bignum_to_double(n2);
1075
1076 if (a == 0.0) {
1077 /* Avoid sign problems. */
1078 #ifdef MZ_USE_SINGLE_FLOATS
1079 if (was_single)
1080 return scheme_zerof;
1081 #endif
1082 return scheme_zerod;
1083 }
1084
1085 na = (a < 0) ? -a : a;
1086 nb = (b < 0) ? -b : b;
1087
1088 if (MZ_IS_POS_INFINITY(nb))
1089 v = na;
1090 else if (MZ_IS_POS_INFINITY(na)) {
1091 #ifdef MZ_USE_SINGLE_FLOATS
1092 if (was_single)
1093 return scheme_zerof;
1094 #endif
1095 return scheme_zerod;
1096 } else {
1097 v = fmod(na, nb);
1098
1099 #ifdef FMOD_CAN_RETURN_NEG_ZERO
1100 if (v == 0.0)
1101 v = 0.0;
1102 #endif
1103 }
1104
1105 if (v) {
1106 if (first_sign) {
1107 /* remainder */
1108 if (a < 0)
1109 v = -v;
1110 } else {
1111 /* modulo */
1112 int neg1, neg2;
1113
1114 neg1 = (a < 0);
1115 neg2 = (b < 0);
1116
1117 if (neg1 != neg2)
1118 v = nb - v;
1119
1120 if (neg2)
1121 v = -v;
1122 }
1123 }
1124
1125 #ifdef MZ_USE_SINGLE_FLOATS
1126 if (was_single)
1127 return scheme_make_float((float)v);
1128 #endif
1129
1130 return scheme_make_double(v);
1131 }
1132
1133 n1 = scheme_to_bignum(n1);
1134 n2 = scheme_to_bignum(n2);
1135
1136 scheme_bignum_divide(n1, n2, NULL, &r, 1);
1137
1138 negate = 0;
1139
1140 if (!SCHEME_INTP(r) || SCHEME_INT_VAL(r)) {
1141 /* Easier if we can assume 'r' is positive: */
1142 if (SCHEME_INTP(r)) {
1143 if (SCHEME_INT_VAL(r) < 0)
1144 r = scheme_make_integer_value(-SCHEME_INT_VAL(r));
1145 } else if (!SCHEME_BIGPOS(r))
1146 r = scheme_bignum_negate(r);
1147
1148 if (first_sign) {
1149 if (!SCHEME_BIGPOS(n1))
1150 negate = 1;
1151 } else {
1152 int neg1, neg2;
1153
1154 neg1 = !SCHEME_BIGPOS(n1);
1155 neg2 = !SCHEME_BIGPOS(n2);
1156
1157 if (neg1 != neg2) {
1158 if (neg2)
1159 r = scheme_bin_plus(n2, r);
1160 else
1161 r = scheme_bin_minus(n2, r);
1162 } else if (neg2)
1163 negate = 1;
1164 }
1165
1166 if (negate) {
1167 if (SCHEME_INTP(r))
1168 r = scheme_make_integer_value(-SCHEME_INT_VAL(r));
1169 else
1170 r = scheme_bignum_normalize(scheme_bignum_negate(r));
1171 }
1172 }
1173
1174 return r;
1175 }
1176
1177 static Scheme_Object *
rem_prim(int argc,Scheme_Object * argv[])1178 rem_prim (int argc, Scheme_Object *argv[])
1179 {
1180 return rem_mod(argc, argv, "remainder", 1);
1181 }
1182
1183 Scheme_Object *
scheme_modulo(int argc,Scheme_Object * argv[])1184 scheme_modulo(int argc, Scheme_Object *argv[])
1185 {
1186 return rem_mod(argc, argv, "modulo", 0);
1187 }
1188
1189 static Scheme_Object *
do_quotient_remainder(const Scheme_Object * n1,const Scheme_Object * n2,Scheme_Object ** _rem)1190 do_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **_rem)
1191 {
1192 Scheme_Object *rem = NULL, *quot, *a[2];
1193
1194 quot = do_bin_quotient("quotient/remainder", n1, n2, &rem);
1195 if (!rem) {
1196 a[0] = (Scheme_Object *)n1;
1197 a[1] = (Scheme_Object *)n2;
1198 rem = rem_mod(2, a, "remainder", 1);
1199 }
1200 *_rem = rem;
1201
1202 return quot;
1203 }
1204
1205 Scheme_Object *
quotient_remainder(int argc,Scheme_Object * argv[])1206 quotient_remainder(int argc, Scheme_Object *argv[])
1207 {
1208 Scheme_Object *rem, *quot, *a[2];
1209
1210 quot = do_quotient_remainder(argv[0], argv[1], &rem);
1211 a[0] = quot;
1212 a[1] = rem;
1213 return scheme_values(2, a);
1214 }
1215
scheme_bin_quotient_remainder(const Scheme_Object * n1,const Scheme_Object * n2,Scheme_Object ** _rem)1216 Scheme_Object *scheme_bin_quotient_remainder(const Scheme_Object *n1, const Scheme_Object *n2,
1217 Scheme_Object **_rem)
1218 {
1219 return do_quotient_remainder(n1, n2, _rem);
1220 }
1221
1222 /************************************************************************/
1223 /* Flfx */
1224 /************************************************************************/
1225
1226 #define CHECK_SECOND_ZERO(name) \
1227 if (!SCHEME_INT_VAL(argv[1])) \
1228 scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, \
1229 name ": undefined for 0");
1230
1231 #ifdef SIXTY_FOUR_BIT_INTEGERS
check_always_fixnum(const char * name,Scheme_Object * o)1232 static void check_always_fixnum(const char *name, Scheme_Object *o)
1233 {
1234 if (SCHEME_INTP(o)) {
1235 intptr_t v = SCHEME_INT_VAL(o);
1236 if ((v < -1073741824) || (v > 1073741823)) {
1237 scheme_contract_error(name,
1238 "cannot fold to result that is not a fixnum on some platforms",
1239 "result", 1, o,
1240 NULL);
1241 }
1242 }
1243 }
1244 # define mzWHEN_64_BITS(e) e
1245 #else
1246 # define mzWHEN_64_BITS(e) /* empty */
1247 #endif
1248
1249 #define SAFE_FX(name, s_name, scheme_op, EXTRA_CHECK) \
1250 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1251 { \
1252 Scheme_Object *o; \
1253 int i; \
1254 for (i = 0; i < argc; i++) { \
1255 if (!SCHEME_INTP(argv[i])) scheme_wrong_contract(s_name, "fixnum?", i, argc, argv); \
1256 } \
1257 EXTRA_CHECK \
1258 o = scheme_op(argc, argv); \
1259 mzWHEN_64_BITS(if (scheme_current_thread->constant_folding) check_always_fixnum(s_name, o);) \
1260 if (!SCHEME_INTP(o)) scheme_non_fixnum_result(s_name, o); \
1261 return o; \
1262 }
1263
1264 SAFE_FX(fx_plus, "fx+", plus, )
1265 SAFE_FX(fx_minus, "fx-", minus, )
1266 SAFE_FX(fx_mult, "fx*", mult, )
1267 SAFE_FX(fx_div, "fxquotient", quotient, CHECK_SECOND_ZERO("fxquotient"))
1268 SAFE_FX(fx_rem, "fxremainder", rem_prim, CHECK_SECOND_ZERO("fxremainder"))
1269 SAFE_FX(fx_mod, "fxmodulo", scheme_modulo, CHECK_SECOND_ZERO("fxmodulo"))
1270
1271 #define SAFE_FX_WRAP(name, s_name, op) \
1272 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1273 { \
1274 uintptr_t r; \
1275 if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
1276 if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
1277 r = ((uintptr_t)SCHEME_INT_VAL(argv[0]) op (uintptr_t)SCHEME_INT_VAL(argv[1])); \
1278 return scheme_make_integer(r); \
1279 }
1280
1281 SAFE_FX_WRAP(fx_plus_wrap, "fx+/wraparound", +)
1282 SAFE_FX_WRAP(fx_minus_wrap, "fx-/wraparound", -)
1283 SAFE_FX_WRAP(fx_mult_wrap, "fx*/wraparound", *)
1284
fx_abs(int argc,Scheme_Object * argv[])1285 static Scheme_Object *fx_abs(int argc, Scheme_Object *argv[])
1286 {
1287 Scheme_Object *o;
1288 if (!SCHEME_INTP(argv[0])) scheme_wrong_contract("fxabs", "fixnum?", 0, argc, argv);
1289 o = scheme_abs(argc, argv);
1290 if (!SCHEME_INTP(o)) scheme_non_fixnum_result("fxabs", o);
1291 return o;
1292 }
1293
1294 #if __GNUC__ >= 8 || __clang_major__ >= 4
1295 # define NO_SANITIZE_SIGNED_INTEGER_OVERFLOW \
1296 __attribute__((no_sanitize("signed-integer-overflow")))
1297 #else
1298 # define NO_SANITIZE_SIGNED_INTEGER_OVERFLOW
1299 #endif
1300 #define UNSAFE_FX(name, op, fold, zero_args, PRE_CHECK) \
1301 NO_SANITIZE_SIGNED_INTEGER_OVERFLOW \
1302 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1303 { \
1304 intptr_t v; \
1305 int i; \
1306 if (scheme_current_thread->constant_folding) return fold(argc, argv); \
1307 if (!argc) return zero_args; \
1308 v = SCHEME_INT_VAL(argv[0]); \
1309 PRE_CHECK \
1310 for (i = 1; i < argc; i++) { \
1311 v = v op SCHEME_INT_VAL(argv[i]); \
1312 } \
1313 return scheme_make_integer(v); \
1314 }
1315
1316 UNSAFE_FX(unsafe_fx_plus, +, fx_plus, scheme_make_integer(0), )
1317 UNSAFE_FX(unsafe_fx_plus_wrap, +, fx_plus, scheme_make_integer(0), )
1318 UNSAFE_FX(unsafe_fx_minus, -, fx_minus, scheme_false, if (argc == 1) v = -v;)
1319 UNSAFE_FX(unsafe_fx_minus_wrap, -, fx_minus, scheme_false, if (argc == 1) v = -v;)
1320 UNSAFE_FX(unsafe_fx_mult, *, fx_mult, scheme_make_integer(1), )
1321 UNSAFE_FX(unsafe_fx_mult_wrap, *, fx_mult, scheme_make_integer(1), )
1322 UNSAFE_FX(unsafe_fx_div, /, fx_div, scheme_false, )
1323 UNSAFE_FX(unsafe_fx_rem, %, fx_rem, scheme_false, )
1324
unsafe_fx_mod(int argc,Scheme_Object * argv[])1325 static Scheme_Object *unsafe_fx_mod(int argc, Scheme_Object *argv[])
1326 {
1327 int neg1, neg2;
1328 intptr_t v, v1, av1, v2, av2;
1329 if (scheme_current_thread->constant_folding) return scheme_modulo(argc, argv);
1330
1331 v1 = SCHEME_INT_VAL(argv[0]);
1332 v2 = SCHEME_INT_VAL(argv[1]);
1333
1334 av1 = (v1 < 0) ? -v1 : v1;
1335 av2 = (v2 < 0) ? -v2 : v2;
1336
1337 v = av1 % av2;
1338
1339 if (v) {
1340 neg1 = (v1 < 0);
1341 neg2 = (v2 < 0);
1342
1343 if (neg1 != neg2)
1344 v = av2 - v;
1345
1346 if (neg2)
1347 v = -v;
1348 }
1349
1350 return scheme_make_integer(v);
1351 }
1352
unsafe_fx_abs(int argc,Scheme_Object * argv[])1353 static Scheme_Object *unsafe_fx_abs(int argc, Scheme_Object *argv[])
1354 {
1355 intptr_t v;
1356 if (scheme_current_thread->constant_folding) return scheme_abs(argc, argv);
1357 v = SCHEME_INT_VAL(argv[0]);
1358 if (v < 0) v = -v;
1359 return scheme_make_integer(v);
1360 }
1361
1362 #define UNSAFE_FL(name, op, fold, zero_args, PRE_CHECK) \
1363 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1364 { \
1365 double v; \
1366 if (!argc) return zero_args; \
1367 if (scheme_current_thread->constant_folding) return fold(argc, argv); \
1368 if (argc == 2) { \
1369 v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
1370 return scheme_make_double(v); \
1371 } else { \
1372 int i; \
1373 v = SCHEME_DBL_VAL(argv[0]); \
1374 PRE_CHECK \
1375 for (i = 1; i < argc; i++) { \
1376 v = v op SCHEME_DBL_VAL(argv[i]); \
1377 } \
1378 return scheme_make_double(v); \
1379 } \
1380 }
1381
1382 UNSAFE_FL(unsafe_fl_plus, +, plus, scheme_zerod, )
1383 UNSAFE_FL(unsafe_fl_minus, -, minus, scheme_false, if (argc == 1) v = 0.0 - v;)
1384 UNSAFE_FL(unsafe_fl_mult, *, mult, scheme_make_double(1.0), )
1385 UNSAFE_FL(unsafe_fl_div, /, div_prim, scheme_false, if (argc == 1) v = 1.0 / v;)
1386
1387 #define UNSAFE_FL1(name, op, fold) \
1388 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1389 { \
1390 double v; \
1391 if (scheme_current_thread->constant_folding) return fold(argc, argv); \
1392 v = SCHEME_DBL_VAL(argv[0]); \
1393 v = op(v); \
1394 return scheme_make_double(v); \
1395 }
1396
UNSAFE_FL1(unsafe_fl_abs,fabs,scheme_abs)1397 UNSAFE_FL1(unsafe_fl_abs, fabs, scheme_abs)
1398
1399 static Scheme_Object *pos_sqrt(int argc, Scheme_Object **argv)
1400 {
1401 if (SCHEME_DBLP(argv[0]) && (SCHEME_DBL_VAL(argv[0]) < 0.0))
1402 return scheme_nan_object;
1403 return scheme_sqrt(argc, argv);
1404 }
1405
1406 UNSAFE_FL1(unsafe_fl_sqrt, sqrt, pos_sqrt)
1407
1408 #define SAFE_FL(name, sname, op, zero_args, PRE_CHECK) \
1409 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1410 { \
1411 double v; \
1412 int i; \
1413 if (!argc) return zero_args; \
1414 if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(sname, "flonum?", 0, argc, argv); \
1415 v = SCHEME_DBL_VAL(argv[0]); \
1416 PRE_CHECK \
1417 for (i = 1; i < argc; i++) { \
1418 if (!SCHEME_DBLP(argv[i])) scheme_wrong_contract(sname, "flonum?", i, argc, argv); \
1419 v = v op SCHEME_DBL_VAL(argv[i]); \
1420 } \
1421 return scheme_make_double(v); \
1422 }
1423
1424 SAFE_FL(fl_plus, "fl+", +, scheme_zerod, )
1425 SAFE_FL(fl_minus, "fl-", -, scheme_false, if (argc == 1) v = 0.0 - v;)
1426 SAFE_FL(fl_mult, "fl*", *, scheme_make_double(1.0), )
1427 SAFE_FL(fl_div, "fl/", /, scheme_false, if (argc == 1) v = 1.0 / v;)
1428
1429 #define SAFE_FL1(name, sname, op) \
1430 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1431 { \
1432 double v; \
1433 if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(sname, "flonum?", 0, argc, argv); \
1434 v = SCHEME_DBL_VAL(argv[0]); \
1435 v = op(v); \
1436 return scheme_make_double(v); \
1437 }
1438
1439 SAFE_FL1(fl_abs, "flabs", fabs)
1440 SAFE_FL1(fl_sqrt, "flsqrt", sqrt)
1441
1442 #ifdef MZ_LONG_DOUBLE
1443 # define UNSAFE_EXTFL(name, op) \
1444 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1445 { \
1446 long_double v; \
1447 CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("unsafe-extfl" #op); \
1448 v = op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
1449 return scheme_make_long_double(v); \
1450 }
1451 #else
1452 # define UNSAFE_EXTFL(name, op) \
1453 static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
1454 { \
1455 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
1456 "unsafe-extfl" #op ": " NOT_SUPPORTED_STR); \
1457 return NULL; \
1458 }
1459 #endif
1460
1461 UNSAFE_EXTFL(unsafe_extfl_plus, long_double_plus)
1462 UNSAFE_EXTFL(unsafe_extfl_minus, long_double_minus)
1463 UNSAFE_EXTFL(unsafe_extfl_mult, long_double_mult)
1464 UNSAFE_EXTFL(unsafe_extfl_div, long_double_div)
1465
1466 #ifdef MZ_LONG_DOUBLE
1467 # define UNSAFE_EXTFL1(name, op) \
1468 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1469 { \
1470 long_double v; \
1471 v = SCHEME_LONG_DBL_VAL(argv[0]); \
1472 v = op(v); \
1473 return scheme_make_long_double(v); \
1474 }
1475 #else
1476 # define UNSAFE_EXTFL1(name, op) UNSAFE_EXTFL(name, op)
1477 #endif
1478
1479 UNSAFE_EXTFL1(unsafe_extfl_abs, long_double_fabs)
1480 UNSAFE_EXTFL1(unsafe_extfl_sqrt, long_double_sqrt)
1481
1482 #ifdef MZ_LONG_DOUBLE
1483 # define SAFE_EXTFL(name, sname, op) \
1484 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1485 { \
1486 long_double v; \
1487 CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(sname); \
1488 if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
1489 if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
1490 v = op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1])); \
1491 return scheme_make_long_double(v); \
1492 }
1493 #else
1494 # define SAFE_EXTFL(name, sname, op) \
1495 static Scheme_Object * name (int argc, Scheme_Object *argv[]) \
1496 { \
1497 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
1498 sname ": " NOT_SUPPORTED_STR); \
1499 return NULL; \
1500 }
1501 #endif
1502
1503 SAFE_EXTFL(extfl_plus, "extfl+", long_double_plus)
1504 SAFE_EXTFL(extfl_minus, "extfl-", long_double_minus)
1505 SAFE_EXTFL(extfl_mult, "extfl*", long_double_mult)
1506 SAFE_EXTFL(extfl_div, "extfl/", long_double_div)
1507
1508 #ifdef MZ_LONG_DOUBLE
1509 # define SAFE_EXTFL1(name, sname, op) \
1510 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
1511 { \
1512 long_double v; \
1513 if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
1514 v = SCHEME_LONG_DBL_VAL(argv[0]); \
1515 v = op(v); \
1516 return scheme_make_long_double(v); \
1517 }
1518 #else
1519 # define SAFE_EXTFL1(name, sname, op) SAFE_EXTFL(name, sname, op)
1520 #endif
1521
1522 SAFE_EXTFL1(extfl_abs, "extflabs", long_double_fabs)
1523 SAFE_EXTFL1(extfl_sqrt, "extflsqrt", long_double_sqrt)
1524