1 /* This file is part of the Sub::Nary Perl module.
2 * See http://search.cpan.org/dist/Sub::Nary/ */
4 #define PERL_NO_GET_CONTEXT
10 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
18 STATIC U32 sn_hash_list = 0;
20 /* --- XS ------------------------------------------------------------------ */
22 MODULE = Sub::Nary PACKAGE = Sub::Nary
28 PERL_HASH(sn_hash_list, "list", 4);
35 ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
44 o = INT2PTR(OP *, SvUV(SvRV(op)));
45 ST(0) = sv_2mortal(newSVuv(o == NULL));
58 res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
62 res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1;
75 res = strEQ(SvPV_nolen(sv), "list");
79 res = hv_exists(hv, "list", 4) && hv_iterinit(hv) == 1;
96 while (key = hv_iternext(hv)) {
97 c += SvNV(HeVAL(key));
115 if (!hv_store_ent(res, sv, val, 0))
118 hv = (HV *) SvRV(sv);
119 if (!hv_iterinit(hv)) {
121 if (!hv_store(res, "0", 1, val, 0))
124 while (key = hv_iternext(hv)) {
125 c += SvNV(HeVAL(key));
128 while (key = hv_iternext(hv)) {
129 val = newSVnv(SvNV(HeVAL(key)) / c);
130 if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
135 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
139 scale(SV *csv, SV *sv)
154 if (!hv_store_ent(res, sv, val, 0))
157 hv = (HV *) SvRV(sv);
158 if (!hv_iterinit(hv)) {
160 if (!hv_store(res, "0", 1, val, 0))
164 while (key = hv_iternext(hv)) {
165 val = newSVnv(SvNV(HeVAL(key)) * c);
166 if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
171 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
186 for (i = 0; i < items; ++i) {
191 if (strEQ(SvPV_nolen(cur), "list")) {
194 if (!hv_store(res, "list", 4, val, sn_hash_list))
199 if ((old = hv_fetch_ent(res, cur, 1, 0)) && SvOK(val = HeVAL(old)))
202 if (!hv_store_ent(res, cur, val, 0))
208 hv_iterinit((HV *) cur);
209 while (key = hv_iternext((HV *) cur)) {
210 SV *k = HeSVKEY_force(key);
211 NV v = SvNV(HeVAL(key));
212 if ((old = hv_fetch_ent(res, k, 1, 0)) && SvOK(val = HeVAL(old)))
215 if (!hv_store_ent(res, k, val, 0))
219 if (!hv_iterinit(res)) {
223 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
238 UV shift = 0, do_shift = 0;
239 sn_combcache *cache = NULL;
244 res[0] = res[1] = NULL;
245 for (i = 0; i < items; ++i) {
250 if (strEQ(SvPV_nolen(cur), "list")) {
254 if (!hv_store(res[0], "list", 4, val, sn_hash_list))
268 while (key = hv_iternext((HV *) cur)) {
269 val = newSVsv(HeVAL(key));
270 if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
278 temp = sv_2mortal(newSViv(0));
279 for (++i; i < items; ++i) {
284 if (strEQ(SvPV_nolen(cur), "list")) {
287 if (!hv_store(res[n], "list", 4, val, sn_hash_list))
303 list1 = hv_delete((HV *) cur, "list", 4, 0);
304 n1 = hv_iterinit((HV *) cur);
305 list2 = hv_delete(res[n], "list", 4, 0);
306 n2 = hv_iterinit(res[n]);
307 if ((list1 && !n1) || (list2 && !n2)) {
309 if (!hv_store(res[o], "list", 4, val, sn_hash_list))
313 } else if (list1 || list2) {
314 NV l1 = list1 ? SvNV(list1) : 0;
315 NV l2 = list2 ? SvNV(list2) : 0;
316 val = newSVnv(l1 + l2 - l1 * l2);
317 if (!hv_store(res[o], "list", 4, val, sn_hash_list))
321 Renew(cache, n2, sn_combcache);
325 while (key = hv_iternext(res[n])) {
326 cache[j].k = SvUV(HeSVKEY_force(key));
327 cache[j].v = SvNV(HeVAL(key));
330 while (key = hv_iternext((HV *) cur)) {
331 IV k = SvUV(HeSVKEY_force(key));
332 NV v = SvNV(HeVAL(key));
333 for (j = 0; j < n2; ++j) {
334 sv_setiv(temp, k + cache[j].k);
335 if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
336 val = newSVnv(SvNV(val) + v * cache[j].v);
338 val = newSVnv(v * cache[j].v);
340 if (!hv_store_ent(res[o], temp, val, 0))
347 if (shift || do_shift) {
350 sv_setiv(temp, shift);
352 if (!hv_store_ent(res[n], temp, val, 0))
360 list1 = hv_delete(res[n], "list", 4, 0);
362 while (key = hv_iternext(res[n])) {
363 sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
364 val = newSVsv(HeVAL(key));
365 if (!hv_store_ent(res[o], temp, val, 0))
369 val = newSVsv(list1);
370 if (!hv_store(res[o], "list", 4, val, sn_hash_list))
375 } else if (!res[0] && !res[1])
378 SvREFCNT_dec(res[0]);
380 SvREFCNT_dec(res[1]);
381 ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
392 if (cxt == G_SCALAR) {
393 for (i = 0; i < OP_max; ++i) {
394 count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
399 } else if (cxt == G_ARRAY) {
400 for (i = 0; i < OP_max; ++i) {
401 if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
402 const char *name = PL_op_name[i];
403 XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));