X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fparser.y;h=a86b13c91a1c2242439d75e5505f516f78633786;hb=8529126a1bae9b5ee55e109de0517402feb76da5;hp=0d787cf93742dc1b54bed6dd1e4d70bd4cc3ed0f;hpb=4847ea83e1d0f4fa8596b71ba64519bdb004de7d;p=ghc-hetmet.git diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 0d787cf..a86b13c 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -12,43 +12,39 @@ * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.11 $ - * $Date: 1999/10/20 02:16:02 $ + * $Revision: 1.28 $ + * $Date: 2000/04/06 00:36:12 $ * ------------------------------------------------------------------------*/ %{ #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))))) #define grded(gs) ap(GUARDED,gs) -#define bang(t) ap(BANG,t) #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 checkContext 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 @@ -74,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) %} @@ -97,16 +95,17 @@ static Void local noIP Args((String)); %token '[' ';' ']' '`' '.' %token TMODULE IMPORT HIDING QUALIFIED ASMOD %token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE -%token INSTIMPORT DYNAMIC +%token INSTIMPORT DYNAMIC CCALL STDKALL +%token UTL UTR UUUSAGE %% /*- 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");} ; @@ -120,75 +119,79 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} */ /*- Top-level interface files -----------------------------*/ -iface : INTERFACE ifName NUMLIT checkVersion WHERE ifDecls - {$$ = gc6(NIL); } +iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls + {$$ = gc7(ap(I_INTERFACE, + zpair($2,$7))); } | INTERFACE error {syntaxError("interface file");} ; -ifDecls: {$$=gc0(NIL);} - | ifDecl ';' ifDecls {$$=gc3(cons($1,$3));} - ; -varid_or_conid - : VARID { $$=gc1($1); } - | CONID { $$=gc1($1); } - ; -opt_bang : '!' {$$=gc1(NIL);} - | {$$=gc0(NIL);} - ; -ifName : CONID {openGHCIface(textOf($1)); - $$ = gc1(NIL);} -checkVersion - : NUMLIT {$$ = gc1(NIL); } + +ifTopDecls: {$$=gc0(NIL);} + | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));} ; -ifDecl - : IMPORT CONID opt_bang NUMLIT COCO version_list_junk - { addGHCImports(intOf($4),textOf($2), - $6); - $$ = gc6(NIL); - } - | INSTIMPORT CONID {$$=gc2(NIL);} - - | UUEXPORT CONID ifEntities { addGHCExports($2,$3); - $$=gc3(NIL);} - - | NUMLIT INFIXL optDigit varid_or_conid - {$$ = gc4(fixdecl($2,singleton($4), - LEFT_ASS,$3)); } - | NUMLIT INFIXR optDigit varid_or_conid - {$$ = gc4(fixdecl($2,singleton($4), - RIGHT_ASS,$3)); } - | NUMLIT INFIXN optDigit varid_or_conid - {$$ = gc4(fixdecl($2,singleton($4), - NON_ASS,$3)); } - - | TINSTANCE ifCtxInst ifInstHd '=' ifVar - { addGHCInstance(intOf($1),$2,$3, - textOf($5)); - $$ = gc5(NIL); } +ifTopDecl + : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList + {$$=gc7(ap(I_IMPORT,zpair($2,$7))); } + + | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));} + + | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));} + + | NUMLIT INFIXL optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(LEFT_ASS),$4)));} + | NUMLIT INFIXR optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(RIGHT_ASS),$4)));} + | NUMLIT INFIXN optDigit ifVarCon + {$$=gc4(ap(I_FIXDECL, + ztriple($3,mkInt(NON_ASS),$4)));} + + | TINSTANCE ifCtxInst ifInstHdL '=' ifVar + {$$=gc5(ap(I_INSTANCE, + z5ble($1,$2,$3,$5,NIL)));} + | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType - { addGHCSynonym(intOf($2),$3,$4,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_TYPE, + z4ble($2,$3,$4,$6)));} | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs - { addGHCDataDecl(intOf($2), - $3,$4,$5,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_DATA, + z5ble($2,$3,$4,$5,$6)));} | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr - { addGHCNewType(intOf($2), - $3,$4,$5,$6); - $$ = gc6(NIL); } - | NUMLIT TCLASS ifCtxDecl ifCon ifTyvar ifCmeths - { addGHCClass(intOf($2),$3,$4,$5,$6); - $$ = gc6(NIL); } + {$$=gc6(ap(I_NEWTYPE, + z5ble($2,$3,$4,$5,$6)));} + + | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths + {$$=gc6(ap(I_CLASS, + z5ble($2,$3,$4, + singleton($5),$6)));} + | NUMLIT ifVar COCO ifType - { addGHCVar(intOf($3),textOf($2),$4); - $$ = gc4(NIL); } + {$$=gc4(ap(I_VALUE, + ztriple($3,$2,$4)));} + | error { syntaxError( "interface declaration"); } ; +/*- Top-level misc interface stuff ------------------------*/ +ifOrphans : '!' {$$=gc1(NIL);} + | {$$=gc0(NIL);} +ifIsBoot : '@' {$$=gc1(NIL);} + | {$$=gc0(NIL);} + ; +ifOptCOCO : COCO {$$=gc1(NIL);} + | {$$=gc0(NIL);} + ; +ifCheckVersion + : NUMLIT {$$ = gc1(NIL); } + ; + + + /*- Interface variable and constructor ids ----------------*/ ifTyvar : VARID {$$ = $1;} ; @@ -196,6 +199,11 @@ ifVar : VARID {$$ = gc1($1);} ; ifCon : CONID {$$ = gc1($1);} ; + +ifVarCon : VARID {$$ = gc1($1);} + | CONID {$$ = gc1($1);} + ; + ifQCon : CONID {$$ = gc1($1);} | QCONID {$$ = gc1($1);} ; @@ -216,86 +224,101 @@ ifQTCName : ifTCName { $$ = gc1($1); } /*- Interface contexts ------------------------------------*/ -ifCtxInst /* __forall [a b] {M.C1 a, M.C2 b} => */ - /* :: [(QConId, VarId)] */ - : ALL ifForall ifCtxDecl {$$=gc3($3);} - | ALL ifForall IMPLIES {$$=gc3(NIL);} +ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */ + : ALL ifForall IMPLIES {$$=gc3($2);} | {$$=gc0(NIL);} ; -ifInstHd /* { Class aType } :: (ConId, Type) */ - : '{' ifCon ifAType '}' {$$=gc4(pair($2,$3));} +ifInstHd /* { Class aType } :: ((ConId, Type)) */ + : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP, + zpair($2,$3)));} ; -ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ - : { $$ = gc0(NIL); } - | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); } +ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */ + : ifInstHd ARROW ifInstHdL {$$=gc3(ap($1,$3));} + | ifInstHd {$$=gc1($1);} + ; + +ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */ + : ifCtxDeclT IMPLIES { $$ = gc2($1); } + | { $$ = gc0(NIL); } ; ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ : { $$ = gc0(NIL); } | '{' ifCtxDeclL '}' { $$ = gc3($2); } ; + ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */ : ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));} | ifCtxDeclLE {$$=gc1(cons($1,NIL));} | {$$=gc0(NIL);} ; ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */ - : ifQCon ifTyvar {$$=gc2(pair($1,$2));} + : ifQCon ifTyvar {$$=gc2(zpair($1,$2));} ; /*- Interface data declarations - constructor lists -------*/ -ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text)],NIL)] */ +/* The (Type,VarId,Int) are (field type, name (or NIL), strictness). + Strictness is a number: mkInt(0) indicates lazy, mkInt(1) + indicates a strict field (!type) as in standard H98, and + mkInt(2) indicates unpacked -- a GHC extension. +*/ + +ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */ : {$$ = gc0(NIL);} | '=' ifConstrL {$$ = gc2($2);} ; -ifConstrL /* [(ConId,[(Type,Text)],NIL)] */ +ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */ : ifConstr {$$ = gc1(singleton($1));} | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));} ; -ifConstr /* (ConId,[(Type,Text)],NIL) */ - : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));} +ifConstr /* ((ConId,[((Type,VarId,Int))])) */ + : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));} | ifConData '{' ifDataNamedFieldL '}' - {$$ = gc4(triple($1,$3,NIL));} + {$$ = gc4(zpair($1,$3));} ; -ifDataAnonFieldL /* [(Type,Text)] */ +ifDataAnonFieldL /* [((Type,VarId,Int))] */ : {$$=gc0(NIL);} | ifDataAnonField ifDataAnonFieldL {$$=gc2(cons($1,$2));} ; -ifDataNamedFieldL /* [(Type,Text)] */ +ifDataNamedFieldL /* [((Type,VarId,Int))] */ : {$$=gc0(NIL);} | ifDataNamedField {$$=gc1(cons($1,NIL));} | ifDataNamedField ',' ifDataNamedFieldL {$$=gc3(cons($1,$3));} ; -ifDataAnonField /* (Type,Text) */ - : ifAType {$$=gc1(pair($1,NIL));} +ifDataAnonField /* ((Type,VarId,Int)) */ + : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));} + | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));} + | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));} ; -ifDataNamedField /* (Type,Text) */ - : VARID COCO ifAType {$$=gc3(pair($3,$1));} +ifDataNamedField /* ((Type,VarId,Int)) */ + : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));} + | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));} + | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));} ; /*- Interface class declarations - methods ----------------*/ -ifCmeths /* [(VarId,Type)] */ +ifCmeths /* [((VarId,Type))] */ : { $$ = gc0(NIL); } | WHERE '{' ifCmethL '}' { $$ = gc4($3); } ; -ifCmethL /* [(VarId,Type)] */ +ifCmethL /* [((VarId,Type))] */ : ifCmeth { $$ = gc1(singleton($1)); } | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); } ; -ifCmeth /* (VarId,Type) */ - : ifVar COCO ifType { $$ = gc3(pair($1,$3)); } - | ifVar '=' COCO ifType { $$ = gc4(pair($1,$4)); } +ifCmeth /* ((VarId,Type)) */ + : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); } + | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); } /* has default method */ ; /*- Interface newtype declararions ------------------------*/ -ifNewTypeConstr /* (ConId,Type) */ - : '=' ifCon ifAType { $$ = gc3(pair($2,$3)); } +ifNewTypeConstr /* ((ConId,Type)) */ + : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); } ; @@ -308,40 +331,57 @@ ifType : ALL ifForall ifCtxDeclT IMPLIES ifType | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); } | ifBType { $$ = gc1($1); } ; -ifForall /* [(VarId,Kind)] */ +ifForall /* [((VarId,Kind))] */ : '[' ifKindedTyvarL ']' { $$ = gc3($2); } - ; -ifTypes2 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } - | ifType ',' ifTypes2 { $$ = gc3(cons($1,$3)); } ; + +ifTypeL2 /* [Type], 2 or more */ + : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } + | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); } + ; + +ifTypeL /* [Type], 0 or more */ + : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); } + | ifType { $$ = gc1(singleton($1)); } + | { $$ = gc0(NIL); } + ; + ifBType : ifAType { $$ = gc1($1); } | ifBType ifAType { $$ = gc2(ap($1,$2)); } + | UUUSAGE ifUsage ifAType { $$ = gc3($3); } ; + ifAType : ifQTCName { $$ = gc1($1); } | ifTyvar { $$ = gc1($1); } | '(' ')' { $$ = gc2(typeUnit); } - | '(' ifTypes2 ')' { $$ = gc3(buildTuple($2)); } - | '[' ifType ']' { $$ = gc3(ap(typeList,$2));} - | '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP, + | '(' ifTypeL2 ')' { $$ = gc3(buildTuple(reverse($2))); } + | '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text), + $2));} + | '{' ifQTCName ifAType '}' { $$ = gc4(ap(DICTAP, pair($2,$3))); } | '(' ifType ')' { $$ = gc3($2); } + | UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); } ; -ifATypes : { $$ = gc0(NIL); } - | ifAType ifATypes { $$ = gc2(cons($1,$2)); } + + +/*- KW's usage stuff --------------------------------------*/ +ifUsage : '-' { $$ = gc1(NIL); } + | '!' { $$ = gc1(NIL); } + | ifVar { $$ = gc1(NIL); } ; /*- Interface kinds ---------------------------------------*/ -ifKindedTyvarL /* [(VarId,Kind)] */ +ifKindedTyvarL /* [((VarId,Kind))] */ : { $$ = gc0(NIL); } | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); } ; -ifKindedTyvar /* (VarId,Kind) */ - : ifTyvar { $$ = gc1(pair($1,STAR)); } - | ifTyvar COCO ifAKind { $$ = gc3(pair($1,$3)); } +ifKindedTyvar /* ((VarId,Kind)) */ + : ifTyvar { $$ = gc1(zpair($1,STAR)); } + | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); } ; ifKind : ifAKind { $$ = gc1($1); } - | ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); } + | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); } ; ifAKind : VAROP { $$ = gc1(STAR); } /* should be '*' */ @@ -356,7 +396,7 @@ ifEntities ; ifEntity : ifEntityOcc {$$=gc1($1);} - | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));} + | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));} ; ifEntityOcc : ifVar { $$ = gc1($1); } @@ -373,66 +413,57 @@ ifValOccs | ifVar ifValOccs { $$ = gc2(cons($1,$2)); } | ifCon ifValOccs { $$ = gc2(cons($1,$2)); } ; -version_list_junk - : {$$=gc0(NIL);} - | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));} - | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));} + +ifVersionList + : {$$=gc0(NIL);} + | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));} + | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));} ; /*- 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);} ; @@ -462,33 +493,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);} + {$$=gc4(singleton( + ap(M_IMPORT_Q,zpair($3,$3)) + ));} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(DOTDOT);} @@ -522,44 +548,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));} @@ -630,13 +662,17 @@ derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));} /*- Processing definitions of primitives ----------------------------------*/ -topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type - {foreignImport($1,pair($4,$5),$7,$9); sp-=9;} +topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type + {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));} + | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type + {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));} | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type - {foreignExport($1,$4,$5,$7); sp-=7;} + {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));} ; -callconv : var {$$ = gc1(NIL); /* ignored */ } +callconv : CCALL {$$ = gc1(textCcall);} + | STDKALL {$$ = gc1(textStdcall);} + | /* empty */ {$$ = gc0(NIL);} ; ext_loc : STRINGLIT {$$ = $1;} ; @@ -649,9 +685,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");} @@ -713,10 +749,10 @@ sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));} context : '(' ')' {$$ = gc2(NIL);} | btype2 {$$ = gc1(singleton(checkPred($1)));} | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));} - | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));} + | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));} /*#if TREX*/ | lacks {$$ = gc1(singleton($1));} - | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));} + | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));} ; lacks : varid '\\' varid { #if TREX @@ -1233,7 +1269,7 @@ varid1 : VARID {$$ = gc1($1);} begin : error {yyerrok; if (offsideON) goOffside(startColumn);} ; - /* deal with trailing semicolon */ + end : '}' {$$ = $1;} | error {yyerrok; if (offsideON && canUnOffside()) { @@ -1407,7 +1443,7 @@ List tup; { /* list [xn,...,x1] */ return tup; } -static List local checkContext(con) /* validate context */ +static List local checkCtxt(con) /* validate context */ Type con; { mapOver(checkPred, con); return con;