File Coverage

Uniqnum.xs
Criterion Covered Total %
statement 45 56 80.3
branch 66 92 71.7
condition n/a
subroutine n/a
pod n/a
total 111 148 75.0


line stmt bran cond sub pod time code
1            
2             #define PERL_NO_GET_CONTEXT 1
3            
4            
5             #include "EXTERN.h"
6             #include "perl.h"
7             #include "XSUB.h"
8            
9            
10             #ifndef sv_setpvs
11             # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
12             #endif
13            
14             /* For uniqnum, define ACTUAL_NVSIZE to be the number *
15             * of bytes that are actually used to store the NV */
16            
17             #if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64
18             #define ACTUAL_NVSIZE 10
19             #else
20             #define ACTUAL_NVSIZE NVSIZE
21             #endif
22            
23 0           int uv_fits_double(UV arg) {
24            
25             /* This function is no longer used. *
26             * The value passed was always > 9007199254740992 *
27             * and always <= 18446744073709551615. *
28             * Return true if there are no more than 51 bits *
29             * between the most significant set bit and the *
30             * least significant set bit - in which case the *
31             * value can be exactly represented by a double. */
32            
33 0 0         while(!(arg & 1)) {
34 0           arg >>= 1;
35 0 0         if(arg < 9007199254740992) return 1;
36             }
37            
38 0           return 0;
39             }
40            
41 26           void uniqnum(pTHX_ SV * input_sv, ...) {
42 26           dXSARGS;
43 26           int retcount = 0;
44             int index;
45 26           SV **args = &PL_stack_base[ax];
46             HV *seen;
47            
48             SV *keysv;
49             SV *arg;
50             NV nv_arg;
51            
52             #ifdef HV_FETCH_EMPTY_HE
53             HE* he;
54             #endif
55            
56 26 50         if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) {
    100          
    50          
    50          
    0          
    0          
    50          
    50          
    50          
57             /* Optimise for the case of the empty list or a defined nonmagic
58             * singleton. Leave a singleton magical||undef for the regular case */
59 0           retcount = items;
60 0           goto finish;
61             }
62            
63 26           sv_2mortal((SV *)(seen = newHV()));
64            
65            
66             /* uniqnum */
67             /* A temporary buffer for number stringification */
68 26           keysv = sv_newmortal();
69            
70 271 100         for(index = 0 ; index < items ; index++) {
71 245           arg = args[index];
72            
73 245 100         if(SvGAMAGIC(arg))
    100          
    50          
    50          
74             /* clone the value so we don't invoke magic again */
75 6           arg = sv_mortalcopy(arg);
76            
77 245 100         if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) {
    50          
    50          
    100          
    100          
    100          
78             #if PERL_VERSION >= 8
79 141 50         SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */
80             #else
81             SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */
82             #endif
83             }
84             #if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */
85             nv_arg = SvNV(arg);
86            
87             /* use 0 for all zeros */
88             if(nv_arg == 0) sv_setpvs(keysv, "0");
89            
90             /* for NaN, use the platform's normal stringification */
91             else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
92             #ifdef NV_IS_DOUBLEDOUBLE
93             /* If the least significant double is zero, it could be either 0.0 *
94             * or -0.0. We therefore ignore the least significant double and *
95             * assign to keysv the bytes of the most significant double only. */
96             else if(nv_arg == (double)nv_arg) {
97             double double_arg = (double)nv_arg;
98             sv_setpvn(keysv, (char *) &double_arg, 8);
99             }
100             #endif
101             else {
102             /* Use the byte structure of the NV. *
103             * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes *
104             * that are allocated but never used. (It is only the 10-byte *
105             * extended precision long double that allocates bytes that are *
106             * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */
107             sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE);
108             }
109             #else /* $Config{nvsize} == $Config{ivsize} == 8 */
110 322 100         if( SvIOK(arg) || !SvOK(arg) ) {
    100          
    50          
    50          
111            
112             /* It doesn't matter if SvUOK(arg) is TRUE */
113 77 100         IV iv = SvIV(arg);
114            
115             /* use "0" for all zeros */
116 77 100         if(iv == 0) sv_setpvs(keysv, "0");
117            
118             else {
119 71           int uok = SvUOK(arg);
120 71 100         int sign = ( iv > 0 || uok ) ? 1 : -1;
    100          
121            
122             /* Set keysv to the bytes of SvNV(arg) if and only if the integer value *
123             * held by arg can be represented exactly as a double - ie if there are *
124             * no more than 51 bits between its least significant set bit and its *
125             * most significant set bit. *
126             * The neatest approach I could find was provided by roboticus at: *
127             * https://www.perlmonks.org/?node_id=11113490 *
128             * First, identify the lowest set bit and assign its value to an IV. *
129             * Note that this value will always be > 0, and always a power of 2. */
130 71           IV lowest_set = iv & -iv;
131            
132             /* Second, shift it left 53 bits to get location of arg's highest *
133             * "allowed" set bit. *
134             * NOTE: If lowest set bit is initially far enough left, then this left *
135             * shift operation will result in a value of 0, which is fine. *
136             * Then subtract 1 so that all of the ("allowed") bits below the set bit *
137             * are 1 && all other ("disallowed") bits are set to 0. *
138             * (If the value prior to subtraction was 0, then subtracing 1 will set *
139             * all bits - which is also fine.) */
140 71           UV valid_bits = (lowest_set << 53) - 1;
141            
142             /* The value of arg can be exactly represented by a double unless one *
143             * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) *
144             * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply it *
145             * by -1 prior to performing that '&' operation. */
146 71 100         if( !((iv * sign) & (~valid_bits)) ) {
147 62 100         nv_arg = SvNV(arg);
148 62           sv_setpvn(keysv, (char *) &nv_arg, 8);
149             }
150             else {
151 9           sv_setpvn(keysv, (char *) &iv, 8);
152             /* We add an extra byte to distinguish between IV/UV and an NV. *
153             * We also use that byte to distinguish between a -ve IV and a UV. *
154             * This is more efficient than reading in the value of the IV/UV. */
155 9 100         if(uok) sv_catpvn(keysv, "U", 1);
156 3           else sv_catpvn(keysv, "I", 1);
157             }
158             }
159             }
160             else {
161 168 100         nv_arg = SvNV(arg);
162            
163             /* for NaN, use the platform's normal stringification */
164 168 100         if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg);
165            
166             /* use "0" for all zeros */
167 164 100         else if(nv_arg == 0) sv_setpvs(keysv, "0");
168 59           else sv_setpvn(keysv, (char *) &nv_arg, 8);
169             }
170             #endif
171             #ifdef HV_FETCH_EMPTY_HE
172 245           he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0);
173 245 100         if (HeVAL(he))
174 134           continue;
175 111           HeVAL(he) = &PL_sv_undef;
176             #else
177             if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv)))
178             continue;
179             hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0);
180             #endif
181            
182 111 50         if(GIMME_V == G_ARRAY)
    100          
183 90 100         ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0));
    50          
    50          
184 111           retcount++;
185             }
186            
187             finish:
188 26 50         if(GIMME_V == G_ARRAY) {
    100          
189 21           XSRETURN(retcount);
190             }
191             else {
192 5           ST(0) = sv_2mortal(newSViv(retcount));
193 26           XSRETURN(1);
194             }
195             }
196            
197 0           int _have_msc_ver(void) {
198             #ifdef _MSC_VER
199             return _MSC_VER;
200             #else
201 0           return 0;
202             #endif
203             }
204            
205            
206             MODULE = List::Uniqnum PACKAGE = List::Uniqnum
207            
208             PROTOTYPES: DISABLE
209            
210            
211             int
212             uv_fits_double (arg)
213             UV arg
214            
215             void
216             uniqnum (input_sv, ...)
217             SV * input_sv
218             PREINIT:
219             I32* temp;
220             PPCODE:
221 26           temp = PL_markstack_ptr++;
222 26           uniqnum(aTHX_ input_sv);
223 26 50         if (PL_markstack_ptr != temp) {
224             /* truly void, because dXSARGS not invoked */
225 0           PL_markstack_ptr = temp;
226 0           XSRETURN_EMPTY; /* return empty stack */
227             }
228             /* must have used dXSARGS; list context implied */
229 26           return; /* assume stack size is correct */
230            
231             int
232             _have_msc_ver ()
233            
234