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 combine(...)
 176 PROTOTYPE: @
 177 PREINIT:
 178  HV *res[2];
 179  SV *cur, *val;
 180  SV *list1, *list2;
 181  SV *temp;
 182  HE *key, *old;
 183  I32 i;
 184  I32 n = 0, o;
 185  I32 j, n1, n2;
 186  UV shift = 0, do_shift = 0;
 187  sn_combcache *cache = NULL;
 188  I32 cachelen = 0;
 189 CODE:
 190  if (!items)
 191   XSRETURN_UNDEF;
 192  res[0] = res[1] = NULL;
 193  for (i = 0; i < items; ++i) {
 194   cur = ST(i);
 195   if (!SvOK(cur))
 196    continue;
 197   if (!SvROK(cur)) {
 198    if (strEQ(SvPV_nolen(cur), "list")) {
 199     res[0] = newHV();
 200     n      = 0;
 201     val    = newSVuv(1);
 202     if (!hv_store(res[0], "list", 4, val, sn_hash_list))
 203      SvREFCNT_dec(val);
 204     i = items;
 205     if (!shift)
 206      do_shift = 0;
 207     break;
 208    } else {
 209     shift += SvUV(cur);
 210     do_shift = 1;
 211     continue;
 212    }
 213   }
 214   cur    = SvRV(cur);
 215   res[0] = newHV();
 216   while (key = hv_iternext((HV *) cur)) {
 217    val = newSVsv(HeVAL(key));
 218    if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
 219     SvREFCNT_dec(val);
 220   }
 221   n = 0;
 222   if (!shift)
 223    do_shift = 0;
 224   break;
 225  }
 226  temp = sv_2mortal(newSViv(0));
 227  for (++i; i < items; ++i) {
 228   cur = ST(i);
 229   if (!SvOK(cur))
 230    continue;
 231   if (!SvROK(cur)) {
 232    if (strEQ(SvPV_nolen(cur), "list")) {
 233     hv_clear(res[n]);
 234     val = newSVuv(1);
 235     if (!hv_store(res[n], "list", 4, val, sn_hash_list))
 236      SvREFCNT_dec(val);
 237     shift = 0;
 238     do_shift = 0;
 239     break;
 240    } else {
 241     shift += SvUV(cur);
 242     continue;
 243    }
 244   }
 245   cur = SvRV(cur);
 246   o   = 1 - n;
 247   if (!res[o])
 248    res[o] = newHV();
 249   else
 250    hv_clear(res[o]);
 251   list1 = hv_delete((HV *) cur, "list", 4, 0);
 252   n1    = hv_iterinit((HV *) cur);
 253   list2 = hv_delete(res[n],     "list", 4, 0);
 254   n2    = hv_iterinit(res[n]);
 255   if ((list1 && !n1) || (list2 && !n2)) {
 256    val = newSViv(1);
 257    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 258     SvREFCNT_dec(val);
 259    n = o;
 260    break;
 261   } else if (list1 || list2) {
 262    NV l1 = list1 ? SvNV(list1) : 0;
 263    NV l2 = list2 ? SvNV(list2) : 0;
 264    val = newSVnv(l1 + l2 - l1 * l2);
 265    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 266     SvREFCNT_dec(val);
 267   }
 268   if (n2 > cachelen) {
 269    Renew(cache, n2, sn_combcache);
 270    cachelen = n2;
 271   }
 272   j = 0;
 273   while (key = hv_iternext(res[n])) {
 274    cache[j].k = SvUV(HeSVKEY_force(key));
 275    cache[j].v = SvNV(HeVAL(key));
 276    ++j;
 277   }
 278   while (key = hv_iternext((HV *) cur)) {
 279    IV k = SvUV(HeSVKEY_force(key));
 280    NV v = SvNV(HeVAL(key));
 281    for (j = 0; j < n2; ++j) {
 282     sv_setiv(temp, k + cache[j].k);
 283     if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
 284      val = newSVnv(SvNV(val) + v * cache[j].v);
 285     } else {
 286      val = newSVnv(v * cache[j].v);
 287     }
 288     if (!hv_store_ent(res[o], temp, val, 0))
 289      SvREFCNT_dec(val);
 290    }
 291   }
 292   n = o;
 293  }
 294  Safefree(cache);
 295  if (shift || do_shift) {
 296   if (!res[n]) {
 297    res[n] = newHV();
 298    sv_setiv(temp, shift);
 299    val = newSViv(1);
 300    if (!hv_store_ent(res[n], temp, val, 0))
 301     SvREFCNT_dec(val);
 302   } else {
 303    o = 1 - n;
 304    if (!res[o])
 305     res[o] = newHV();
 306    else
 307     hv_clear(res[o]);
 308    list1 = hv_delete(res[n], "list", 4, 0);
 309    hv_iterinit(res[n]);
 310    while (key = hv_iternext(res[n])) {
 311     sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
 312     val = newSVsv(HeVAL(key));
 313     if (!hv_store_ent(res[o], temp, val, 0))
 314      SvREFCNT_dec(val);
 315    }
 316    if (list1) {
 317     val = newSVsv(list1);
 318     if (!hv_store(res[o], "list", 4, val, sn_hash_list))
 319      SvREFCNT_dec(val);
 320    }
 321    n = o;
 322   }
 323  } else if (!res[0] && !res[1])
 324   XSRETURN_UNDEF;
 325  if (n == 1)
 326   SvREFCNT_dec(res[0]);
 327  else if (res[1])
 328   SvREFCNT_dec(res[1]);
 329  ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
 330  XSRETURN(1);
 331
 332 void
 333 scalops()
 334 PROTOTYPE:
 335 PREINIT:
 336  U32 cxt;
 337  int i, count = 0;
 338 CODE:
 339  cxt = GIMME_V;
 340  if (cxt == G_SCALAR) {
 341   for (i = 0; i < OP_max; ++i) {
 342    count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
 343   }
 344   EXTEND(SP, 1);
 345   mPUSHi(count);
 346   XSRETURN(1);
 347  } else if (cxt == G_ARRAY) {
 348   for (i = 0; i < OP_max; ++i) {
 349    if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
 350     const char *name = PL_op_name[i];
 351     XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
 352     ++count;
 353    }
 354   }
 355   XSRETURN(count);
 356  }
 357