X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fparser.y;h=b91d7d57cda2cb4227b94294769756a8767621f5;hb=333e9b497dd063a37af367abd937d2f6454ae84c;hp=c54fb2c51a32712876469a300dd0fc8c2f872508;hpb=9da01c710daee2cd5038afb8fad761cdaf343033;p=ghc-hetmet.git diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index c54fb2c..b91d7d5 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -5,14 +5,15 @@ * 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.4 $ - * $Date: 1999/03/09 14:51:09 $ + * $Revision: 1.13 $ + * $Date: 1999/11/17 16:57:42 $ * ------------------------------------------------------------------------*/ %{ @@ -28,11 +29,8 @@ #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) -#if IGNORE_MODULES -#define exportSelf() NIL -#else -#define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text))) -#endif +#define exportSelf() singleton(ap(MODULEENT, \ + mkCon(module(currentModule).text))) #define yyerror(s) /* errors handled elsewhere */ #define YYSTYPE Cell @@ -40,14 +38,18 @@ 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 List local checkCtxt Args((List)); static Cell local checkPred Args((Cell)); static Pair local checkDo Args((List)); static Cell local checkTyLhs Args((Cell)); #if !TREX static Void local noTREX Args((String)); #endif +#if !IPARAM +static Void local noIP Args((String)); +#endif /* For the purposes of reasonably portable garbage collection, it is * necessary to simulate the YACC stack on the Hugs stack to keep @@ -75,33 +77,311 @@ static Void local noTREX Args((String)); %} -%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 +/*#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 UNSAFE +%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE +%token INSTIMPORT DYNAMIC CCALL STDCALL %% /*- 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");} ; + +/*- GHC interface file parsing: -------------------------------------------*/ + +/* Reading in an interface file is surprisingly like reading + * a normal Haskell module: we read in a bunch of declarations, + * construct symbol table entries, etc. The "only" differences + * are that there's no syntactic sugar to deal with and we don't + * have to read in expressions. + */ + +/*- Top-level interface files -----------------------------*/ +iface : INTERFACE ifName NUMLIT checkVersion WHERE ifDecls + {$$ = gc6(NIL); } + | 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); } + ; +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); } + | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType + { addGHCSynonym(intOf($2),$3,$4,$6); + $$ = gc6(NIL); } + + | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs + { addGHCDataDecl(intOf($2), + $3,$4,$5,$6); + $$ = gc6(NIL); } + + | 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); } + | NUMLIT ifVar COCO ifType + { addGHCVar(intOf($3),textOf($2),$4); + $$ = gc4(NIL); } + | error { syntaxError( + "interface declaration"); } + ; + + +/*- Interface variable and constructor ids ----------------*/ +ifTyvar : VARID {$$ = $1;} + ; +ifVar : VARID {$$ = gc1($1);} + ; +ifCon : CONID {$$ = gc1($1);} + ; +ifQCon : CONID {$$ = gc1($1);} + | QCONID {$$ = gc1($1);} + ; +ifConData : ifCon {$$ = gc1($1);} + | '(' ')' {$$ = gc2(typeUnit);} + | '[' ']' {$$ = gc2(typeList);} + | '(' ARROW ')' {$$ = gc3(typeArrow);} + ; +ifTCName : CONID { $$ = gc1($1); } + | CONOP { $$ = gc1($1); } + | '(' ARROW ')' { $$ = gc3(typeArrow); } + | '[' ']' { $$ = gc1(typeList); } + ; +ifQTCName : ifTCName { $$ = gc1($1); } + | QCONID { $$ = gc1($1); } + | QCONOP { $$ = 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);} + | {$$=gc0(NIL);} + ; +ifInstHd /* { Class aType } :: (ConId, Type) */ + : '{' ifCon ifAType '}' {$$=gc4(pair($2,$3));} + ; + +ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ + : { $$ = gc0(NIL); } + | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); } + ; +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));} + ; + + +/*- Interface data declarations - constructor lists -------*/ +ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text)],NIL)] */ + : {$$ = gc0(NIL);} + | '=' ifConstrL {$$ = gc2($2);} + ; +ifConstrL /* [(ConId,[(Type,Text)],NIL)] */ + : ifConstr {$$ = gc1(singleton($1));} + | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));} + ; +ifConstr /* (ConId,[(Type,Text)],NIL) */ + : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));} + | ifConData '{' ifDataNamedFieldL '}' + {$$ = gc4(triple($1,$3,NIL));} + ; +ifDataAnonFieldL /* [(Type,Text)] */ + : {$$=gc0(NIL);} + | ifDataAnonField ifDataAnonFieldL + {$$=gc2(cons($1,$2));} + ; +ifDataNamedFieldL /* [(Type,Text)] */ + : {$$=gc0(NIL);} + | ifDataNamedField {$$=gc1(cons($1,NIL));} + | ifDataNamedField ',' ifDataNamedFieldL + {$$=gc3(cons($1,$3));} + ; +ifDataAnonField /* (Type,Text) */ + : ifAType {$$=gc1(pair($1,NIL));} + ; +ifDataNamedField /* (Type,Text) */ + : VARID COCO ifAType {$$=gc3(pair($3,$1));} + ; + + +/*- Interface class declarations - methods ----------------*/ +ifCmeths /* [(VarId,Type)] */ + : { $$ = gc0(NIL); } + | WHERE '{' ifCmethL '}' { $$ = gc4($3); } + ; +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)); } + /* has default method */ + ; + + +/*- Interface newtype declararions ------------------------*/ +ifNewTypeConstr /* (ConId,Type) */ + : '=' ifCon ifAType { $$ = gc3(pair($2,$3)); } + ; + + +/*- Interface type expressions ----------------------------*/ +ifType : ALL ifForall ifCtxDeclT IMPLIES ifType + { if ($3 == NIL) + $$=gc5($5); else + $$=gc5(pair(QUAL,pair($3,$5))); + } + | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); } + | ifBType { $$ = gc1($1); } + ; +ifForall /* [(VarId,Kind)] */ + : '[' ifKindedTyvarL ']' { $$ = gc3($2); } + ; +ifTypes2 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } + | ifType ',' ifTypes2 { $$ = gc3(cons($1,$3)); } + ; +ifBType : ifAType { $$ = gc1($1); } + | ifBType ifAType { $$ = gc2(ap($1,$2)); } + ; +ifAType : ifQTCName { $$ = gc1($1); } + | ifTyvar { $$ = gc1($1); } + | '(' ')' { $$ = gc2(typeUnit); } + | '(' ifTypes2 ')' { $$ = gc3(buildTuple($2)); } + | '[' ifType ']' { $$ = gc3(ap(typeList,$2));} + | '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP, + pair($2,$3))); } + | '(' ifType ')' { $$ = gc3($2); } + ; +ifATypes : { $$ = gc0(NIL); } + | ifAType ifATypes { $$ = gc2(cons($1,$2)); } + ; + + +/*- Interface kinds ---------------------------------------*/ +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)); } + ; +ifKind : ifAKind { $$ = gc1($1); } + | ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); } + ; +ifAKind : VAROP { $$ = gc1(STAR); } + /* should be '*' */ + | '(' ifKind ')' { $$ = gc3($2); } + ; + + +/*- Interface version/export/import stuff -----------------*/ +ifEntities + : { $$ = gc0(NIL); } + | ifEntity ifEntities { $$ = gc2(cons($1,$2)); } + ; +ifEntity + : ifEntityOcc {$$=gc1($1);} + | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));} + ; +ifEntityOcc + : ifVar { $$ = gc1($1); } + | ifCon { $$ = gc1($1); } + | ARROW { $$ = gc1(typeArrow); } + | '(' ARROW ')' { $$ = gc3(typeArrow); } + /* why allow both? */ + ; +ifStuffInside + : '{' ifValOccs '}' { $$ = gc3($2); } + ; +ifValOccs + : { $$ = gc0(NIL); } + | 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));} + ; + + /*- 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. @@ -112,7 +392,10 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} * We use the 1.2 header because it breaks much less pre-module code. */ topModule : startMain begin modBody end { - setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text)))); + setExportList(singleton( + ap(MODULEENT, + mkCon(module(currentModule).text) + ))); $$ = gc3($3); } | TMODULE modname expspec WHERE '{' modBody end @@ -130,8 +413,11 @@ 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 */ + String modName + = findPathname(scriptFile, + textToStr(textOf($1))); + if (modName) { + /* fillin pathname if known */ $$ = mkStr(findText(modName)); } else { $$ = $1; @@ -256,7 +542,7 @@ topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM);} | TYPE error {syntaxError("type definition");} | DATA btype2 '=' constrs deriving {defTycon(5,$3,checkTyLhs($2), - ap(rev($4),$5),DATATYPE);} + ap(rev($4),$5),DATATYPE);} | DATA context IMPLIES tyLhs '=' constrs deriving {defTycon(7,$5,$4, ap(qualify($2,rev($6)), @@ -284,7 +570,7 @@ invars : invars ',' invar {$$ = gc3(cons($3,$1));} | invar {$$ = gc1(cons($1,NIL));} ; invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1), - $3));} + $3));} | var {$$ = $1;} ; constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));} @@ -345,12 +631,14 @@ 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;} + {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;} + | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type + {foreignExport($1,$3,$4,$5,$7); sp-=7;} ; -callconv : var {$$ = gc1(NIL); /* ignored */ } +callconv : CCALL {$$ = gc1(textCcall);} + | STDCALL {$$ = gc1(textStdcall);} + | /* empty */ {$$ = gc0(NIL);} ; ext_loc : STRINGLIT {$$ = $1;} ; @@ -363,7 +651,7 @@ unsafe_flag: /* empty */ {$$ = gc0(NIL);} /*- Class declarations: ---------------------------------------------------*/ -topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;} +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;} | TCLASS error {syntaxError("class declaration");} @@ -383,9 +671,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));} @@ -395,11 +701,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));} @@ -408,10 +715,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 @@ -420,6 +727,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));} @@ -457,7 +771,6 @@ atype1 : varid {$$ = $1;} | '(' tupCommas ')' {$$ = gc3($2);} | '(' btypes2 ')' {$$ = gc3(buildTuple($2));} | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} -/*#if TREX*/ | '(' tfields ')' { #if TREX $$ = gc3(revOnto($2,typeNoRow)); @@ -465,11 +778,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)));} @@ -483,7 +802,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*/ @@ -575,6 +895,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));} @@ -654,6 +975,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;} @@ -688,6 +1016,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));} @@ -698,6 +1033,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)));} @@ -779,6 +1115,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)));} @@ -884,12 +1232,13 @@ varid1 : VARID {$$ = gc1($1);} /*- Tricks to force insertion of leading and closing braces ---------------*/ -begin : error {yyerrok; goOffside(startColumn);} +begin : error {yyerrok; + if (offsideON) goOffside(startColumn);} ; /* deal with trailing semicolon */ end : '}' {$$ = $1;} | error {yyerrok; - if (canUnOffside()) { + if (offsideON && canUnOffside()) { unOffside(); /* insert extra token on stack*/ push(NIL); @@ -914,7 +1263,7 @@ Cell e; { * x1 | ... | xn | la ===> e | la * top() top() * - * Othwerwise, the transformation is: + * Otherwise, the transformation is: * pushed: n-1 0 0 * x1 | ... | xn ===> e * top() top() @@ -966,7 +1315,15 @@ static String local unexpected() { /* find name for unexpected token */ case DEFAULT : keyword("default"); case IMPORT : keyword("import"); case TMODULE : keyword("module"); - case ALL : keyword("forall"); + /* 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 "`->'"; @@ -978,12 +1335,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 "`]'"; @@ -996,6 +1353,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 : @@ -1047,7 +1409,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; @@ -1060,7 +1422,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; } @@ -1076,21 +1442,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; { @@ -1099,5 +1464,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 /*-------------------------------------------------------------------------*/