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    SvREFCNT_dec(res);
 118    XSRETURN_UNDEF;
 119   }
 120  } else {
 121   hv = (HV *) SvRV(sv);
 122   if (!hv_iterinit(hv)) {
 123    val = newSVuv(1);
 124    if (!hv_store(res, "0", 1, val, 0)) {
 125     SvREFCNT_dec(val);
 126     SvREFCNT_dec(res);
 127     XSRETURN_UNDEF;
 128    }
 129   } else {
 130    while (key = hv_iternext(hv)) {
 131     c += SvNV(HeVAL(key));
 132    }
 133    hv_iterinit(hv);
 134    while (key = hv_iternext(hv)) {
 135     val = newSVnv(SvNV(HeVAL(key)) / c);
 136     if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
 137      SvREFCNT_dec(val);
 138    }
 139   }
 140  }
 141  ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 142  XSRETURN(1);
 143
 144 void
 145 combine(...)
 146 PROTOTYPE: @
 147 PREINIT:
 148  HV *res[2];
 149  SV *cur, *val;
 150  SV *list1, *list2;
 151  SV *temp;
 152  HE *key, *old;
 153  I32 i;
 154  I32 n = 0, o;
 155  I32 j, n1, n2;
 156  UV shift = 0, do_shift = 0;
 157  sn_combcache *cache = NULL;
 158  I32 cachelen = 0;
 159 CODE:
 160  if (!items)
 161   XSRETURN_UNDEF;
 162  res[0] = res[1] = NULL;
 163  for (i = 0; i < items; ++i) {
 164   cur = ST(i);
 165   if (!SvOK(cur))
 166    continue;
 167   if (!SvROK(cur)) {
 168    if (strEQ(SvPV_nolen(cur), "list")) {
 169     res[0] = newHV();
 170     n      = 0;
 171     val    = newSVuv(1);
 172     if (!hv_store(res[0], "list", 4, val, sn_hash_list))
 173      SvREFCNT_dec(val);
 174     i = items;
 175     if (!shift)
 176      do_shift = 0;
 177     break;
 178    } else {
 179     shift += SvUV(cur);
 180     do_shift = 1;
 181     continue;
 182    }
 183   }
 184   cur    = SvRV(cur);
 185   res[0] = newHV();
 186   while (key = hv_iternext((HV *) cur)) {
 187    val = newSVsv(HeVAL(key));
 188    if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
 189     SvREFCNT_dec(val);
 190   }
 191   n = 0;
 192   if (!shift)
 193    do_shift = 0;
 194   break;
 195  }
 196  temp = sv_2mortal(newSViv(0));
 197  for (++i; i < items; ++i) {
 198   cur = ST(i);
 199   if (!SvOK(cur))
 200    continue;
 201   if (!SvROK(cur)) {
 202    if (strEQ(SvPV_nolen(cur), "list")) {
 203     hv_clear(res[n]);
 204     val = newSVuv(1);
 205     if (!hv_store(res[n], "list", 4, val, sn_hash_list))
 206      SvREFCNT_dec(val);
 207     shift = 0;
 208     do_shift = 0;
 209     break;
 210    } else {
 211     shift += SvUV(cur);
 212     continue;
 213    }
 214   }
 215   cur = SvRV(cur);
 216   o   = 1 - n;
 217   if (!res[o])
 218    res[o] = newHV();
 219   else
 220    hv_clear(res[o]);
 221   list1 = hv_delete((HV *) cur, "list", 4, 0);
 222   n1    = hv_iterinit((HV *) cur);
 223   list2 = hv_delete(res[n],     "list", 4, 0);
 224   n2    = hv_iterinit(res[n]);
 225   if ((list1 && !n1) || (list2 && !n2)) {
 226    val = newSViv(1);
 227    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 228     SvREFCNT_dec(val);
 229    n = o;
 230    break;
 231   } else if (list1 || list2) {
 232    NV l1 = list1 ? SvNV(list1) : 0;
 233    NV l2 = list2 ? SvNV(list2) : 0;
 234    val = newSVnv(l1 + l2 - l1 * l2);
 235    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 236     SvREFCNT_dec(val);
 237   }
 238   if (n2 > cachelen) {
 239    Renew(cache, n2, sn_combcache);
 240    cachelen = n2;
 241   }
 242   j = 0;
 243   while (key = hv_iternext(res[n])) {
 244    cache[j].k = SvUV(HeSVKEY_force(key));
 245    cache[j].v = SvNV(HeVAL(key));
 246    ++j;
 247   }
 248   while (key = hv_iternext((HV *) cur)) {
 249    IV k = SvUV(HeSVKEY_force(key));
 250    NV v = SvNV(HeVAL(key));
 251    for (j = 0; j < n2; ++j) {
 252     sv_setiv(temp, k + cache[j].k);
 253     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
 254      val = newSVnv(SvNV(val) + v * cache[j].v);
 255     } else {
 256      val = newSVnv(v * cache[j].v);
 257     }
 258     if (!hv_store_ent(res[o], temp, val, 0))
 259      SvREFCNT_dec(val);
 260    }
 261   }
 262   n = o;
 263  }
 264  Safefree(cache);
 265  if (shift || do_shift) {
 266   if (!res[n]) {
 267    res[n] = newHV();
 268    sv_setiv(temp, shift);
 269    val = newSViv(1);
 270    if (!hv_store_ent(res[n], temp, val, 0))
 271     SvREFCNT_dec(val);
 272   } else {
 273    o = 1 - n;
 274    if (!res[o])
 275     res[o] = newHV();
 276    else
 277     hv_clear(res[o]);
 278    list1 = hv_delete(res[n], "list", 4, 0);
 279    hv_iterinit(res[n]);
 280    while (key = hv_iternext(res[n])) {
 281     sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
 282     val = newSVsv(HeVAL(key));
 283     if (!hv_store_ent(res[o], temp, val, 0))
 284      SvREFCNT_dec(val);
 285    }
 286    if (list1) {
 287     val = newSVsv(list1);
 288     if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 289      SvREFCNT_dec(val);
 290    }
 291    n = o;
 292   }
 293  } else if (!res[0] && !res[1])
 294   XSRETURN_UNDEF;
 295  if (n == 1)
 296   SvREFCNT_dec(res[0]);
 297  else if (res[1])
 298   SvREFCNT_dec(res[1]);
 299  ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
 300  XSRETURN(1);
 301
 302 void
 303 scalops()
 304 PROTOTYPE:
 305 PREINIT:
 306  U32 cxt;
 307  int i, count = 0;
 308 CODE:
 309  cxt = GIMME_V;
 310  if (cxt == G_SCALAR) {
 311   for (i = 0; i < OP_max; ++i) {
 312    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
 313   }
 314   EXTEND(SP, 1);
 315   mPUSHi(count);
 316   XSRETURN(1);
 317  } else if (cxt == G_ARRAY) {
 318   for (i = 0; i < OP_max; ++i) {
 319    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
 320     const char *name = PL_op_name[i];
 321     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
 322     ++count;
 323    }
 324   }
 325   XSRETURN(count);
 326  }
 327