1 #!/usr/local/bin/perl -w
2 # -----------------------------------------------------------------------------
21 # "qgamma.c", # Not good enough.
58 # These are for plugin fn-R. They are so small it makes no sense to place
71 my $mathfunc = $ARGV[0];
73 my $subdir = "src/nmath";
75 unless (defined ($mathfunc) && -r
$mathfunc &&
76 defined ($dir) && -d
"$dir/$subdir") {
77 print STDERR
"Usage: $0 mathfunc.c R-directory\n";
82 my ($prefix,$postfix) = &read_mathfunc
($mathfunc);
86 print "/* The following source code was imported from the R project. */\n";
87 print "/* It was automatically transformed by $0. */\n";
90 foreach my $file (@files) {
91 my $cleandefs = ($file =~ /\.c$/);
92 print "/* Imported $subdir/$file from R. */\n";
93 &import_file
("$dir/$subdir/$file", $cleandefs);
97 # -----------------------------------------------------------------------------
100 my ($filename,$cleandefs) = @_;
103 my $incomment = 0; # Stupid.
106 open (*FIL
, "<$filename") or
107 die "$0: Cannot read $filename: $!\n";
110 if (/^\s*\#\s*ifndef\s+GNUMERIC_VERSION\b/ ... /^\s*\#\s*endif\b.*\bGNUMERIC_VERSION\b/) {
114 if (/^\s*\#\s*define\s+([a-zA-Z0-9_]+)/) {
116 } elsif (/^\s*\#\s*undef\s+([a-zA-Z0-9_]+)/) {
118 } elsif (/^\s*\#\s*include\s+/) {
123 $_ .= <FIL
> if /^static\s+double\s*$/;
127 $incomment = 0 if m
|\
*/|;
129 s/\bdouble\b/gnm_float/g;
130 s/\bRboolean\b/gboolean/g;
132 s/^(\s*)(const\s+gnm_float\s+([a-zA-Z_][a-zA-Z0-9_]*)\s*\[\s*\d+\s*\]\s*=)/$1static $2/;
134 # Improve precision of "log(1-x)".
135 s/\blog\s*\(\s*1\s*-\s*([a-zA-Z0-9_]+)\s*\)/gnm_log1p (-$1)/g;
137 # Improve precision of "log(1+x)".
138 s/\blog\s*\(\s*1\s*\+\s*/gnm_log1p \(/g;
140 s/\bISNAN\b/gnm_isnan/g;
141 s/\bR_(finite|FINITE)\b/gnm_finite/g;
142 s/\b(sqrt|exp|log|pow|log1p|expm1|floor|ceil|sin|cos|sinh|tan)(\s|$|\()/gnm_$1$2/g;
143 s/\bfabs\b/gnm_abs/g;
145 s/\bgnm_floor\s*\(\s*([a-z]+)\s*\+\s*1e-7\s*\)/gnm_fake_floor($1)/;
148 s/\b(M_LN2|M_PI|M_PI_2|M_SQRT2|M_2PI)\b/$1gnum/g;
149 s/\bDBL_(EPSILON|MIN|MAX)/GNM_$1/g;
150 s/([-+]?\d*\.(\d{5,})([eE][-+]?\d+)?)/GNM_const\($1\)/g;
151 s@
(\d
)\s
*/\s*(\d+\.\d*)@$1 / GNM_const\
($2\
)@g;
153 # Fix constant quotients.
154 s
~([-+]?\d
+\
.\d
*)(\s
*/\s
*)([-+e0
-9.]+)~GNM_const\
($1\
)$2$3~;
156 # These are made static.
157 s/^gnm_float\s+(pbeta_both|bd0|dpois_raw|chebyshev_eval|lgammacor|lbeta|pbeta_raw|dbinom_raw|bessel_[ijky]|bessel_[jy]_ex)\b/static gnm_float $1/;
158 s/^int\s+(chebyshev_init)/static int $1/;
161 s/\(\(-37\.5193 < x\) \|\| \(x < 8\.2924\)\)/((-37.5193 < x) && (x < 8.2924))/;
163 # Optimization given our stupid gammafn.
164 s
|> 10|< 10| if /p and q are small: p <= q > 10/;
165 s
|gnm_log\
(gammafn\
(p\
) \
* \
(gammafn\
(q\
) / gammafn\
(p \
+ q\
)\
)\
)|gnm_lgamma
(p
) + gnm_lgamma
(q
) - gnm_lgamma
(p
+ q
)|;
171 s/\b(trunc|ftrunc)\b/gnm_trunc/g;
172 s/\b(lgammafn|lgamma)\b/gnm_lgamma/g;
173 s/\bML_NAN\b/gnm_nan/g;
174 s/\bML_VALID\b/\!gnm_isnan/g;
175 s/\bML_NEGINF\b/gnm_ninf/g;
176 s/\bML_POSINF\b/gnm_pinf/g;
178 if ($filename !~ /\bpgamma\.c$/) {
179 # Improve precision of "lgammagnum(x+1)".
180 s/\bgnm_lgamma\s*\(([^()]+)\s*\+\s*1(\.0*)?\s*\)/lgamma1p ($1)/;
181 s/\bgamma_cody\s*\(1\.\s*\+\s*([^()]+)\s*\)/gnm_exp(lgamma1p ($1))/;
183 s/\bR_Log1_Exp\b/swap_log_tail/g;
185 if ($filename =~ m
|/bessel_i\
.c
$|) {
186 s/\bgamma_cody\(empal\)/gnm_exp(lgamma1p(nu))/;
189 s/\bgamma_cody\b/gnm_gamma/g;
191 if (/^(static\s+)?(gnm_float|int)\s+(chebyshev_init)\s*\(/ .. /^\}/) {
192 next unless s/^(static\s+)?(gnm_float|int)\s+([a-zA-Z0-9_]+)\s*\(.*//;
193 $_ = "/* Definition of function $3 removed. */";
196 if ($filename =~ m
|/bessel_j\
.c
$|) {
197 if (/^\s*const static gnm_float fact\[/) {
201 $_ = '/* removed array fact */';
203 s/\bfact\s*\[([^][]*)\]/fact($1)/g;
208 s/\%([-0-9.]*)([efgEFG])/\%$1\" GNM_FORMAT_$2 \"/g;
210 s/int give_log/gboolean give_log/g;
211 s/int log_p/gboolean log_p/g;
212 s/int lower_tail/gboolean lower_tail/g;
215 s/\bpbeta\s*\(1\s*-\s*([^,]*),\s*([^,]*),\s*([^,]*),\s*([^,]*),\s*([^,]*)\)/pbeta ($1, $3, $2, !$4, $5)/;
218 if ($filename =~ m
|/pt\
.c
$|) {
219 s/(n > 4e5)/0 && $1/;
220 if (/(^.*\s*=\s*)pbeta\s*(\(.*\);)/) {
221 $_ = "$1 (n > x * x)\n" .
222 "\t? pbeta (x * x / (n + x * x), 0.5, n / 2, /*lower_tail*/0, log_p)\n" .
228 if ($filename =~ m
|/qbeta\.c$| && /xinbta
= 0\
.5;/) {
229 s/0\.5/(xinbta < lower) ? gnm_sqrt (lower) : 1 - gnm_sqrt (lower)/;
232 $incomment = 1 if m
|/\
*$|;
239 if ($cleandefs && keys %defines) {
240 print "/* Cleaning up done by $0: */\n";
241 foreach my $def (sort keys %defines) {
242 print "#undef $def\n";
247 print "/* ", ('-' x
72), " */\n";
250 # -----------------------------------------------------------------------------
259 open (*FIL
, "<$filename") or
260 die "$0: Cannot read $filename: $!\n";
263 if ($state eq 'pre') {
265 $state = 'mid' if m
"--- BEGIN MAGIC R SOURCE MARKER ---";
267 if ($state eq 'mid') {
268 $state = 'post' if m
"--- END MAGIC R SOURCE MARKER ---";
270 if ($state eq 'post') {
276 die "$0: wrong set of magic markers in $filename.\n" if $state ne 'post';
278 return ($prefix,$postfix);
281 # -----------------------------------------------------------------------------