%{ #if 0 L_BREAK L_CASE L_CATCH L_CLASS L_CONTINUE L_DEFAULT L_DO L_EFUN L_ELSE L_FOR L_FOREACH L_IF L_IN L_INHERIT L_NEW L_NIL L_RETURN L_RLIMITS L_SWITCH L_SSCANF L_TRY L_WHILE T_BOOL, T_CLOSURE, T_INTEGER, T_MAPPING, T_MIXED, T_OBJECT, T_STRING, T_VOID, M_NOMASK, M_NOSAVE, M_PRIVATE, M_PROTECTED, M_PUBLIC, M_VARARGS, L_PLUS_EQ L_MINUS_EQ L_DIV_EQ L_TIMES_EQ L_MOD_EQ L_AND_EQ L_OR_EQ L_XOR_EQ L_DOT_EQ L_EQ L_NE L_LE L_GE L_LOR L_LAND L_INC L_DEC L_RSH L_LSH L_MAP_START L_MAP_END L_ARRAY_START L_ARRAY_END L_FUNCTION_START L_FUNCTION_END L_COLONCOLON L_ARROW L_RANGE L_ELLIPSIS #endif #include "compiler.h" #include "../Type/type.h" #define YYPARSE_PARAM yyparse_param #define YYLEX_PARAM yyparse_param #define YYDEBUG 0 #define YYERROR_VERBOSE #if 0 || (YYDEBUG != 0) #define yylex(lvalp, yypp) yylex_verbose(lvalp, yypp) #else #define yylex(lvalp, yypp) yylex(lvalp, yypp) #endif #define Z1 NULL #define Z2 Z1, NULL #define Z3 Z2, NULL #define Z4 Z3, NULL #define Z5 Z4, NULL #define Z6 Z5, NULL #define N_A0(t) yyparse_node(t, Z6) #define N_A1(t,a0) yyparse_node(t,a0, Z5) #define N_A2(t,a0,a1) yyparse_node(t,a0,a1, Z4) #define N_A3(t,a0,a1,a2) yyparse_node(t,a0,a1,a2, Z3) #define N_A4(t,a0,a1,a2,a3) yyparse_node(t,a0,a1,a2,a3, Z2) #define N_A5(t,a0,a1,a2,a3,a4) yyparse_node(t,a0,a1,a2,a3,a4,Z1) #define N_A0R(t,r) yyparse_node(t, Z5,r) #define N_A1R(t,a0,r) yyparse_node(t,a0, Z4,r) #define N_A2R(t,a0,a1,r) yyparse_node(t,a0,a1, Z3,r) #define N_A3R(t,a0,a1,a2,r) yyparse_node(t,a0,a1,a2, Z2,r) #define N_A4R(t,a0,a1,a2,a3,r) yyparse_node(t,a0,a1,a2,a3,Z1,r) #define N_A5R(t,a0,a1,a2,a3,a4,r) yyparse_node(t,a0,a1,a2,a3,a4,r) static SV * yyparse_node(char *type, SV *arg0, SV *arg1, SV *arg2, SV *arg3, SV *arg4, AV *rest) { dSP; int count; SV *node; char buf[512]; SV *class; SV **svp; int len; int i; strcpy(buf, _AMD "::Compiler::Node::"); strcat(buf, type); class = sv_2mortal(newSVpv(buf, 0)); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(class); /* This unconventional formatting pushes the first few of argN * which are not NULL. */ if (arg0) { XPUSHs(arg0); if (arg1) { XPUSHs(arg1); if (arg2) { XPUSHs(arg2); if (arg3) { XPUSHs(arg3); if (arg4) { XPUSHs(arg4); } } } } } if (rest) { len = av_len(rest); for (i = 0; i <= len; i++) { svp = av_fetch(rest, i, FALSE); if (svp) XPUSHs(*svp); } } PUTBACK; count = call_method("new", G_SCALAR); SPAGAIN; if (count != 1) croak("Didn't get a return value from constructing %s\n", type); node = POPs; PUTBACK; SvREFCNT_inc(node); FREETMPS; LEAVE; // sv_2mortal(node); /* This segfaults it at the moment. */ return node; } /* We have to make sure that 'type' coming into here is PV not RV */ static SV * yyparse_type(const char *type, SV *stars) { static SV *class = NULL; SV *sv; dSP; int count; SV *node; if (!class) { class = newSVpv(_AMD "::Compiler::Type", 0); } // fprintf(stderr, "Type is %s, stars is %s\n", type, SvPV_nolen(stars)); /* XXX It's quite likely that we own the only ref to 'stars' here. */ sv = newSVsv(stars); sv_catpv(sv, type); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(class); XPUSHs(sv); /* Does this get freed? */ PUTBACK; count = call_method("new", G_SCALAR); SPAGAIN; if (count != 1) croak("Didn't get a return value from constructing Type\n"); node = POPs; PUTBACK; SvREFCNT_inc(node); FREETMPS; LEAVE; /* In the outer scope. Let's hope this doesn't get dested. */ sv_2mortal(node); return node; #if 0 return sv_bless(newRV_noinc(stars), gv_stashpv(_AMD "::Compiler::Type", TRUE)); #endif } /* Can I pass mods as a primitive integer, and not bother if they * are zero? This applies to functions as well. */ static SV * yyparse_variable(SV *name, const char *type, SV *stars, SV *mods) { static SV *class = NULL; static SV *k_type = NULL; static SV *k_name = NULL; static SV *k_flags = NULL; SV *newtype; dSP; int count; SV *node; if (!class) { class = newSVpv(_AMD "::Program::Variable", 0); k_type = newSVpv("Type", 0); k_name = newSVpv("Name", 0); k_flags = newSVpv("Flags", 0); } newtype = yyparse_type(type, stars); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(class); XPUSHs(k_type); XPUSHs(newtype); XPUSHs(k_name); XPUSHs(name); XPUSHs(k_flags); XPUSHs(mods); PUTBACK; count = call_method("new", G_SCALAR); SPAGAIN; if (count != 1) croak("Didn't get a return value from constructing Variable\n"); node = POPs; PUTBACK; SvREFCNT_inc(node); FREETMPS; LEAVE; return node; } static SV * yyparse_method(SV *name, const char *type, SV *stars, SV *args, SV *mods) { static SV *class = NULL; static SV *k_type = NULL; static SV *k_name = NULL; static SV *k_args = NULL; static SV *k_flags = NULL; SV *newtype; dSP; int count; SV *node; if (!class) { class = newSVpv(_AMD "::Program::Method", 0); k_type = newSVpv("Type", 0); k_name = newSVpv("Name", 0); k_args = newSVpv("Args", 0); k_flags = newSVpv("Flags", 0); } newtype = yyparse_type(type, stars); // printf("Start of yyparse_method\n"); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(class); XPUSHs(k_type); XPUSHs(newtype); XPUSHs(k_name); XPUSHs(name); XPUSHs(k_args); XPUSHs(args); XPUSHs(k_flags); XPUSHs(mods); PUTBACK; count = call_method("new", G_SCALAR); SPAGAIN; if (count != 1) croak("Didn't get a return value from constructing Method\n"); node = POPs; PUTBACK; SvREFCNT_inc(node); FREETMPS; LEAVE; // printf("End of yyparse_method\n"); return node; } static void yyparse_method_add_code(SV *method, SV *code) { dSP; int count; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(method); XPUSHs(code); PUTBACK; count = call_method("code", G_DISCARD); SPAGAIN; if (count != 0) croak("Got a return value from method->code()\n"); PUTBACK; FREETMPS; LEAVE; } static SV * yyparse_program_apply(amd_parse_param_t *param, const char *func, SV *arg0, SV *arg1) { dSP; int count; SV *node; // printf("Apply %s\n", func); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(param->program); if (arg0) XPUSHs(arg0); if (arg1) XPUSHs(arg1); PUTBACK; count = call_method(func, G_SCALAR); SPAGAIN; if (count != 1) croak("No returned value from apply %s\n", func); node = POPs; SvREFCNT_inc(node); PUTBACK; FREETMPS; LEAVE; return node; } %} %token L_BREAK L_CASE L_CATCH L_CLASS L_CONTINUE L_DEFAULT L_DO %token L_EFUN L_ELSE L_FOR L_FOREACH L_IF L_IN L_INHERIT L_NEW %token L_NIL L_RETURN L_RLIMITS L_SWITCH L_SSCANF L_TRY L_WHILE %token L_MAP_START L_MAP_END %token L_ARRAY_START L_ARRAY_END %token L_FUNCTION_START L_FUNCTION_END %token L_PARAMETER L_IDENTIFIER L_NIL L_STRING L_CHARACTER %token L_INTEGER L_HEXINTEGER %token L_BASIC_TYPE L_TYPE_MODIFIER L_STATIC %token L_INHERIT L_COLONCOLON %token L_IF L_DO L_WHILE L_FOR L_FOREACH L_IN L_RLIMITS %token L_TRY L_CATCH %token L_SWITCH L_CASE L_BREAK %token L_CONTINUE L_RETURN L_ELSE %token L_VOID L_ELLIPSIS %token L_ARROW L_RANGE %nonassoc LOWER_THAN_ELSE %nonassoc L_ELSE /* Strictly these can be %token */ %nonassoc L_PLUS_EQ L_MINUS_EQ L_DIV_EQ L_TIMES_EQ %nonassoc L_MOD_EQ L_AND_EQ L_OR_EQ L_XOR_EQ L_DOT_EQ /* Is this the right place? */ %nonassoc L_LOR_EQ L_LAND_EQ /* %left CONST */ %right '?' %left L_LOR %left L_LAND %left '|' %left '^' %left '&' %left L_EQ L_NE %left L_GE L_LE '<' '>' %left L_LSH L_RSH %left '.' %left '+' '-' %left '*' '%' '/' %right '!' '~' %nonassoc L_INC L_DEC /* These aren't strictly necessary, but they help debugging. */ %token '{' '}' ',' ';' ':' '(' ')' '[' ']' '=' '$' /* I should have a new type 'node' in here for blessed objects * which are specifically parse nodes. */ /* It is very very tempting to expand this to say 12 bytes * to save on the use of AVs for type declarators. */ %union { int number; const char *str; SV *sv; SV *obj; AV *av; struct _assoc_t { SV *key; SV *value; } assoc; } %{ /* This declares either yylex or yylex_verbose, according to * the macros above. This is a bit obscure and occasionally * highly fucked up. */ int yylex(YYSTYPE *yylval, amd_parse_param_t *param); %} /* %TYPES */ %type <av> function_declarator %type <av> argument_list arguments %type <sv> argument %type <sv> function_prologue %type <av> variable_declarator variable_declarator_list %type <av> variable_declarator_init variable_declarator_list_init %type <str> L_VOID L_BASIC_TYPE /* This might point into an SvPV in the type cache. */ %type <str> type_specifier /* An SvPV. */ %type <sv> star_list %type <number> opt_endrange %type <number> type_modifier_list L_TYPE_MODIFIER %type <av> class_member_list class_member %type <number> L_PARAMETER %type <number> integer L_INTEGER L_HEXINTEGER L_CHARACTER %type <sv> L_STRING string string_const %type <sv> L_IDENTIFIER identifier %type <obj> function_name %type <assoc> assoc_exp %type <av> arg_list opt_arg_list opt_arg_list_comma %type <av> assoc_arg_list opt_assoc_arg_list_comma %type <av> array mapping %type <obj> lvalue %type <av> lvalue_list %type <obj> block %type <av> local_decls local_decl %type <obj> statement %type <av> statement_list %type <obj> opt_else %type <obj> list_exp exp cond_exp logical_exp compare_exp arith_exp %type <obj> prefix_exp postfix_exp array_exp basic_exp %type <obj> opt_nv_list_exp nv_list_exp opt_list_exp %type <obj> closure %pure_parser %token_table %start program %% program : program definition | /* empty */ ; definition : inheritance | global_decl | type_decl | function | prototype ; inheritance : L_INHERIT string_const ';' { /* printf("Inheriting %s\n", SvPVX($2)); */ SvREFCNT_dec( yyparse_program_apply(yyparse_param, "inherit", &PL_sv_undef, $2)); } | L_INHERIT identifier string_const ';' { printf("Inheriting %s as %s\n", SvPVX($3), SvPVX($2)); SvREFCNT_dec( yyparse_program_apply(yyparse_param, "inherit", $2, $3)); } ; identifier : L_IDENTIFIER { $$ = $1; } ; function_declarator : star_list identifier '(' arguments ')' { $$ = newAV(); av_push($$, $1); av_push($$, $2); av_push($$, newRV_noinc((SV *)($4))); } ; variable_declarator : star_list identifier { $$ = newAV(); av_push($$, $1); av_push($$, $2); } ; variable_declarator_list : variable_declarator { $$ = newAV(); av_push($$, newRV_noinc((SV *)($1))); } | variable_declarator_list ',' variable_declarator { $$ = $1; av_push($$, newRV_noinc((SV *)($3))); } ; variable_declarator_init : variable_declarator { $$ = $1; } | variable_declarator '=' exp { av_push($1, $3); $$ = $1; } ; variable_declarator_list_init : variable_declarator_init { $$ = newAV(); av_push($$, newRV_noinc((SV *)($1))); } | variable_declarator_list_init ',' variable_declarator_init { $$ = $1; av_push($$, newRV_noinc((SV *)($3))); } ; /* This isn't quite the way it ought to be done since it doesn't * let me mix declarator types between function and data. */ /* The return value from this rule has an extra ref from * yyparse_program_apply(). */ function_prologue : type_modifier_list type_specifier function_declarator { SV *method; const char *type; SV *stars; SV *name; SV *args; SV *mods; type = $2; stars = *( av_fetch($3, 0, FALSE) ); name = *( av_fetch($3, 1, FALSE) ); args = *( av_fetch($3, 2, FALSE) ); mods = newSViv($1); method = yyparse_method(name, type, stars, args, mods); /* Check that this is the empty list. */ SvREFCNT_dec( yyparse_program_apply(yyparse_param, "method", name, method)); $$ = method; } ; prototype : function_prologue ';' { SvREFCNT_dec($1); } ; function : function_prologue block { /* $1->code($2); */ yyparse_method_add_code($1, $2); SvREFCNT_dec($1); } ; block : '{' local_decls statement_list '}' { $$ = N_A2("Block", newRV_noinc((SV *)($2)), newRV_noinc((SV *)($3))); // amd_dump("Block locals", sv_2mortal(newRV_noinc((SV *)($2)))); } ; statement_list : /* empty */ { $$ = newAV(); } | statement_list statement { av_push($1, $2); $$ = $1; } ; statement : list_exp ';' { $$ = N_A1("StmtExp", $1); } | block { $$ = $1; } | L_IF '(' nv_list_exp ')' statement opt_else { /* if ($6 == &PL_sv_undef) - use StmtIfElse */ $$ = N_A3("StmtIf", $3, $5, $6); } | L_DO statement L_WHILE '(' nv_list_exp ')' ';' { $$ = N_A2("StmtDo", $5, $2); } | L_WHILE '(' nv_list_exp ')' statement { $$ = N_A2("StmtWhile", $3, $5); } | L_FOR '(' opt_list_exp ';' opt_nv_list_exp ';' opt_list_exp ')' statement { $$ = N_A4("StmtFor", $3, $5, $7, $9); } | L_FOREACH '(' lvalue L_IN exp ')' statement { $$ = N_A4("StmtForeach", $3, &PL_sv_undef, $5, $7); } | L_FOREACH '(' lvalue ',' lvalue L_IN exp ')' statement { $$ = N_A4("StmtForeach", $3, $5, $7, $9); } | L_RLIMITS '(' nv_list_exp ';' nv_list_exp ')' block { $$ = N_A3("StmtRlimits", $3, $5, $7); } | L_TRY block L_CATCH '(' lvalue ')' block { $$ = N_A3("StmtTry", $2, $5, $7); } | L_CATCH block { /* A MudOS hack */ $$ = N_A1("StmtCatch", $2); } | L_SWITCH '(' nv_list_exp ')' block { $$ = N_A2("StmtSwitch", $3, $5); } | L_CASE exp ':' { $$ = N_A2("StmtCase", $2, &PL_sv_undef); } /* | L_CASE exp L_RANGE exp ':' { $$ = N_A2("StmtCase", $2, $4); } */ | L_DEFAULT ':' { $$ = N_A0("StmtDefault"); } | L_BREAK ';' { $$ = N_A0("StmtBreak"); } | L_CONTINUE ';' { $$ = N_A0("StmtContinue"); } | L_RETURN opt_nv_list_exp ';' { $$ = N_A1("StmtReturn", $2); } | ';' { $$ = N_A0("StmtNull"); } | error ';' { $$ = N_A0("StmtNull"); } ; opt_else : %prec LOWER_THAN_ELSE { $$ = &PL_sv_undef; } | L_ELSE statement { $$ = $2; } ; list_exp : exp { $$ = $1; } | list_exp ',' exp { $$ = N_A2("ExpComma", $1, $3); } ; opt_list_exp : /* empty */ { $$ = &PL_sv_undef; } | list_exp { $$ = $1; } ; nv_list_exp /* XXX This is wrong, but ... */ : exp /* Check nonvoid */ ; opt_nv_list_exp : { $$ = &PL_sv_undef; } | nv_list_exp { $$ = $1; } ; arg_list : exp { $$ = newAV(); av_push($$, $1); } | arg_list ',' exp { av_push($1, $3); $$ = $1; } ; opt_arg_list : /* empty */ { $$ = newAV(); } | arg_list /* default */ ; opt_arg_list_comma : /* empty */ { $$ = newAV(); } | arg_list /* default */ | arg_list ',' /* default */ ; assoc_exp : exp ':' exp /* Check nonvoid */ { $$.key = $1; $$.value = $3; /* AV *av; av = newAV(); av_push(av, $1); av_push(av, $3); $$ = newRV_noinc((SV *)av); */ } ; assoc_arg_list : assoc_exp { $$ = newAV(); av_push($$, $1.key); av_push($$, $1.value); } | assoc_arg_list ',' assoc_exp { av_push($1, $3.key); av_push($1, $3.value); $$ = $1; } ; opt_assoc_arg_list_comma : /* empty */ { $$ = newAV(); } | assoc_arg_list /* default */ | assoc_arg_list ',' /* default */ ; function_name : identifier { $$ = yyparse_program_apply(yyparse_param, "method", $1, NULL); } | L_COLONCOLON identifier { SV *name; name = newSVpv("::", 2); sv_catsv(name, $2); $$ = yyparse_program_apply(yyparse_param, "method", sv_2mortal(name), NULL); } | identifier L_COLONCOLON identifier { SV *name; name = newSVsv($1); sv_catpv(name, "::"); sv_catsv(name, $3); $$ = yyparse_program_apply(yyparse_param, "method", sv_2mortal(name), NULL); } | L_EFUN L_COLONCOLON identifier { SV *name; name = newSVpv("efun::", 6); sv_catsv(name, $3); $$ = yyparse_program_apply(yyparse_param, "method", sv_2mortal(name), NULL); } ; lvalue : array_exp /* Check lvalue */ { $$ = $1; } ; exp : cond_exp { $$ = $1; } | lvalue '=' exp { $$ = N_A2("Assign", $1, $3); } | lvalue L_PLUS_EQ exp { $$ = N_A2("AddEq", $1, $3); } | lvalue L_MINUS_EQ exp { $$ = N_A2("SubEq", $1, $3); } | lvalue L_DIV_EQ exp { $$ = N_A2("DivEq", $1, $3); } | lvalue L_TIMES_EQ exp { $$ = N_A2("MulEq", $1, $3); } | lvalue L_MOD_EQ exp { $$ = N_A2("ModEq", $1, $3); } | lvalue L_AND_EQ exp { $$ = N_A2("AndEq", $1, $3); } | lvalue L_OR_EQ exp { $$ = N_A2("OrEq", $1, $3); } | lvalue L_XOR_EQ exp { $$ = N_A2("XorEq", $1, $3); } | lvalue L_DOT_EQ exp { $$ = N_A2("StrAddEq", $1, $3); } | lvalue L_LOR_EQ exp { $$ = N_A2("LogOrEq", $1, $3); } | lvalue L_LAND_EQ exp { $$ = N_A2("LogAndEq", $1, $3); } ; cond_exp : logical_exp { $$ = $1; } | logical_exp '?' list_exp ':' cond_exp %prec '?' { $$ = N_A3("ExpCond", $1, $3, $5); } ; logical_exp : compare_exp { $$ = $1; } | logical_exp L_LOR logical_exp { $$ = N_A2("LogOr", $1, $3); } | logical_exp L_LAND logical_exp { $$ = N_A2("LogAnd", $1, $3); } | logical_exp '|' logical_exp { $$ = N_A2("Or", $1, $3); } | logical_exp '^' logical_exp { $$ = N_A2("Xor", $1, $3); } | logical_exp '&' logical_exp { $$ = N_A2("And", $1, $3); } ; /* I could swap some of these operands around to save code */ compare_exp : arith_exp { $$ = $1; } | compare_exp L_EQ compare_exp { $$ = N_A2("Eq", $1, $3); } | compare_exp L_NE compare_exp { $$ = N_A2("Ne", $1, $3); } | compare_exp '<' compare_exp { $$ = N_A2("Lt", $1, $3); } | compare_exp '>' compare_exp { $$ = N_A2("Gt", $1, $3); } | compare_exp L_LE compare_exp { $$ = N_A2("Le", $1, $3); } | compare_exp L_GE compare_exp { $$ = N_A2("Ge", $1, $3); } ; arith_exp : prefix_exp { $$ = $1; } | arith_exp L_LSH arith_exp { $$ = N_A2("Lsh", $1, $3); } | arith_exp L_RSH arith_exp { $$ = N_A2("Rsh", $1, $3); } | arith_exp '.' arith_exp { $$ = N_A2("StrAdd", $1, $3); } | arith_exp '+' arith_exp { $$ = N_A2("Add", $1, $3); } | arith_exp '-' arith_exp { $$ = N_A2("Sub", $1, $3); } | arith_exp '*' arith_exp { $$ = N_A2("Mul", $1, $3); } | arith_exp '/' arith_exp { $$ = N_A2("Div", $1, $3); } | arith_exp '%' arith_exp { $$ = N_A2("Mod", $1, $3); } ; prefix_exp : postfix_exp { $$ = $1; } | L_INC prefix_exp { $$ = N_A1("Preinc", $2); } | L_DEC prefix_exp { $$ = N_A1("Predec", $2); } | '!' prefix_exp { $$ = N_A1("Unot", $2); } | '~' prefix_exp { $$ = N_A1("Tilde", $2); } | '+' prefix_exp { $$ = N_A1("Plus", $2); } | '-' prefix_exp { $$ = N_A1("Minus", $2); } ; postfix_exp : array_exp { $$ = $1; } | postfix_exp L_INC { $$ = N_A1("Postinc", $1); } | postfix_exp L_DEC { $$ = N_A1("Postdec", $1); } ; array_exp : basic_exp { $$ = $1; } | array_exp '[' opt_endrange nv_list_exp close_square { $$ = N_A3("Index", $1, $4, newSViv($3)); } | array_exp '[' opt_endrange nv_list_exp L_RANGE opt_endrange nv_list_exp close_square { $$ = N_A5("Range", $1, $4, $7, newSViv($3), newSViv($6)); } ; close_square : ']' | L_MAP_END { yyunput_map_end(); } ; opt_endrange : /* empty */ { $$ = 0; } | '<' { $$ = 1; } ; basic_exp : L_NIL { $$ = N_A0("Nil"); } | string { $$ = N_A1("String", $1); } | integer { $$ = N_A1("Integer", newSViv($1)); } | array { $$ = N_A0R("Array", $1); } | mapping { $$ = N_A0R("Mapping", $1); } | closure { $$ = N_A1("Closure", $1); } | identifier { $$ = N_A1("Variable", $1); } | L_PARAMETER { $$ = N_A1("Parameter", newSViv($1)); } | '$' '(' list_exp ')' { $$ = N_A1("Parameter", $3); } | '(' list_exp ')' { $$ = $2; } | function_name '(' opt_arg_list ')' { $$ = N_A1R("Funcall", $1, $3); } | L_SSCANF '(' exp lvalue_list ')' { $$ = N_A1R("Sscanf", $3, $4); } | L_CATCH '(' list_exp ')' { $$ = N_A1("Catch", $3); } | L_NEW '(' L_CLASS identifier ')' { $$ = N_A1("New", $4); } | array_exp L_ARROW identifier '(' opt_arg_list ')' { $$ = N_A2R("CallOther", $1, $3, $5); } | array_exp L_ARROW identifier { $$ = N_A2("Member", $1, $3); } ; lvalue_list : /* empty */ { $$ = newAV(); } | lvalue_list ',' lvalue { av_push($1, $3); $$ = $1; } ; global_decl : type_modifier_list type_specifier variable_declarator_list ';' { int len; int i; SV **svp; AV *vdl; AV *vd; SV *name; const char *type; SV *stars; SV *var; type = $2; vdl = $3; len = av_len(vdl); for (i = 0; i <= len; i++) { svp = av_fetch(vdl, i, FALSE); if (!svp) continue; /* The AV returned from variable_declarator */ vd = (AV *)SvRV(*svp); /* These two should be guaranteed dereferencable */ stars = *( av_fetch(vd, 0, FALSE) ); name = *( av_fetch(vd, 1, FALSE) ); var = yyparse_variable(name, type, stars, newSViv($1)); /* XXX Check global modifiers, and possibly make these * variables static. */ if ($1 & M_STATIC) { SvREFCNT_dec( yyparse_program_apply(yyparse_param, "static", name, var)); } else { SvREFCNT_dec( yyparse_program_apply(yyparse_param, "global", name, var)); } } /* See local_decl for memory management notes. */ } ; local_decls : /* empty */ { $$ = newAV(); } | local_decls local_decl { SV **svp; int len; int i; len = av_len($2); av_extend($1, av_len($1) + av_len($2) + 1); for (i = 0; i <= len; i++) { svp = av_fetch($2, i, FALSE); if (svp) av_push($1, *svp); else av_push($1, &PL_sv_undef); } $$ = $1; } ; local_decl : type_specifier variable_declarator_list_init ';' { int len; int i; SV **svp; AV *vdl; AV *vd; SV *name; const char *type; SV *stars; SV *var; $$ = newAV(); type = $1; vdl = $2; len = av_len(vdl); for (i = 0; i <= len; i++) { svp = av_fetch(vdl, i, FALSE); if (!svp) continue; /* The AV returned from variable_declarator_init */ vd = (AV *)SvRV(*svp); /* These two should be guaranteed dereferencable */ stars = *( av_fetch(vd, 0, FALSE) ); name = *( av_fetch(vd, 1, FALSE) ); var = yyparse_variable(name, type, stars, &PL_sv_undef); av_push($$, var); } /* All of these break things badly. */ // SvREFCNT_dec($1); // SvREFCNT_dec($2); // av_clear($2); // amd_peek("local_decl", sv_2mortal(newRV_noinc((SV *)($$)))); } ; /* The type_modifier_list is expected to be empty but * avoids a shift-reduce conflict at top level. */ type_decl : type_modifier_list L_CLASS identifier '{' class_member_list '}' { /* XXX Make a class object */ SvREFCNT_dec( yyparse_program_apply(yyparse_param, "class", $3, newRV_noinc((SV *)$5))); } ; class_member_list : /* empty */ { $$ = newAV(); } | class_member_list class_member { SV *sv; int len; int i; len = av_len($2); for (i = 0; i <= len; i++) { sv = *( av_fetch($2, i, FALSE) ); av_push($1, sv); } /* XXX Lose ((AV)($2))! */ $$ = $1; } ; class_member : type_specifier variable_declarator_list ';' { int len; int i; SV **svp; AV *vdl; AV *vd; SV *name; const char *type; SV *stars; SV *var; $$ = newAV(); type = $1; vdl = $2; len = av_len(vdl); for (i = 0; i <= len; i++) { svp = av_fetch(vdl, i, FALSE); if (!svp) continue; /* The AV returned from variable_declarator */ vd = (AV *)SvRV(*svp); /* These two should be guaranteed dereferencable */ stars = *( av_fetch(vd, 0, FALSE) ); name = *( av_fetch(vd, 1, FALSE) ); var = yyparse_variable(name, type, stars, &PL_sv_undef); av_push($$, var); } /* See local_decl for memory management notes. */ } ; arguments : /* empty */ { $$ = newAV(); } | L_VOID { $$ = newAV(); } | argument_list { $$ = $1; } | argument_list L_ELLIPSIS { av_push($1, &PL_sv_undef); /* XXX Fix L_ELLIPSIS */ $$ = $1; } ; argument_list : argument { $$ = newAV(); av_push($$, $1); } | argument_list ',' argument { av_push($1, $3); $$ = $1; } ; argument : type_specifier variable_declarator { const char *type; SV *stars; SV *name; type = $1; stars = *( av_fetch($2, 0, FALSE) ); name = *( av_fetch($2, 1, FALSE) ); $$ = yyparse_variable(name, type, stars, &PL_sv_undef); } ; type_modifier_list : { $$ = 0; } | L_TYPE_MODIFIER type_modifier_list { $$ = $1 | $2; } ; /* opt_static : | L_STATIC ; */ /* XXX IMMEDIATE: Make this return a const char * all the * way up to yyparse_type */ type_specifier : L_BASIC_TYPE { $$ = $1; } | L_VOID { $$ = $1; } | L_CLASS identifier { // $$ = "{}"; /* As long as I don't free the underlying SV, * I could just use SvPV here. We can't free the * original type since it'll be in the type cache. * Don't free the type cache while in the parser. * Do the apply, then call SvPV_nolen(SvRV(x)) on it. */ SV *ct; ct = yyparse_program_apply(yyparse_param, "class_type", $2, &PL_sv_undef); $$ = SvPV_nolen(SvRV(ct)); } ; star_list : /* empty */ { /* Work on using PL_sv_undef here instead. */ $$ = newSVpv("", 0);; } | star_list '*' { STRLEN len; char *v; v = SvPV($1, len); sv_setpv($1, "*"); sv_catpvn($1, v, len); $$ = $1; } | star_list '#' { STRLEN len; char *v; v = SvPV($1, len); sv_setpv($1, "#"); sv_catpvn($1, v, len); $$ = $1; } ; string_const : string /* default */ | string_const '.' string_const { /* Coercion should NOT be necessary. */ sv_catpv($1, SvPVX($3)); SvREFCNT_dec($3); $$ = $1; } | string_const '+' string_const { sv_catpv($1, SvPVX($3)); SvREFCNT_dec($3); $$ = $1; } | integer /* Is this my extension? */ { char buf[64]; snprintf(buf, 64, "%d", $1); $$ = newSVpv(buf, 0); } ; string : L_STRING /* default */ | string L_STRING { sv_catpv($1, SvPVX($2)); SvREFCNT_dec($2); $$ = $1; } ; integer : L_INTEGER | L_CHARACTER ; array : L_ARRAY_START opt_arg_list_comma L_ARRAY_END { $$ = $2; } ; mapping : L_MAP_START opt_assoc_arg_list_comma L_MAP_END { /* This doesn't expand the pairs into a single list. * There is a hack elsewhere. */ $$ = $2; } ; /* Also things like (: foo :) ? */ closure : L_FUNCTION_START list_exp L_FUNCTION_END { $$ = $2; } ; %% const char * yytokname(int i) { return yytname[YYTRANSLATE(i)]; } int yyparser_parse(SV *program, const char *str) { amd_parse_param_t param; int ret; // fprintf(stderr, "Start of yyparser_parse\n"); // fflush(stderr); memset(¶m, 0, sizeof(param)); param.program = program; param.symtab = newHV(); yylex_init(str); #if YYDEBUG != 0 yydebug = 1; #endif ret = yyparse((void *)(¶m)); /* Delete the HV but not the contents. */ hv_undef(param.symtab); return ret; }