X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fparser.y;h=13b3b0a37a968758fdb852f51a3a1a1afe551647;hb=6e0892adec42702e7879a23587d2c7210c55a078;hp=dc8251c365b9d0b2a0997374e2dbe5e9d2bd06c3;hpb=ca8c38184c97ab7b8dd5a2540868d6b47536e72b;p=ghc-hetmet.git diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index dc8251c..13b3b0a 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,15 +12,14 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.23 $ - * $Date: 2000/03/09 02:47:13 $ + * $Revision: 1.30 $ + * $Date: 2000/04/25 17:43:50 $ * ------------------------------------------------------------------------*/ %{ #ifndef lint #define lint #endif -#define defTycon(n,l,lhs,rhs,w) tyconDefn(intOf(l),lhs,rhs,w); sp-=n #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t)) #define fixdecl(l,ops,a,p) ap(FIXDECL,\ triple(l,ops,mkInt(mkSyntax(a,intOf(p))))) @@ -28,26 +27,24 @@ #define only(t) ap(ONLY,t) #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e) #define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t) -#define exportSelf() singleton(ap(MODULEENT, \ - mkCon(module(currentModule).text))) #define yyerror(s) /* errors handled elsewhere */ #define YYSTYPE Cell -static Cell local gcShadow Args((Int,Cell)); -static Void local syntaxError Args((String)); -static String local unexpected Args((Void)); -static Cell local checkPrec Args((Cell)); -static Void local fixDefn Args((Syntax,Cell,Cell,List)); -static Cell local buildTuple Args((List)); -static List local checkCtxt Args((List)); -static Cell local checkPred Args((Cell)); -static Pair local checkDo Args((List)); -static Cell local checkTyLhs Args((Cell)); +static Cell local gcShadow ( Int,Cell ); +static Void local syntaxError ( String ); +static String local unexpected ( Void ); +static Cell local checkPrec ( Cell ); +static Void local fixDefn ( Syntax,Cell,Cell,List ); +static Cell local buildTuple ( List ); +static List local checkCtxt ( List ); +static Cell local checkPred ( Cell ); +static Pair local checkDo ( List ); +static Cell local checkTyLhs ( Cell ); #if !TREX -static Void local noTREX Args((String)); +static Void local noTREX ( String ); #endif #if !IPARAM -static Void local noIP Args((String)); +static Void local noIP ( String ); #endif /* For the purposes of reasonably portable garbage collection, it is @@ -73,6 +70,8 @@ static Void local noIP Args((String)); #define gc5(e) gcShadow(5,e) #define gc6(e) gcShadow(6,e) #define gc7(e) gcShadow(7,e) +#define gc8(e) gcShadow(8,e) +#define gc9(e) gcShadow(9,e) %} @@ -81,6 +80,7 @@ static Void local noIP Args((String)); %token THEN ELSE WHERE LET IN %token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE %token DEFAULT DERIVING DO TCLASS TINSTANCE +%token MDO /*#if IPARAM*/ %token WITH DLET /*#endif*/ @@ -98,16 +98,15 @@ static Void local noIP Args((String)); %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE %token INSTIMPORT DYNAMIC CCALL STDKALL %token UTL UTR UUUSAGE -%token PRIVILEGED %% /*- Top level script/module structure -------------------------------------*/ -start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} - | CONTEXT context {inputContext = $2; sp-=1;} - | SCRIPT topModule {valDefns = $2; sp-=1;} - | INTERFACE iface {sp-=1;} - | error {syntaxError("input");} +start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} + | CONTEXT context {inputContext = $2; sp-=1;} + | SCRIPT topModule {drop(); push($2);} + | INTERFACE iface {sp-=1;} + | error {syntaxError("input");} ; @@ -121,9 +120,9 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} */ /*- Top-level interface files -----------------------------*/ -iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls - {$$ = gc7(ap(I_INTERFACE, - zpair($2,$7))); } +iface : INTERFACE STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls + {$$ = gc8(ap(I_INTERFACE, + zpair($3,$8))); } | INTERFACE error {syntaxError("interface file");} ; @@ -132,8 +131,8 @@ ifTopDecls: {$$=gc0(NIL);} ; ifTopDecl - : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList - {$$=gc6(ap(I_IMPORT,zpair($2,$6))); } + : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList + {$$=gc7(ap(I_IMPORT,zpair($2,$7))); } | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));} @@ -182,6 +181,8 @@ ifTopDecl /*- Top-level misc interface stuff ------------------------*/ ifOrphans : '!' {$$=gc1(NIL);} | {$$=gc0(NIL);} +ifIsBoot : '@' {$$=gc1(NIL);} + | {$$=gc0(NIL);} ; ifOptCOCO : COCO {$$=gc1(NIL);} | {$$=gc0(NIL);} @@ -422,57 +423,48 @@ ifVersionList /*- Haskell module header/import parsing: ----------------------------------- - * Syntax for Haskell modules (module headers and imports) is parsed but - * most of it is ignored. However, module names in import declarations - * are used, of course, if import chasing is turned on. + * Module chasing is now totally different from Classic Hugs98. We parse + * the entire syntax tree. Subsequent passes over the tree collect and + * chase imports; we no longer attempt to do so whilst parsing. *-------------------------------------------------------------------------*/ /* In Haskell 1.2, the default module header was "module Main where" * In 1.3, this changed to "module Main(main) where". * We use the 1.2 header because it breaks much less pre-module code. + * STG Hugs, 15 March 00: disallow default headers (pro tem). */ -topModule : startMain begin modBody end { - setExportList(singleton( - ap(MODULEENT, - mkCon(module(currentModule).text) - ))); - $$ = gc3($3); - } - | TMODULE modname expspec WHERE '{' modBody end - {setExportList($3); $$ = gc7($6);} +topModule : TMODULE modname expspec WHERE '{' modBody end + {$$=gc7(ap(M_MODULE, + ztriple($2,$3,$6)));} + | TMODULE modname WHERE '{' modBody end + {$$=gc6(ap(M_MODULE, + ztriple( + $2, + singleton(ap(MODULEENT,$2)), + $5)));} + + | begin modBody end {ConId fakeNm = mkCon(module( + moduleBeingParsed).text); + $$ = gc2(ap(M_MODULE, + ztriple(fakeNm, + singleton(ap(MODULEENT,fakeNm)), + $2)));} + | TMODULE error {syntaxError("module definition");} ; -/* To implement the Haskell module system, we have to keep track of the - * current module. We rely on the use of LALR parsing to ensure that this - * side effect happens before any declarations within the module. - */ -startMain : /* empty */ {startModule(conMain); - $$ = gc0(NIL);} - ; -modname : CONID {startModule($1); $$ = gc1(NIL);} - ; -modid : CONID {$$ = $1;} - | STRINGLIT { extern String scriptFile; - String modName - = findPathname(scriptFile, - textToStr(textOf($1))); - if (modName) { - /* fillin pathname if known */ - $$ = mkStr(findText(modName)); - } else { - $$ = $1; - } - } + +modname : CONID {$$ = gc1($1);} + ; +modid : CONID {$$ = gc1($1);} ; -modBody : topDecls {$$ = $1;} - | impDecls chase {$$ = gc2(NIL);} - | impDecls ';' chase topDecls {$$ = gc4($4);} +modBody : topDecls {$$ = gc1($1);} + | impDecls {$$ = gc1($1);} + | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));} ; /*- Exports: --------------------------------------------------------------*/ -expspec : /* empty */ {$$ = gc0(exportSelf());} - | '(' ')' {$$ = gc2(NIL);} +expspec : '(' ')' {$$ = gc2(NIL);} | '(' exports ')' {$$ = gc3($2);} | '(' exports ',' ')' {$$ = gc4($2);} ; @@ -502,36 +494,28 @@ qname : qvar {$$ = $1;} /*- Import declarations: --------------------------------------------------*/ -impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);} - | impDecl {imps = singleton($1); $$=gc1(NIL);} - ; -chase : /* empty */ {if (chase(imps)) { - clearStack(); - onto(imps); - done(); - closeAnyInput(); - return 0; - } - $$ = gc0(NIL); - } +impDecls : impDecls ';' impDecl {$$ = gc3(appendOnto($3,$1));} + | impDecl {$$ = gc1($1);} ; + /* Note that qualified import ignores the import list. */ -impDecl : IMPORT modid impspec {addQualImport($2,$2); - addUnqualImport($2,$3); - $$ = gc3($2);} +impDecl : IMPORT modid impspec {$$=gc3(doubleton( + ap(M_IMPORT_Q,zpair($2,$2)), + ap(M_IMPORT_UNQ,zpair($2,$3)) + ));} | IMPORT modid ASMOD modid impspec - {addQualImport($2,$4); - addUnqualImport($2,$5); - $$ = gc5($2);} + {$$=gc5(doubleton( + ap(M_IMPORT_Q,zpair($2,$4)), + ap(M_IMPORT_UNQ,zpair($2,$5)) + ));} | IMPORT QUALIFIED modid ASMOD modid impspec - {addQualImport($3,$5); - $$ = gc6($3);} + {$$=gc6(singleton( + ap(M_IMPORT_Q,zpair($3,$5)) + ));} | IMPORT QUALIFIED modid impspec - {addQualImport($3,$3); - $$ = gc4($3);} - | IMPORT PRIVILEGED modid {addQualImport($3,$3); - addUnqualImport($3,gc0(STAR)); - $$ = gc4($3);} + {$$=gc4(singleton( + ap(M_IMPORT_Q,zpair($3,$3)) + ));} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(DOTDOT);} @@ -565,44 +549,50 @@ name : var {$$ = $1;} /*- Top-level declarations: -----------------------------------------------*/ -topDecls : /* empty */ {$$ = gc0(NIL);} - | ';' {$$ = gc1(NIL);} - | topDecls1 {$$ = $1;} - | topDecls1 ';' {$$ = gc2($1);} - ; -topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);} - | topDecls1 ';' decl {$$ = gc3(cons($3,$1));} - | topDecl {$$ = gc0(NIL);} - | decl {$$ = gc1(cons($1,NIL));} - ; +topDecls : /* empty */ {$$=gc0(NIL);} + | topDecl ';' topDecls {$$=gc3(cons($1,$3));} + | decl ';' topDecls {$$=gc3(cons(ap(M_VALUE,$1),$3));} + | topDecl {$$=gc1(cons($1,NIL));} + | decl {$$=gc1(cons(ap(M_VALUE,$1),NIL));} + ; /*- Type declarations: ----------------------------------------------------*/ -topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);} +topDecl : TYPE tyLhs '=' type {$$=gc4(ap(M_TYCON, + z4ble($3,$2,$4, + SYNONYM)));} | TYPE tyLhs '=' type IN invars - {defTycon(6,$3,$2, - ap($4,$6),RESTRICTSYN);} + {$$=gc6(ap(M_TYCON, + z4ble($3,$2,ap($4,$6), + RESTRICTSYN)));} | TYPE error {syntaxError("type definition");} | DATA btype2 '=' constrs deriving - {defTycon(5,$3,checkTyLhs($2), - ap(rev($4),$5),DATATYPE);} + {$$=gc5(ap(M_TYCON, + z4ble($3,checkTyLhs($2), + ap(rev($4),$5), + DATATYPE)));} | DATA context IMPLIES tyLhs '=' constrs deriving - {defTycon(7,$5,$4, - ap(qualify($2,rev($6)), - $7),DATATYPE);} - | DATA btype2 {defTycon(2,$1,checkTyLhs($2), - ap(NIL,NIL),DATATYPE);} - | DATA context IMPLIES tyLhs {defTycon(4,$1,$4, - ap(qualify($2,NIL), - NIL),DATATYPE);} + {$$=gc7(ap(M_TYCON, + z4ble($5,$4, + ap(qualify($2,rev($6)),$7), + DATATYPE)));} + | DATA btype2 {$$=gc2(ap(M_TYCON, + z4ble($1,checkTyLhs($2), + ap(NIL,NIL),DATATYPE)));} + | DATA context IMPLIES tyLhs {$$=gc4(ap(M_TYCON, + z4ble($1,$4, + ap(qualify($2,NIL),NIL), + DATATYPE)));} | DATA error {syntaxError("data definition");} | TNEWTYPE btype2 '=' nconstr deriving - {defTycon(5,$3,checkTyLhs($2), - ap($4,$5),NEWTYPE);} + {$$=gc5(ap(M_TYCON, + z4ble($3,checkTyLhs($2), + ap($4,$5),NEWTYPE)));} | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving - {defTycon(7,$5,$4, - ap(qualify($2,$6), - $7),NEWTYPE);} + {$$=gc7(ap(M_TYCON, + z4ble($5,$4, + ap(qualify($2,$6),$7), + NEWTYPE)));} | TNEWTYPE error {syntaxError("newtype definition");} ; tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));} @@ -674,11 +664,11 @@ derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));} /*- Processing definitions of primitives ----------------------------------*/ topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type - {foreignImport($1,$3,NIL,$6,$8); sp-=8;} + {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));} | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type - {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;} + {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));} | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type - {foreignExport($1,$3,$4,$5,$7); sp-=7;} + {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));} ; callconv : CCALL {$$ = gc1(textCcall);} @@ -696,9 +686,9 @@ unsafe_flag: /* empty */ {$$ = gc0(NIL);} /*- Class declarations: ---------------------------------------------------*/ -topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;} - | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;} - | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;} +topDecl : TCLASS crule fds wherePart {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));} + | TINSTANCE irule wherePart {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));} + | DEFAULT '(' dtypes ')' {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));} | TCLASS error {syntaxError("class declaration");} | TINSTANCE error {syntaxError("instance declaration");} | DEFAULT error {syntaxError("default declaration");} @@ -1054,6 +1044,7 @@ infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} ; exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));} | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));} + | MDO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));} | appExp {$$ = $1;} ; exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, @@ -1205,7 +1196,6 @@ varid : VARID {$$ = $1;} | HIDING {$$ = gc1(varHiding);} | QUALIFIED {$$ = gc1(varQualified);} | ASMOD {$$ = gc1(varAsMod);} - | PRIVILEGED {$$ = gc1(varPrivileged);} ; qconid : QCONID {$$ = $1;} | CONID {$$ = $1;} @@ -1274,7 +1264,6 @@ varid1 : VARID {$$ = gc1($1);} | HIDING {$$ = gc1(varHiding);} | QUALIFIED {$$ = gc1(varQualified);} | ASMOD {$$ = gc1(varAsMod);} - | PRIVILEGED {$$ = gc1(varPrivileged);} ; /*- Tricks to force insertion of leading and closing braces ---------------*/ @@ -1282,7 +1271,7 @@ varid1 : VARID {$$ = gc1($1);} begin : error {yyerrok; if (offsideON) goOffside(startColumn);} ; - /* deal with trailing semicolon */ + end : '}' {$$ = $1;} | error {yyerrok; if (offsideON && canUnOffside()) { @@ -1419,7 +1408,6 @@ static String local unexpected() { /* find name for unexpected token */ return buffer; case HIDING : return "symbol \"hiding\""; case QUALIFIED : return "symbol \"qualified\""; - case PRIVILEGED : return "symbol \"privileged\""; case ASMOD : return "symbol \"as\""; case NUMLIT : return "numeric literal"; case CHARLIT : return "character literal";