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 Newx
  10 # define Newx(v, n, c) New(0, v, n, c)
  11 #endif
  12
  13 #ifndef mPUSHi
  14 # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
  15 #endif /* !mPUSHi */
  16
  17 typedef struct {
  18  UV k;
  19  NV v;
  20 } sn_combcache;
  21
  22 STATIC void sn_store(pTHX_ HV *tb, const char *key, I32 klen, SV *val, U32 hash) {
  23 #define sn_store(T, K, KL, V, H) sn_store(aTHX_ (T), (K), (KL), (V), (H))
  24  if (!hv_store(tb, key, klen, val, hash)) SvREFCNT_dec(val);
  25 }
  26
  27 STATIC void sn_store_ent(pTHX_ HV *tb, SV *key, SV *val, U32 hash) {
  28 #define sn_store_ent(T, K, V, H) sn_store_ent(aTHX_ (T), (K), (V), (H))
  29  if (!hv_store_ent(tb, key, val, hash)) SvREFCNT_dec(val);
  30 }
  31
  32 STATIC U32 sn_hash_list = 0;
  33 STATIC U32 sn_hash_exit = 0;
  34 STATIC U32 sn_hash_die  = 0;
  35
  36 /* --- XS ------------------------------------------------------------------ */
  37
  38 MODULE = Sub::Nary            PACKAGE = Sub::Nary
  39
  40 PROTOTYPES: ENABLE
  41
  42 BOOT:
  43 {
  44  PERL_HASH(sn_hash_list, "list", 4);
  45  PERL_HASH(sn_hash_exit, "exit", 4);
  46  PERL_HASH(sn_hash_die,  "die",  3);
  47 }
  48
  49 void
  50 tag(SV *op)
  51 PROTOTYPE: $
  52 CODE:
  53  ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
  54  XSRETURN(1);
  55
  56 void
  57 null(SV *op)
  58 PROTOTYPE: $
  59 PREINIT:
  60  OP *o;
  61 CODE:
  62  o = INT2PTR(OP *, SvUV(SvRV(op)));
  63  ST(0) = sv_2mortal(newSVuv(o == NULL));
  64  XSRETURN(1);
  65
  66 void
  67 zero(SV *sv)
  68 PROTOTYPE: $
  69 PREINIT:
  70  HV *hv;
  71  IV res;
  72 CODE:
  73  if (!SvOK(sv))
  74   XSRETURN_IV(1);
  75  if (!SvROK(sv)) {
  76   res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
  77   XSRETURN_IV(res);
  78  }
  79  hv = (HV *) SvRV(sv);
  80  res = hv_iterinit(hv) == 1 && hv_exists(hv, "0", 1);
  81  XSRETURN_IV(res);
  82
  83 void
  84 count(SV *sv)
  85 PROTOTYPE: $
  86 PREINIT:
  87  HV *hv;
  88  HE *key;
  89  NV c = 0;
  90 CODE:
  91  if (!SvOK(sv))
  92   XSRETURN_IV(0);
  93  if (!SvROK(sv))
  94   XSRETURN_IV(1);
  95  hv = (HV *) SvRV(sv);
  96  hv_iterinit(hv);
  97  while (key = hv_iternext(hv)) {
  98   c += SvNV(HeVAL(key));
  99  }
 100  XSRETURN_NV(c);
 101
 102 void
 103 normalize(SV *sv)
 104 PROTOTYPE: $
 105 PREINIT:
 106  HV *hv, *res;
 107  HE *key;
 108  NV c = 0;
 109 CODE:
 110  if (!SvOK(sv))
 111   XSRETURN_UNDEF;
 112  res = newHV();
 113  if (!SvROK(sv)) {
 114   sn_store_ent(res, sv, newSVuv(1), 0);
 115  } else {
 116   hv = (HV *) SvRV(sv);
 117   if (!hv_iterinit(hv)) {
 118    sn_store(res, "0", 1, newSVuv(1), 0);
 119   } else {
 120    while (key = hv_iternext(hv))
 121     c += SvNV(HeVAL(key));
 122    hv_iterinit(hv);
 123    while (key = hv_iternext(hv)) {
 124     SV *val = newSVnv(SvNV(HeVAL(key)) / c);
 125     sn_store_ent(res, HeSVKEY_force(key), val, HeHASH(key));
 126    }
 127   }
 128  }
 129  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 130  XSRETURN(1);
 131
 132 void
 133 scale(SV *csv, SV *sv)
 134 PROTOTYPE: $;$
 135 PREINIT:
 136  HV *hv, *res;
 137  HE *key;
 138  NV c = 1;
 139 CODE:
 140  if (!SvOK(sv))
 141   XSRETURN_UNDEF;
 142  if (SvOK(csv))
 143   c = SvNV(csv);
 144  res = newHV();
 145  if (!SvROK(sv)) {
 146   sn_store_ent(res, sv, newSVnv(c), 0);
 147  } else {
 148   hv = (HV *) SvRV(sv);
 149   if (!hv_iterinit(hv)) {
 150    XSRETURN_UNDEF;
 151   } else {
 152    hv_iterinit(hv);
 153    while (key = hv_iternext(hv)) {
 154     SV *val = newSVnv(SvNV(HeVAL(key)) * c);
 155     sn_store_ent(res, HeSVKEY_force(key), val, HeHASH(key));
 156    }
 157   }
 158  }
 159  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 160  XSRETURN(1);
 161
 162 void
 163 add(...)
 164 PROTOTYPE: @
 165 PREINIT:
 166  HV *res;
 167  SV *cur, *val;
 168  HE *key, *old;
 169  I32 i;
 170 CODE:
 171  if (!items)
 172   XSRETURN_UNDEF;
 173  res = newHV();
 174  for (i = 0; i < items; ++i) {
 175   cur = ST(i);
 176   if (!SvOK(cur))
 177    continue;
 178   if (!SvROK(cur)) {
 179    NV v = 1;
 180    if ((old = hv_fetch_ent(res, cur, 1, 0)) && SvOK(val = HeVAL(old)))
 181     v += SvNV(val);
 182    sn_store_ent(res, cur, newSVnv(v), 0);
 183    continue;
 184   }
 185   cur = SvRV(cur);
 186   hv_iterinit((HV *) cur);
 187   while (key = hv_iternext((HV *) cur)) {
 188    SV *k = HeSVKEY_force(key);
 189    NV  v = SvNV(HeVAL(key));
 190    if ((old = hv_fetch_ent(res, k, 1, 0)) && SvOK(val = HeVAL(old)))
 191     v += SvNV(val);
 192    sn_store_ent(res, k, newSVnv(v), 0);
 193   }
 194  }
 195  if (!hv_iterinit(res)) {
 196   SvREFCNT_dec(res);
 197   XSRETURN_UNDEF;
 198  }
 199  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 200  XSRETURN(1);
 201
 202 void
 203 cumulate(SV *sv, SV *nsv, SV *csv)
 204 PROTOTYPE: $$$
 205 PREINIT:
 206  HV *res;
 207  HE *key;
 208  NV c0, c, a;
 209  UV i, n;
 210 CODE:
 211  if (!SvOK(sv))
 212   XSRETURN_UNDEF;
 213  n  = SvUV(nsv);
 214  c0 = SvNV(csv);
 215  if (!n) {
 216   ST(0) = sv_2mortal(newSVuv(0));
 217   XSRETURN(1);
 218  }
 219  if (!SvROK(sv) || !c0) {
 220   ST(0) = sv;
 221   XSRETURN(1);
 222  }
 223  sv = SvRV(sv);
 224  if (!hv_iterinit((HV *) sv))
 225   XSRETURN_UNDEF;
 226  if (c0 == 1 || (SvIOK(csv) && SvIV(csv) == 1)) {
 227   c = n;
 228  } else {
 229   c = 1;
 230   a = c0;
 231   for (; n > 0; n /= 2) {
 232    if (n % 2)
 233     c *= a;
 234    a *= a;
 235   }
 236   c = (1 - c) / (1 - c0);
 237  }
 238  res = newHV();
 239  while (key = hv_iternext((HV *) sv)) {
 240   SV *k   = HeSVKEY_force(key);
 241   SV *val = newSVnv(c * SvNV(HeVAL(key)));
 242   sn_store_ent(res, k, val, 0);
 243  }
 244  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 245  XSRETURN(1);
 246
 247 void
 248 combine(...)
 249 PROTOTYPE: @
 250 PREINIT:
 251  HV *res[3];
 252  SV *val;
 253  SV *kexit, *klist, *kdie;
 254  SV *temp;
 255  HE *key, *old;
 256  I32 i;
 257  I32 n = 0, o;
 258  I32 j, n1, n2;
 259  NV pe = 0, pd = 0, pl = 0;
 260  sn_combcache *cache = NULL;
 261  I32 cachelen = 1;
 262 CODE:
 263  if (!items)
 264   XSRETURN_UNDEF;
 265  res[0] = newHV();
 266  res[1] = NULL;
 267  res[2] = NULL;
 268  Newx(cache, 1, sn_combcache);
 269  n = 0;
 270  temp = sv_2mortal(newSViv(0));
 271  for (i = 0; i < items; ++i) {
 272   SV *cur = ST(i);
 273   NV pe1 = 0, pd1 = 0, pd2, pl1 = 0;
 274   if (!SvOK(cur))
 275    continue;
 276   if (!SvROK(cur)) {
 277    if (!res[2])
 278     res[2] = newHV();
 279    else
 280     hv_clear(res[2]);
 281    sn_store_ent(res[2], cur, newSVuv(1), 0);
 282    cur = (SV *) res[2];
 283   } else
 284    cur = SvRV(cur);
 285   o = 1 - n;
 286   if (!res[o])
 287    res[o] = newHV();
 288   else
 289    hv_clear(res[o]);
 290   kexit = hv_delete((HV *) cur, "exit", 4, 0);
 291   n1    = hv_iterinit((HV *) cur);
 292   if (kexit) {
 293    if (!n1) {
 294     pe = 1 - pd;
 295     pl = 0;
 296     n  = o;
 297     break;
 298    }
 299    pe1 = SvNV(kexit);
 300   }
 301   kdie  = hv_delete((HV *) cur, "die", 3, 0);
 302   if (kdie) {
 303    if (n1 == 1) {
 304     pd = 1 - pe;
 305     pl = 0;
 306     n  = o;
 307     break;
 308    }
 309    --n1;
 310    pd1 = SvNV(kdie);
 311   }
 312   klist = hv_delete((HV *) cur, "list", 4, 0);
 313   if (klist) {
 314    if (n1 == 1) {
 315     pl = 1 - (pe + pd);
 316     n  = o;
 317     break;
 318    }
 319    pl1 = SvNV(klist);
 320   }
 321   pl  = pl1 * (1 - (pd + pe)) + pl * (1 - (pd1 + pe1)) - pl * pl1;
 322   pd2 = pd1 * (1 - pe)        + pd                     - pd * pd1;
 323   pe  = pe1 * (1 - pd)        + pe                     - pe * pe1;
 324   pd  = pd2;
 325   n2  = hv_iterinit(res[n]);
 326   if (!n2) {
 327    cache[0].k = 0;
 328    cache[0].v = 1;
 329    n2 = 1;
 330   } else {
 331    if (n2 > cachelen) {
 332     Renew(cache, n2, sn_combcache);
 333     cachelen = n2;
 334    }
 335    j = 0;
 336    while (key = hv_iternext(res[n])) {
 337     cache[j].k = SvUV(HeSVKEY_force(key));
 338     cache[j].v = SvNV(HeVAL(key));
 339     ++j;
 340    }
 341   }
 342   while (key = hv_iternext((HV *) cur)) {
 343    IV k = SvUV(HeSVKEY_force(key));
 344    NV v = SvNV(HeVAL(key));
 345    for (j = 0; j < n2; ++j) {
 346     sv_setiv(temp, k + cache[j].k);
 347     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
 348      val = newSVnv(SvNV(val) + v * cache[j].v);
 349     } else {
 350      val = newSVnv(v * cache[j].v);
 351     }
 352     sn_store_ent(res[o], temp, val, 0);
 353    }
 354   }
 355   n = o;
 356  }
 357  Safefree(cache);
 358  SvREFCNT_dec(res[2]);
 359  if (pe)
 360   sn_store(res[n], "exit", 4, newSVnv(pe), sn_hash_exit);
 361  if (pd)
 362   sn_store(res[n], "die",  3, newSVnv(pd), sn_hash_die);
 363  if (pl)
 364   sn_store(res[n], "list", 4, newSVnv(pl), sn_hash_list);
 365  if (n == 1)
 366   SvREFCNT_dec(res[0]);
 367  else if (res[1])
 368   SvREFCNT_dec(res[1]);
 369  if (!hv_iterinit(res[n])) {
 370   SvREFCNT_dec(res[n]);
 371   XSRETURN_UNDEF;
 372  } else {
 373   ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
 374   XSRETURN(1);
 375  }
 376
 377 void
 378 scalops()
 379 PROTOTYPE:
 380 PREINIT:
 381  U32 cxt;
 382  int i, count = 0;
 383 CODE:
 384  cxt = GIMME_V;
 385  if (cxt == G_SCALAR) {
 386   for (i = 0; i < OP_max; ++i) {
 387    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
 388   }
 389   EXTEND(SP, 1);
 390   mPUSHi(count);
 391   XSRETURN(1);
 392  } else if (cxt == G_ARRAY) {
 393   for (i = 0; i < OP_max; ++i) {
 394    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
 395     const char *name = PL_op_name[i];
 396     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
 397     ++count;
 398    }
 399   }
 400   XSRETURN(count);
 401  }
 402