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