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_iterinit(hv) == 1 && hv_exists(hv, "0", 1);
  63  XSRETURN_IV(res);
  64
  65 void
  66 count(SV *sv)
  67 PROTOTYPE: $
  68 PREINIT:
  69  HV *hv;
  70  HE *key;
  71  NV c = 0;
  72 CODE:
  73  if (!SvOK(sv))
  74   XSRETURN_IV(0);
  75  if (!SvROK(sv))
  76   XSRETURN_IV(1);
  77  hv = (HV *) SvRV(sv);
  78  hv_iterinit(hv);
  79  while (key = hv_iternext(hv)) {
  80   c += SvNV(HeVAL(key));
  81  }
  82  XSRETURN_NV(c);
  83
  84 void
  85 normalize(SV *sv)
  86 PROTOTYPE: $
  87 PREINIT:
  88  HV *hv, *res;
  89  HE *key;
  90  SV *val;
  91  NV c = 0;
  92 CODE:
  93  if (!SvOK(sv))
  94   XSRETURN_UNDEF;
  95  res = newHV();
  96  if (!SvROK(sv)) {
  97   val = newSVuv(1);
  98   if (!hv_store_ent(res, sv, val, 0))
  99    SvREFCNT_dec(val);
 100  } else {
 101   hv = (HV *) SvRV(sv);
 102   if (!hv_iterinit(hv)) {
 103    val = newSVuv(1);
 104    if (!hv_store(res, "0", 1, val, 0))
 105     SvREFCNT_dec(val);
 106   } else {
 107    while (key = hv_iternext(hv)) {
 108     c += SvNV(HeVAL(key));
 109    }
 110    hv_iterinit(hv);
 111    while (key = hv_iternext(hv)) {
 112     val = newSVnv(SvNV(HeVAL(key)) / c);
 113     if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
 114      SvREFCNT_dec(val);
 115    }
 116   }
 117  }
 118  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 119  XSRETURN(1);
 120
 121 void
 122 scale(SV *csv, SV *sv)
 123 PROTOTYPE: $;$
 124 PREINIT:
 125  HV *hv, *res;
 126  HE *key;
 127  SV *val;
 128  NV c = 1;
 129 CODE:
 130  if (!SvOK(sv))
 131   XSRETURN_UNDEF;
 132  if (SvOK(csv))
 133   c = SvNV(csv);
 134  res = newHV();
 135  if (!SvROK(sv)) {
 136   val = newSVnv(c);
 137   if (!hv_store_ent(res, sv, val, 0))
 138    SvREFCNT_dec(val);
 139  } else {
 140   hv = (HV *) SvRV(sv);
 141   if (!hv_iterinit(hv)) {
 142    val = newSVnv(c);
 143    if (!hv_store(res, "0", 1, val, 0))
 144     SvREFCNT_dec(val);
 145   } else {
 146    hv_iterinit(hv);
 147    while (key = hv_iternext(hv)) {
 148     val = newSVnv(SvNV(HeVAL(key)) * c);
 149     if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
 150      SvREFCNT_dec(val);
 151    }
 152   }
 153  }
 154  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 155  XSRETURN(1);
 156
 157 void
 158 add(...)
 159 PROTOTYPE: @
 160 PREINIT:
 161  HV *res;
 162  SV *cur, *val;
 163  HE *key, *old;
 164  I32 i;
 165 CODE:
 166  if (!items)
 167   XSRETURN_UNDEF;
 168  res = newHV();
 169  for (i = 0; i < items; ++i) {
 170   cur = ST(i);
 171   if (!SvOK(cur))
 172    continue;
 173   if (!SvROK(cur)) {
 174    if (strEQ(SvPV_nolen(cur), "list")) {
 175     hv_clear(res);
 176     val = newSVuv(1);
 177     if (!hv_store(res, "list", 4, val, sn_hash_list))
 178      SvREFCNT_dec(val);
 179     break;
 180    } else {
 181     NV v = 1;
 182     if ((old = hv_fetch_ent(res, cur, 1, 0)) && SvOK(val = HeVAL(old)))
 183      v += SvNV(val);
 184     val = newSVnv(v);
 185     if (!hv_store_ent(res, cur, val, 0))
 186      SvREFCNT_dec(val);
 187     continue;
 188    }
 189   }
 190   cur = SvRV(cur);
 191   hv_iterinit((HV *) cur);
 192   while (key = hv_iternext((HV *) cur)) {
 193    SV *k = HeSVKEY_force(key);
 194    NV  v = SvNV(HeVAL(key));
 195    if ((old = hv_fetch_ent(res, k, 1, 0)) && SvOK(val = HeVAL(old)))
 196     v += SvNV(val);
 197    val = newSVnv(v);
 198    if (!hv_store_ent(res, k, val, 0))
 199     SvREFCNT_dec(val);
 200   }
 201  }
 202  if (!hv_iterinit(res)) {
 203   SvREFCNT_dec(res);
 204   XSRETURN_UNDEF;
 205  }
 206  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 207  XSRETURN(1);
 208
 209 void
 210 cumulate(SV *sv, SV *nsv, SV *csv)
 211 PROTOTYPE: $$$
 212 PREINIT:
 213  HV *res;
 214  SV *val;
 215  HE *key;
 216  NV c0, c, a;
 217  UV i, n;
 218 CODE:
 219  if (!SvOK(sv))
 220   XSRETURN_UNDEF;
 221  n  = SvUV(nsv);
 222  c0 = SvNV(csv);
 223  if (!n) {
 224   ST(0) = sv_2mortal(newSVuv(0));
 225   XSRETURN(1);
 226  }
 227  if (!SvROK(sv) || !c0) {
 228   ST(0) = sv;
 229   XSRETURN(1);
 230  }
 231  sv = SvRV(sv);
 232  if (!hv_iterinit((HV *) sv))
 233   XSRETURN_UNDEF;
 234  c = 1;
 235  a = c0;
 236  for (; n > 0; n /= 2) {
 237   if (n % 2)
 238    c *= a;
 239   a *= a;
 240  }
 241  c = (1 - c) / (1 - c0);
 242  res = newHV();
 243  while (key = hv_iternext((HV *) sv)) {
 244   SV *k = HeSVKEY_force(key);
 245   val = newSVnv(c * SvNV(HeVAL(key)));
 246   if (!hv_store_ent(res, k, val, 0))
 247    SvREFCNT_dec(val);
 248  }
 249  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 250  XSRETURN(1);
 251
 252 void
 253 combine(...)
 254 PROTOTYPE: @
 255 PREINIT:
 256  HV *res[2];
 257  SV *cur, *val;
 258  SV *list1, *list2;
 259  SV *temp;
 260  HE *key, *old;
 261  I32 i;
 262  I32 n = 0, o;
 263  I32 j, n1, n2;
 264  UV shift = 0, do_shift = 0;
 265  sn_combcache *cache = NULL;
 266  I32 cachelen = 0;
 267 CODE:
 268  if (!items)
 269   XSRETURN_UNDEF;
 270  res[0] = res[1] = NULL;
 271  for (i = 0; i < items; ++i) {
 272   cur = ST(i);
 273   if (!SvOK(cur))
 274    continue;
 275   if (!SvROK(cur)) {
 276    if (strEQ(SvPV_nolen(cur), "list")) {
 277     res[0] = newHV();
 278     n      = 0;
 279     val    = newSVuv(1);
 280     if (!hv_store(res[0], "list", 4, val, sn_hash_list))
 281      SvREFCNT_dec(val);
 282     i = items;
 283     if (!shift)
 284      do_shift = 0;
 285     break;
 286    } else {
 287     shift += SvUV(cur);
 288     do_shift = 1;
 289     continue;
 290    }
 291   }
 292   cur    = SvRV(cur);
 293   res[0] = newHV();
 294   while (key = hv_iternext((HV *) cur)) {
 295    val = newSVsv(HeVAL(key));
 296    if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
 297     SvREFCNT_dec(val);
 298   }
 299   n = 0;
 300   if (!shift)
 301    do_shift = 0;
 302   break;
 303  }
 304  temp = sv_2mortal(newSViv(0));
 305  for (++i; i < items; ++i) {
 306   cur = ST(i);
 307   if (!SvOK(cur))
 308    continue;
 309   if (!SvROK(cur)) {
 310    if (strEQ(SvPV_nolen(cur), "list")) {
 311     hv_clear(res[n]);
 312     val = newSVuv(1);
 313     if (!hv_store(res[n], "list", 4, val, sn_hash_list))
 314      SvREFCNT_dec(val);
 315     shift = 0;
 316     do_shift = 0;
 317     break;
 318    } else {
 319     shift += SvUV(cur);
 320     continue;
 321    }
 322   }
 323   cur = SvRV(cur);
 324   o   = 1 - n;
 325   if (!res[o])
 326    res[o] = newHV();
 327   else
 328    hv_clear(res[o]);
 329   list1 = hv_delete((HV *) cur, "list", 4, 0);
 330   n1    = hv_iterinit((HV *) cur);
 331   list2 = hv_delete(res[n],     "list", 4, 0);
 332   n2    = hv_iterinit(res[n]);
 333   if ((list1 && !n1) || (list2 && !n2)) {
 334    val = newSViv(1);
 335    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 336     SvREFCNT_dec(val);
 337    n = o;
 338    break;
 339   } else if (list1 || list2) {
 340    NV l1 = list1 ? SvNV(list1) : 0;
 341    NV l2 = list2 ? SvNV(list2) : 0;
 342    val = newSVnv(l1 + l2 - l1 * l2);
 343    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 344     SvREFCNT_dec(val);
 345   }
 346   if (n2 > cachelen) {
 347    Renew(cache, n2, sn_combcache);
 348    cachelen = n2;
 349   }
 350   j = 0;
 351   while (key = hv_iternext(res[n])) {
 352    cache[j].k = SvUV(HeSVKEY_force(key));
 353    cache[j].v = SvNV(HeVAL(key));
 354    ++j;
 355   }
 356   while (key = hv_iternext((HV *) cur)) {
 357    IV k = SvUV(HeSVKEY_force(key));
 358    NV v = SvNV(HeVAL(key));
 359    for (j = 0; j < n2; ++j) {
 360     sv_setiv(temp, k + cache[j].k);
 361     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
 362      val = newSVnv(SvNV(val) + v * cache[j].v);
 363     } else {
 364      val = newSVnv(v * cache[j].v);
 365     }
 366     if (!hv_store_ent(res[o], temp, val, 0))
 367      SvREFCNT_dec(val);
 368    }
 369   }
 370   n = o;
 371  }
 372  Safefree(cache);
 373  if (shift || do_shift) {
 374   if (!res[n]) {
 375    res[n] = newHV();
 376    sv_setiv(temp, shift);
 377    val = newSViv(1);
 378    if (!hv_store_ent(res[n], temp, val, 0))
 379     SvREFCNT_dec(val);
 380   } else {
 381    o = 1 - n;
 382    if (!res[o])
 383     res[o] = newHV();
 384    else
 385     hv_clear(res[o]);
 386    list1 = hv_delete(res[n], "list", 4, 0);
 387    hv_iterinit(res[n]);
 388    while (key = hv_iternext(res[n])) {
 389     sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
 390     val = newSVsv(HeVAL(key));
 391     if (!hv_store_ent(res[o], temp, val, 0))
 392      SvREFCNT_dec(val);
 393    }
 394    if (list1) {
 395     val = newSVsv(list1);
 396     if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 397      SvREFCNT_dec(val);
 398    }
 399    n = o;
 400   }
 401  } else if (!res[0] && !res[1])
 402   XSRETURN_UNDEF;
 403  if (n == 1)
 404   SvREFCNT_dec(res[0]);
 405  else if (res[1])
 406   SvREFCNT_dec(res[1]);
 407  ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
 408  XSRETURN(1);
 409
 410 void
 411 scalops()
 412 PROTOTYPE:
 413 PREINIT:
 414  U32 cxt;
 415  int i, count = 0;
 416 CODE:
 417  cxt = GIMME_V;
 418  if (cxt == G_SCALAR) {
 419   for (i = 0; i < OP_max; ++i) {
 420    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
 421   }
 422   EXTEND(SP, 1);
 423   mPUSHi(count);
 424   XSRETURN(1);
 425  } else if (cxt == G_ARRAY) {
 426   for (i = 0; i < OP_max; ++i) {
 427    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
 428     const char *name = PL_op_name[i];
 429     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
 430     ++count;
 431    }
 432   }
 433   XSRETURN(count);
 434  }
 435