This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dfff9f4382b9327903bb3f17971ab5b43594e2ef
[perl5.git] / dist / Math-BigInt-FastCalc / FastCalc.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 /* for Perl prior to v5.7.1 */
6 #ifndef SvUOK
7 #  define SvUOK(sv) SvIOK_UV(sv)
8 #endif
9
10 double XS_BASE = 0;
11 double XS_BASE_LEN = 0;
12
13 MODULE = Math::BigInt::FastCalc         PACKAGE = Math::BigInt::FastCalc
14
15 PROTOTYPES: DISABLE
16
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()
28  # 2007-04-02 0.08 Tels
29  #  * plug leaks by creating mortals
30  # 2007-05-27 0.09 Tels
31  #  * add _new()
32
33 #define RETURN_MORTAL_INT(value)                \
34       ST(0) = sv_2mortal(newSViv(value));       \
35       XSRETURN(1);
36
37 BOOT:
38 {
39     if (items < 4)
40         S_croak_xs_usage(aTHX_ cv, "package, version, base_len, base");
41     XS_BASE_LEN = SvIV(ST(2)); 
42     XS_BASE = SvNV(ST(3)); 
43 }
44
45 ##############################################################################
46 # _new
47
48 SV *
49 _new(class, x)
50   SV*   x
51   INIT:
52     STRLEN len;
53     char* cur;
54     STRLEN part_len;
55     AV *av = newAV();
56
57   CODE:
58     if (SvUOK(x) && SvUV(x) < XS_BASE)
59       {
60       /* shortcut for integer arguments */
61       av_push (av, newSVuv( SvUV(x) ));
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 */
76         part_len = (STRLEN) XS_BASE_LEN;
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           {
87           av_push (av, newSVpvn(cur, part_len) );
88           }
89         }
90       }
91     RETVAL = newRV_noinc((SV *)av);
92   OUTPUT:
93     RETVAL
94
95 ##############################################################################
96 # _copy
97
98 void
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());
110     av_extend (a2, elems);              /* pre-padd */
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
134 void
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
179 void
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 */
199       sv_setnv (temp, SvNV(temp)-1);    /* decrement */
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
223 void
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
261 void
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
297 SV *
298 _zero(class)
299   ALIAS:
300     _one = 1
301     _two = 2
302     _ten = 10
303   PREINIT:
304     AV *av = newAV();
305   CODE:
306     av_push (av, newSViv( ix ));
307     RETVAL = newRV_noinc((SV *)av);
308   OUTPUT:
309     RETVAL
310
311 ##############################################################################
312
313 void
314 _is_even(class, x)
315   SV*   x
316   ALIAS:
317     _is_odd = 1
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 */
325     ST(0) = sv_2mortal(boolSV((SvIV(temp) & 1) == ix));
326
327 ##############################################################################
328
329 void
330 _is_zero(class, x)
331   SV*   x
332   ALIAS:
333     _is_one = 1
334     _is_two = 2
335     _is_ten = 10
336   INIT:
337     AV* a;
338
339   CODE:
340     a = (AV*)SvRV(x);                   /* ref to aray, don't check ref */
341     if ( av_len(a) != 0)
342       {
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);
349       }
350     XSRETURN(1);                
351
352 ##############################################################################
353
354 void
355 _len(class,x)
356   SV*   x
357   INIT:
358     AV* a;
359     SV* temp;
360     IV  elems;
361     STRLEN len;
362
363   CODE:
364     a = (AV*)SvRV(x);                   /* ref to aray, don't check ref */
365     elems = av_len(a);                  /* number of elems in array */
366     temp = *av_fetch(a, elems, 0);      /* fetch last element */
367     SvPV(temp, len);                    /* convert to string & store length */
368     len += (IV) XS_BASE_LEN * elems;
369     ST(0) = sv_2mortal(newSViv(len));
370
371 ##############################################################################
372
373 void
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       {
397       RETURN_MORTAL_INT(1);             /* len differs: X > Y */
398       }
399     else if (diff < 0)
400       {
401       RETURN_MORTAL_INT(-1);            /* len differs: X < Y */
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       {
412       RETURN_MORTAL_INT(1);             /* same len, but first elems differs in len */
413       }
414     if (diff_str < 0)
415       {
416       RETURN_MORTAL_INT(-1);            /* same len, but first elems differs in len */
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       {
433       RETURN_MORTAL_INT(1);
434       }
435     if (diff_nv < 0)
436       {
437       RETURN_MORTAL_INT(-1);
438       }
439     ST(0) = sv_2mortal(newSViv(0));             /* X and Y are equal */
440