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