X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fparser.y;h=13b3b0a37a968758fdb852f51a3a1a1afe551647;hb=a7568f61b7b3dd1af469b16eca81d068bf0f1eb8;hp=4b860aaf81072eb413743896e6b6fa68194ee115;hpb=ca6e1e45c806ac5190589eb9e6720c5cf133df1b;p=ghc-hetmet.git diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index 4b860aa..13b3b0a 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -5,46 +5,46 @@ * Expect 6 shift/reduce conflicts when passing this grammar through yacc, * but don't worry; they should all be resolved in an appropriate manner. * - * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale - * Haskell Group 1994-99, and is distributed as Open Source software - * under the Artistic License; see the file "Artistic" that is included - * in the distribution for details. + * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the + * Yale Haskell Group, and the Oregon Graduate Institute of Science and + * Technology, 1994-1999, All rights reserved. It is distributed as + * free software under the license in the file "License", which is + * included in the distribution. * * $RCSfile: parser.y,v $ - * $Revision: 1.7 $ - * $Date: 1999/07/06 15:24:40 $ + * $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))))) #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 ( String ); #endif /* For the purposes of reasonably portable garbage collection, it is @@ -70,34 +70,43 @@ static Void local noTREX 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) %} -%token EXPR SCRIPT +%token EXPR CONTEXT SCRIPT %token CASEXP OF DATA TYPE IF %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*/ %token REPEAT ALL NUMLIT CHARLIT STRINGLIT %token VAROP VARID CONOP CONID %token QVAROP QVARID QCONOP QCONID /*#if TREX*/ -%token RECSELID +%token RECSELID IPVARID /*#endif*/ %token COCO '=' UPTO '@' '\\' %token '|' '-' FROM ARROW '~' %token '!' IMPLIES '(' ',' ')' %token '[' ';' ']' '`' '.' %token TMODULE IMPORT HIDING QUALIFIED ASMOD -%token EXPORT INTERFACE REQUIRES UNSAFE INSTIMPORT +%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE +%token INSTIMPORT DYNAMIC CCALL STDKALL +%token UTL UTR UUUSAGE %% /*- Top level script/module structure -------------------------------------*/ -start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} - | 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");} ; @@ -111,75 +120,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 STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls + {$$ = gc8(ap(I_INTERFACE, + zpair($3,$8))); } | 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);} - - | EXPORT 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;} ; @@ -187,6 +200,11 @@ ifVar : VARID {$$ = gc1($1);} ; ifCon : CONID {$$ = gc1($1);} ; + +ifVarCon : VARID {$$ = gc1($1);} + | CONID {$$ = gc1($1);} + ; + ifQCon : CONID {$$ = gc1($1);} | QCONID {$$ = gc1($1);} ; @@ -207,86 +225,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)); } ; @@ -299,40 +332,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 '*' */ @@ -347,7 +397,7 @@ ifEntities ; ifEntity : ifEntityOcc {$$=gc1($1);} - | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));} + | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));} ; ifEntityOcc : ifVar { $$ = gc1($1); } @@ -364,66 +414,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);} ; -modBody : topDecls {$$ = $1;} - | impDecls chase {$$ = gc2(NIL);} - | impDecls ';' chase topDecls {$$ = gc4($4);} +modid : CONID {$$ = gc1($1);} + ; +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);} ; @@ -453,33 +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);} + {$$=gc4(singleton( + ap(M_IMPORT_Q,zpair($3,$3)) + ));} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(DOTDOT);} @@ -513,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));} @@ -621,13 +663,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;} - | FOREIGN EXPORT callconv ext_name qvarid COCO type - {foreignExport($1,$4,$5,$7); sp-=7;} +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 + {$$=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;} ; @@ -640,9 +686,9 @@ unsafe_flag: /* empty */ {$$ = gc0(NIL);} /*- Class declarations: ---------------------------------------------------*/ -topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;} - | 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");} @@ -660,9 +706,27 @@ dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));} | type {$$ = gc1(cons($1,NIL));} ; -/*- Type expressions: -----------------------------------------------------*/ - -topType : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));} +fds : /* empty */ {$$ = gc0(NIL);} + | '|' fds1 {h98DoesntSupport(row,"dependent parameters"); + $$ = gc2(rev($2));} + ; +fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));} + | fd {$$ = gc1(cons($1,NIL));} + | + ; +fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));} + ; +varids0 : /* empty */ {$$ = gc0(NIL);} + | varids0 varid {$$ = gc2(cons($2,$1));} + ; + + /*- Type expressions: -----------------------------------------------------*/ + +topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE, + pair(rev($2),$4)));} + | topType0 {$$ = $1;} + ; +topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));} | topType1 {$$ = $1;} ; topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));} @@ -672,11 +736,12 @@ topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));} ; polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE, pair(rev($2),$4)));} + | context IMPLIES type {$$ = gc3(qualify($1,$3));} | bpolyType {$$ = $1;} ; bpolyType : '(' polyType ')' {$$ = gc3($2);} ; -varids : varids ',' varid {$$ = gc3(cons($3,$1));} +varids : varids varid {$$ = gc2(cons($2,$1));} | varid {$$ = gc1(singleton($1));} ; sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));} @@ -685,10 +750,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 @@ -697,6 +762,13 @@ lacks : varid '\\' varid { noTREX("a type context"); #endif } + | IPVARID COCO type { +#if IPARAM + $$ = gc3(pair(mkIParam($1),$3)); +#else + noIP("a type context"); +#endif + } ; lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));} | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));} @@ -734,7 +806,6 @@ atype1 : varid {$$ = $1;} | '(' tupCommas ')' {$$ = gc3($2);} | '(' btypes2 ')' {$$ = gc3(buildTuple($2));} | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} -/*#if TREX*/ | '(' tfields ')' { #if TREX $$ = gc3(revOnto($2,typeNoRow)); @@ -742,11 +813,17 @@ atype1 : varid {$$ = $1;} noTREX("a type"); #endif } - | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));} -/*#endif*/ + | '(' tfields '|' type ')' { +#if TREX + $$ = gc5(revOnto($2,$4)); +#else + noTREX("a type"); +#endif + } | '[' type ']' {$$ = gc3(ap(typeList,$2));} | '[' ']' {$$ = gc2(typeList);} - | '_' {$$ = gc1(inventVar());} + | '_' {h98DoesntSupport(row,"anonymous type variables"); + $$ = gc1(inventVar());} ; btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));} | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));} @@ -760,7 +837,8 @@ typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));} tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));} | tfield {$$ = gc1(singleton($1));} ; -tfield : varid COCO type {$$ = gc3(ap(mkExt(textOf($1)),$3));} +tfield : varid COCO type {h98DoesntSupport(row,"extensible records"); + $$ = gc3(ap(mkExt(textOf($1)),$3));} ; /*#endif*/ @@ -852,6 +930,7 @@ pat0_vI : pat10_vI {$$ = $1;} | infixPat {$$ = gc1(ap(INFIX,$1));} ; infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));} + | '-' error {syntaxError("pattern");} | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));} | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));} | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));} @@ -931,6 +1010,13 @@ exp : exp_err {$$ = $1;} | error {syntaxError("expression");} ; exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));} + | exp0a WITH dbinds { +#if IPARAM + $$ = gc3(ap(WITHEXP,pair($1,$3))); +#else + noIP("an expression"); +#endif + } | exp0 {$$ = $1;} ; exp0 : exp0a {$$ = $1;} @@ -958,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, @@ -965,6 +1052,13 @@ exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, pair($3,$4))));} | LET decls IN exp {$$ = gc4(letrec($2,$4));} | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));} + | DLET dbinds IN exp { +#if IPARAM + $$ = gc4(ap(WITHEXP,pair($4,$2))); +#else + noIP("an expression"); +#endif + } ; pats : pats apat {$$ = gc2(cons($2,$1));} | apat {$$ = gc1(cons($1,NIL));} @@ -975,6 +1069,7 @@ appExp : appExp aexp {$$ = gc2(ap($1,$2));} aexp : qvar {$$ = $1;} | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));} | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));} + | IPVARID {$$ = $1;} | '_' {$$ = gc1(WILDCARD);} | gcon {$$ = $1;} | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));} @@ -1056,6 +1151,18 @@ fbind : var {$$ = $1;} | qvar '=' exp {$$ = gc3(pair($1,$3));} ; +dbinds : '{' dbs0 end {$$ = gc3($2);} + | '{' dbs1 end {$$ = gc3($2);} + ; +dbs0 : /* empty */ {$$ = gc0(NIL);} + | dbs0 ';' {$$ = gc2($1);} + | dbs1 ';' {$$ = gc2($1);} + ; +dbs1 : dbs0 dbind {$$ = gc2(cons($2,$1));} + ; +dbind : IPVARID '=' exp {$$ = gc3(pair($1,$3));} + ; + /*- List Expressions: -------------------------------------------------------*/ list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));} @@ -1164,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()) { @@ -1244,7 +1351,15 @@ static String local unexpected() { /* find name for unexpected token */ case DEFAULT : keyword("default"); case IMPORT : keyword("import"); case TMODULE : keyword("module"); + /* AJG: Hugs98/Classic use the keyword forall + rather than __forall. + Agree on one or the other + */ case ALL : keyword("__forall"); +#if IPARAM + case DLET : keyword("dlet"); + case WITH : keyword("with"); +#endif #undef keyword case ARROW : return "`->'"; @@ -1256,12 +1371,12 @@ static String local unexpected() { /* find name for unexpected token */ case '@' : return "`@'"; case '(' : return "`('"; case ')' : return "`)'"; - case '{' : return "`{'"; - case '}' : return "`}'"; + case '{' : return "`{', possibly due to bad layout"; + case '}' : return "`}', possibly due to bad layout"; case '_' : return "`_'"; case '|' : return "`|'"; case '.' : return "`.'"; - case ';' : return "`;'"; + case ';' : return "`;', possibly due to bad layout"; case UPTO : return "`..'"; case '[' : return "`['"; case ']' : return "`]'"; @@ -1274,6 +1389,11 @@ static String local unexpected() { /* find name for unexpected token */ textToStr(extText(snd(yylval)))); return buffer; #endif +#if IPARAM + case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"", + textToStr(textOf(yylval))); + return buffer; +#endif case VAROP : case VARID : case CONOP : @@ -1325,7 +1445,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; @@ -1338,7 +1458,11 @@ Cell c; { /* constraint */ if (isExt(cn) && argCount==1) return c; #endif - if (!isQCon(cn) || argCount==0) +#if IPARAM + if (isIP(cn)) + return c; +#endif + if (!isQCon(cn) /*|| argCount==0*/) syntaxError("class expression"); return c; } @@ -1354,21 +1478,20 @@ List dqs; { /* to an (expr,quals) pair */ return dqs; } -static Cell local checkTyLhs(c) /* check that lhs is of the form */ -Cell c; { /* T a1 ... a */ +static Cell local checkTyLhs(c) /* check that lhs is of the form */ +Cell c; { /* T a1 ... a */ Cell tlhs = c; - while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) - tlhs = fun(tlhs); - switch (whatIs(tlhs)) { - case CONIDCELL : return c; - - default : - ERRMSG(row) "Illegal left hand side in datatype definition" - EEND; + while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) { + tlhs = fun(tlhs); + } + if (whatIs(tlhs)!=CONIDCELL) { + ERRMSG(row) "Illegal left hand side in datatype definition" + EEND; } - return 0; /* NOTREACHED */ + return c; } + #if !TREX static Void local noTREX(where) String where; { @@ -1377,5 +1500,13 @@ String where; { EEND; } #endif +#if !IPARAM +static Void local noIP(where) +String where; { + ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN + ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)" + EEND; +} +#endif /*-------------------------------------------------------------------------*/