1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
/* ocamlgsl - OCaml interface to GSL */
/* Copyright () 2002 - Olivier Andrieu */
/* distributed under the terms of the GPL version 2 */
#include <gsl/gsl_ieee_utils.h>
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include "wrappers.h"
static value rep_val(const gsl_ieee_double_rep *r)
{
CAMLparam0();
CAMLlocal2(v, m);
m=copy_string(r->mantissa);
v=alloc_small(4, 0);
Field(v, 0)= Val_int(r->sign);
Field(v, 1)= m;
Field(v, 2)= Val_int(r->exponent);
Field(v, 3)= Val_int(r->type - 1);
CAMLreturn(v);
}
value ml_gsl_ieee_double_to_rep(value x)
{
double d;
gsl_ieee_double_rep r;
d = Double_val(x);
gsl_ieee_double_to_rep(&d, &r);
return rep_val(&r);
}
value ml_gsl_ieee_env_setup(value unit)
{
gsl_ieee_env_setup();
return Val_unit;
}
value ml_gsl_ieee_set_mode(value oprecision, value orounding, value ex_list)
{
const int precision_conv [] = {
GSL_IEEE_SINGLE_PRECISION, GSL_IEEE_DOUBLE_PRECISION, GSL_IEEE_EXTENDED_PRECISION };
const int round_conv [] = {
GSL_IEEE_ROUND_TO_NEAREST, GSL_IEEE_ROUND_DOWN, GSL_IEEE_ROUND_UP, GSL_IEEE_ROUND_TO_ZERO };
int mask_conv [] = {
GSL_IEEE_MASK_INVALID, GSL_IEEE_MASK_DENORMALIZED,
GSL_IEEE_MASK_DENORMALIZED, GSL_IEEE_MASK_OVERFLOW,
GSL_IEEE_MASK_UNDERFLOW, GSL_IEEE_MASK_ALL,
GSL_IEEE_TRAP_INEXACT } ;
int mask = convert_flag_list(ex_list, mask_conv);
#define Lookup_precision(v) precision_conv[ Int_val(v) ]
#define Lookup_round(v) round_conv[ Int_val(v) ]
gsl_ieee_set_mode(Opt_arg(oprecision, Lookup_precision, 0),
Opt_arg(orounding, Lookup_round, 0),
mask);
return Val_unit;
}
#ifdef HAVE_FENV
#include <fenv.h>
static int except_conv [] = {
#ifdef FE_INEXACT
FE_INEXACT,
#else
0,
#endif
#ifdef FE_DIVBYZERO
FE_DIVBYZERO,
#else
0,
#endif
#ifdef FE_UNDERFLOW
FE_UNDERFLOW,
#else
0,
#endif
#ifdef FE_OVERFLOW
FE_OVERFLOW,
#else
0,
#endif
#ifdef FE_INVALID
FE_INVALID,
#else
0,
#endif
#ifdef FE_ALL_EXCEPT
FE_ALL_EXCEPT,
#else
0,
#endif
};
static int conv_excepts(value e)
{
return convert_flag_list(e, except_conv);
}
static value rev_conv_excepts(int e)
{
CAMLparam0();
CAMLlocal2(v, c);
int i, tab_size = (sizeof except_conv / sizeof (int)) ;
v = Val_emptylist;
for(i = tab_size-2; i >= 0 ; i--)
if(except_conv[i] & e) {
c = alloc_small(2, Tag_cons);
Field(c, 0) = Val_int(i);
Field(c, 1) = v;
v = c;
}
CAMLreturn(v);
}
CAMLprim value ml_feclearexcept(value e)
{
feclearexcept(conv_excepts(e));
return Val_unit;
}
CAMLprim value ml_fetestexcept(value e)
{
return rev_conv_excepts(fetestexcept(conv_excepts(e)));
}
#else /* HAVE_FENV */
CAMLprim value ml_feclearexcept(value e)
{
return Val_unit;
}
CAMLprim value ml_fetestexcept(value e)
{
return Val_emptylist;
}
#endif /* HAVE_FENV */
|
