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