This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix Math::BigInt::FastCalc build under Win32 with croak_xs_usage().
[perl5.git] / dist / Math-BigInt-FastCalc / FastCalc.xs
CommitLineData
062a4e99
T
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
206957a7
SP
5/* for Perl prior to v5.7.1 */
6#ifndef SvUOK
7# define SvUOK(sv) SvIOK_UV(sv)
8#endif
9
062a4e99
T
10double XS_BASE = 0;
11double XS_BASE_LEN = 0;
12
13MODULE = Math::BigInt::FastCalc PACKAGE = Math::BigInt::FastCalc
14
e31720c4
RGS
15PROTOTYPES: DISABLE
16
062a4e99
T
17 #############################################################################
18 # 2002-08-12 0.03 Tels unreleased
19 # * is_zero/is_one/is_odd/is_even/len work now (pass v1.61 tests)
20 # 2002-08-13 0.04 Tels unreleased
21 # * returns no/yes for is_foo() methods to be faster
22 # 2002-08-18 0.06alpha
23 # * added _num(), _inc() and _dec()
24 # 2002-08-25 0.06 Tels
25 # * added __strip_zeros(), _copy()
26 # 2004-08-13 0.07 Tels
27 # * added _is_two(), _is_ten(), _ten()
7d193e39
T
28 # 2007-04-02 0.08 Tels
29 # * plug leaks by creating mortals
5ed38b1a
T
30 # 2007-05-27 0.09 Tels
31 # * add _new()
7d193e39
T
32
33#define RETURN_MORTAL_INT(value) \
34 ST(0) = sv_2mortal(newSViv(value)); \
35 XSRETURN(1);
36
c0fdee65
NC
37BOOT:
38{
39 if (items < 4)
5e4a1484 40 croak_xs_usage(aTHX_ cv, "package, version, base_len, base");
c0fdee65
NC
41 XS_BASE_LEN = SvIV(ST(2));
42 XS_BASE = SvNV(ST(3));
43}
062a4e99
T
44
45##############################################################################
5ed38b1a
T
46# _new
47
4019471a 48SV *
5ed38b1a
T
49_new(class, x)
50 SV* x
51 INIT:
52 STRLEN len;
53 char* cur;
a436f3ee 54 STRLEN part_len;
4019471a 55 AV *av = newAV();
5ed38b1a
T
56
57 CODE:
206957a7 58 if (SvUOK(x) && SvUV(x) < XS_BASE)
5ed38b1a
T
59 {
60 /* shortcut for integer arguments */
4019471a 61 av_push (av, newSVuv( SvUV(x) ));
5ed38b1a
T
62 }
63 else
64 {
65 /* split the input (as string) into XS_BASE_LEN long parts */
66 /* in perl:
67 [ reverse(unpack("a" . ($il % $BASE_LEN+1)
68 . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
69 */
70 cur = SvPV(x, len); /* convert to string & store length */
71 cur += len; /* doing "cur = SvEND(x)" does not work! */
72 # process the string from the back
73 while (len > 0)
74 {
75 /* use either BASE_LEN or the amount of remaining digits */
a436f3ee 76 part_len = (STRLEN) XS_BASE_LEN;
5ed38b1a
T
77 if (part_len > len)
78 {
79 part_len = len;
80 }
81 /* processed so many digits */
82 cur -= part_len;
83 len -= part_len;
84 /* printf ("part '%s' (part_len: %i, len: %i, BASE_LEN: %i)\n", cur, part_len, len, XS_BASE_LEN); */
85 if (part_len > 0)
86 {
4019471a 87 av_push (av, newSVpvn(cur, part_len) );
5ed38b1a
T
88 }
89 }
90 }
4019471a 91 RETVAL = newRV_noinc((SV *)av);
5ed38b1a
T
92 OUTPUT:
93 RETVAL
94
95##############################################################################
062a4e99
T
96# _copy
97
98void
99_copy(class, x)
100 SV* x
101 INIT:
102 AV* a;
103 AV* a2;
104 I32 elems;
105
106 CODE:
107 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
108 elems = av_len(a); /* number of elems in array */
109 a2 = (AV*)sv_2mortal((SV*)newAV());
206957a7 110 av_extend (a2, elems); /* pre-padd */
062a4e99
T
111 while (elems >= 0)
112 {
113 /* av_store( a2, elems, newSVsv( (SV*)*av_fetch(a, elems, 0) ) ); */
114
115 /* looking and trying to preserve IV is actually slower when copying */
116 /* temp = (SV*)*av_fetch(a, elems, 0);
117 if (SvIOK(temp))
118 {
119 av_store( a2, elems, newSViv( SvIV( (SV*)*av_fetch(a, elems, 0) )));
120 }
121 else
122 {
123 av_store( a2, elems, newSVnv( SvNV( (SV*)*av_fetch(a, elems, 0) )));
124 }
125 */
126 av_store( a2, elems, newSVnv( SvNV( (SV*)*av_fetch(a, elems, 0) )));
127 elems--;
128 }
129 ST(0) = sv_2mortal( newRV_inc((SV*) a2) );
130
131##############################################################################
132# __strip_zeros (also check for empty arrays from div)
133
134void
135__strip_zeros(x)
136 SV* x
137 INIT:
138 AV* a;
139 SV* temp;
140 I32 elems;
141 I32 index;
142
143 CODE:
144 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
145 elems = av_len(a); /* number of elems in array */
146 ST(0) = x; /* we return x */
147 if (elems == -1)
148 {
149 av_push (a, newSViv(0)); /* correct empty arrays */
150 XSRETURN(1);
151 }
152 if (elems == 0)
153 {
154 XSRETURN(1); /* nothing to do since only one elem */
155 }
156 index = elems;
157 while (index > 0)
158 {
159 temp = *av_fetch(a, index, 0); /* fetch ptr to current element */
160 if (SvNV(temp) != 0)
161 {
162 break;
163 }
164 index--;
165 }
166 if (index < elems)
167 {
168 index = elems - index;
169 while (index-- > 0)
170 {
171 av_pop (a);
172 }
173 }
174 XSRETURN(1);
175
176##############################################################################
177# decrement (subtract one)
178
179void
180_dec(class,x)
181 SV* x
182 INIT:
183 AV* a;
184 SV* temp;
185 I32 elems;
186 I32 index;
187 NV MAX;
188
189 CODE:
190 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
191 elems = av_len(a); /* number of elems in array */
192 ST(0) = x; /* we return x */
193
194 MAX = XS_BASE - 1;
195 index = 0;
196 while (index <= elems)
197 {
198 temp = *av_fetch(a, index, 0); /* fetch ptr to current element */
206957a7 199 sv_setnv (temp, SvNV(temp)-1); /* decrement */
062a4e99
T
200 if (SvNV(temp) >= 0)
201 {
202 break; /* early out */
203 }
204 sv_setnv (temp, MAX); /* overflow, so set this to $MAX */
205 index++;
206 }
207 /* do have more than one element? */
208 /* (more than one because [0] should be kept as single-element) */
209 if (elems > 0)
210 {
211 temp = *av_fetch(a, elems, 0); /* fetch last element */
212 if (SvIV(temp) == 0) /* did last elem overflow? */
213 {
214 av_pop(a); /* yes, so shrink array */
215 /* aka remove leading zeros */
216 }
217 }
218 XSRETURN(1); /* return x */
219
220##############################################################################
221# increment (add one)
222
223void
224_inc(class,x)
225 SV* x
226 INIT:
227 AV* a;
228 SV* temp;
229 I32 elems;
230 I32 index;
231 NV BASE;
232
233 CODE:
234 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
235 elems = av_len(a); /* number of elems in array */
236 ST(0) = x; /* we return x */
237
238 BASE = XS_BASE;
239 index = 0;
240 while (index <= elems)
241 {
242 temp = *av_fetch(a, index, 0); /* fetch ptr to current element */
243 sv_setnv (temp, SvNV(temp)+1);
244 if (SvNV(temp) < BASE)
245 {
246 XSRETURN(1); /* return (early out) */
247 }
248 sv_setiv (temp, 0); /* overflow, so set this elem to 0 */
249 index++;
250 }
251 temp = *av_fetch(a, elems, 0); /* fetch last element */
252 if (SvIV(temp) == 0) /* did last elem overflow? */
253 {
254 av_push(a, newSViv(1)); /* yes, so extend array by 1 */
255 }
256 XSRETURN(1); /* return x */
257
258##############################################################################
259# Make a number (scalar int/float) from a BigInt object
260
261void
262_num(class,x)
263 SV* x
264 INIT:
265 AV* a;
266 NV fac;
267 SV* temp;
268 NV num;
269 I32 elems;
270 I32 index;
271 NV BASE;
272
273 CODE:
274 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
275 elems = av_len(a); /* number of elems in array */
276
277 if (elems == 0) /* only one element? */
278 {
279 ST(0) = *av_fetch(a, 0, 0); /* fetch first (only) element */
280 XSRETURN(1); /* return it */
281 }
282 fac = 1.0; /* factor */
283 index = 0;
284 num = 0.0;
285 BASE = XS_BASE;
286 while (index <= elems)
287 {
288 temp = *av_fetch(a, index, 0); /* fetch current element */
289 num += fac * SvNV(temp);
290 fac *= BASE;
291 index++;
292 }
293 ST(0) = newSVnv(num);
294
295##############################################################################
296
4019471a 297SV *
caa64001 298_zero(class)
2d032f98
NC
299 ALIAS:
300 _one = 1
301 _two = 2
302 _ten = 10
4019471a
NC
303 PREINIT:
304 AV *av = newAV();
062a4e99 305 CODE:
4019471a
NC
306 av_push (av, newSViv( ix ));
307 RETVAL = newRV_noinc((SV *)av);
caa64001
T
308 OUTPUT:
309 RETVAL
062a4e99
T
310
311##############################################################################
312
313void
314_is_even(class, x)
315 SV* x
2d032f98
NC
316 ALIAS:
317 _is_odd = 1
062a4e99
T
318 INIT:
319 AV* a;
320 SV* temp;
321
322 CODE:
323 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
324 temp = *av_fetch(a, 0, 0); /* fetch first element */
2d032f98 325 ST(0) = sv_2mortal(boolSV((SvIV(temp) & 1) == ix));
062a4e99
T
326
327##############################################################################
328
329void
330_is_zero(class, x)
331 SV* x
2d032f98
NC
332 ALIAS:
333 _is_one = 1
334 _is_two = 2
335 _is_ten = 10
062a4e99
T
336 INIT:
337 AV* a;
062a4e99
T
338
339 CODE:
340 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
341 if ( av_len(a) != 0)
342 {
8e1dd0a2
NC
343 ST(0) = &PL_sv_no; /* len != 1, can't be '0' */
344 }
345 else
346 {
347 SV *const temp = *av_fetch(a, 0, 0); /* fetch first element */
348 ST(0) = boolSV(SvIV(temp) == ix);
062a4e99 349 }
8e1dd0a2 350 XSRETURN(1);
062a4e99
T
351
352##############################################################################
353
354void
355_len(class,x)
356 SV* x
357 INIT:
358 AV* a;
359 SV* temp;
6c0b8e73 360 IV elems;
062a4e99
T
361 STRLEN len;
362
363 CODE:
364 a = (AV*)SvRV(x); /* ref to aray, don't check ref */
6c0b8e73 365 elems = av_len(a); /* number of elems in array */
062a4e99
T
366 temp = *av_fetch(a, elems, 0); /* fetch last element */
367 SvPV(temp, len); /* convert to string & store length */
6c0b8e73 368 len += (IV) XS_BASE_LEN * elems;
7d193e39 369 ST(0) = sv_2mortal(newSViv(len));
062a4e99
T
370
371##############################################################################
372
373void
374_acmp(class, cx, cy);
375 SV* cx
376 SV* cy
377 INIT:
378 AV* array_x;
379 AV* array_y;
380 I32 elemsx, elemsy, diff;
381 SV* tempx;
382 SV* tempy;
383 STRLEN lenx;
384 STRLEN leny;
385 NV diff_nv;
386 I32 diff_str;
387
388 CODE:
389 array_x = (AV*)SvRV(cx); /* ref to aray, don't check ref */
390 array_y = (AV*)SvRV(cy); /* ref to aray, don't check ref */
391 elemsx = av_len(array_x);
392 elemsy = av_len(array_y);
393 diff = elemsx - elemsy; /* difference */
394
395 if (diff > 0)
396 {
7d193e39 397 RETURN_MORTAL_INT(1); /* len differs: X > Y */
062a4e99 398 }
7d193e39 399 else if (diff < 0)
062a4e99 400 {
7d193e39 401 RETURN_MORTAL_INT(-1); /* len differs: X < Y */
062a4e99
T
402 }
403 /* both have same number of elements, so check length of last element
404 and see if it differes */
405 tempx = *av_fetch(array_x, elemsx, 0); /* fetch last element */
406 tempy = *av_fetch(array_y, elemsx, 0); /* fetch last element */
407 SvPV(tempx, lenx); /* convert to string & store length */
408 SvPV(tempy, leny); /* convert to string & store length */
409 diff_str = (I32)lenx - (I32)leny;
410 if (diff_str > 0)
411 {
7d193e39 412 RETURN_MORTAL_INT(1); /* same len, but first elems differs in len */
062a4e99
T
413 }
414 if (diff_str < 0)
415 {
7d193e39 416 RETURN_MORTAL_INT(-1); /* same len, but first elems differs in len */
062a4e99
T
417 }
418 /* same number of digits, so need to make a full compare */
419 diff_nv = 0;
420 while (elemsx >= 0)
421 {
422 tempx = *av_fetch(array_x, elemsx, 0); /* fetch curr x element */
423 tempy = *av_fetch(array_y, elemsx, 0); /* fetch curr y element */
424 diff_nv = SvNV(tempx) - SvNV(tempy);
425 if (diff_nv != 0)
426 {
427 break;
428 }
429 elemsx--;
430 }
431 if (diff_nv > 0)
432 {
7d193e39 433 RETURN_MORTAL_INT(1);
062a4e99
T
434 }
435 if (diff_nv < 0)
436 {
7d193e39 437 RETURN_MORTAL_INT(-1);
062a4e99 438 }
7d193e39 439 ST(0) = sv_2mortal(newSViv(0)); /* X and Y are equal */
062a4e99 440