X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2Fhsparser.y;h=59d6f9d9ad64bd4868c7f8c3ff55210a2708cf1f;hb=123f2400f92ba0aaac34340b9276954bd2371743;hp=0ea933fef4195fb3311f4dc6431959ebf9ed55b8;hpb=e1fc52f6868619bbeafaced910c50a304db5e0f9;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 0ea933f..59d6f9d 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -75,8 +75,8 @@ static int Fixity = 0, Precedence = 0; char *ineg PROTO((char *)); long source_version = 0; +BOOLEAN pat_check=TRUE; -BOOLEAN inpat; %} %union { @@ -161,7 +161,8 @@ BOOLEAN inpat; %token SCC %token CCALL CCALL_GC CASM CASM_GC - +%token EXPORT UNSAFE STDCALL C_CALL +%token PASCAL FASTCALL FOREIGN DYNAMIC /********************************************************************** * * @@ -184,7 +185,7 @@ BOOLEAN inpat; **********************************************************************/ %token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA -%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA +%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA %token END_UPRAGMA %token SOURCE_UPRAGMA @@ -239,7 +240,8 @@ BOOLEAN inpat; gdrhs gdpat valrhs lampats cexps gd -%type maybeexports impspec deriving +%type maybeexports impspec deriving + ext_name %type lit_constant @@ -261,10 +263,10 @@ BOOLEAN inpat; qvar qcon qvarop qconop qop qvark qconk qtycon qtycls gcon gconk gtycon itycon qop1 qvarop1 - ename iname + ename iname %type topdecl topdecls letdecls - typed datad newtd classd instd defaultd + typed datad newtd classd instd defaultd foreignd decl decls valdef instdef instdefs maybe_where cbody rinst type_and_maybe_id @@ -284,6 +286,7 @@ BOOLEAN inpat; %type export import %type commas importkey get_line_no + unsafe_flag callconv /********************************************************************** * * @@ -385,6 +388,8 @@ impdecl : importkey modid impspec { $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); } | importkey QUALIFIED modid AS modid impspec { $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,startlineno)); } + | importkey modid AS modid impspec + { $$ = lsing(mkimport($3,1,mkjust($4),$5,$1,startlineno)); } ; impspec : /* empty */ { $$ = mknothing(); } @@ -480,6 +485,7 @@ topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; } | classd { $$ = $1; FN = NULL; SAMEFN = 0; } | instd { $$ = $1; FN = NULL; SAMEFN = 0; } | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; } + | foreignd { $$ = $1; FN = NULL; SAMEFN = 0; } | decl { $$ = $1; } ; @@ -503,10 +509,14 @@ deriving: /* empty */ { $$ = mknothing(); } | DERIVING dtyclses { $$ = mkjust($2); } ; -classd : classkey simple_context DARROW simple_con_app1 cbody - { $$ = mkcbind($2,$4,$5,startlineno); } - | classkey simple_con_app1 cbody - { $$ = mkcbind(Lnil,$2,$3,startlineno); } +classd : classkey btype DARROW simple_con_app1 cbody + /* Context can now be more than simple_context */ + { $$ = mkcbind(type2context($2),$4,$5,startlineno); } + | classkey btype cbody + /* We have to say btype rather than simple_con_app1, else + we get reduce/reduce errs */ + { check_class_decl_head($2); + $$ = mkcbind(Lnil,$2,$3,startlineno); } ; cbody : /* empty */ { $$ = mknullbind(); } @@ -520,7 +530,7 @@ instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); } /* Compare ctype */ inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */ $$ = mkcontext(type2context($1),$3); } - | type { is_context_format( $1, 0 ); /* Check the instance head */ + | btype { is_context_format( $1, 0 ); /* Check the instance head */ $$ = $1; } ; @@ -534,6 +544,27 @@ defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); } ; +/* FFI primitive declarations - GHC/Hugs specific */ +foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON sigtype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); } + | foreignkey EXPORT callconv ext_name qvarid DCOLON sigtype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); } + ; + +callconv: STDCALL { $$ = CALLCONV_STDCALL; } + | C_CALL { $$ = CALLCONV_CCALL; } + | PASCAL { $$ = CALLCONV_PASCAL; } + | FASTCALL { $$ = CALLCONV_FASTCALL; } + ; + +ext_name: STRING { $$ = mkjust(lsing($1)); } + | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); } + | DYNAMIC { $$ = mknothing(); } + +unsafe_flag: UNSAFE { $$ = 1; } + | /*empty*/ { $$ = 0; } + ; + + + decls : decl | decls SEMI decl { @@ -589,6 +620,12 @@ decl : qvarsk DCOLON sigtype PREVPATT = NULL; FN = NULL; SAMEFN = 0; } + | NOINLINE_UPRAGMA qvark END_UPRAGMA + { + $$ = mknoinline_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA { $$ = mkmagicuf_uprag($2, $3, startlineno); @@ -642,7 +679,7 @@ type_and_maybe_id : /* A sigtype is a rank 2 type; it can have for-alls as function args: f :: All a => (All b => ...) -> Int */ -sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); } +sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); } | sigarrowtype ; @@ -652,11 +689,11 @@ sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); } ; /* A "big" atype can be a forall-type in brackets. */ -bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); } +bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); } ; /* 1 S/R conflict at DARROW -> shift */ -ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); } +ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); } | type ; @@ -726,7 +763,7 @@ constrs : constr { $$ = lsing($1); } ; constr : constr_after_context - | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); } + | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); } ; constr_after_context : @@ -844,6 +881,12 @@ instdef : PREVPATT = NULL; FN = NULL; SAMEFN = 0; } + | NOINLINE_UPRAGMA qvark END_UPRAGMA + { + $$ = mknoinline_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA { $$ = mkmagicuf_uprag($2, $3, startlineno); @@ -965,10 +1008,10 @@ dexp : MINUS kexp { $$ = mknegate($2); } /* We need to factor out a leading let expression so we can set - inpat=TRUE when parsing (non let) expressions inside stmts and quals + pat_check=FALSE when parsing (non let) expressions inside stmts and quals */ -expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); } - | oexpLno +expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); } + | oexpLno ; oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); } | dexpLno @@ -1094,7 +1137,7 @@ cexps : cexps aexp { $$ = lapp($1,$2); } caserest: ocurly alts ccurly { $$ = $2; } | vocurly alts vccurly { $$ = $2; } -dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; } +dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; } | vocurly stmts vccurly { checkdostmts($2); $$ = $2; } ; @@ -1150,26 +1193,56 @@ list_rest : exp { $$ = lsing($1); } at it, it *will* do the wrong thing [WDP 94/06]) */ -letdecls: LET ocurly decls ccurly { $$ = $3; } - | LET vocurly decls vccurly { $$ = $3; } +letdecls: LET { pat_check = TRUE; } ocurly decls ccurly { $$ = $4; } + | LET { pat_check = TRUE; } vocurly decls vccurly { $$ = $4; } ; -quals : qual { $$ = lsing($1); } - | quals COMMA qual { $$ = lapp($1,$3); } +/* + When parsing patterns inside do stmt blocks or quals, we have + to tentatively parse them as expressions, since we don't know at + the time of parsing `p' whether it will be part of "p <- e" (pat) + or "p" (expr). When we eventually can tell the difference, the parse + of `p' is examined to see if it consitutes a syntactically legal pattern + or expression. + + The expr rule used to parse the pattern/expression do contain + pattern-special productions (e.g., _ , a@pat, etc.), which are + illegal in expressions. Since we don't know whether what + we're parsing is an expression rather than a pattern, we turn off + the check and instead do it later. + + The rather clumsy way that this check is turned on/off is there + to work around a Bison feature/shortcoming. Turning the flag + on/off just around the relevant nonterminal by decorating it + with simple semantic actions, e.g., + + {pat_check = FALSE; } expLNo { pat_check = TRUE; } + + causes Bison to generate a parser where in one state it either + has to reduce/perform a semantic action ( { pat_check = FALSE; }) + or reduce an error (the error production used to implement + vccurly.) Bison picks the semantic action, which it ideally shouldn't. + The work around is to lift out the setting of { pat_check = FALSE; } + and then later reset pat_check. Not pretty. + +*/ + + +quals : { pat_check = FALSE;} qual { pat_check = TRUE; $$ = lsing($2); } + | quals COMMA { pat_check = FALSE; } qual { pat_check = TRUE; $$ = lapp($1,$4); } ; -qual : letdecls { $$ = mkseqlet($1); } - | expL { $$ = $1; } - | {inpat=TRUE;} expLno - {inpat=FALSE;} leftexp - { if ($4 == NULL) { - expORpat(LEGIT_EXPR,$2); - $$ = mkguard($2); - } else { - expORpat(LEGIT_PATT,$2); - $$ = mkqual($2,$4); - } - } +qual : letdecls { $$ = mkseqlet($1); } + | expL { expORpat(LEGIT_EXPR,$1); $$ = $1; } + | expLno { pat_check = TRUE; } leftexp + { if ($3 == NULL) { + expORpat(LEGIT_EXPR,$1); + $$ = mkguard($1); + } else { + expORpat(LEGIT_PATT,$1); + $$ = mkqual($1,$3); + } + } ; alts : alt { $$ = $1; } @@ -1188,24 +1261,25 @@ gdpat : gd RARROW exp { $$ = lsing(mkpgdexp($1,$3)); } | gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); } ; -stmts : stmt { $$ = $1; } - | stmts SEMI stmt { $$ = lconc($1,$3); } +stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; } + | stmts SEMI {pat_check=FALSE;} stmt {pat_check=TRUE; $$ = lconc($1,$4); } ; -stmt : /* empty */ { $$ = Lnil; } - | letdecls { $$ = lsing(mkseqlet($1)); } - | expL { $$ = lsing(mkdoexp($1,hsplineno)); } - | {inpat=TRUE;} expLno {inpat=FALSE;} leftexp - { if ($4 == NULL) { - expORpat(LEGIT_EXPR,$2); - $$ = lsing(mkdoexp($2,endlineno)); - } else { - expORpat(LEGIT_PATT,$2); - $$ = lsing(mkdobind($2,$4,endlineno)); - } - } +stmt : /* empty */ { $$ = Lnil; } + | letdecls { $$ = lsing(mkseqlet($1)); } + | expL { expORpat(LEGIT_EXPR,$1); $$ = lsing(mkdoexp($1,hsplineno)); } + | expLno {pat_check=TRUE;} leftexp + { if ($3 == NULL) { + expORpat(LEGIT_EXPR,$1); + $$ = lsing(mkdoexp($1,endlineno)); + } else { + expORpat(LEGIT_PATT,$1); + $$ = lsing(mkdobind($1,$3,endlineno)); + } + } ; + leftexp : LARROW exp { $$ = $2; } | /* empty */ { $$ = NULL; } ; @@ -1382,6 +1456,9 @@ instkey : INSTANCE { setstartlineno(); defaultkey: DEFAULT { setstartlineno(); } ; +foreignkey: FOREIGN { setstartlineno(); } + ; + classkey: CLASS { setstartlineno(); if(etags) #if 1/*etags*/ @@ -1570,7 +1647,7 @@ vccurly1: FN = NULL; SAMEFN = 0; PREVPATT = NULL; hsendindent(); } - ; + ; %% @@ -1582,14 +1659,14 @@ vccurly1: * * **********************************************************************/ + void checkinpat() { - if(!inpat) + if(pat_check) hsperror("pattern syntax used in expression"); } - /* The parser calls "hsperror" when it sees a `report this and die' error. It sets the stage and calls "yyerror". @@ -1625,7 +1702,7 @@ yyerror(s) /* We want to be able to distinguish 'error'-raised yyerrors from yyerrors explicitly coded by the parser hacker. */ - if (expect_ccurly && ! error_and_I_mean_it ) { + if ( expect_ccurly && ! error_and_I_mean_it ) { /*NOTHING*/; } else {