1 #include "schpriv.h"
2 #include "nummacs.h"
3 #include <math.h>
4
5 /* read only globals */
6 READ_ONLY Scheme_Object *scheme_unsafe_fx_eq_proc;
7 READ_ONLY Scheme_Object *scheme_unsafe_fx_lt_proc;
8 READ_ONLY Scheme_Object *scheme_unsafe_fx_gt_proc;
9 READ_ONLY Scheme_Object *scheme_unsafe_fx_lt_eq_proc;
10 READ_ONLY Scheme_Object *scheme_unsafe_fx_gt_eq_proc;
11 READ_ONLY Scheme_Object *scheme_unsafe_fx_min_proc;
12 READ_ONLY Scheme_Object *scheme_unsafe_fx_max_proc;
13
14 /* locals */
15 static Scheme_Object *eq (int argc, Scheme_Object *argv[]);
16 static Scheme_Object *lt (int argc, Scheme_Object *argv[]);
17 static Scheme_Object *gt (int argc, Scheme_Object *argv[]);
18 static Scheme_Object *lt_eq (int argc, Scheme_Object *argv[]);
19 static Scheme_Object *gt_eq (int argc, Scheme_Object *argv[]);
20 static Scheme_Object *zero_p (int argc, Scheme_Object *argv[]);
21 static Scheme_Object *positive_p (int argc, Scheme_Object *argv[]);
22 static Scheme_Object *negative_p (int argc, Scheme_Object *argv[]);
23 static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]);
24 static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]);
25
26 static Scheme_Object *fx_eq (int argc, Scheme_Object *argv[]);
27 static Scheme_Object *fx_lt (int argc, Scheme_Object *argv[]);
28 static Scheme_Object *fx_gt (int argc, Scheme_Object *argv[]);
29 static Scheme_Object *fx_lt_eq (int argc, Scheme_Object *argv[]);
30 static Scheme_Object *fx_gt_eq (int argc, Scheme_Object *argv[]);
31 static Scheme_Object *fx_min (int argc, Scheme_Object *argv[]);
32 static Scheme_Object *fx_max (int argc, Scheme_Object *argv[]);
33
34 static Scheme_Object *unsafe_fx_eq (int argc, Scheme_Object *argv[]);
35 static Scheme_Object *unsafe_fx_lt (int argc, Scheme_Object *argv[]);
36 static Scheme_Object *unsafe_fx_gt (int argc, Scheme_Object *argv[]);
37 static Scheme_Object *unsafe_fx_lt_eq (int argc, Scheme_Object *argv[]);
38 static Scheme_Object *unsafe_fx_gt_eq (int argc, Scheme_Object *argv[]);
39 static Scheme_Object *unsafe_fx_min (int argc, Scheme_Object *argv[]);
40 static Scheme_Object *unsafe_fx_max (int argc, Scheme_Object *argv[]);
41
42 static Scheme_Object *fl_eq (int argc, Scheme_Object *argv[]);
43 static Scheme_Object *fl_lt (int argc, Scheme_Object *argv[]);
44 static Scheme_Object *fl_gt (int argc, Scheme_Object *argv[]);
45 static Scheme_Object *fl_lt_eq (int argc, Scheme_Object *argv[]);
46 static Scheme_Object *fl_gt_eq (int argc, Scheme_Object *argv[]);
47 static Scheme_Object *fl_min (int argc, Scheme_Object *argv[]);
48 static Scheme_Object *fl_max (int argc, Scheme_Object *argv[]);
49
50 static Scheme_Object *unsafe_fl_eq (int argc, Scheme_Object *argv[]);
51 static Scheme_Object *unsafe_fl_lt (int argc, Scheme_Object *argv[]);
52 static Scheme_Object *unsafe_fl_gt (int argc, Scheme_Object *argv[]);
53 static Scheme_Object *unsafe_fl_lt_eq (int argc, Scheme_Object *argv[]);
54 static Scheme_Object *unsafe_fl_gt_eq (int argc, Scheme_Object *argv[]);
55 static Scheme_Object *unsafe_fl_min (int argc, Scheme_Object *argv[]);
56 static Scheme_Object *unsafe_fl_max (int argc, Scheme_Object *argv[]);
57
58 static Scheme_Object *extfl_eq (int argc, Scheme_Object *argv[]);
59 static Scheme_Object *extfl_lt (int argc, Scheme_Object *argv[]);
60 static Scheme_Object *extfl_gt (int argc, Scheme_Object *argv[]);
61 static Scheme_Object *extfl_lt_eq (int argc, Scheme_Object *argv[]);
62 static Scheme_Object *extfl_gt_eq (int argc, Scheme_Object *argv[]);
63 static Scheme_Object *extfl_min (int argc, Scheme_Object *argv[]);
64 static Scheme_Object *extfl_max (int argc, Scheme_Object *argv[]);
65
66 static Scheme_Object *unsafe_extfl_eq (int argc, Scheme_Object *argv[]);
67 static Scheme_Object *unsafe_extfl_lt (int argc, Scheme_Object *argv[]);
68 static Scheme_Object *unsafe_extfl_gt (int argc, Scheme_Object *argv[]);
69 static Scheme_Object *unsafe_extfl_lt_eq (int argc, Scheme_Object *argv[]);
70 static Scheme_Object *unsafe_extfl_gt_eq (int argc, Scheme_Object *argv[]);
71 static Scheme_Object *unsafe_extfl_min (int argc, Scheme_Object *argv[]);
72 static Scheme_Object *unsafe_extfl_max (int argc, Scheme_Object *argv[]);
73
74 #define zeroi scheme_exact_zero
75
scheme_init_numcomp(Scheme_Startup_Env * env)76 void scheme_init_numcomp(Scheme_Startup_Env *env)
77 {
78 Scheme_Object *p;
79
80 p = scheme_make_folding_prim(eq, "=", 1, -1, 1);
81 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
82 | SCHEME_PRIM_IS_NARY_INLINED
83 | SCHEME_PRIM_WANTS_NUMBER
84 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
85 | SCHEME_PRIM_AD_HOC_OPT
86 | SCHEME_PRIM_PRODUCES_BOOL);
87 scheme_addto_prim_instance("=", p, env);
88
89 p = scheme_make_folding_prim(lt, "<", 1, -1, 1);
90 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
91 | SCHEME_PRIM_IS_NARY_INLINED
92 | SCHEME_PRIM_WANTS_REAL
93 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
94 | SCHEME_PRIM_AD_HOC_OPT
95 | SCHEME_PRIM_PRODUCES_BOOL);
96 scheme_addto_prim_instance("<", p, env);
97
98 p = scheme_make_folding_prim(gt, ">", 1, -1, 1);
99 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
100 | SCHEME_PRIM_IS_NARY_INLINED
101 | SCHEME_PRIM_WANTS_REAL
102 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
103 | SCHEME_PRIM_AD_HOC_OPT
104 | SCHEME_PRIM_PRODUCES_BOOL);
105 scheme_addto_prim_instance(">", p, env);
106
107 p = scheme_make_folding_prim(lt_eq, "<=", 1, -1, 1);
108 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
109 | SCHEME_PRIM_IS_NARY_INLINED
110 | SCHEME_PRIM_WANTS_REAL
111 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
112 | SCHEME_PRIM_AD_HOC_OPT
113 | SCHEME_PRIM_PRODUCES_BOOL);
114 scheme_addto_prim_instance("<=", p, env);
115
116 p = scheme_make_folding_prim(gt_eq, ">=", 1, -1, 1);
117 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
118 | SCHEME_PRIM_IS_NARY_INLINED
119 | SCHEME_PRIM_WANTS_REAL
120 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
121 | SCHEME_PRIM_AD_HOC_OPT
122 | SCHEME_PRIM_PRODUCES_BOOL);
123 scheme_addto_prim_instance(">=", p, env);
124
125 p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1);
126 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
127 | SCHEME_PRIM_WANTS_NUMBER
128 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
129 | SCHEME_PRIM_PRODUCES_BOOL);
130 scheme_addto_prim_instance("zero?", p, env);
131
132 p = scheme_make_folding_prim(positive_p, "positive?", 1, 1, 1);
133 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
134 | SCHEME_PRIM_WANTS_REAL
135 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
136 | SCHEME_PRIM_PRODUCES_BOOL);
137 scheme_addto_prim_instance("positive?", p, env);
138
139 p = scheme_make_folding_prim(negative_p, "negative?", 1, 1, 1);
140 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
141 | SCHEME_PRIM_WANTS_REAL
142 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
143 | SCHEME_PRIM_PRODUCES_BOOL);
144 scheme_addto_prim_instance("negative?", p, env);
145
146 p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1);
147 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
148 | SCHEME_PRIM_IS_NARY_INLINED
149 | SCHEME_PRIM_WANTS_REAL
150 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
151 | SCHEME_PRIM_PRODUCES_REAL
152 | SCHEME_PRIM_AD_HOC_OPT);
153 scheme_addto_prim_instance("max", p, env);
154
155 p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1);
156 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
157 | SCHEME_PRIM_IS_NARY_INLINED
158 | SCHEME_PRIM_WANTS_REAL
159 | SCHEME_PRIM_OMITTABLE_ON_GOOD_ARGS
160 | SCHEME_PRIM_PRODUCES_REAL
161 | SCHEME_PRIM_AD_HOC_OPT);
162 scheme_addto_prim_instance("min", p, env);
163 }
164
scheme_init_flfxnum_numcomp(Scheme_Startup_Env * env)165 void scheme_init_flfxnum_numcomp(Scheme_Startup_Env *env)
166 {
167 Scheme_Object *p;
168 int flags;
169
170 p = scheme_make_folding_prim(fx_eq, "fx=", 1, -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_AD_HOC_OPT
174 | SCHEME_PRIM_PRODUCES_BOOL);
175 scheme_addto_prim_instance("fx=", p, env);
176
177 p = scheme_make_folding_prim(fx_lt, "fx<", 1, -1, 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_AD_HOC_OPT
181 | SCHEME_PRIM_PRODUCES_BOOL);
182 scheme_addto_prim_instance("fx<", p, env);
183
184 p = scheme_make_folding_prim(fx_gt, "fx>", 1, -1, 1);
185 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
186 | SCHEME_PRIM_IS_NARY_INLINED
187 | SCHEME_PRIM_AD_HOC_OPT
188 | SCHEME_PRIM_PRODUCES_BOOL);
189 scheme_addto_prim_instance("fx>", p, env);
190
191 p = scheme_make_folding_prim(fx_lt_eq, "fx<=", 1, -1, 1);
192 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
193 | SCHEME_PRIM_IS_NARY_INLINED
194 | SCHEME_PRIM_AD_HOC_OPT
195 | SCHEME_PRIM_PRODUCES_BOOL);
196 scheme_addto_prim_instance("fx<=", p, env);
197
198 p = scheme_make_folding_prim(fx_gt_eq, "fx>=", 1, -1, 1);
199 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
200 | SCHEME_PRIM_IS_NARY_INLINED
201 | SCHEME_PRIM_AD_HOC_OPT
202 | SCHEME_PRIM_PRODUCES_BOOL);
203 scheme_addto_prim_instance("fx>=", p, env);
204
205 p = scheme_make_folding_prim(fx_min, "fxmin", 1, -1, 1);
206 if (scheme_can_inline_fp_comp())
207 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
208 else
209 flags = SCHEME_PRIM_SOMETIMES_INLINED;
210 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
211 | SCHEME_PRIM_PRODUCES_FIXNUM
212 | SCHEME_PRIM_AD_HOC_OPT);
213 scheme_addto_prim_instance("fxmin", p, env);
214
215 p = scheme_make_folding_prim(fx_max, "fxmax", 1, -1, 1);
216 if (scheme_can_inline_fp_comp())
217 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
218 else
219 flags = SCHEME_PRIM_SOMETIMES_INLINED;
220 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
221 | SCHEME_PRIM_PRODUCES_FIXNUM
222 | SCHEME_PRIM_AD_HOC_OPT);
223 scheme_addto_prim_instance("fxmax", p, env);
224
225
226 p = scheme_make_folding_prim(fl_eq, "fl=", 1, -1, 1);
227 if (scheme_can_inline_fp_comp())
228 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
229 else
230 flags = SCHEME_PRIM_SOMETIMES_INLINED;
231 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
232 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
233 scheme_addto_prim_instance("fl=", p, env);
234
235 p = scheme_make_folding_prim(fl_lt, "fl<", 1, -1, 1);
236 if (scheme_can_inline_fp_comp())
237 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
238 else
239 flags = SCHEME_PRIM_SOMETIMES_INLINED;
240 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
241 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
242 scheme_addto_prim_instance("fl<", p, env);
243
244 p = scheme_make_folding_prim(fl_gt, "fl>", 1, -1, 1);
245 if (scheme_can_inline_fp_comp())
246 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
247 else
248 flags = SCHEME_PRIM_SOMETIMES_INLINED;
249 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
250 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
251 scheme_addto_prim_instance("fl>", p, env);
252
253 p = scheme_make_folding_prim(fl_lt_eq, "fl<=", 1, -1, 1);
254 if (scheme_can_inline_fp_comp())
255 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
256 else
257 flags = SCHEME_PRIM_SOMETIMES_INLINED;
258 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
259 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
260 scheme_addto_prim_instance("fl<=", p, env);
261
262 p = scheme_make_folding_prim(fl_gt_eq, "fl>=", 1, -1, 1);
263 if (scheme_can_inline_fp_comp())
264 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
265 else
266 flags = SCHEME_PRIM_SOMETIMES_INLINED;
267 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
268 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
269 scheme_addto_prim_instance("fl>=", p, env);
270
271 p = scheme_make_folding_prim(fl_min, "flmin", 1, -1, 1);
272 if (scheme_can_inline_fp_op())
273 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
274 else
275 flags = SCHEME_PRIM_SOMETIMES_INLINED;
276 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
277 | SCHEME_PRIM_PRODUCES_FLONUM
278 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
279 scheme_addto_prim_instance("flmin", p, env);
280
281 p = scheme_make_folding_prim(fl_max, "flmax", 1, -1, 1);
282 if (scheme_can_inline_fp_op())
283 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
284 else
285 flags = SCHEME_PRIM_SOMETIMES_INLINED;
286 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
287 | SCHEME_PRIM_PRODUCES_FLONUM
288 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
289 scheme_addto_prim_instance("flmax", p, env);
290 }
291
scheme_init_extfl_numcomp(Scheme_Startup_Env * env)292 void scheme_init_extfl_numcomp(Scheme_Startup_Env *env)
293 {
294 Scheme_Object *p;
295 int flags;
296
297 p = scheme_make_folding_prim(extfl_eq, "extfl=", 2, 2, 1);
298 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
299 flags = SCHEME_PRIM_IS_BINARY_INLINED;
300 else
301 flags = SCHEME_PRIM_SOMETIMES_INLINED;
302 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
303 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
304 scheme_addto_prim_instance("extfl=", p, env);
305
306 p = scheme_make_folding_prim(extfl_lt, "extfl<", 2, 2, 1);
307 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
308 flags = SCHEME_PRIM_IS_BINARY_INLINED;
309 else
310 flags = SCHEME_PRIM_SOMETIMES_INLINED;
311 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
312 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
313 scheme_addto_prim_instance("extfl<", p, env);
314
315 p = scheme_make_folding_prim(extfl_gt, "extfl>", 2, 2, 1);
316 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
317 flags = SCHEME_PRIM_IS_BINARY_INLINED;
318 else
319 flags = SCHEME_PRIM_SOMETIMES_INLINED;
320 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
321 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
322 scheme_addto_prim_instance("extfl>", p, env);
323
324 p = scheme_make_folding_prim(extfl_lt_eq, "extfl<=", 2, 2, 1);
325 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
326 flags = SCHEME_PRIM_IS_BINARY_INLINED;
327 else
328 flags = SCHEME_PRIM_SOMETIMES_INLINED;
329 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
330 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
331 scheme_addto_prim_instance("extfl<=", p, env);
332
333 p = scheme_make_folding_prim(extfl_gt_eq, "extfl>=", 2, 2, 1);
334 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
335 flags = SCHEME_PRIM_IS_BINARY_INLINED;
336 else
337 flags = SCHEME_PRIM_SOMETIMES_INLINED;
338 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
339 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
340 scheme_addto_prim_instance("extfl>=", p, env);
341
342 p = scheme_make_folding_prim(extfl_min, "extflmin", 2, 2, 1);
343 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
344 flags = SCHEME_PRIM_IS_BINARY_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_BOTH);
350 scheme_addto_prim_instance("extflmin", p, env);
351
352 p = scheme_make_folding_prim(extfl_max, "extflmax", 2, 2, 1);
353 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
354 flags = SCHEME_PRIM_IS_BINARY_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_BOTH);
360 scheme_addto_prim_instance("extflmax", p, env);
361 }
362
scheme_init_unsafe_numcomp(Scheme_Startup_Env * env)363 void scheme_init_unsafe_numcomp(Scheme_Startup_Env *env)
364 {
365 Scheme_Object *p;
366 int flags;
367
368 REGISTER_SO(scheme_unsafe_fx_eq_proc);
369 p = scheme_make_folding_prim(unsafe_fx_eq, "unsafe-fx=", 1, -1, 1);
370 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
371 | SCHEME_PRIM_IS_NARY_INLINED
372 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
373 scheme_addto_prim_instance("unsafe-fx=", p, env);
374 scheme_unsafe_fx_eq_proc = p;
375
376 REGISTER_SO(scheme_unsafe_fx_lt_proc);
377 p = scheme_make_folding_prim(unsafe_fx_lt, "unsafe-fx<", 1, -1, 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_addto_prim_instance("unsafe-fx<", p, env);
382 scheme_unsafe_fx_lt_proc = p;
383
384 REGISTER_SO(scheme_unsafe_fx_gt_proc);
385 p = scheme_make_folding_prim(unsafe_fx_gt, "unsafe-fx>", 1, -1, 1);
386 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
387 | SCHEME_PRIM_IS_NARY_INLINED
388 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
389 scheme_addto_prim_instance("unsafe-fx>", p, env);
390 scheme_unsafe_fx_gt_proc = p;
391
392 REGISTER_SO(scheme_unsafe_fx_lt_eq_proc);
393 p = scheme_make_folding_prim(unsafe_fx_lt_eq, "unsafe-fx<=", 1, -1, 1);
394 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
395 | SCHEME_PRIM_IS_NARY_INLINED
396 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
397 scheme_addto_prim_instance("unsafe-fx<=", p, env);
398 scheme_unsafe_fx_lt_eq_proc = p;
399
400 REGISTER_SO(scheme_unsafe_fx_gt_eq_proc);
401 p = scheme_make_folding_prim(unsafe_fx_gt_eq, "unsafe-fx>=", 1, -1, 1);
402 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
403 | SCHEME_PRIM_IS_NARY_INLINED
404 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
405 scheme_addto_prim_instance("unsafe-fx>=", p, env);
406 scheme_unsafe_fx_gt_eq_proc = p;
407
408 REGISTER_SO(scheme_unsafe_fx_min_proc);
409 p = scheme_make_folding_prim(unsafe_fx_min, "unsafe-fxmin", 1, -1, 1);
410 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
411 | SCHEME_PRIM_IS_NARY_INLINED
412 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
413 | SCHEME_PRIM_PRODUCES_FIXNUM);
414 scheme_addto_prim_instance("unsafe-fxmin", p, env);
415 scheme_unsafe_fx_min_proc = p;
416
417 REGISTER_SO(scheme_unsafe_fx_max_proc);
418 p = scheme_make_folding_prim(unsafe_fx_max, "unsafe-fxmax", 1, -1, 1);
419 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
420 | SCHEME_PRIM_IS_NARY_INLINED
421 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
422 | SCHEME_PRIM_PRODUCES_FIXNUM);
423 scheme_addto_prim_instance("unsafe-fxmax", p, env);
424 scheme_unsafe_fx_max_proc = p;
425
426 p = scheme_make_folding_prim(unsafe_fl_eq, "unsafe-fl=", 1, -1, 1);
427 if (scheme_can_inline_fp_comp())
428 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
429 else
430 flags = SCHEME_PRIM_SOMETIMES_INLINED;
431 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
432 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
433 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
434 scheme_addto_prim_instance("unsafe-fl=", p, env);
435
436 p = scheme_make_folding_prim(unsafe_fl_lt, "unsafe-fl<", 1, -1, 1);
437 if (scheme_can_inline_fp_comp())
438 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
439 else
440 flags = SCHEME_PRIM_SOMETIMES_INLINED;
441 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
442 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
443 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
444 scheme_addto_prim_instance("unsafe-fl<", p, env);
445
446 p = scheme_make_folding_prim(unsafe_fl_gt, "unsafe-fl>", 1, -1, 1);
447 if (scheme_can_inline_fp_comp())
448 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
449 else
450 flags = SCHEME_PRIM_SOMETIMES_INLINED;
451 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
452 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
453 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
454 scheme_addto_prim_instance("unsafe-fl>", p, env);
455
456 p = scheme_make_folding_prim(unsafe_fl_lt_eq, "unsafe-fl<=", 1, -1, 1);
457 if (scheme_can_inline_fp_comp())
458 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
459 else
460 flags = SCHEME_PRIM_SOMETIMES_INLINED;
461 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
462 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
463 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
464 scheme_addto_prim_instance("unsafe-fl<=", p, env);
465
466 p = scheme_make_folding_prim(unsafe_fl_gt_eq, "unsafe-fl>=", 1, -1, 1);
467 if (scheme_can_inline_fp_comp())
468 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_INLINED);
469 else
470 flags = SCHEME_PRIM_SOMETIMES_INLINED;
471 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
472 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
473 | SCHEME_PRIM_WANTS_FLONUM_BOTH);
474 scheme_addto_prim_instance("unsafe-fl>=", p, env);
475
476 p = scheme_make_folding_prim(unsafe_fl_min, "unsafe-flmin", 1, -1, 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-flmin", p, env);
486
487 p = scheme_make_folding_prim(unsafe_fl_max, "unsafe-flmax", 1, -1, 1);
488 if (scheme_can_inline_fp_op())
489 flags = (SCHEME_PRIM_IS_BINARY_INLINED | SCHEME_PRIM_IS_NARY_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_BOTH);
496 scheme_addto_prim_instance("unsafe-flmax", p, env);
497 }
498
scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env * env)499 void scheme_init_extfl_unsafe_numcomp(Scheme_Startup_Env *env)
500 {
501 Scheme_Object *p;
502 int flags;
503
504 p = scheme_make_folding_prim(unsafe_extfl_eq, "unsafe-extfl=", 2, 2, 1);
505 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
506 flags = SCHEME_PRIM_IS_BINARY_INLINED;
507 else
508 flags = SCHEME_PRIM_SOMETIMES_INLINED;
509 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
510 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
511 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
512 scheme_addto_prim_instance("unsafe-extfl=", p, env);
513
514 p = scheme_make_folding_prim(unsafe_extfl_lt, "unsafe-extfl<", 2, 2, 1);
515 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
516 flags = SCHEME_PRIM_IS_BINARY_INLINED;
517 else
518 flags = SCHEME_PRIM_SOMETIMES_INLINED;
519 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
520 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
521 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
522 scheme_addto_prim_instance("unsafe-extfl<", p, env);
523
524 p = scheme_make_folding_prim(unsafe_extfl_gt, "unsafe-extfl>", 2, 2, 1);
525 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
526 flags = SCHEME_PRIM_IS_BINARY_INLINED;
527 else
528 flags = SCHEME_PRIM_SOMETIMES_INLINED;
529 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
530 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
531 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
532 scheme_addto_prim_instance("unsafe-extfl>", p, env);
533
534 p = scheme_make_folding_prim(unsafe_extfl_lt_eq, "unsafe-extfl<=", 2, 2, 1);
535 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
536 flags = SCHEME_PRIM_IS_BINARY_INLINED;
537 else
538 flags = SCHEME_PRIM_SOMETIMES_INLINED;
539 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
540 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
541 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
542 scheme_addto_prim_instance("unsafe-extfl<=", p, env);
543
544 p = scheme_make_folding_prim(unsafe_extfl_gt_eq, "unsafe-extfl>=", 2, 2, 1);
545 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_comp()))
546 flags = SCHEME_PRIM_IS_BINARY_INLINED;
547 else
548 flags = SCHEME_PRIM_SOMETIMES_INLINED;
549 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
550 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
551 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
552 scheme_addto_prim_instance("unsafe-extfl>=", p, env);
553
554 p = scheme_make_folding_prim(unsafe_extfl_min, "unsafe-extflmin", 2, 2, 1);
555 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
556 flags = SCHEME_PRIM_IS_BINARY_INLINED;
557 else
558 flags = SCHEME_PRIM_SOMETIMES_INLINED;
559 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
560 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
561 | SCHEME_PRIM_PRODUCES_EXTFLONUM
562 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
563 scheme_addto_prim_instance("unsafe-extflmin", p, env);
564
565 p = scheme_make_folding_prim(unsafe_extfl_max, "unsafe-extflmax", 2, 2, 1);
566 if (MZ_LONG_DOUBLE_AVAIL_AND(scheme_can_inline_fp_op()))
567 flags = SCHEME_PRIM_IS_BINARY_INLINED;
568 else
569 flags = SCHEME_PRIM_SOMETIMES_INLINED;
570 SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags
571 | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
572 | SCHEME_PRIM_PRODUCES_EXTFLONUM
573 | SCHEME_PRIM_WANTS_EXTFLONUM_BOTH);
574 scheme_addto_prim_instance("unsafe-extflmax", p, env);
575 }
576
577 /* Prototype needed for 3m conversion: */
578 static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr);
579
force_rat(Scheme_Object * n,Small_Rational * sr)580 static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr)
581 XFORM_SKIP_PROC
582 {
583 Scheme_Type t = SCHEME_TYPE(n);
584 if (t == scheme_rational_type)
585 return n;
586 else
587 return scheme_make_small_bn_rational(n, sr);
588 }
589
590 GEN_NARY_COMP(eq, "=", scheme_bin_eq, SCHEME_NUMBERP, "number?")
591 GEN_NARY_COMP(lt, "<", scheme_bin_lt, SCHEME_REALP, "real?")
592 GEN_NARY_COMP(gt, ">", scheme_bin_gt, SCHEME_REALP, "real?")
593 GEN_NARY_COMP(lt_eq, "<=", scheme_bin_lt_eq, SCHEME_REALP, "real?")
594 GEN_NARY_COMP(gt_eq, ">=", scheme_bin_gt_eq, SCHEME_REALP, "real?")
595
596 #define EQUAL(x, y) (x == y)
597 #define LESS_THAN(x, y) (x < y)
598 #define GREATER_THAN(x, y) (x > y)
599 #define LESS_OR_EQUAL(x, y) (x <= y)
600 #define GREATER_OR_EQUAL(x, y) (x >= y)
601
602 #ifdef NAN_LT_COMPARISON_WRONG
603 # define fLESS_THAN(x, y) (!(x >= y) && (x == x) && (y == y))
604 # define fLESS_OR_EQUAL(x, y) (!(x > y) && (x == x) && (y == y))
605 #else
606 # define fLESS_THAN LESS_THAN
607 # define fLESS_OR_EQUAL LESS_OR_EQUAL
608 #endif
609
610 #define COMP_IZI_LT(a, b) scheme_bin_lt(IZI_REAL_PART(a), IZI_REAL_PART(b))
611 #define COMP_IZI_GT(a, b) scheme_bin_gt(IZI_REAL_PART(a), IZI_REAL_PART(b))
612 #define COMP_IZI_LT_EQ(a, b) scheme_bin_lt_eq(IZI_REAL_PART(a), IZI_REAL_PART(b))
613 #define COMP_IZI_GT_EQ(a, b) scheme_bin_gt_eq(IZI_REAL_PART(a), IZI_REAL_PART(b))
614
615 #define GEN_IDENT_FOR_IZI GEN_OMIT
616
617 GEN_BIN_COMP(scheme_bin_eq, "=", EQUAL, EQUAL, scheme_bignum_eq, scheme_rational_eq, scheme_complex_eq, 0, 0, scheme_is_inexact, scheme_is_inexact, GEN_IDENT, GEN_IDENT, "number?")
618 GEN_BIN_COMP(scheme_bin_lt, "<", LESS_THAN, fLESS_THAN, scheme_bignum_lt, scheme_rational_lt, COMP_IZI_LT, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, "real?")
619 GEN_BIN_COMP(scheme_bin_gt, ">", GREATER_THAN, GREATER_THAN, scheme_bignum_gt, scheme_rational_gt, COMP_IZI_GT, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, "real?")
620 GEN_BIN_COMP(scheme_bin_lt_eq, "<=", LESS_OR_EQUAL, fLESS_OR_EQUAL, scheme_bignum_le, scheme_rational_le, COMP_IZI_LT_EQ, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, "real?")
621 GEN_BIN_COMP(scheme_bin_gt_eq, ">=", GREATER_OR_EQUAL, GREATER_OR_EQUAL, scheme_bignum_ge, scheme_rational_ge, COMP_IZI_GT_EQ, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, "real?")
622
623 int
scheme_is_zero(const Scheme_Object * o)624 scheme_is_zero(const Scheme_Object *o)
625 {
626 Scheme_Type t;
627
628 if (SCHEME_INTP(o))
629 return o == zeroi;
630 t = _SCHEME_TYPE(o);
631 #ifdef MZ_USE_SINGLE_FLOATS
632 if (t == scheme_float_type) {
633 # ifdef NAN_EQUALS_ANYTHING
634 if (MZ_IS_NAN(SCHEME_FLT_VAL(o)))
635 return 0;
636 # endif
637 return SCHEME_FLT_VAL(o) == 0.0f;
638 }
639 #endif
640 if (t == scheme_double_type) {
641 #ifdef NAN_EQUALS_ANYTHING
642 if (MZ_IS_NAN(SCHEME_DBL_VAL(o)))
643 return 0;
644 #endif
645 return SCHEME_DBL_VAL(o) == 0.0;
646 }
647 if (t == scheme_complex_type) {
648 if (scheme_is_zero(scheme_complex_imaginary_part(o)))
649 return scheme_is_zero(scheme_complex_real_part(o));
650 return 0;
651 }
652
653 if ((t >= scheme_bignum_type) && (t <= scheme_complex_type))
654 return 0;
655
656 return -1;
657 }
658
659 Scheme_Object *
zero_p(int argc,Scheme_Object * argv[])660 zero_p (int argc, Scheme_Object *argv[])
661 {
662 int v;
663 v = scheme_is_zero(argv[0]);
664 if (v < 0) {
665 NEED_NUMBER(zero?);
666 ESCAPED_BEFORE_HERE;
667 }
668 return (v ? scheme_true : scheme_false);
669 }
670
671 int
scheme_is_positive(const Scheme_Object * o)672 scheme_is_positive(const Scheme_Object *o)
673 {
674 Scheme_Type t;
675
676 if (SCHEME_INTP(o))
677 return SCHEME_INT_VAL(o) > 0;
678 t = _SCHEME_TYPE(o);
679 #ifdef MZ_USE_SINGLE_FLOATS
680 if (t == scheme_float_type) {
681 float d = SCHEME_FLT_VAL(o);
682 # ifdef NAN_EQUALS_ANYTHING
683 if (MZ_IS_NAN(d))
684 return 0;
685 # endif
686 return d > 0;
687 }
688 #endif
689 if (t == scheme_double_type) {
690 double d = SCHEME_DBL_VAL(o);
691 #ifdef NAN_EQUALS_ANYTHING
692 if (MZ_IS_NAN(d))
693 return 0;
694 #endif
695 return d > 0;
696 }
697 if (t == scheme_bignum_type)
698 return SCHEME_BIGPOS(o);
699 if (t == scheme_rational_type)
700 return scheme_is_rational_positive(o);
701
702 return -1;
703 }
704
705 Scheme_Object *
positive_p(int argc,Scheme_Object * argv[])706 positive_p (int argc, Scheme_Object *argv[])
707 {
708 int v;
709 v = scheme_is_positive(argv[0]);
710 if (v < 0) {
711 NEED_REAL(positive?);
712 ESCAPED_BEFORE_HERE;
713 }
714 return (v ? scheme_true : scheme_false);
715 }
716
717 int
scheme_is_negative(const Scheme_Object * o)718 scheme_is_negative(const Scheme_Object *o)
719 {
720 Scheme_Type t;
721
722 if (SCHEME_INTP(o))
723 return SCHEME_INT_VAL(o) < 0;
724 t = _SCHEME_TYPE(o);
725 #ifdef MZ_USE_SINGLE_FLOATS
726 if (t == scheme_float_type) {
727 float d = SCHEME_FLT_VAL(o);
728 # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG)
729 if (MZ_IS_NAN(d))
730 return 0;
731 # endif
732 return d < 0;
733 }
734 #endif
735 if (t == scheme_double_type) {
736 double d = SCHEME_DBL_VAL(o);
737 # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG)
738 if (MZ_IS_NAN(d))
739 return 0;
740 #endif
741 return d < 0;
742 }
743 if (t == scheme_bignum_type)
744 return !SCHEME_BIGPOS(o);
745 if (t == scheme_rational_type)
746 return !scheme_is_rational_positive(o);
747
748 return -1;
749 }
750
751 Scheme_Object *
negative_p(int argc,Scheme_Object * argv[])752 negative_p (int argc, Scheme_Object *argv[])
753 {
754 int v;
755 v = scheme_is_negative(argv[0]);
756 if (v < 0) {
757 NEED_REAL(negative?);
758 ESCAPED_BEFORE_HERE;
759 }
760 return (v ? scheme_true : scheme_false);
761 }
762
763 #define MAX(n1,n2) scheme_make_integer((n1>n2) ? n1 : n2)
764 #define MIN(n1,n2) scheme_make_integer((n1<n2) ? n1 : n2)
765 #define F_MAX(n1,n2) scheme_make_double((n1>n2) ? n1 : n2)
766 #define F_MIN(n1,n2) scheme_make_double((n1<n2) ? n1 : n2)
767
768 #define FS_MAX(n1,n2) scheme_make_float((n1>n2) ? n1 : n2)
769 #define FS_MIN(n1,n2) scheme_make_float((n1<n2) ? n1 : n2)
770
771 #define MAX_IZI(a, b) bin_max(IZI_REAL_PART(a), IZI_REAL_PART(b))
772 #define MIN_IZI(a, b) bin_min(IZI_REAL_PART(a), IZI_REAL_PART(b))
773
774 static GEN_BIN_OP(bin_max, "max", MAX, F_MAX, FS_MAX, scheme_bignum_max, scheme_rational_max, MAX_IZI, GEN_OMIT, GEN_OMIT, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
775 static GEN_BIN_OP(bin_min, "min", MIN, F_MIN, FS_MIN, scheme_bignum_min, scheme_rational_min, MIN_IZI, GEN_OMIT, GEN_OMIT, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
776
777 GEN_TWOARY_OP(static, sch_max, "max", bin_max, SCHEME_REALP, "real?")
778 GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, "real?")
779
780 /************************************************************************/
781 /* Flfx */
782 /************************************************************************/
783
784 #define SAFE_FX_X(name, s_name, op, T, F, result_init, loop_arg, loop_F) \
785 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
786 { \
787 if (!SCHEME_INTP(argv[0])) scheme_wrong_contract(s_name, "fixnum?", 0, argc, argv); \
788 if (argc == 2) { \
789 if (!SCHEME_INTP(argv[1])) scheme_wrong_contract(s_name, "fixnum?", 1, argc, argv); \
790 if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
791 return T; \
792 else \
793 return F; \
794 } else { \
795 int i; \
796 Scheme_Object *result = result_init; \
797 for (i = 1; i < argc; i++) { \
798 if (!SCHEME_INTP(argv[i])) scheme_wrong_contract(s_name, "fixnum?", i, argc, argv); \
799 if (!(SCHEME_INT_VAL(loop_arg) op SCHEME_INT_VAL(argv[i]))) \
800 result = loop_F; \
801 } \
802 return result; \
803 } \
804 }
805
806 #define SAFE_FX(name, s_name, op) SAFE_FX_X(name, s_name, op, scheme_true, scheme_false, scheme_true, argv[i-1], scheme_false)
807
808 SAFE_FX(fx_eq, "fx=", ==)
809 SAFE_FX(fx_lt, "fx<", <)
810 SAFE_FX(fx_gt, "fx>", >)
811 SAFE_FX(fx_lt_eq, "fx<=", <=)
812 SAFE_FX(fx_gt_eq, "fx>=", >=)
813 SAFE_FX_X(fx_min, "fxmin", <, argv[0], argv[1], argv[0], result, argv[i])
814 SAFE_FX_X(fx_max, "fxmax", >, argv[0], argv[1], argv[0], result, argv[i])
815
816 #define UNSAFE_FX_X(name, op, fold, T, F, result_init, loop_arg, loop_F) \
817 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
818 { \
819 if (scheme_current_thread->constant_folding) return fold(argc, argv); \
820 if (argc == 2) { \
821 if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
822 return T; \
823 else \
824 return F; \
825 } else { \
826 int i; \
827 Scheme_Object *result = result_init; \
828 for (i = 1; i < argc; i++) { \
829 if (!(SCHEME_INT_VAL(loop_arg) op SCHEME_INT_VAL(argv[i]))) \
830 result = loop_F; \
831 } \
832 return result; \
833 } \
834 }
835
836 #define UNSAFE_FX(name, op, fold) UNSAFE_FX_X(name, op, fold, scheme_true, scheme_false, scheme_true, argv[i-1], scheme_false)
837
838 UNSAFE_FX(unsafe_fx_eq, ==, eq)
839 UNSAFE_FX(unsafe_fx_lt, <, lt)
840 UNSAFE_FX(unsafe_fx_gt, >, gt)
841 UNSAFE_FX(unsafe_fx_lt_eq, <=, lt_eq)
842 UNSAFE_FX(unsafe_fx_gt_eq, >=, gt_eq)
843
844 UNSAFE_FX_X(unsafe_fx_min, <, sch_min, argv[0], argv[1], argv[0], result, argv[i])
845 UNSAFE_FX_X(unsafe_fx_max, >, sch_max, argv[0], argv[1], argv[0], result, argv[i])
846
847 #define SAFE_FL_X(name, s_name, op, T, F, PRE_CHECK, result_init, loop_arg, loop_F, LOOP_PRE_CHECK) \
848 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
849 { \
850 if (!SCHEME_DBLP(argv[0])) scheme_wrong_contract(s_name, "flonum?", 0, argc, argv); \
851 if (argc == 2) { \
852 if (!SCHEME_DBLP(argv[1])) scheme_wrong_contract(s_name, "flonum?", 1, argc, argv); \
853 PRE_CHECK \
854 if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
855 return T; \
856 else \
857 return F; \
858 } else { \
859 int i; \
860 Scheme_Object *result = result_init; \
861 for (i = 1; i < argc; i++) { \
862 if (!SCHEME_DBLP(argv[i])) scheme_wrong_contract(s_name, "flonum?", i, argc, argv); \
863 LOOP_PRE_CHECK \
864 if (!(SCHEME_DBL_VAL(loop_arg) op SCHEME_DBL_VAL(argv[i]))) \
865 result = loop_F; \
866 } \
867 return result; \
868 } \
869 }
870
871 #define SAFE_FL(name, sname, op) SAFE_FL_X(name, sname, op, scheme_true, scheme_false, ;, scheme_true, argv[i-1], scheme_false, ;)
872
873 SAFE_FL(fl_eq, "fl=", ==)
874 SAFE_FL(fl_lt, "fl<", <)
875 SAFE_FL(fl_gt, "fl>", >)
876 SAFE_FL(fl_lt_eq, "fl<=", <=)
877 SAFE_FL(fl_gt_eq, "fl>=", >=)
878
879 #define CHECK_ARGV0_NAN { if (MZ_IS_NAN(SCHEME_DBL_VAL(argv[0])) || MZ_IS_NAN(SCHEME_DBL_VAL(argv[1]))) return scheme_nan_object; }
880 #define CHECK_ARGVi_NAN if (MZ_IS_NAN(SCHEME_DBL_VAL(result)) || MZ_IS_NAN(SCHEME_DBL_VAL(argv[i]))) { result = scheme_nan_object; } else
881
882 SAFE_FL_X(fl_min, "flmin", <, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
883 SAFE_FL_X(fl_max, "flmax", >, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
884
885 #define UNSAFE_FL_X(name, op, fold, T, F, PRE_CHECK, result_init, loop_arg, loop_F, LOOP_PRE_CHECK) \
886 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
887 { \
888 if (scheme_current_thread->constant_folding) return fold(argc, argv); \
889 if (argc == 2) { \
890 PRE_CHECK \
891 if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
892 return T; \
893 else \
894 return F; \
895 } else { \
896 int i; \
897 Scheme_Object *result = result_init; \
898 for (i = 1; i < argc; i++) { \
899 LOOP_PRE_CHECK \
900 if (!(SCHEME_DBL_VAL(loop_arg) op SCHEME_DBL_VAL(argv[i]))) \
901 result = loop_F; \
902 } \
903 return result; \
904 } \
905 }
906
907 #define UNSAFE_FL_COMP(name, op, fold) UNSAFE_FL_X(name, op, fold, scheme_true, scheme_false, ;, scheme_true, argv[i-1], scheme_false, ;)
908
909 UNSAFE_FL_COMP(unsafe_fl_eq, ==, eq)
910 UNSAFE_FL_COMP(unsafe_fl_lt, <, lt)
911 UNSAFE_FL_COMP(unsafe_fl_gt, >, gt)
912 UNSAFE_FL_COMP(unsafe_fl_lt_eq, <=, lt_eq)
913 UNSAFE_FL_COMP(unsafe_fl_gt_eq, >=, gt_eq)
914
915 UNSAFE_FL_X(unsafe_fl_min, <, sch_min, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
916 UNSAFE_FL_X(unsafe_fl_max, >, sch_max, argv[0], argv[1], CHECK_ARGV0_NAN, argv[0], result, argv[i], CHECK_ARGVi_NAN)
917
918 #ifdef MZ_LONG_DOUBLE
919 # define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \
920 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
921 { \
922 CHECK_MZ_LONG_DOUBLE_UNSUPPORTED(sname); \
923 if (!SCHEME_LONG_DBLP(argv[0])) scheme_wrong_contract(sname, "extflonum?", 0, argc, argv); \
924 if (!SCHEME_LONG_DBLP(argv[1])) scheme_wrong_contract(sname, "extflonum?", 1, argc, argv); \
925 PRE_CHECK \
926 if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
927 return T; \
928 else \
929 return F; \
930 }
931 #else
932 # define SAFE_EXTFL_X(name, sname, op, T, F, PRE_CHECK) \
933 static Scheme_Object * name(int argc, Scheme_Object *argv[]) \
934 { \
935 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
936 sname ": " NOT_SUPPORTED_STR); \
937 return NULL; \
938 }
939 #endif
940
941 #define SAFE_EXTFL(name, sname, op) SAFE_EXTFL_X(name, sname, op, scheme_true, scheme_false, ;)
942
943 SAFE_EXTFL(extfl_eq, "extfl=", long_double_eqv)
944 SAFE_EXTFL(extfl_lt, "extfl<", long_double_less)
945 SAFE_EXTFL(extfl_gt, "extfl>", long_double_greater)
946 SAFE_EXTFL(extfl_lt_eq, "extfl<=", long_double_less_or_eqv)
947 SAFE_EXTFL(extfl_gt_eq, "extfl>=", long_double_greater_or_eqv)
948
949 #define CHECK_ARGV0_LONG_NAN { if (MZ_IS_LONG_NAN(SCHEME_LONG_DBL_VAL(argv[0]))) return argv[0]; }
950
951 SAFE_EXTFL_X(extfl_min, "extflmin", long_double_less, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
952 SAFE_EXTFL_X(extfl_max, "extflmax", long_double_greater, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
953
954 #ifdef MZ_LONG_DOUBLE
955 /* Unsafe EXTFL comparisons. Return boolean */
956 /* removed if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \ */
957 # define UNSAFE_EXTFL_COMP(name, op) \
958 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
959 { \
960 if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
961 return scheme_true; \
962 else \
963 return scheme_false; \
964 }
965
966 /* Unsafe EXTFL binary operators. Return extflonum */
967 /* removed if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1])); \ */
968 # define UNSAFE_EXTFL_BINOP(name, op, T, F, PRE_CHECK) \
969 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
970 { \
971 PRE_CHECK \
972 CHECK_MZ_LONG_DOUBLE_UNSUPPORTED("extfl" #op); \
973 if (op(SCHEME_LONG_DBL_VAL(argv[0]), SCHEME_LONG_DBL_VAL(argv[1]))) \
974 return T; \
975 else \
976 return F; \
977 }
978 #else
979 # define UNSAFE_EXTFL_COMP(name, op) \
980 static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
981 { \
982 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, \
983 "unsafe-extfl" #op ": " NOT_SUPPORTED_STR); \
984 return NULL; \
985 }
986 # define UNSAFE_EXTFL_BINOP(name, op, T, F, PRE_CHECK) UNSAFE_EXTFL_COMP(name, op)
987 #endif
988
989 UNSAFE_EXTFL_COMP(unsafe_extfl_eq, long_double_eqv)
990 UNSAFE_EXTFL_COMP(unsafe_extfl_lt, long_double_less)
991 UNSAFE_EXTFL_COMP(unsafe_extfl_gt, long_double_greater)
992 UNSAFE_EXTFL_COMP(unsafe_extfl_lt_eq, long_double_less_or_eqv)
993 UNSAFE_EXTFL_COMP(unsafe_extfl_gt_eq, long_double_greater_or_eqv)
994
995 UNSAFE_EXTFL_BINOP(unsafe_extfl_min, long_double_less, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
996 UNSAFE_EXTFL_BINOP(unsafe_extfl_max, long_double_greater, argv[0], argv[1], CHECK_ARGV0_LONG_NAN)
997
998