Initial attack at basic 'class' feature

Adds a new experimental warning, feature, keywords and enough parsing to
implement basic classes with an empty `new` constructor method.

Inject a $self lexical into method bodies; populate it with the object instance, suitably shifted
Creates a new OP_METHSTART opcode to perform method setup
Define an aux flag to remark which stashes are classes

Basic implementation of fields.

Basic anonymous methods.

1 files changed, 58 insertions, 7 deletions

diff --git a/toke.c b/toke.c
index 14808e3731..6433fdeea6 100644
--- a/toke.c
+++ b/toke.c
@@ -235,6 +235,7 @@ static const char* const lex_state_names[] = {
 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
+#define PHASERBLOCK(f) return (pl_yylval.ival=f, PL_expect = XBLOCK, PL_bufptr = s, REPORT((int)PHASER))
 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
                          pl_yylval.ival=f, \
@@ -441,16 +442,20 @@ static struct debug_tokens {
     DEBUG_TOKEN (OPNUM, FUNC1),
     DEBUG_TOKEN (NONE,  HASHBRACK),
     DEBUG_TOKEN (IVAL,  KW_CATCH),
+    DEBUG_TOKEN (IVAL,  KW_CLASS),
     DEBUG_TOKEN (IVAL,  KW_CONTINUE),
     DEBUG_TOKEN (IVAL,  KW_DEFAULT),
     DEBUG_TOKEN (IVAL,  KW_DO),
     DEBUG_TOKEN (IVAL,  KW_ELSE),
     DEBUG_TOKEN (IVAL,  KW_ELSIF),
+    DEBUG_TOKEN (IVAL,  KW_FIELD),
     DEBUG_TOKEN (IVAL,  KW_GIVEN),
     DEBUG_TOKEN (IVAL,  KW_FOR),
     DEBUG_TOKEN (IVAL,  KW_FORMAT),
     DEBUG_TOKEN (IVAL,  KW_IF),
     DEBUG_TOKEN (IVAL,  KW_LOCAL),
+    DEBUG_TOKEN (IVAL,  KW_METHOD_anon),
+    DEBUG_TOKEN (IVAL,  KW_METHOD_named),
     DEBUG_TOKEN (IVAL,  KW_MY),
     DEBUG_TOKEN (IVAL,  KW_PACKAGE),
     DEBUG_TOKEN (IVAL,  KW_REQUIRE),
@@ -5382,7 +5387,10 @@ yyl_sub(pTHX_ char *s, const int key)
     bool have_name, have_proto;
     STRLEN len;
     SV *format_name = NULL;
-    bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
+    bool is_method = (key == KEY_method);
+
+    /* method always implies signatures */
+    bool is_sigsub = is_method || FEATURE_SIGNATURES_IS_ENABLED;
 
     SSize_t off = s-SvPVX(PL_linestr);
     char *d;
@@ -5461,9 +5469,9 @@ yyl_sub(pTHX_ char *s, const int key)
     if (  !(*s == ':' && s[1] != ':')
         && (*s != '{' && *s != '(') && key != KEY_format)
     {
-        assert(key == KEY_sub || key == KEY_AUTOLOAD ||
-               key == KEY_DESTROY || key == KEY_BEGIN ||
-               key == KEY_UNITCHECK || key == KEY_CHECK ||
+        assert(key == KEY_sub || key == KEY_method ||
+               key == KEY_AUTOLOAD || key == KEY_DESTROY ||
+               key == KEY_BEGIN || key == KEY_UNITCHECK || key == KEY_CHECK ||
                key == KEY_INIT || key == KEY_END ||
                key == KEY_my || key == KEY_state ||
                key == KEY_our);
@@ -5479,18 +5487,23 @@ yyl_sub(pTHX_ char *s, const int key)
         PL_lex_stuff = NULL;
         force_next(THING);
     }
+
     if (!have_name) {
         if (PL_curstash)
             sv_setpvs(PL_subname, "__ANON__");
         else
             sv_setpvs(PL_subname, "__ANON__::__ANON__");
-        if (is_sigsub)
+        if (is_method)
+            TOKEN(KW_METHOD_anon);
+        else if (is_sigsub)
             TOKEN(KW_SUB_anon_sig);
         else
             TOKEN(KW_SUB_anon);
     }
     force_ident_maybe_lex('&');
-    if (is_sigsub)
+    if (is_method)
+        TOKEN(KW_METHOD_named);
+    else if (is_sigsub)
         TOKEN(KW_SUB_named_sig);
     else
         TOKEN(KW_SUB_named);
@@ -7815,6 +7828,16 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
             return yyl_sub(aTHX_ PL_bufptr, key);
         return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
 
+    case KEY_ADJUST:
+        Perl_ck_warner_d(aTHX_
+            packWARN(WARN_EXPERIMENTAL__CLASS), "ADJUST is experimental");
+
+        /* The way that KEY_CHECK et.al. are handled currently are nothing
+         * short of crazy. We won't copy that model for new phasers, but use
+         * this as an experiment to test if this will work
+         */
+        PHASERBLOCK(KEY_ADJUST);
+
     case KEY_abs:
         UNI(OP_ABS);
 
@@ -7852,6 +7875,15 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
     case KEY_chop:
         UNI(OP_CHOP);
 
+    case KEY_class:
+        Perl_ck_warner_d(aTHX_
+            packWARN(WARN_EXPERIMENTAL__CLASS), "class is experimental");
+
+        s = force_word(s,BAREWORD,FALSE,TRUE);
+        s = skipspace(s);
+        s = force_strict_version(s);
+        PREBLOCK(KW_CLASS);
+
     case KEY_continue:
         /* We have to disambiguate the two senses of
           "continue". If the next token is a '{' then
@@ -8005,6 +8037,18 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
     case KEY_endgrent:
         FUN0(OP_EGRENT);
 
+    case KEY_field:
+        /* TODO: maybe this should use the same parser/grammar structures as
+         * `my`, but it's also rather messy because of the `our` conflation
+         */
+        Perl_ck_warner_d(aTHX_
+            packWARN(WARN_EXPERIMENTAL__CLASS), "field is experimental");
+
+        croak_kw_unless_class("field");
+
+        PL_parser->in_my = KEY_field;
+        OPERATOR(KW_FIELD);
+
     case KEY_finally:
         Perl_ck_warner_d(aTHX_
             packWARN(WARN_EXPERIMENTAL__TRY), "try/catch/finally is experimental");
@@ -8537,6 +8581,12 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
     case KEY_substr:
         LOP(OP_SUBSTR,XTERM);
 
+    case KEY_method:
+        /* For now we just treat 'method' identical to 'sub' plus a warning */
+        Perl_ck_warner_d(aTHX_
+            packWARN(WARN_EXPERIMENTAL__CLASS), "method is experimental");
+        return yyl_sub(aTHX_ s, KEY_method);
+
     case KEY_format:
     case KEY_sub:
         return yyl_sub(aTHX_ s, key);
@@ -9816,7 +9866,8 @@ S_pending_ident(pTHX)
                 /* PL_no_myglob is constant */
                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
                 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
-                            PL_in_my == KEY_my ? "my" : "state",
+                            PL_in_my == KEY_my ? "my" :
+                            PL_in_my == KEY_field ? "field" : "state",
                             *PL_tokenbuf == '&' ? "subroutine" : "variable",
                             PL_tokenbuf),
                             UTF ? SVf_UTF8 : 0);