* included in the distribution.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.12 $
- * $Date: 1999/10/26 17:27:37 $
+ * $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 Args((String));
+static Void local noIP ( String );
#endif
/* For the purposes of reasonably portable garbage collection, it is
#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 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 '[' ';' ']' '`' '.'
%token TMODULE IMPORT HIDING QUALIFIED ASMOD
%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
-%token INSTIMPORT DYNAMIC CCALL STDCALL
+%token INSTIMPORT DYNAMIC CCALL STDKALL
+%token UTL UTR UUUSAGE
%%
/*- Top level script/module structure -------------------------------------*/
-start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
- | CONTEXT context {inputContext = $2; sp-=1;}
- | SCRIPT topModule {valDefns = $2; sp-=1;}
- | INTERFACE iface {sp-=1;}
- | error {syntaxError("input");}
+start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
+ | CONTEXT context {inputContext = $2; sp-=1;}
+ | SCRIPT topModule {drop(); push($2);}
+ | INTERFACE iface {sp-=1;}
+ | error {syntaxError("input");}
;
*/
/*- 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);}
-
- | UUEXPORT CONID ifEntities { addGHCExports($2,$3);
- $$=gc3(NIL);}
-
- | NUMLIT INFIXL optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- LEFT_ASS,$3)); }
- | NUMLIT INFIXR optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- RIGHT_ASS,$3)); }
- | NUMLIT INFIXN optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- NON_ASS,$3)); }
-
- | TINSTANCE ifCtxInst ifInstHd '=' ifVar
- { addGHCInstance(intOf($1),$2,$3,
- textOf($5));
- $$ = gc5(NIL); }
+ifTopDecl
+ : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList
+ {$$=gc7(ap(I_IMPORT,zpair($2,$7))); }
+
+ | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
+
+ | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
+
+ | NUMLIT INFIXL optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(LEFT_ASS),$4)));}
+ | NUMLIT INFIXR optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(RIGHT_ASS),$4)));}
+ | NUMLIT INFIXN optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(NON_ASS),$4)));}
+
+ | TINSTANCE ifCtxInst ifInstHdL '=' ifVar
+ {$$=gc5(ap(I_INSTANCE,
+ z5ble($1,$2,$3,$5,NIL)));}
+
| NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
- { addGHCSynonym(intOf($2),$3,$4,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_TYPE,
+ z4ble($2,$3,$4,$6)));}
| NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
- { addGHCDataDecl(intOf($2),
- $3,$4,$5,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_DATA,
+ z5ble($2,$3,$4,$5,$6)));}
| NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
- { addGHCNewType(intOf($2),
- $3,$4,$5,$6);
- $$ = gc6(NIL); }
- | NUMLIT TCLASS ifCtxDecl ifCon ifTyvar ifCmeths
- { addGHCClass(intOf($2),$3,$4,$5,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_NEWTYPE,
+ z5ble($2,$3,$4,$5,$6)));}
+
+ | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
+ {$$=gc6(ap(I_CLASS,
+ z5ble($2,$3,$4,
+ singleton($5),$6)));}
+
| NUMLIT ifVar COCO ifType
- { addGHCVar(intOf($3),textOf($2),$4);
- $$ = gc4(NIL); }
+ {$$=gc4(ap(I_VALUE,
+ ztriple($3,$2,$4)));}
+
| error { syntaxError(
"interface declaration"); }
;
+/*- Top-level misc interface stuff ------------------------*/
+ifOrphans : '!' {$$=gc1(NIL);}
+ | {$$=gc0(NIL);}
+ifIsBoot : '@' {$$=gc1(NIL);}
+ | {$$=gc0(NIL);}
+ ;
+ifOptCOCO : COCO {$$=gc1(NIL);}
+ | {$$=gc0(NIL);}
+ ;
+ifCheckVersion
+ : NUMLIT {$$ = gc1(NIL); }
+ ;
+
+
+
/*- Interface variable and constructor ids ----------------*/
ifTyvar : VARID {$$ = $1;}
;
;
ifCon : CONID {$$ = gc1($1);}
;
+
+ifVarCon : VARID {$$ = gc1($1);}
+ | CONID {$$ = gc1($1);}
+ ;
+
ifQCon : CONID {$$ = gc1($1);}
| QCONID {$$ = 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)); }
;
| 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 '*' */
;
ifEntity
: ifEntityOcc {$$=gc1($1);}
- | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));}
+ | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));}
;
ifEntityOcc
: ifVar { $$ = gc1($1); }
| ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
| ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
;
-version_list_junk
- : {$$=gc0(NIL);}
- | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
- | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
+
+ifVersionList
+ : {$$=gc0(NIL);}
+ | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
+ | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
;
/*- Haskell module header/import parsing: -----------------------------------
-
- * Syntax for Haskell modules (module headers and imports) is parsed but
- * most of it is ignored. However, module names in import declarations
- * are used, of course, if import chasing is turned on.
+ * Module chasing is now totally different from Classic Hugs98. We parse
+ * the entire syntax tree. Subsequent passes over the tree collect and
+ * chase imports; we no longer attempt to do so whilst parsing.
*-------------------------------------------------------------------------*/
/* In Haskell 1.2, the default module header was "module Main where"
* In 1.3, this changed to "module Main(main) where".
* We use the 1.2 header because it breaks much less pre-module code.
+ * STG Hugs, 15 March 00: disallow default headers (pro tem).
*/
-topModule : startMain begin modBody end {
- setExportList(singleton(
- ap(MODULEENT,
- mkCon(module(currentModule).text)
- )));
- $$ = gc3($3);
- }
- | TMODULE modname expspec WHERE '{' modBody end
- {setExportList($3); $$ = gc7($6);}
+topModule : TMODULE modname expspec WHERE '{' modBody end
+ {$$=gc7(ap(M_MODULE,
+ ztriple($2,$3,$6)));}
+ | TMODULE modname WHERE '{' modBody end
+ {$$=gc6(ap(M_MODULE,
+ ztriple(
+ $2,
+ singleton(ap(MODULEENT,$2)),
+ $5)));}
+
+ | begin modBody end {ConId fakeNm = mkCon(module(
+ moduleBeingParsed).text);
+ $$ = gc2(ap(M_MODULE,
+ ztriple(fakeNm,
+ singleton(ap(MODULEENT,fakeNm)),
+ $2)));}
+
| TMODULE error {syntaxError("module definition");}
;
-/* To implement the Haskell module system, we have to keep track of the
- * current module. We rely on the use of LALR parsing to ensure that this
- * side effect happens before any declarations within the module.
- */
-startMain : /* empty */ {startModule(conMain);
- $$ = gc0(NIL);}
- ;
-modname : CONID {startModule($1); $$ = gc1(NIL);}
- ;
-modid : CONID {$$ = $1;}
- | STRINGLIT { extern String scriptFile;
- String modName
- = findPathname(scriptFile,
- textToStr(textOf($1)));
- if (modName) {
- /* fillin pathname if known */
- $$ = mkStr(findText(modName));
- } else {
- $$ = $1;
- }
- }
+
+modname : CONID {$$ = gc1($1);}
+ ;
+modid : CONID {$$ = gc1($1);}
;
-modBody : topDecls {$$ = $1;}
- | impDecls chase {$$ = gc2(NIL);}
- | impDecls ';' chase topDecls {$$ = gc4($4);}
+modBody : topDecls {$$ = gc1($1);}
+ | impDecls {$$ = gc1($1);}
+ | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));}
;
/*- Exports: --------------------------------------------------------------*/
-expspec : /* empty */ {$$ = gc0(exportSelf());}
- | '(' ')' {$$ = gc2(NIL);}
+expspec : '(' ')' {$$ = gc2(NIL);}
| '(' exports ')' {$$ = gc3($2);}
| '(' exports ',' ')' {$$ = gc4($2);}
;
/*- 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);}
/*- 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));}
/*- Processing definitions of primitives ----------------------------------*/
-topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
- {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;}
+topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type
+ {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));}
+ | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
+ {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));}
| FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
- {foreignExport($1,$3,$4,$5,$7); sp-=7;}
+ {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));}
;
callconv : CCALL {$$ = gc1(textCcall);}
- | STDCALL {$$ = gc1(textStdcall);}
+ | STDKALL {$$ = gc1(textStdcall);}
| /* empty */ {$$ = gc0(NIL);}
;
ext_loc : STRINGLIT {$$ = $1;}
/*- Class declarations: ---------------------------------------------------*/
-topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;}
- | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
- | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
+topDecl : TCLASS crule fds wherePart {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));}
+ | TINSTANCE irule wherePart {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));}
+ | DEFAULT '(' dtypes ')' {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));}
| TCLASS error {syntaxError("class declaration");}
| TINSTANCE error {syntaxError("instance declaration");}
| DEFAULT error {syntaxError("default declaration");}
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
;
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,
begin : error {yyerrok;
if (offsideON) goOffside(startColumn);}
;
- /* deal with trailing semicolon */
+
end : '}' {$$ = $1;}
| error {yyerrok;
if (offsideON && canUnOffside()) {
return tup;
}
-static List local checkContext(con) /* validate context */
+static List local checkCtxt(con) /* validate context */
Type con; {
mapOver(checkPred, con);
return con;
projects / ghc-hetmet.git / blobdiff