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