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_exists(hv, "0", 1) && hv_iterinit(hv) == 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_exists(hv, "list", 4) && hv_iterinit(hv) == 1;
  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 combine(...)
 228 PROTOTYPE: @
 229 PREINIT:
 230  HV *res[2];
 231  SV *cur, *val;
 232  SV *list1, *list2;
 233  SV *temp;
 234  HE *key, *old;
 235  I32 i;
 236  I32 n = 0, o;
 237  I32 j, n1, n2;
 238  UV shift = 0, do_shift = 0;
 239  sn_combcache *cache = NULL;
 240  I32 cachelen = 0;
 241 CODE:
 242  if (!items)
 243   XSRETURN_UNDEF;
 244  res[0] = res[1] = NULL;
 245  for (i = 0; i < items; ++i) {
 246   cur = ST(i);
 247   if (!SvOK(cur))
 248    continue;
 249   if (!SvROK(cur)) {
 250    if (strEQ(SvPV_nolen(cur), "list")) {
 251     res[0] = newHV();
 252     n      = 0;
 253     val    = newSVuv(1);
 254     if (!hv_store(res[0], "list", 4, val, sn_hash_list))
 255      SvREFCNT_dec(val);
 256     i = items;
 257     if (!shift)
 258      do_shift = 0;
 259     break;
 260    } else {
 261     shift += SvUV(cur);
 262     do_shift = 1;
 263     continue;
 264    }
 265   }
 266   cur    = SvRV(cur);
 267   res[0] = newHV();
 268   while (key = hv_iternext((HV *) cur)) {
 269    val = newSVsv(HeVAL(key));
 270    if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
 271     SvREFCNT_dec(val);
 272   }
 273   n = 0;
 274   if (!shift)
 275    do_shift = 0;
 276   break;
 277  }
 278  temp = sv_2mortal(newSViv(0));
 279  for (++i; i < items; ++i) {
 280   cur = ST(i);
 281   if (!SvOK(cur))
 282    continue;
 283   if (!SvROK(cur)) {
 284    if (strEQ(SvPV_nolen(cur), "list")) {
 285     hv_clear(res[n]);
 286     val = newSVuv(1);
 287     if (!hv_store(res[n], "list", 4, val, sn_hash_list))
 288      SvREFCNT_dec(val);
 289     shift = 0;
 290     do_shift = 0;
 291     break;
 292    } else {
 293     shift += SvUV(cur);
 294     continue;
 295    }
 296   }
 297   cur = SvRV(cur);
 298   o   = 1 - n;
 299   if (!res[o])
 300    res[o] = newHV();
 301   else
 302    hv_clear(res[o]);
 303   list1 = hv_delete((HV *) cur, "list", 4, 0);
 304   n1    = hv_iterinit((HV *) cur);
 305   list2 = hv_delete(res[n],     "list", 4, 0);
 306   n2    = hv_iterinit(res[n]);
 307   if ((list1 && !n1) || (list2 && !n2)) {
 308    val = newSViv(1);
 309    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 310     SvREFCNT_dec(val);
 311    n = o;
 312    break;
 313   } else if (list1 || list2) {
 314    NV l1 = list1 ? SvNV(list1) : 0;
 315    NV l2 = list2 ? SvNV(list2) : 0;
 316    val = newSVnv(l1 + l2 - l1 * l2);
 317    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 318     SvREFCNT_dec(val);
 319   }
 320   if (n2 > cachelen) {
 321    Renew(cache, n2, sn_combcache);
 322    cachelen = n2;
 323   }
 324   j = 0;
 325   while (key = hv_iternext(res[n])) {
 326    cache[j].k = SvUV(HeSVKEY_force(key));
 327    cache[j].v = SvNV(HeVAL(key));
 328    ++j;
 329   }
 330   while (key = hv_iternext((HV *) cur)) {
 331    IV k = SvUV(HeSVKEY_force(key));
 332    NV v = SvNV(HeVAL(key));
 333    for (j = 0; j < n2; ++j) {
 334     sv_setiv(temp, k + cache[j].k);
 335     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
 336      val = newSVnv(SvNV(val) + v * cache[j].v);
 337     } else {
 338      val = newSVnv(v * cache[j].v);
 339     }
 340     if (!hv_store_ent(res[o], temp, val, 0))
 341      SvREFCNT_dec(val);
 342    }
 343   }
 344   n = o;
 345  }
 346  Safefree(cache);
 347  if (shift || do_shift) {
 348   if (!res[n]) {
 349    res[n] = newHV();
 350    sv_setiv(temp, shift);
 351    val = newSViv(1);
 352    if (!hv_store_ent(res[n], temp, val, 0))
 353     SvREFCNT_dec(val);
 354   } else {
 355    o = 1 - n;
 356    if (!res[o])
 357     res[o] = newHV();
 358    else
 359     hv_clear(res[o]);
 360    list1 = hv_delete(res[n], "list", 4, 0);
 361    hv_iterinit(res[n]);
 362    while (key = hv_iternext(res[n])) {
 363     sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
 364     val = newSVsv(HeVAL(key));
 365     if (!hv_store_ent(res[o], temp, val, 0))
 366      SvREFCNT_dec(val);
 367    }
 368    if (list1) {
 369     val = newSVsv(list1);
 370     if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 371      SvREFCNT_dec(val);
 372    }
 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