WIP

diff --git a/Types.xs b/Types.xs
index 6ead2eb61321356b7f6336749e2def7bd224945b..c0b1d1d85ef2b25a03ab0c2a8fba3cacd523e101 100644 (file)
--- a/Types.xs
+++ b/Types.xs
@@ -16,10 +16,12 @@
 #if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
 # ifndef PL_in_my_stash
 #  define PL_in_my_stash PL_parser->in_my_stash
+#  define PL_tokenbuf    PL_parser->tokenbuf
 # endif
 #else
 # ifndef PL_in_my_stash
 #  define PL_in_my_stash PL_Iin_my_stash
+#  define PL_tokenbuf    PL_Itokenbuf
 # endif
 #endif
 
@@ -31,6 +33,14 @@
 # define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
 #endif
 
+#ifndef STR_WITH_LEN
+# define STR_WITH_LEN(s)  ("" s ""), (sizeof(s)-1)
+#endif
+
+#ifndef newSVpvs
+# define newSVpvs(S) Perl_newSVpvn(aTHX_ STR_WITH_LEN(S))
+#endif
+
 #ifndef HvNAME_get
 # define HvNAME_get(H) HvNAME(H)
 #endif
@@ -197,13 +207,28 @@ typedef SV lt_hint_t;
 
 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 
+#define LT_TYPE_SCALAR 0
+
+#if LT_HAS_PERL(5, 11, 1)
+
+#define LT_TYPE_ARRAY  1
+#define LT_TYPE_HASH   2
+
+#define LT_TYPE_COUNT  3
+
+#else
+
+#define LT_TYPE_COUNT  1
+
+#endif
+
 typedef struct {
 #if LT_THREADSAFE
  ptable *tbl; /* It really is a ptable_hints */
  tTHX    owner;
 #endif
  ptable *seen; /* It really is a ptable_seen */
- SV     *default_meth;
+ SV     *default_meth[LT_TYPE_COUNT];
 } my_cxt_t;
 
 START_MY_CXT
@@ -439,9 +464,14 @@ typedef struct {
 #endif /* !MULTIPLICITY */
 } lt_op_padxv_info;
 
+STATIC const char lt_type_desc_scalar[] = "scalar";
+STATIC const char lt_type_desc_array[]  = "array";
+STATIC const char lt_type_desc_hash[]   = "hash";
+
 STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
 #define lt_op_padxv_info_call(O, S) lt_op_padxv_info_call(aTHX_ (O), (S))
  SV *orig_pkg, *type_pkg, *type_meth;
+ svtype var_type;
  int items;
  dSP;
 
@@ -470,7 +500,16 @@ STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
  PUSHMARK(SP);
  EXTEND(SP, 3);
  PUSHs(type_pkg);
- PUSHs(sv);
+ var_type = SvTYPE(sv);
+ switch (var_type) {
+  case SVt_PVAV:
+  case SVt_PVHV:
+   PUSHs(sv_2mortal(newRV_inc(sv)));
+   break;
+  default:
+   PUSHs(sv);
+   break;
+ }
  PUSHs(orig_pkg);
  PUTBACK;
 
@@ -480,11 +519,64 @@ STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
  switch (items) {
   case 0:
    break;
-  case 1:
-   sv_setsv(sv, POPs);
+  case 1: {
+   SV *rsv = POPs;
+   switch (var_type) {
+    case SVt_PVAV:
+     if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
+      AV *av = (AV *) SvRV(rsv);
+      SV **src, **dst;
+      I32 len = av_len(av);
+      I32 i;
+      av_fill((AV *) sv, len);
+      src = AvARRAY(av);
+      dst = AvARRAY(sv);
+      for (i = 0; i <= len; ++i, ++src, ++dst) {
+       SvREFCNT_dec(*dst);
+       *dst = SvREFCNT_inc(*src);
+      }
+     } else {
+      goto type_mismatch;
+     }
+     break;
+    case SVt_PVHV:
+     if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
+      HV *hv = (HV *) SvRV(rsv);
+      HE *he;
+      hv_iterinit(hv);
+      hv_clear((HV *) sv);
+      while ((he = hv_iternext(hv)) != NULL) {
+       SV *val = SvREFCNT_inc(HeVAL(he));
+       if (!hv_store((HV *) sv, HeKEY(he), HeKLEN(he), val, HeHASH(he)))
+        SvREFCNT_dec(val);
+      }
+     } else {
+      goto type_mismatch;
+     }
+     break;
+    default:
+     sv_setsv(sv, rsv);
+     break;
+   }
    break;
-  default:
-   croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
+type_mismatch:
+   croak("Type mismatch");
+  }
+  default: {
+   const char *type_desc;
+   switch (var_type) {
+    case SVt_PVAV:
+     type_desc = lt_type_desc_array;
+     break;
+    case SVt_PVHV:
+     type_desc = lt_type_desc_hash;
+     break;
+    default:
+     type_desc = lt_type_desc_scalar;
+     break;
+   }
+   croak("Typed %s initializer method should return zero or one scalar, but got %d", type_desc, items);
+  }
  }
  PUTBACK;
 
@@ -626,7 +718,7 @@ STATIC void lt_map_delete(pTHX_ const OP *o) {
 
 /* ... Our pp_padsv ........................................................ */
 
-STATIC OP *lt_pp_padsv(pTHX) {
+STATIC OP *lt_pp_padxv(pTHX) {
  lt_op_padxv_info oi;
 
  if (lt_padxv_map_fetch(PL_op, &oi)) {
@@ -654,8 +746,19 @@ STATIC OP *lt_pp_padrange(pTHX) {
 
   for (i = 0, p = roi.padxv_start; i < count && p; ++i, p = p->op_sibling) {
    lt_op_padxv_info oi;
-   if (p->op_type == OP_PADSV && lt_padxv_map_fetch(p, &oi))
-    lt_op_padxv_info_call(&oi, PAD_SV(base + i));
+
+   switch (p->op_type) {
+    case OP_PADSV:
+#if LT_HAS_PERL(5, 11, 1)
+    case OP_PADAV:
+    case OP_PADHV:
+#endif
+     if (lt_padxv_map_fetch(p, &oi))
+      lt_op_padxv_info_call(&oi, PAD_SV(base + i));
+     break;
+    default:
+     break;
+   }
   }
 
   return roi.old_pp(aTHX);
@@ -666,10 +769,10 @@ STATIC OP *lt_pp_padrange(pTHX) {
 
 #endif
 
-/* ... Our ck_pad{any,sv} .................................................. */
+/* ... Our ck_pad{any,sv,av,hv} ............................................ */
 
-/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
- * function, but are instead manually mutated from a padany. So we store
+/* Sadly, the padxv OPs we are interested in don't trigger the padxv check
+ * functions, but are instead manually mutated from a padany. So we store
  * the op entry in the op map in the padany check function, and we set their
  * op_ppaddr member in our peephole optimizer replacement below. */
 
@@ -685,11 +788,34 @@ STATIC OP *lt_ck_padany(pTHX_ OP *o) {
  if (stash && (code = lt_hint())) {
   dMY_CXT;
   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
-  SV *orig_meth = MY_CXT.default_meth;
+  SV *orig_meth = NULL;
   SV *type_pkg  = NULL;
   SV *type_meth = NULL;
+  unsigned int type;
+  const char *s;
   int items;
 
+  s = PL_tokenbuf;
+  while (*s && isSPACE(*s))
+   ++s;
+  switch (*s) {
+   case '$':
+    type = LT_TYPE_SCALAR;
+    break;
+#if LT_HAS_PERL(5, 11, 1)
+   case '@':
+    type = LT_TYPE_ARRAY;
+    break;
+   case '%':
+    type = LT_TYPE_HASH;
+    break;
+#endif
+   default:
+    croak("Unsupported sigil '%c'", *s);
+    break;
+  }
+  orig_meth = MY_CXT.default_meth[type];
+
   dSP;
 
   SvREADONLY_on(orig_pkg);
@@ -760,6 +886,26 @@ STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
  return lt_old_ck_padsv(aTHX_ o);
 }
 
+#if LT_HAS_PERL(5, 11, 1)
+
+STATIC OP *(*lt_old_ck_padav)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padav(pTHX_ OP *o) {
+ lt_map_delete(o);
+
+ return lt_old_ck_padav(aTHX_ o);
+}
+
+STATIC OP *(*lt_old_ck_padhv)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padhv(pTHX_ OP *o) {
+ lt_map_delete(o);
+
+ return lt_old_ck_padhv(aTHX_ o);
+}
+
+#endif
+
 /* ... Our peephole optimizer .............................................. */
 
 #if LT_HAS_PERL(5, 17, 6)
@@ -772,19 +918,27 @@ STATIC int lt_maybe_padrange_setup(pTHX_ OP *o, const OP *start) {
  count = o->op_private & OPpPADRANGE_COUNTMASK;
 
  for (i = 0, p = start; i < count && p; ++i, p = p->op_sibling) {
-  if (p->op_type == OP_PADSV) {
-   /* In a padrange sequence, either all lexicals are typed, or none are.
-    * Thus we can stop at the first padsv op. However, note that these
-    * lexicals can need to call different methods in different packages. */
-   LT_LOCK(&lt_op_map_mutex);
-   if (ptable_fetch(lt_op_padxv_map, p)) {
-    LT_UNLOCK(&lt_op_map_mutex);
-    lt_padrange_map_store(o, start, o->op_ppaddr);
-    o->op_ppaddr = lt_pp_padrange;
-   } else {
-    LT_UNLOCK(&lt_op_map_mutex);
-   }
-   return 1;
+  switch (p->op_type) {
+   case OP_PADSV:
+#if LT_HAS_PERL(5, 11, 1)
+   case OP_PADAV:
+   case OP_PADHV:
+#endif
+    /* In a padrange sequence, either all lexicals are typed, or none are.
+     * Thus we can stop at the first padsv op. However, note that these
+     * lexicals can need to call different methods in different packages. */
+    LT_LOCK(&lt_op_map_mutex);
+    if (ptable_fetch(lt_op_padxv_map, p)) {
+     LT_UNLOCK(&lt_op_map_mutex);
+     lt_padrange_map_store(o, start, o->op_ppaddr);
+     o->op_ppaddr = lt_pp_padrange;
+    } else {
+     LT_UNLOCK(&lt_op_map_mutex);
+    }
+    return 1;
+    break;
+   default:
+    break;
   }
  }
 
@@ -804,13 +958,17 @@ STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) {
 
   switch (o->op_type) {
    case OP_PADSV:
-    if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
+#if LT_HAS_PERL(5, 11, 1)
+   case OP_PADAV:
+   case OP_PADHV:
+#endif
+    if (o->op_ppaddr != lt_pp_padxv && o->op_private & OPpLVAL_INTRO) {
      lt_op_padxv_info *oi;
      LT_LOCK(&lt_op_map_mutex);
      oi = ptable_fetch(lt_op_padxv_map, o);
      if (oi) {
       oi->old_pp   = o->op_ppaddr;
-      o->op_ppaddr = lt_pp_padsv;
+      o->op_ppaddr = lt_pp_padxv;
      }
      LT_UNLOCK(&lt_op_map_mutex);
     }
@@ -909,16 +1067,22 @@ STATIC void lt_teardown(pTHX_ void *root) {
 #endif
 
  {
+  unsigned int i;
   dMY_CXT;
 #if LT_THREADSAFE
   ptable_hints_free(MY_CXT.tbl);
 #endif
   ptable_seen_free(MY_CXT.seen);
-  SvREFCNT_dec(MY_CXT.default_meth);
+  for (i = 0; i < LT_TYPE_COUNT; ++i)
+   SvREFCNT_dec(MY_CXT.default_meth[i]);
  }
 
  lt_ck_restore(OP_PADANY, &lt_old_ck_padany);
  lt_ck_restore(OP_PADSV,  &lt_old_ck_padsv);
+#if LT_HAS_PERL(5, 11, 1)
+ lt_ck_restore(OP_PADAV,  &lt_old_ck_padav);
+ lt_ck_restore(OP_PADHV,  &lt_old_ck_padhv);
+#endif
 
 #if LT_HAS_RPEEP
  PL_rpeepp   = lt_old_peep;
@@ -938,16 +1102,26 @@ STATIC void lt_setup(pTHX) {
  {
   MY_CXT_INIT;
 #if LT_THREADSAFE
-  MY_CXT.tbl          = ptable_new();
-  MY_CXT.owner        = aTHX;
+  MY_CXT.tbl   = ptable_new();
+  MY_CXT.owner = aTHX;
+#endif
+  MY_CXT.seen  = ptable_new();
+  MY_CXT.default_meth[LT_TYPE_SCALAR] = newSVpvs("TYPEDSCALAR");
+  SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_SCALAR]);
+#if LT_HAS_PERL(5, 11, 1)
+  MY_CXT.default_meth[LT_TYPE_ARRAY]  = newSVpvs("TYPEDARRAY");
+  SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_ARRAY]);
+  MY_CXT.default_meth[LT_TYPE_HASH]   = newSVpvs("TYPEDHASH");
+  SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_HASH]);
 #endif
-  MY_CXT.seen         = ptable_new();
-  MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
-  SvREADONLY_on(MY_CXT.default_meth);
  }
 
  lt_ck_replace(OP_PADANY, lt_ck_padany, &lt_old_ck_padany);
  lt_ck_replace(OP_PADSV,  lt_ck_padsv,  &lt_old_ck_padsv);
+#if LT_HAS_PERL(5, 11, 1)
+ lt_ck_replace(OP_PADAV,  lt_ck_padav,  &lt_old_ck_padav);
+ lt_ck_replace(OP_PADHV,  lt_ck_padhv,  &lt_old_ck_padhv);
+#endif
 
 #if LT_HAS_RPEEP
  lt_old_peep = PL_rpeepp;
@@ -1003,9 +1177,10 @@ void
 CLONE(...)
 PROTOTYPE: DISABLE
 PREINIT:
- ptable *t;
- ptable *s;
- SV     *cloned_default_meth;
+ ptable      *t;
+ ptable      *s;
+ SV          *cloned_default_meth[LT_TYPE_COUNT];
+ unsigned int i;
 PPCODE:
  {
   {
@@ -1015,17 +1190,19 @@ PPCODE:
    t = ptable_new();
    lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
    ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
-   cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud);
+   for (i = 0; i < LT_TYPE_COUNT; ++i)
+    cloned_default_meth[i] = lt_dup_inc(MY_CXT.default_meth[i], &ud);
    lt_ptable_clone_ud_deinit(ud);
   }
   s = ptable_new();
  }
  {
   MY_CXT_CLONE;
-  MY_CXT.tbl          = t;
-  MY_CXT.owner        = aTHX;
-  MY_CXT.seen         = s;
-  MY_CXT.default_meth = cloned_default_meth;
+  MY_CXT.tbl           = t;
+  MY_CXT.owner         = aTHX;
+  MY_CXT.seen          = s;
+  for (i = 0; i < LT_TYPE_COUNT; ++i)
+   MY_CXT.default_meth[i] = cloned_default_meth[i];
  }
  reap(3, lt_thread_cleanup, NULL);
  XSRETURN(0);