X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Finterpreter%2Fparser.y;h=13b3b0a37a968758fdb852f51a3a1a1afe551647;hb=67a402e25d3707ce4e031e809b874f8341032d23;hp=f816a16c6858d8efb823d4ec5fc8ebb27ae63dca;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y index f816a16..13b3b0a 100644 --- a/ghc/interpreter/parser.y +++ b/ghc/interpreter/parser.y @@ -1,48 +1,51 @@ -/* -*- mode: hugs-c; -*- */ + /* -------------------------------------------------------------------------- * Hugs parser (included as part of input.c) * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 + * Expect 6 shift/reduce conflicts when passing this grammar through yacc, + * but don't worry; they should all be resolved in an appropriate manner. * - * Expect 24 shift/reduce conflicts when passing this grammar through yacc, - * but don't worry; they will all be resolved in an appropriate manner. + * 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.2 $ - * $Date: 1998/12/02 13:22:26 $ + * $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 exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text))) +#define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t) #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 Void local setSyntax Args((Int,Syntax,Cell)); -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 -static Cell local tidyInfix Args((Cell)); /* For the purposes of reasonably portable garbage collection, it is * necessary to simulate the YACC stack on the Hugs stack to keep @@ -52,52 +55,61 @@ static Cell local tidyInfix Args((Cell)); * taking account of look-ahead tokens as described by gcShadow() * below. * - * Of the non-terminals used below, only start, topDecl, fixDecl & begin + * Of the non-terminals used below, only start, topDecl & begin * do not leave any values on the Hugs stack. The same is true for the * terminals EXPR and SCRIPT. At the end of a successful parse, there * should only be one element left on the stack, containing the result * of the parse. */ -#define gc0(e) gcShadow(0,e) -#define gc1(e) gcShadow(1,e) -#define gc2(e) gcShadow(2,e) -#define gc3(e) gcShadow(3,e) -#define gc4(e) gcShadow(4,e) -#define gc5(e) gcShadow(5,e) -#define gc6(e) gcShadow(6,e) -#define gc7(e) gcShadow(7,e) +#define gc0(e) gcShadow(0,e) +#define gc1(e) gcShadow(1,e) +#define gc2(e) gcShadow(2,e) +#define gc3(e) gcShadow(3,e) +#define gc4(e) gcShadow(4,e) +#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 INFIX INFIXL INFIXR FOREIGN TNEWTYPE +%token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE %token DEFAULT DERIVING DO TCLASS TINSTANCE -%token REPEAT ALL -%token VAROP VARID NUMLIT CHARLIT STRINGLIT -%token CONOP CONID +%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 MODULETOK IMPORT HIDING QUALIFIED ASMOD -%token EXPORT INTERFACE REQUIRES UNSAFE +%token TMODULE IMPORT HIDING QUALIFIED ASMOD +%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE +%token INSTIMPORT DYNAMIC CCALL STDKALL +%token UTL UTR UUUSAGE %% -/*- Top level script/module structure: ------------------------------------*/ +/*- 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");} ; + /*- GHC interface file parsing: -------------------------------------------*/ /* Reading in an interface file is surprisingly like reading @@ -107,296 +119,352 @@ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} * have to read in expressions. */ -iface : INTERFACE ifaceName NUMLIT checkVersion ifaceDecls { $$ = gc5(NIL); } +/*- Top-level interface files -----------------------------*/ +iface : INTERFACE STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls + {$$ = gc8(ap(I_INTERFACE, + zpair($3,$8))); } | INTERFACE error {syntaxError("interface file");} ; -ifaceName : CONID {openGHCIface(textOf($1)); $$ = gc1(NIL);} +ifTopDecls: {$$=gc0(NIL);} + | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));} ; -ifaceDecls: {$$=gc0(NIL);} - | ifaceDecl ';' ifaceDecls {$$=gc3(cons($1,$2));} - ; +ifTopDecl + : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList + {$$=gc7(ap(I_IMPORT,zpair($2,$7))); } -/* We use ifaceData in data decls so as to include () */ -ifaceDecl : IMPORT CONID NUMLIT { extern String scriptFile; - String fileName = findPathname(scriptFile,textToStr(textOf($2))); - addGHCImport(intOf($1),textOf($2),fileName); - $$ = gc3(NIL); - } - | EXPORT CONID ifaceEntities {} - | REQUIRES STRINGLIT { extern String scriptFile; - String fileName = findPathname(scriptFile,textToStr(textOf($2))); - loadSharedLib(fileName); - $$ = gc2(NIL); - } - | INFIXL optdigit op { fixDefn(LEFT_ASS,$1,$2,$3); $$ = gc3(NIL); } - | INFIXR optdigit op { fixDefn(RIGHT_ASS,$1,$2,$3); $$ = gc3(NIL); } - | INFIX optdigit op { fixDefn(NON_ASS,$1,$2,$3); $$ = gc3(NIL); } - | TINSTANCE ifaceQuant ifaceClass '=' ifaceVar { addGHCInstance(intOf($1),$2,$3,textOf($5)); $$ = gc5(NIL); } - | NUMLIT TYPE ifaceTCName ifaceTVBndrs '=' ifaceType { addGHCSynonym(intOf($2),$3,$4,$6); $$ = gc6(NIL); } - | NUMLIT DATA ifaceData ifaceTVBndrs ifaceConstrs ifaceSels { addGHCDataDecl(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); } - | NUMLIT TNEWTYPE ifaceTCName ifaceTVBndrs ifaceNewTypeConstr { addGHCNewType(intOf($2),$3,$4,$5); $$ = gc5(NIL); } - | NUMLIT TCLASS ifaceDeclContext ifaceTCName ifaceTVBndrs ifaceCSigs { addGHCClass(intOf($2),$3,$4,$5,$6); $$ = gc6(NIL); } - | NUMLIT ifaceVar COCO ifaceType { addGHCVar(intOf($3),textOf($2),$4); $$ = gc4(NIL); } - | error { syntaxError("interface declaration"); } - ; + | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));} -checkVersion - : NUMLIT { $$ = gc1(NIL); } - ; + | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));} -ifaceSels /* [(VarId,Type)] */ - : { $$ = gc0(NIL); } - | WHERE '{' ifaceSels1 '}' { $$ = gc4($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)));} -ifaceSels1 /* [(VarId,Type)] */ - : ifaceSel { $$ = gc1(singleton($1)); } - | ifaceSel ';' ifaceSels1 { $$ = gc3(cons($1,$3)); } - ; + | TINSTANCE ifCtxInst ifInstHdL '=' ifVar + {$$=gc5(ap(I_INSTANCE, + z5ble($1,$2,$3,$5,NIL)));} -ifaceSel /* (VarId,Type) */ - : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); } - ; + | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType + {$$=gc6(ap(I_TYPE, + z4ble($2,$3,$4,$6)));} -ifaceCSigs /* [(VarId,Type)] */ - : { $$ = gc0(NIL); } - | WHERE '{' ifaceCSigs1 '}' { $$ = gc4($3); } - ; + | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs + {$$=gc6(ap(I_DATA, + z5ble($2,$3,$4,$5,$6)));} + + | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr + {$$=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 + {$$=gc4(ap(I_VALUE, + ztriple($3,$2,$4)));} -ifaceCSigs1 /* [(VarId,Type)] */ - : ifaceCSig { $$ = gc1(singleton($1)); } - | ifaceCSig ';' ifaceCSigs1 { $$ = gc3(cons($1,$3)); } + | error { syntaxError( + "interface declaration"); } ; -ifaceCSig /* (VarId,Type) */ - : ifaceVarName COCO ifaceType { $$ = gc3(pair($1,$3)); } - | ifaceVarName '=' COCO ifaceType { $$ = gc4(pair($1,$4)); } /* has default method */ + +/*- 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); } ; -ifaceConstrs /* [(ConId,[VarId],Type)] */ - : { $$ = gc0(NIL); } - | '=' ifaceConstrs1 { $$ = gc2($2); } + + +/*- Interface variable and constructor ids ----------------*/ +ifTyvar : VARID {$$ = $1;} + ; +ifVar : VARID {$$ = gc1($1);} + ; +ifCon : CONID {$$ = gc1($1);} ; -ifaceConstrs1 /* [(ConId,[VarId],Type)] */ - : ifaceConstr { $$ = gc1(singleton($1)); } - | ifaceConstr '|' ifaceConstrs1 { $$ = gc3(cons($1,$3)); } +ifVarCon : VARID {$$ = gc1($1);} + | CONID {$$ = gc1($1);} ; -/* We use ifaceData so as to include () */ -ifaceConstr /* (ConId,[VarId],Type) */ - : ifaceData COCO ifaceType { $$ = gc3(triple($1,NIL,$3)); } - | ifaceData '{' ifaceVarNames1 '}' COCO ifaceType { $$ = gc6(triple($1,$3,$6)); } +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); } + ; + -ifaceNewTypeConstr /* (ConId,Type) */ - : { $$ = gc0(NIL); } - | '=' ifaceDataName COCO ifaceType { $$ = gc4(pair($2,$4)); } +/*- Interface contexts ------------------------------------*/ +ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */ + : ALL ifForall IMPLIES {$$=gc3($2);} + | {$$=gc0(NIL);} + ; +ifInstHd /* { Class aType } :: ((ConId, Type)) */ + : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP, + zpair($2,$3)));} ; -ifaceQuant /* Maybe ([(VarId,Kind)],[(ConId, [Type])]) */ - : { $$ = gc0(NIL); } - | ALL ifaceForall ifaceContext IMPLIES { $$ = gc4(pair($2,$3)); } +ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */ + : ifInstHd ARROW ifInstHdL {$$=gc3(ap($1,$3));} + | ifInstHd {$$=gc1($1);} ; -ifaceType - : ALL ifaceForall ifaceContext IMPLIES ifaceType { $$ = gc5(ap(POLYTYPE,triple($2,$3,$5))); } - | ifaceBType ARROW ifaceType { $$ = gc3(fn($1,$3)); } - | ifaceBType { $$ = gc1($1); } - ; - -ifaceForall /* [(VarId,Kind)] */ - : '[' ifaceTVBndrs ']' { $$ = gc3($2); } - ; - -ifaceDeclContext /* [(ConId, [Type])] */ - : { $$ = gc0(NIL); } - | '{' ifaceContextList1 '}' IMPLIES { $$ = gc4($2); } +ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */ + : ifCtxDeclT IMPLIES { $$ = gc2($1); } + | { $$ = gc0(NIL); } ; - -ifaceContext /* [(ConId, [Type])] */ - : { $$ = gc0(NIL); } - | '{' ifaceContextList1 '}' { $$ = gc3($2); } +ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ + : { $$ = gc0(NIL); } + | '{' ifCtxDeclL '}' { $$ = gc3($2); } ; - -ifaceContextList1 /* [(ConId, [Type])] */ - : ifaceClass { $$ = gc1(singleton($1)); } - | ifaceClass ',' ifaceContextList1 { $$ = gc3(cons($1,$3)); } + +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(zpair($1,$2));} + ; + -ifaceClass /* (ConId, [Type]) */ - : ifaceQTCName ifaceATypes { $$ = gc2(pair($1,$2)); } - ; +/*- Interface data declarations - constructor lists -------*/ +/* 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. +*/ -ifaceTypes2 - : ifaceType ',' ifaceType { $$ = gc3(doubleton($1,$3)); } - | ifaceType ',' ifaceTypes2 { $$ = gc3(cons($1,$3)); } +ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */ + : {$$ = gc0(NIL);} + | '=' ifConstrL {$$ = gc2($2);} ; - -ifaceBType - : ifaceAType { $$ = gc1($1); } - | ifaceBType ifaceAType { $$ = gc2(ap($1,$2)); } +ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */ + : ifConstr {$$ = gc1(singleton($1));} + | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));} ; - -ifaceAType - : ifaceQTCName { $$ = gc1($1); } - | ifaceTVName { $$ = gc1($1); } - | '(' ')' { $$ = gc2(conPreludeUnit); } - | '(' ifaceTypes2 ')' { $$ = gc3(buildTuple($2)); } - | '[' ifaceType ']' { $$ = gc3(ap(conPreludeList,$2));} - | '{' ifaceQTCName ifaceATypes '}' { $$ = gc4(ap(DICTAP,pair($2,$3))); } - | '(' ifaceType ')' { $$ = gc3($2); } +ifConstr /* ((ConId,[((Type,VarId,Int))])) */ + : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));} + | ifConData '{' ifDataNamedFieldL '}' + {$$ = gc4(zpair($1,$3));} ; - -ifaceATypes - : { $$ = gc0(NIL); } - | ifaceAType ifaceATypes { $$ = gc2(cons($1,$2)); } +ifDataAnonFieldL /* [((Type,VarId,Int))] */ + : {$$=gc0(NIL);} + | ifDataAnonField ifDataAnonFieldL + {$$=gc2(cons($1,$2));} ; - -ifaceEntities - : { $$ = gc0(NIL); } - | ifaceEntity ifaceEntities { $$ = gc2(cons($1,$2)); } +ifDataNamedFieldL /* [((Type,VarId,Int))] */ + : {$$=gc0(NIL);} + | ifDataNamedField {$$=gc1(cons($1,NIL));} + | ifDataNamedField ',' ifDataNamedFieldL + {$$=gc3(cons($1,$3));} ; - -ifaceEntity - : ifaceEntityOcc {} - | ifaceEntityOcc ifaceStuffInside {} -| ifaceEntityOcc '|' ifaceStuffInside {} /* exporting datacons but not tycon */ +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)));} ; - -ifaceEntityOcc - : ifaceVar { $$ = gc1($1); } - | ifaceData { $$ = gc1($1); } - | ARROW { $$ = gc3(typeArrow); } - | '(' ARROW ')' { $$ = gc3(typeArrow); } /* why allow both? */ +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)));} ; -ifaceStuffInside - : '{' ifaceValOccs '}' { $$ = gc1($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(zpair($1,$3)); } + | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); } + /* has default method */ ; -ifaceValOccs - : ifaceValOcc { $$ = gc1(singleton($1)); } - | ifaceValOcc ifaceValOccs { $$ = gc2(cons($1,$2)); } +/*- Interface newtype declararions ------------------------*/ +ifNewTypeConstr /* ((ConId,Type)) */ + : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); } ; -ifaceValOcc - : ifaceVar {$$ = gc1($1); } - | ifaceData {$$ = gc1($1); } - ; -ifaceVar : VARID {$$ = gc1($1); } - | VAROP {$$ = gc1($1); } - | '!' {$$ = gc1(varBang); } - | '.' {$$ = gc1(varDot); } - | '-' {$$ = gc1(varMinus);} +/*- 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); } ; -ifaceData /* ConId | QualConId */ - : CONID {$$ = gc1($1);} - | CONOP {$$ = gc1($1);} - | '(' ')' {$$ = gc2(conPreludeUnit);} - | '[' ']' {$$ = gc2(conPreludeList);} +ifTypeL2 /* [Type], 2 or more */ + : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); } + | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); } ; -ifaceVarName /* VarId */ - : ifaceVar { $$ = gc1($1); } +ifTypeL /* [Type], 0 or more */ + : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); } + | ifType { $$ = gc1(singleton($1)); } + | { $$ = gc0(NIL); } ; -ifaceDataName /* ConId|QualConId */ - : ifaceData { $$ = gc1($1); } +ifBType : ifAType { $$ = gc1($1); } + | ifBType ifAType { $$ = gc2(ap($1,$2)); } + | UUUSAGE ifUsage ifAType { $$ = gc3($3); } ; -ifaceVarNames1 /* [VarId] */ - : ifaceVarName { $$ = gc1(singleton($1)); } - | ifaceVarName ifaceVarNames1 { $$ = gc2(cons($1,$2)); } +ifAType : ifQTCName { $$ = gc1($1); } + | ifTyvar { $$ = gc1($1); } + | '(' ')' { $$ = gc2(typeUnit); } + | '(' 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)); } ; -ifaceTVName /* VarId */ - : VARID { $$ = gc1($1); } - ; -ifaceTVBndrs /* [(VarId,Kind)] */ - : { $$ = gc0(NIL); } - | ifaceTVBndr ifaceTVBndrs { $$ = gc2(cons($1,$2)); } +/*- KW's usage stuff --------------------------------------*/ +ifUsage : '-' { $$ = gc1(NIL); } + | '!' { $$ = gc1(NIL); } + | ifVar { $$ = gc1(NIL); } ; -ifaceTVBndr /* (VarId,Kind) */ - : ifaceTVName { $$ = gc1(pair($1,STAR)); } - | ifaceTVName COCO ifaceAKind { $$ = gc3(pair($1,$3)); } - ; -ifaceKind - : ifaceAKind { $$ = gc1($1); } - | ifaceAKind ARROW ifaceKind { $$ = gc3(fn($1,$3)); } +/*- Interface kinds ---------------------------------------*/ +ifKindedTyvarL /* [((VarId,Kind))] */ + : { $$ = gc0(NIL); } + | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); } + ; +ifKindedTyvar /* ((VarId,Kind)) */ + : ifTyvar { $$ = gc1(zpair($1,STAR)); } + | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); } + ; +ifKind : ifAKind { $$ = gc1($1); } + | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); } ; +ifAKind : VAROP { $$ = gc1(STAR); } + /* should be '*' */ + | '(' ifKind ')' { $$ = gc3($2); } + ; + -ifaceAKind - : VAROP { $$ = gc1(STAR); } /* should be '*' */ - | '(' ifaceKind ')' { $$ = gc1($1); } +/*- Interface version/export/import stuff -----------------*/ +ifEntities + : { $$ = gc0(NIL); } + | ifEntity ifEntities { $$ = gc2(cons($1,$2)); } + ; +ifEntity + : ifEntityOcc {$$=gc1($1);} + | ifEntityOcc ifStuffInside {$$=gc2(zpair($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)); } ; -ifaceTCName - : CONID { $$ = gc1($1); } - | CONOP { $$ = gc1($1); } - | '(' ARROW ')' { $$ = gc3(typeArrow); } - | '[' ']' { $$ = gc1(conPreludeList); } - ; +ifVersionList + : {$$=gc0(NIL);} + | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));} + | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));} + ; -ifaceQTCName - : ifaceTCName { $$ = gc1($1); } - | QCONID { $$ = gc1($1); } - | QCONOP { $$ = gc1($1); } - ; -/*- Haskell module header/import parsing: ---------------------------------*/ +/*- Haskell module header/import parsing: ----------------------------------- + * 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); - } - | MODULETOK modname expspec WHERE '{' modBody end - {setExportList($3); $$ = gc7($6);} - | MODULETOK 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);} +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");} ; -modname : CONID {startModule($1); $$ = gc1(NIL);} + +modname : CONID {$$ = gc1($1);} ; modid : CONID {$$ = gc1($1);} - | STRINGLIT { extern String scriptFile; - String modName = findPathname(scriptFile,textToStr(textOf($1))); - if (modName) { /* fillin pathname if known */ - $$ = mkStr(findText(modName)); - } else { - $$ = $1; - } - } ; modBody : topDecls {$$ = gc1($1);} - | fixDecls ';' topDecls {$$ = gc3($3);} - | impDecls chase {$$ = gc2(NIL);} - | impDecls ';' chase topDecls {$$ = gc4($4);} - | impDecls ';' chase fixDecls ';' topDecls - {$$ = gc6($6);} + | 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);} ; @@ -406,59 +474,48 @@ exports : exports ',' export {$$ = gc3(cons($3,$1));} /* The qcon should be qconid. * Relaxing the rule lets us explicitly export (:) from the Prelude. */ -export : qvar {$$ = gc1($1);} - | qcon {$$ = gc1($1);} - | qcon2 '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));} - | qcon2 '(' qnames ')' {$$ = gc4(pair($1,$3));} - | MODULETOK modid {$$ = gc2(ap(MODULEENT,$2));} +export : qvar {$$ = $1;} + | qcon {$$ = $1;} + | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));} + | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));} + | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));} ; qnames : /* empty */ {$$ = gc0(NIL);} | ',' {$$ = gc1(NIL);} - | qnames1 {$$ = gc1($1);} + | qnames1 {$$ = $1;} | qnames1 ',' {$$ = gc2($1);} ; qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));} | qname {$$ = gc1(singleton($1));} ; -qname : qvar {$$ = gc1($1);} - | qcon {$$ = gc1($1);} - | '(' ')' {$$ = gc2(conPreludeUnit);} - | '[' ']' {$$ = gc2(conPreludeList);} - ; -qcon2 : '(' ')' {$$ = gc2(conPreludeUnit);} - | '[' ']' {$$ = gc2(conPreludeList);} - | qconid {$$ = gc1($1);} +qname : qvar {$$ = $1;} + | qcon {$$ = $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);} @@ -467,112 +524,107 @@ impspec : /* empty */ {$$ = gc0(DOTDOT);} ; imports : /* empty */ {$$ = gc0(NIL);} | ',' {$$ = gc1(NIL);} - | imports1 {$$ = gc1($1);} + | imports1 {$$ = $1;} | imports1 ',' {$$ = gc2($1);} ; imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));} | import {$$ = gc1(singleton($1));} ; -import : var {$$ = gc1($1);} - | CONID {$$ = gc1($1);} +import : var {$$ = $1;} + | CONID {$$ = $1;} | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));} | CONID '(' names ')' {$$ = gc4(pair($1,$3));} ; names : /* empty */ {$$ = gc0(NIL);} | ',' {$$ = gc1(NIL);} - | names1 {$$ = gc1($1);} + | names1 {$$ = $1;} | names1 ',' {$$ = gc2($1);} ; names1 : names1 ',' name {$$ = gc3(cons($3,$1));} | name {$$ = gc1(singleton($1));} ; -name : var {$$ = gc1($1);} - | con {$$ = gc1($1);} - ; - -/*- Fixity declarations: --------------------------------------------------*/ - -fixDecls : fixDecls ';' fixDecl {$$ = gc2(NIL);} - | fixDecl {$$ = gc0(NIL);} - ; -fixDecl : INFIXL optdigit ops {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;} - | INFIXR optdigit ops {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;} - | INFIX optdigit ops {fixDefn(NON_ASS,$1,$2,$3); sp-=3;} - ; -optdigit : NUMLIT {$$ = gc1(checkPrec($1));} - | /* empty */ {$$ = gc0(mkInt(DEF_PREC));} - ; -ops : ops ',' op {$$ = gc3(cons($3,$1));} - | op {$$ = gc1(cons($1,NIL));} +name : var {$$ = $1;} + | con {$$ = $1;} ; /*- Top-level declarations: -----------------------------------------------*/ -topDecls : /* empty */ {$$ = gc0(NIL);} - | ';' {$$ = gc1(NIL);} - | topDecls1 {$$ = gc1($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(ap(QUAL,pair($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(ap(QUAL,pair($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(ap(QUAL,pair($2,$6)), - $7),NEWTYPE);} - ; -tyLhs : tyLhs varid1 {$$ = gc2(ap($1,$2));} - | CONID {$$ = gc1($1);} - | '[' type ']' {$$ = gc3(ap(conList,$2));} - | '(' ')' {$$ = gc2(conUnit);} - | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} + {$$=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));} + | CONID {$$ = $1;} | error {syntaxError("type defn lhs");} ; invars : invars ',' invar {$$ = gc3(cons($3,$1));} | invar {$$ = gc1(cons($1,NIL));} ; -invar : qvar COCO topType {$$ = gc3(sigdecl($2,singleton($1), - $3));} - | qvar {$$ = gc1($1);} +invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1), + $3));} + | var {$$ = $1;} ; -constrs : constrs '|' constr {$$ = gc3(cons($3,$1));} - | constr {$$ = gc1(cons($1,NIL));} +constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));} + | pconstr {$$ = gc1(cons($1,NIL));} ; -constr : '!' btype conop bbtype {$$ = gc4(ap2($3,bang($2),$4));} - | btype1 conop bbtype {$$ = gc3(ap2($2,$1,$3));} - | btype2 conop bbtype {$$ = gc3(ap2($2,$1,$3));} - | bpolyType conop bbtype {$$ = gc3(ap2($2,$1,$3));} - | btype2 {$$ = gc1($1);} - | btype3 {$$ = gc1($1);} - | btype4 {$$ = gc1($1);} +pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE, + pair(rev($2),$4)));} + | qconstr {$$ = $1;} + ; +qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));} + | constr {$$ = $1;} + ; +constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));} + | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));} + | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));} + | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));} + | btype2 {$$ = $1;} + | btype3 {$$ = $1;} + | btype4 {$$ = $1;} | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));} - | '[' ']' {$$ = gc2(conNil);} - | '(' ')' {$$ = gc2(conUnit);} - | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} + | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));} | error {syntaxError("data type definition");} ; btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));} @@ -586,17 +638,17 @@ btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));} | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));} ; bbtype : '!' btype {$$ = gc2(bang($2));} - | btype {$$ = gc1($1);} - | bpolyType {$$ = gc1($1);} + | btype {$$ = $1;} + | bpolyType {$$ = $1;} + ; +nconstr : pconstr {$$ = gc1(singleton($1));} ; fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));} | fieldspec {$$ = gc1(cons($1,NIL));} ; fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));} | vars COCO type {$$ = gc3(pair(rev($1),$3));} - ; -nconstr : con atype {$$ = gc2(singleton(ap($1,$2)));} - | con bpolyType {$$ = gc2(singleton(ap($1,$2)));} + | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));} ; deriving : /* empty */ {$$ = gc0(NIL);} | DERIVING qconid {$$ = gc2(singleton($2));} @@ -611,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;} ; @@ -630,9 +686,12 @@ 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");} ; crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));} | btype2 {$$ = gc1(pair(NIL,checkPred($1)));} @@ -647,43 +706,69 @@ dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));} | type {$$ = gc1(cons($1,NIL));} ; -/*- Type expressions: -----------------------------------------------------*/ - -sigType : context IMPLIES type {$$ = gc3(ap(QUAL,pair($1,$3)));} - | type {$$ = gc1($1);} - ; -topType : context IMPLIES topType1 {$$ = gc3(ap(QUAL,pair($1,$3)));} - | topType1 {$$ = gc1($1);} +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));} | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));} | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));} - | btype {$$ = gc1($1);} + | btype {$$ = $1;} ; -polyType : ALL varid1s '.' sigType {$$ = gc4(ap(POLYTYPE, +polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE, pair(rev($2),$4)));} - | bpolyType {$$ = gc1($1);} + | context IMPLIES type {$$ = gc3(qualify($1,$3));} + | bpolyType {$$ = $1;} ; bpolyType : '(' polyType ')' {$$ = gc3($2);} ; -varid1s : varid1s ',' varid1 {$$ = gc3(cons($3,$1));} - | varid1 {$$ = gc1(cons($1,NIL));} +varids : varids varid {$$ = gc2(cons($2,$1));} + | varid {$$ = gc1(singleton($1));} + ; +sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));} + | type {$$ = $1;} ; context : '(' ')' {$$ = gc2(NIL);} | btype2 {$$ = gc1(singleton(checkPred($1)));} | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));} - | '(' btypes2 ')' {$$ = gc3(checkContext($2));} + | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));} /*#if TREX*/ | lacks {$$ = gc1(singleton($1));} - | '(' lacks1 ')' {$$ = gc3(checkContext($2));} + | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));} ; -lacks : varid1 '\\' varid1 { +lacks : varid '\\' varid { #if TREX $$ = gc3(ap(mkExt(textOf($3)),$1)); #else 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));} @@ -693,35 +778,34 @@ lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));} ; /*#endif*/ -type : type1 {$$ = gc1($1);} - | btype2 {$$ = gc1($1);} +type : type1 {$$ = $1;} + | btype2 {$$ = $1;} ; -type1 : btype1 {$$ = gc1($1);} +type1 : btype1 {$$ = $1;} | btype1 ARROW type {$$ = gc3(fn($1,$3));} | btype2 ARROW type {$$ = gc3(fn($1,$3));} | error {syntaxError("type expression");} ; -btype : btype1 {$$ = gc1($1);} - | btype2 {$$ = gc1($1);} +btype : btype1 {$$ = $1;} + | btype2 {$$ = $1;} ; btype1 : btype1 atype {$$ = gc2(ap($1,$2));} - | atype1 {$$ = gc1($1);} + | atype1 {$$ = $1;} ; btype2 : btype2 atype {$$ = gc2(ap($1,$2));} - | qconid {$$ = gc1($1);} + | qconid {$$ = $1;} ; -atype : atype1 {$$ = gc1($1);} - | qconid {$$ = gc1($1);} +atype : atype1 {$$ = $1;} + | qconid {$$ = $1;} ; -atype1 : varid1 {$$ = gc1($1);} - | '(' ')' {$$ = gc2(conPreludeUnit);} +atype1 : varid {$$ = $1;} + | '(' ')' {$$ = gc2(typeUnit);} | '(' ARROW ')' {$$ = gc3(typeArrow);} | '(' type1 ')' {$$ = gc3($2);} | '(' btype2 ')' {$$ = gc3($2);} | '(' tupCommas ')' {$$ = gc3($2);} | '(' btypes2 ')' {$$ = gc3(buildTuple($2));} | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} -/*#if TREX*/ | '(' tfields ')' { #if TREX $$ = gc3(revOnto($2,typeNoRow)); @@ -729,14 +813,17 @@ atype1 : varid1 {$$ = gc1($1);} noTREX("a type"); #endif } - | '(' tfields '|' type ')' {$$ = gc5(revOnto($2,$4));} -/*#endif*/ - | '[' type ']' {$$ = gc3(ap(conPreludeList,$2));} - | '[' ']' {$$ = gc2(conPreludeList);} - | '_' {$$ = gc1(inventVar());} - ; -tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));} - | ',' {$$ = gc1(mkTuple(2));} + | '(' tfields '|' type ')' { +#if TREX + $$ = gc5(revOnto($2,$4)); +#else + noTREX("a type"); +#endif + } + | '[' type ']' {$$ = gc3(ap(typeList,$2));} + | '[' ']' {$$ = gc2(typeList);} + | '_' {h98DoesntSupport(row,"anonymous type variables"); + $$ = gc1(inventVar());} ; btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));} | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));} @@ -750,161 +837,248 @@ 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*/ /*- Value declarations: ---------------------------------------------------*/ -decllist : '{' decls end {$$ = gc3($2);} +gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));} + | INFIXN error {syntaxError("fixity decl");} + | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));} + | INFIXL error {syntaxError("fixity decl");} + | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));} + | INFIXR error {syntaxError("fixity decl");} + | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));} + | vars COCO error {syntaxError("type signature");} + ; +optDigit : NUMLIT {$$ = gc1(checkPrec($1));} + | /* empty */ {$$ = gc0(mkInt(DEF_PREC));} + ; +ops : ops ',' op {$$ = gc3(cons($3,$1));} + | op {$$ = gc1(singleton($1));} + ; +vars : vars ',' var {$$ = gc3(cons($3,$1));} + | var {$$ = gc1(singleton($1));} + ; +decls : '{' decls0 end {$$ = gc3($2);} + | '{' decls1 end {$$ = gc3($2);} ; -decls : /* empty */ {$$ = gc0(NIL);} - | ';' {$$ = gc1(NIL);} - | decls1 {$$ = gc1($1);} +decls0 : /* empty */ {$$ = gc0(NIL);} + | decls0 ';' {$$ = gc2($1);} | decls1 ';' {$$ = gc2($1);} ; -decls1 : decls1 ';' decl {$$ = gc3(cons($3,$1));} - | decl {$$ = gc1(cons($1,NIL));} +decls1 : decls0 decl {$$ = gc2(cons($2,$1));} ; -/* Sneakily using qvars to eliminate a conflict... */ -decl : qvars COCO topType {$$ = gc3(sigdecl($2,$1,$3));} - | opExp rhs {$$ = gc2(pair($1,$2));} +decl : gendecl {$$ = $1;} + | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));} + | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND, + pair($1,ap(RSIGN, + ap($4,$3)))));} + | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));} + ; +funlhs : funlhs0 {$$ = $1;} + | funlhs1 {$$ = $1;} + | npk {$$ = $1;} + ; +funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));} + | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));} + | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));} + | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));} + | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));} + ; +funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));} + | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));} + | '(' npk ')' apat {$$ = gc4(ap($2,$4));} + | var apat {$$ = gc2(ap($1,$2));} + | funlhs1 apat {$$ = gc2(ap($1,$2));} ; rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));} | error {syntaxError("declaration");} ; rhs1 : '=' exp {$$ = gc2(pair($1,$2));} - | gdefs {$$ = gc1(grded(rev($1)));} - ; -wherePart : WHERE decllist {$$ = gc2($2);} - | /*empty*/ {$$ = gc0(NIL);} + | gdrhs {$$ = gc1(grded(rev($1)));} ; -gdefs : gdefs gdef {$$ = gc2(cons($2,$1));} - | gdef {$$ = gc1(cons($1,NIL));} +gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));} + | gddef {$$ = gc1(singleton($1));} ; -gdef : '|' exp '=' exp {$$ = gc4(pair($3,pair($2,$4)));} +gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));} ; -vars : vars ',' var {$$ = gc3(cons($3,$1));} - | var {$$ = gc1(cons($1,NIL));} - ; -qvars : qvars ',' qvar {$$ = gc3(cons($3,$1));} - | qvar {$$ = gc1(cons($1,NIL));} +wherePart : /* empty */ {$$ = gc0(NIL);} + | WHERE decls {$$ = gc2($2);} ; +/*- Patterns: -------------------------------------------------------------*/ - -var : varid {$$ = gc1($1);} - | '(' '-' ')' {$$ = gc3(varMinus);} +pat : npk {$$ = $1;} + | pat_npk {$$ = $1;} ; -varid : varid1 {$$ = gc1($1);} - | '(' VAROP ')' {$$ = gc3($2);} - | '(' '!' ')' {$$ = gc3(varBang);} - | '(' '.' ')' {$$ = gc3(varDot);} +pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));} + | pat0 {$$ = $1;} ; -varid1 : VARID {$$ = gc1($1);} - | HIDING {$$ = gc1(varHiding);} - | QUALIFIED {$$ = gc1(varQualified);} - | ASMOD {$$ = gc1(varAsMod);} +npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));} ; -qvar : qvarid {$$ = gc1($1);} - | '(' qvarsym ')' {$$ = gc3($2);} - | '(' '.' ')' {$$ = gc3(varDot);} - | '(' '!' ')' {$$ = gc3(varBang);} - | '(' '-' ')' {$$ = gc3(varMinus);} +pat0 : var {$$ = $1;} + | NUMLIT {$$ = $1;} + | pat0_vI {$$ = $1;} ; -qvarid : varid1 {$$ = gc1($1);} - | QVARID {$$ = gc1($1);} +pat0_INT : var {$$ = $1;} + | pat0_vI {$$ = $1;} ; - -op : varop {$$ = gc1($1);} - | conop {$$ = gc1($1);} - | '-' {$$ = gc1(varMinus);} +pat0_vI : pat10_vI {$$ = $1;} + | infixPat {$$ = gc1(ap(INFIX,$1));} ; -qop : qvarop {$$ = gc1($1);} - | qconop {$$ = gc1($1);} - | '-' {$$ = gc1(varMinus);} +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));} + | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));} + | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));} + | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));} + | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));} + | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} ; - -varop : VAROP {$$ = gc1($1);} - | '!' {$$ = gc1(varBang);} - | '.' {$$ = gc1(varDot);} - | '`' varid1 '`' {$$ = gc3($2);} +pat10 : fpat {$$ = $1;} + | apat {$$ = $1;} ; -qvarop : qvarsym {$$ = gc1($1);} - | '!' {$$ = gc1(varBang);} - | '.' {$$ = gc1(varDot);} - | '`' qvarid '`' {$$ = gc3($2);} +pat10_vI : fpat {$$ = $1;} + | apat_vI {$$ = $1;} ; -qvarsym : VAROP {$$ = gc1($1);} - | QVAROP {$$ = gc1($1);} +fpat : fpat apat {$$ = gc2(ap($1,$2));} + | gcon apat {$$ = gc2(ap($1,$2));} ; - -con : CONID {$$ = gc1($1);} - | '(' CONOP ')' {$$ = gc3($2);} +apat : NUMLIT {$$ = $1;} + | var {$$ = $1;} + | apat_vI {$$ = $1;} ; -qcon : qconid {$$ = gc1($1);} - | '(' qconsym ')' {$$ = gc3($2);} +apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));} + | gcon {$$ = $1;} + | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));} + | CHARLIT {$$ = $1;} + | STRINGLIT {$$ = $1;} + | '_' {$$ = gc1(WILDCARD);} + | '(' pat_npk ')' {$$ = gc3($2);} + | '(' npk ')' {$$ = gc3($2);} + | '(' pats2 ')' {$$ = gc3(buildTuple($2));} + | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));} + | '~' apat {$$ = gc2(ap(LAZYPAT,$2));} +/*#if TREX*/ + | '(' patfields ')' { +#if TREX + $$ = gc3(revOnto($2,nameNoRec)); +#else + $$ = gc3(NIL); +#endif + } + | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));} +/*#endif TREX*/ ; -qconid : CONID {$$ = gc1($1);} - | QCONID {$$ = gc1($1);} +pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));} + | pat ',' pat {$$ = gc3(cons($3,singleton($1)));} ; -qconsym : CONOP {$$ = gc1($1);} - | QCONOP {$$ = gc1($1);} +pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));} + | pat {$$ = gc1(singleton($1));} ; - -conop : CONOP {$$ = gc1($1);} - | '`' CONID '`' {$$ = gc3($2);} +patbinds : /* empty */ {$$ = gc0(NIL);} + | patbinds1 {$$ = gc1(rev($1));} + ; +patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));} + | patbind {$$ = gc1(singleton($1));} + ; +patbind : qvar '=' pat {$$ = gc3(pair($1,$3));} + | var {$$ = $1;} + ; +/*#if TREX*/ +patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));} + | patfield {$$ = gc1(singleton($1));} ; -qconop : qconsym {$$ = gc1($1);} - | '`' qconid '`' {$$ = gc3($2);} +patfield : varid '=' pat { +#if TREX + $$ = gc3(ap(mkExt(textOf($1)),$3)); +#else + noTREX("a pattern"); +#endif + } ; +/*#endif TREX*/ /*- Expressions: ----------------------------------------------------------*/ -exp : exp1 {$$ = gc1($1);} +exp : exp_err {$$ = $1;} | error {syntaxError("expression");} ; -exp1 : opExp COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));} - | opExp {$$ = gc1($1);} +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;} + | exp0b {$$ = $1;} ; -opExp : opExp0 {$$ = gc1(tidyInfix($1));} - | pfxExp {$$ = gc1($1);} +exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));} + | exp10a {$$ = $1;} ; -opExp0 : opExp0 qop '-' pfxExp {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} - | opExp0 qop pfxExp {$$ = gc3(ap2($2,$1,$3));} - | '-' pfxExp {$$ = gc2(ap(NEG,only($2)));} - | pfxExp qop pfxExp {$$ = gc3(ap(ap($2,only($1)),$3));} - | pfxExp qop '-' pfxExp {$$ = gc4(ap(NEG, +exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));} + | exp10b {$$ = $1;} + ; +infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} + | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));} + | '-' exp10a {$$ = gc2(ap(NEG,only($2)));} + | exp10a qop '-' exp10a {$$ = gc4(ap(NEG, + ap(ap($2,only($1)),$4)));} + | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));} + ; +infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} + | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));} + | '-' exp10b {$$ = gc2(ap(NEG,only($2)));} + | exp10a qop '-' exp10b {$$ = gc4(ap(NEG, ap(ap($2,only($1)),$4)));} + | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));} + ; +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;} ; -pfxExp : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, +exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, pair(rev($2), pair($3,$4))));} - | LET decllist IN exp {$$ = gc4(letrec($2,$4));} + | LET decls IN exp {$$ = gc4(letrec($2,$4));} | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));} - | CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));} - | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));} - | appExp {$$ = gc1($1);} + | DLET dbinds IN exp { +#if IPARAM + $$ = gc4(ap(WITHEXP,pair($4,$2))); +#else + noIP("an expression"); +#endif + } ; -pats : pats atomic {$$ = gc2(cons($2,$1));} - | atomic {$$ = gc1(cons($1,NIL));} +pats : pats apat {$$ = gc2(cons($2,$1));} + | apat {$$ = gc1(cons($1,NIL));} ; -appExp : appExp atomic {$$ = gc2(ap($1,$2));} - | atomic {$$ = gc1($1);} +appExp : appExp aexp {$$ = gc2(ap($1,$2));} + | aexp {$$ = $1;} ; -atomic : qvar {$$ = gc1($1);} - | qvar '@' atomic {$$ = gc3(ap(ASPAT,pair($1,$3)));} - | '~' atomic {$$ = gc2(ap(LAZYPAT,$2));} +aexp : qvar {$$ = $1;} + | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));} + | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));} + | IPVARID {$$ = $1;} | '_' {$$ = gc1(WILDCARD);} - | qcon {$$ = gc1($1);} + | gcon {$$ = $1;} | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));} - | atomic '{' fbinds '}' {$$ = gc4(ap(UPDFLDS, + | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS, triple($1,NIL,$3)));} - | '(' ')' {$$ = gc2(conPreludeUnit);} - | NUMLIT {$$ = gc1($1);} - | CHARLIT {$$ = gc1($1);} - | STRINGLIT {$$ = gc1($1);} - | REPEAT {$$ = gc1($1);} + | NUMLIT {$$ = $1;} + | CHARLIT {$$ = $1;} + | STRINGLIT {$$ = $1;} + | REPEAT {$$ = $1;} | '(' exp ')' {$$ = gc3($2);} | '(' exps2 ')' {$$ = gc3(buildTuple($2));} /*#if TREX*/ @@ -916,13 +1090,12 @@ atomic : qvar {$$ = gc1($1);} #endif } | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));} - | RECSELID {$$ = gc1($1);} + | RECSELID {$$ = $1;} /*#endif*/ | '[' list ']' {$$ = gc3($2);} - | '(' pfxExp qop ')' {$$ = gc4(ap($3,$2));} - | '(' qvarop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));} - | '(' qconop atomic ')' {$$ = gc4(ap2(varFlip,$2,$3));} - | '(' tupCommas ')' {$$ = gc3($2);} + | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));} + | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));} + | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));} ; exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));} | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));} @@ -931,7 +1104,7 @@ exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));} vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));} | vfield {$$ = gc1(singleton($1));} ; -vfield : qvarid '=' exp { +vfield : varid '=' exp { #if TREX $$ = gc3(ap(mkExt(textOf($1)),$3)); #else @@ -940,13 +1113,13 @@ vfield : qvarid '=' exp { } ; /*#endif*/ -alts : alts1 {$$ = gc1($1);} +alts : alts1 {$$ = $1;} | alts1 ';' {$$ = gc2($1);} ; alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));} | alt {$$ = gc1(cons($1,NIL));} ; -alt : opExp altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));} +alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));} ; altRhs : guardAlts {$$ = gc1(grded(rev($1)));} | ARROW exp {$$ = gc2(pair($1,$2));} @@ -955,18 +1128,18 @@ altRhs : guardAlts {$$ = gc1(grded(rev($1)));} guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));} | guardAlt {$$ = gc1(cons($1,NIL));} ; -guardAlt : '|' opExp ARROW exp {$$ = gc4(pair($3,pair($2,$4)));} +guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));} ; stmts : stmts1 ';' {$$ = gc2($1);} - | stmts1 {$$ = gc1($1);} + | stmts1 {$$ = $1;} ; stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));} | stmt {$$ = gc1(cons($1,NIL));} ; -stmt : exp1 FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} - | LET decllist {$$ = gc2(ap(QWHERE,$2));} - | IF exp {$$ = gc2(ap(BOOLQUAL,$2));} - | exp1 {$$ = gc1(ap(DOQUAL,$1));} +stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} + | LET decls {$$ = gc2(ap(QWHERE,$2));} +/* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/ + | exp_err {$$ = gc1(ap(DOQUAL,$1));} ; fbinds : /* empty */ {$$ = gc0(NIL);} | fbinds1 {$$ = gc1(rev($1));} @@ -974,38 +1147,134 @@ fbinds : /* empty */ {$$ = gc0(NIL);} fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));} | fbind {$$ = gc1(singleton($1));} ; -fbind : var {$$ = gc1($1);} +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 : /* empty */ {$$ = gc0(conPreludeNil);} - | exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));} +list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));} | exps2 {$$ = gc1(ap(FINLIST,rev($1)));} | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));} - | exp UPTO exp {$$ = gc3(ap2(varEnumFromTo,$1,$3));} - | exp ',' exp UPTO {$$ = gc4(ap2(varEnumFromThen,$1,$3));} - | exp UPTO {$$ = gc2(ap1(varEnumFrom,$1));} - | exp ',' exp UPTO exp {$$ = gc5(ap3(varEnumFromThenTo, - $1,$3,$5));} + | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));} + | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));} + | exp UPTO {$$ = gc2(ap(nameFrom,$1));} + | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo, + $1),$3),$5));} ; quals : quals ',' qual {$$ = gc3(cons($3,$1));} | qual {$$ = gc1(cons($1,NIL));} ; qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} | exp {$$ = gc1(ap(BOOLQUAL,$1));} - | LET decllist {$$ = gc2(ap(QWHERE,$2));} + | LET decls {$$ = gc2(ap(QWHERE,$2));} + ; + +/*- Identifiers and symbols: ----------------------------------------------*/ + +gcon : qcon {$$ = $1;} + | '(' ')' {$$ = gc2(nameUnit);} + | '[' ']' {$$ = gc2(nameNil);} + | '(' tupCommas ')' {$$ = gc3($2);} + ; +tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));} + | ',' {$$ = gc1(mkTuple(2));} + ; +varid : VARID {$$ = $1;} + | HIDING {$$ = gc1(varHiding);} + | QUALIFIED {$$ = gc1(varQualified);} + | ASMOD {$$ = gc1(varAsMod);} + ; +qconid : QCONID {$$ = $1;} + | CONID {$$ = $1;} + ; +var : varid {$$ = $1;} + | '(' VAROP ')' {$$ = gc3($2);} + | '(' '+' ')' {$$ = gc3(varPlus);} + | '(' '-' ')' {$$ = gc3(varMinus);} + | '(' '!' ')' {$$ = gc3(varBang);} + | '(' '.' ')' {$$ = gc3(varDot);} + ; +qvar : QVARID {$$ = $1;} + | '(' QVAROP ')' {$$ = gc3($2);} + | var {$$ = $1;} + ; +con : CONID {$$ = $1;} + | '(' CONOP ')' {$$ = gc3($2);} + ; +qcon : QCONID {$$ = $1;} + | '(' QCONOP ')' {$$ = gc3($2);} + | con {$$ = $1;} + ; +varop : '+' {$$ = gc1(varPlus);} + | '-' {$$ = gc1(varMinus);} + | varop_mipl {$$ = $1;} + ; +varop_mi : '+' {$$ = gc1(varPlus);} + | varop_mipl {$$ = $1;} + ; +varop_pl : '-' {$$ = gc1(varMinus);} + | varop_mipl {$$ = $1;} + ; +varop_mipl: VAROP {$$ = $1;} + | '`' varid '`' {$$ = gc3($2);} + | '!' {$$ = gc1(varBang);} + | '.' {$$ = gc1(varDot);} + ; +qvarop : '-' {$$ = gc1(varMinus);} + | qvarop_mi {$$ = $1;} + ; +qvarop_mi : QVAROP {$$ = $1;} + | '`' QVARID '`' {$$ = gc3($2);} + | varop_mi {$$ = $1;} + ; + +conop : CONOP {$$ = $1;} + | '`' CONID '`' {$$ = gc3($2);} + ; +qconop : QCONOP {$$ = $1;} + | '`' QCONID '`' {$$ = gc3($2);} + | conop {$$ = $1;} + ; +op : varop {$$ = $1;} + | conop {$$ = $1;} + ; +qop : qvarop {$$ = $1;} + | qconop {$$ = $1;} + ; + +/*- Stuff from STG hugs ---------------------------------------------------*/ + +qvarid : varid1 {$$ = gc1($1);} + | QVARID {$$ = gc1($1);} + +varid1 : VARID {$$ = gc1($1);} + | HIDING {$$ = gc1(varHiding);} + | QUALIFIED {$$ = gc1(varQualified);} + | ASMOD {$$ = gc1(varAsMod);} ; /*- 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 : '}' {$$ = gc1($1);} + +end : '}' {$$ = $1;} | error {yyerrok; - if (canUnOffside()) { + if (offsideON && canUnOffside()) { unOffside(); /* insert extra token on stack*/ push(NIL); @@ -1030,7 +1299,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() @@ -1045,7 +1314,7 @@ Cell e; { return e; } -static Void local syntaxError(s) /* report on syntax error */ +static Void local syntaxError(s) /* report on syntax error */ String s; { ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected() EEND; @@ -1062,7 +1331,7 @@ static String local unexpected() { /* find name for unexpected token */ #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer; case INFIXL : keyword("infixl"); case INFIXR : keyword("infixr"); - case INFIX : keyword("infix"); + case INFIXN : keyword("infix"); case FOREIGN : keyword("foreign"); case UNSAFE : keyword("unsafe"); case TINSTANCE : keyword("instance"); @@ -1081,11 +1350,16 @@ static String local unexpected() { /* find name for unexpected token */ case DERIVING : keyword("deriving"); case DEFAULT : keyword("default"); case IMPORT : keyword("import"); - case EXPORT : keyword("export"); - case MODULETOK : keyword("module"); - case INTERFACE : keyword("interface"); - case WILDCARD : keyword("_"); - case ALL : keyword("forall"); + 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 "`->'"; @@ -1097,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 "`]'"; @@ -1115,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 : @@ -1138,59 +1417,35 @@ static String local unexpected() { /* find name for unexpected token */ } } -static Cell local checkPrec(p) /* Check for valid precedence value */ +static Cell local checkPrec(p) /* Check for valid precedence value*/ Cell p; { - if ((!isInt(p) || intOf(p)MAX_PREC) - && (!isBignum(p) || bignumOf(p)MAX_PREC) - ) { + if (!isInt(p) || intOf(p)MAX_PREC) { ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]", MIN_PREC, MAX_PREC EEND; } - if (isBignum(p)) { - return mkInt(bignumOf(p)); - } else { - return p; - } + return p; } -static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators */ -Syntax a; -Cell line; -Cell p; -List ops; { - Int l = intOf(line); - a = mkSyntax(a,intOf(p)); - map2Proc(setSyntax,l,a,ops); -} - -static Void local setSyntax(line,sy,op)/* set syntax of individ. operator */ -Int line; -Syntax sy; -Cell op; { - addSyntax(line,textOf(op),sy); - opDefns = cons(op,opDefns); -} - -static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from list*/ -List tup; { /* [xn,...,x1] */ +static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */ +List tup; { /* list [xn,...,x1] */ Int n = 0; Cell t = tup; Cell x; - do { /* . . */ - x = fst(t); /* / \ / \ */ - fst(t) = snd(t); /* xn . . xn */ - snd(t) = x; /* . ===> . */ - x = t; /* . . */ - t = fun(x); /* . . */ - n++; /* / \ / \ */ - } while (nonNull(t)); /* x1 NIL (n) x1 */ + do { /* . . */ + x = fst(t); /* / \ / \ */ + fst(t) = snd(t); /* xn . . xn */ + snd(t) = x; /* . ===> . */ + x = t; /* . . */ + t = fun(x); /* . . */ + n++; /* / \ / \ */ + } while (nonNull(t)); /* x1 NIL (n) x1 */ fst(x) = mkTuple(n); return tup; } -static List local checkContext(con) /* validate context */ +static List local checkCtxt(con) /* validate context */ Type con; { mapOver(checkPred, con); return con; @@ -1203,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; } @@ -1219,240 +1478,35 @@ 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 c; } + #if !TREX static Void local noTREX(where) String where; { - ERRMSG(row) "Attempt to use Typed Records with Extensions\nwhile parsing %s. This feature is disabled in this build of Hugs.", - where + ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN + ERRTEXT "(TREX is disabled in this build of Hugs)" EEND; } #endif - -/* Expressions involving infix operators or unary minus are parsed as elements - * of the following type: - * - * data OpExp = Only Exp | Neg OpExp | Infix OpExp Op Exp - * - * (The algorithms here do not assume that negation can be applied only once, - * i.e., that - - x is a syntax error, as required by the Haskell report. - * Instead, that restriction is captured by the grammar itself, given above.) - * - * There are rules of precedence and grouping, expressed by two functions: - * - * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R}) - * - * OpExp values are rearranged accordingly when a complete expression has - * been read using a simple shift-reduce parser whose result may be taken - * to be a value of the following type: - * - * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String - * - * The machine on which this parser is based can be defined as follows: - * - * tidy :: OpExp -> [(Op,Exp)] -> Exp - * tidy (Only a) [] = a - * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss - * tidy (Infix a o b) [] = tidy a [(o,b)] - * tidy (Infix a o b) ((p,c):ss) - * | shift o p = tidy a ((o,b):(p,c):ss) - * | red o p = tidy (Infix a o (Apply p b c)) ss - * | ambig o p = Error "ambiguous use of operators" - * tidy (Neg e) [] = tidy (tidyNeg e) [] - * tidy (Neg e) ((o,b):ss) - * | nshift o = tidy (Neg (underNeg o b e)) ss - * | nred o = tidy (tidyNeg e) ((o,b):ss) - * | nambig o = Error "illegal use of negation" - * - * At each stage, the parser can either shift, reduce, accept, or error. - * The transitions when dealing with juxtaposed operators o and p are - * determined by the following rules: - * - * shift o p = (prec o > prec p) - * || (prec o == prec p && assoc o == L && assoc p == L) - * - * red o p = (prec o < prec p) - * || (prec o == prec p && assoc o == R && assoc p == R) - * - * ambig o p = (prec o == prec p) - * && (assoc o == N || assoc p == N || assoc o /= assoc p) - * - * The transitions when dealing with juxtaposed unary minus and infix operators - * are as follows. The precedence of unary minus (infixl 6) is hardwired in - * to these definitions, as it is to the definitions of the Haskell grammar - * in the official report. - * - * nshift o = (prec o > 6) - * nred o = (prec o < 6) || (prec o == 6 && assoc o == L) - * nambig o = prec o == 6 && (assoc o == R || assoc o == N) - * - * An OpExp of the form (Neg e) means negate the last thing in the OpExp e; - * we can force this negation using: - * - * tidyNeg :: OpExp -> OpExp - * tidyNeg (Only e) = Only (Negate e) - * tidyNeg (Infix a o b) = Infix a o (Negate b) - * tidyNeg (Neg e) = tidyNeg (tidyNeg e) - * - * On the other hand, if we want to sneak application of an infix operator - * under a negation, then we use: - * - * underNeg :: Op -> Exp -> OpExp -> OpExp - * underNeg o b (Only e) = Only (Apply o e b) - * underNeg o b (Neg e) = Neg (underNeg o b e) - * underNeg o b (Infix e p f) = Infix e p (Apply o f b) - * - * As a concession to efficiency, we lower the number of calls to syntaxOf - * by keeping track of the values of sye, sys throughout the process. The - * value APPLIC is used to indicate that the syntax value is unknown. - */ - -#define UMINUS_PREC 6 /* Change these settings at your */ -#define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */ - -static Cell local tidyInfix(e) /* convert OpExp to Expr */ -Cell e; { /* :: OpExp */ - Cell s = NIL; /* :: [(Op,Exp)] */ - Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/ - Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/ - - for (;;) - switch (whatIs(e)) { - case ONLY : e = snd(e); - while (nonNull(s)) { - Cell next = arg(fun(s)); - arg(fun(s)) = e; - e = s; - s = next; - } - return e; - - case NEG : if (nonNull(s)) { - - if (sys==APPLIC) { /* calculate sys */ - sys = identSyntax(fun(fun(s))); - if (sys==APPLIC) sys=DEF_OPSYNTAX; - } - - if (precOf(sys)==UMINUS_PREC && /* nambig */ - assocOf(sys)!=UMINUS_ASSOC) { - ERRMSG(row) - "Ambiguous use of unary minus with \"%s\"", - textToStr(textOf(fun(fun(s)))) - EEND; - } - - if (precOf(sys)>UMINUS_PREC) { /* nshift */ - Cell e1 = snd(e); - Cell t = s; - s = arg(fun(s)); - while (whatIs(e1)==NEG) - e1 = snd(e1); - arg(fun(t)) = arg(e1); - arg(e1) = t; - sys = APPLIC; - continue; - } - - } - - /* Intentional fall-thru for nreduce and isNull(s) */ - { Cell prev = e; /* e := tidyNeg e */ - Cell temp = arg(prev); - Int nneg = 1; - for (; whatIs(temp)==NEG; nneg++) { - fun(prev) = varNegate; - prev = temp; - temp = arg(prev); - } - /* These special cases are required for - * pattern matching. - */ - if (isInt(arg(temp))) { /* special cases */ - if (nneg&1) /* for literals */ - arg(temp) = intNegate(arg(temp)); - } - else if (isBignum(arg(temp))) { - if (nneg&1) - arg(temp) = bignumNegate(arg(temp)); - } - else if (isFloat(arg(temp))) { - if (nneg&1) - arg(temp) = floatNegate(arg(temp)); - } - else { - fun(prev) = varNegate; - arg(prev) = arg(temp); - arg(temp) = e; - } - e = temp; - } - continue; - - default : if (isNull(s)) {/* Move operation onto empty stack */ - Cell next = arg(fun(e)); - s = e; - arg(fun(s)) = NIL; - e = next; - sys = sye; - sye = APPLIC; - } - else { /* deal with pair of operators */ - - if (sye==APPLIC) { /* calculate sys and sye */ - sye = identSyntax(fun(fun(e))); - if (sye==APPLIC) sye=DEF_OPSYNTAX; - } - if (sys==APPLIC) { - sys = identSyntax(fun(fun(s))); - if (sys==APPLIC) sys=DEF_OPSYNTAX; - } - - if (precOf(sye)==precOf(sys) && /* ambig */ - (assocOf(sye)!=assocOf(sys) || - assocOf(sye)==NON_ASS)) { - ERRMSG(row) - "Ambiguous use of operator \"%s\" with \"%s\"", - textToStr(textOf(fun(fun(e)))), - textToStr(textOf(fun(fun(s)))) - EEND; - } - - if (precOf(sye)>precOf(sys) || /* shift */ - (precOf(sye)==precOf(sys) && - assocOf(sye)==LEFT_ASS && - assocOf(sys)==LEFT_ASS)) { - Cell next = arg(fun(e)); - arg(fun(e)) = s; - s = e; - e = next; - sys = sye; - sye = APPLIC; - } - else { /* reduce */ - Cell next = arg(fun(s)); - arg(fun(s)) = arg(e); - arg(e) = s; - s = next; - sys = APPLIC; - /* sye unchanged */ - } - } - continue; - } +#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 /*-------------------------------------------------------------------------*/