]> git.vpit.fr Git - perl/modules/Sub-Nary.git/blob - Nary.xs
75892ce3338d7bcd61ca2996b5d4a865e1c7dc94
[perl/modules/Sub-Nary.git] / Nary.xs
1 /* This file is part of the Sub::Nary Perl module.
2  * See http://search.cpan.org/dist/Sub::Nary/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #ifndef mPUSHi
10 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
11 #endif /* !mPUSHi */
12
13 typedef struct {
14  UV k;
15  NV v;
16 } sn_combcache;
17
18 STATIC U32 sn_hash_list = 0;
19
20 /* --- XS ------------------------------------------------------------------ */
21
22 MODULE = Sub::Nary            PACKAGE = Sub::Nary
23
24 PROTOTYPES: ENABLE
25
26 BOOT:
27 {
28  PERL_HASH(sn_hash_list, "list", 4);
29 }
30
31 void
32 tag(SV *op)
33 PROTOTYPE: $
34 CODE:
35  ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
36  XSRETURN(1);
37
38 void
39 null(SV *op)
40 PROTOTYPE: $
41 PREINIT:
42  OP *o;
43 CODE:
44  o = INT2PTR(OP *, SvUV(SvRV(op)));
45  ST(0) = sv_2mortal(newSVuv(o == NULL));
46  XSRETURN(1);
47
48 void
49 zero(SV *sv)
50 PROTOTYPE: $
51 PREINIT:
52  HV *hv;
53  IV res;
54 CODE:
55  if (!SvOK(sv))
56   XSRETURN_IV(1);
57  if (!SvROK(sv)) {
58   res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
59   XSRETURN_IV(res);
60  }
61  hv = (HV *) SvRV(sv);
62  res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1;
63  XSRETURN_IV(res);
64
65 void
66 list(SV *sv)
67 PROTOTYPE: $
68 PREINIT:
69  HV *hv;
70  IV res;
71 CODE:
72  if (!SvOK(sv))
73   XSRETURN_IV(0);
74  if (!SvROK(sv)) {
75   res = strEQ(SvPV_nolen(sv), "list");
76   XSRETURN_IV(res);
77  }
78  hv = (HV *) SvRV(sv);
79  res = hv_exists(hv, "list", 4) && hv_iterinit(hv) == 1;
80  XSRETURN_IV(res);
81
82 void
83 count(SV *sv)
84 PROTOTYPE: $
85 PREINIT:
86  HV *hv;
87  HE *key;
88  NV c = 0;
89 CODE:
90  if (!SvOK(sv))
91   XSRETURN_IV(0);
92  if (!SvROK(sv))
93   XSRETURN_IV(1);
94  hv = (HV *) SvRV(sv);
95  hv_iterinit(hv);
96  while (key = hv_iternext(hv)) {
97   c += SvNV(HeVAL(key));
98  }
99  XSRETURN_NV(c);
100
101 void
102 normalize(SV *sv)
103 PROTOTYPE: $
104 PREINIT:
105  HV *hv, *res;
106  HE *key;
107  SV *val;
108  NV c = 0;
109 CODE:
110  if (!SvOK(sv))
111   XSRETURN_UNDEF;
112  res = newHV();
113  if (!SvROK(sv)) {
114   val = newSVuv(1);
115   if (!hv_store_ent(res, sv, val, 0)) {
116    SvREFCNT_dec(val);
117    SvREFCNT_dec(res);
118    XSRETURN_UNDEF;
119   }
120  } else {
121   hv = (HV *) SvRV(sv);
122   if (!hv_iterinit(hv)) {
123    val = newSVuv(1);
124    if (!hv_store(res, "0", 1, val, 0)) {
125     SvREFCNT_dec(val);
126     SvREFCNT_dec(res);
127     XSRETURN_UNDEF;
128    }
129   } else {
130    while (key = hv_iternext(hv)) {
131     c += SvNV(HeVAL(key));
132    }
133    hv_iterinit(hv);
134    while (key = hv_iternext(hv)) {
135     val = newSVnv(SvNV(HeVAL(key)) / c);
136     if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
137      SvREFCNT_dec(val);
138    }
139   }
140  }
141  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
142  XSRETURN(1);
143
144 void
145 combine(...)
146 PROTOTYPE: @
147 PREINIT:
148  HV *res[2];
149  SV *cur, *val;
150  SV *list1, *list2;
151  SV *temp;
152  HE *key, *old;
153  I32 i;
154  I32 n = 0, o;
155  I32 j, n1, n2;
156  UV shift = 0, do_shift = 0;
157  sn_combcache *cache = NULL;
158  I32 cachelen = 0;
159 CODE:
160  if (!items)
161   XSRETURN_UNDEF;
162  res[0] = res[1] = NULL;
163  for (i = 0; i < items; ++i) {
164   cur = ST(i);
165   if (!SvOK(cur)) 
166    continue;
167   if (!SvROK(cur)) {
168    if (strEQ(SvPV_nolen(cur), "list")) {
169     res[0] = newHV();
170     n      = 0;
171     val    = newSVuv(1);
172     if (!hv_store(res[0], "list", 4, val, sn_hash_list))
173      SvREFCNT_dec(val);
174     i = items;
175     if (!shift)
176      do_shift = 0;
177     break;
178    } else {
179     shift += SvUV(cur);
180     do_shift = 1;
181     continue;
182    }
183   }
184   cur    = SvRV(cur);
185   res[0] = newHV();
186   while (key = hv_iternext((HV *) cur)) {
187    val = newSVsv(HeVAL(key));
188    if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
189     SvREFCNT_dec(val);
190   }
191   n = 0;
192   if (!shift)
193    do_shift = 0;
194   break;
195  }
196  temp = sv_2mortal(newSViv(0));
197  for (++i; i < items; ++i) {
198   cur = ST(i);
199   if (!SvOK(cur))
200    continue;
201   if (!SvROK(cur)) {
202    if (strEQ(SvPV_nolen(cur), "list")) {
203     hv_clear(res[n]);
204     val = newSVuv(1);
205     if (!hv_store(res[n], "list", 4, val, sn_hash_list))
206      SvREFCNT_dec(val);
207     shift = 0;
208     do_shift = 0;
209     break;
210    } else {
211     shift += SvUV(cur);
212     continue;
213    }
214   }
215   cur = SvRV(cur);
216   o   = 1 - n;
217   if (!res[o])
218    res[o] = newHV();
219   else
220    hv_clear(res[o]);
221   list1 = hv_delete((HV *) cur, "list", 4, 0);
222   n1    = hv_iterinit((HV *) cur);
223   list2 = hv_delete(res[n],     "list", 4, 0);
224   n2    = hv_iterinit(res[n]);
225   if ((list1 && !n1) || (list2 && !n2)) {
226    val = newSViv(1);
227    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
228     SvREFCNT_dec(val);
229    n = o;
230    break;
231   } else if (list1 || list2) {
232    NV l1 = list1 ? SvNV(list1) : 0;
233    NV l2 = list2 ? SvNV(list2) : 0;
234    val = newSVnv(l1 + l2 - l1 * l2);
235    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
236     SvREFCNT_dec(val);
237   }
238   if (n2 > cachelen) {
239    Renew(cache, n2, sn_combcache);
240    cachelen = n2;
241   }
242   j = 0;
243   while (key = hv_iternext(res[n])) {
244    cache[j].k = SvUV(HeSVKEY_force(key));
245    cache[j].v = SvNV(HeVAL(key));
246    ++j;
247   }
248   while (key = hv_iternext((HV *) cur)) {
249    IV k = SvUV(HeSVKEY_force(key));
250    NV v = SvNV(HeVAL(key));
251    for (j = 0; j < n2; ++j) {
252     sv_setiv(temp, k + cache[j].k);
253     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
254      val = newSVnv(SvNV(val) + v * cache[j].v);
255     } else {
256      val = newSVnv(v * cache[j].v);
257     }
258     if (!hv_store_ent(res[o], temp, val, 0))
259      SvREFCNT_dec(val);
260    }
261   }
262   n = o;
263  }
264  Safefree(cache);
265  if (shift || do_shift) {
266   if (!res[n]) {
267    res[n] = newHV();
268    sv_setiv(temp, shift);
269    val = newSViv(1);
270    if (!hv_store_ent(res[n], temp, val, 0))
271     SvREFCNT_dec(val);
272   } else {
273    o = 1 - n;
274    if (!res[o])
275     res[o] = newHV();
276    else
277     hv_clear(res[o]);
278    list1 = hv_delete(res[n], "list", 4, 0);
279    hv_iterinit(res[n]);
280    while (key = hv_iternext(res[n])) {
281     sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
282     val = newSVsv(HeVAL(key));
283     if (!hv_store_ent(res[o], temp, val, 0))
284      SvREFCNT_dec(val);
285    }
286    if (list1) {
287     val = newSVsv(list1);
288     if (!hv_store(res[o], "list", 4, val, sn_hash_list))
289      SvREFCNT_dec(val);
290    }
291    n = o;
292   }
293  } else if (!res[0] && !res[1])
294   XSRETURN_UNDEF;
295  if (n == 1)
296   SvREFCNT_dec(res[0]);
297  else if (res[1]) 
298   SvREFCNT_dec(res[1]);
299  ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
300  XSRETURN(1);
301
302 void
303 scalops()
304 PROTOTYPE:
305 PREINIT:
306  U32 cxt;
307  int i, count = 0;
308 CODE:
309  cxt = GIMME_V;
310  if (cxt == G_SCALAR) {
311   for (i = 0; i < OP_max; ++i) {
312    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
313   }
314   EXTEND(SP, 1);
315   mPUSHi(count);
316   XSRETURN(1);
317  } else if (cxt == G_ARRAY) {
318   for (i = 0; i < OP_max; ++i) {
319    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
320     const char *name = PL_op_name[i];
321     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
322     ++count;
323    }
324   }
325   XSRETURN(count);
326  }
327