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