* 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.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)
-#if IGNORE_MODULES
-#define exportSelf() NIL
-#else
-#define exportSelf() singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
-#endif
#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 Cell local buildTuple Args((List));
-static List local checkContext Args((List));
-static Cell local checkPred Args((Cell));
-static Pair local checkDo Args((List));
-static Cell local checkTyLhs Args((Cell));
+static Cell local gcShadow ( Int,Cell );
+static Void local syntaxError ( String );
+static String local unexpected ( Void );
+static Cell local checkPrec ( Cell );
+static Void local fixDefn ( Syntax,Cell,Cell,List );
+static Cell local buildTuple ( List );
+static List local checkCtxt ( List );
+static Cell local checkPred ( Cell );
+static Pair local checkDo ( List );
+static Cell local checkTyLhs ( Cell );
#if !TREX
-static Void local noTREX Args((String));
+static Void local noTREX ( String );
+#endif
+#if !IPARAM
+static Void local noIP ( String );
#endif
/* For the purposes of reasonably portable garbage collection, it is
#define gc5(e) gcShadow(5,e)
#define gc6(e) gcShadow(6,e)
#define gc7(e) gcShadow(7,e)
+#define gc8(e) gcShadow(8,e)
+#define gc9(e) gcShadow(9,e)
%}
-%token EXPR SCRIPT
+%token EXPR CONTEXT SCRIPT
%token CASEXP OF DATA TYPE IF
%token THEN ELSE WHERE LET IN
%token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
%token DEFAULT DERIVING DO TCLASS TINSTANCE
+%token MDO
+/*#if IPARAM*/
+%token WITH DLET
+/*#endif*/
%token REPEAT ALL NUMLIT CHARLIT STRINGLIT
%token VAROP VARID CONOP CONID
%token QVAROP QVARID QCONOP QCONID
/*#if TREX*/
-%token RECSELID
+%token RECSELID IPVARID
/*#endif*/
%token COCO '=' UPTO '@' '\\'
%token '|' '-' FROM ARROW '~'
%token '!' IMPLIES '(' ',' ')'
%token '[' ';' ']' '`' '.'
%token TMODULE IMPORT HIDING QUALIFIED ASMOD
-%token EXPORT UNSAFE
+%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
+%token INSTIMPORT DYNAMIC CCALL STDKALL
+%token UTL UTR UUUSAGE
%%
/*- Top level script/module structure -------------------------------------*/
-start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
- | SCRIPT topModule {valDefns = $2; sp-=1;}
- | 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
+ * 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 STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
+ {$$ = gc8(ap(I_INTERFACE,
+ zpair($3,$8))); }
+ | INTERFACE error {syntaxError("interface file");}
+ ;
+
+ifTopDecls: {$$=gc0(NIL);}
+ | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
+ ;
+
+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
+ {$$=gc6(ap(I_TYPE,
+ z4ble($2,$3,$4,$6)));}
+
+ | 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)));}
+
+ | 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;}
+ ;
+ifVar : VARID {$$ = gc1($1);}
+ ;
+ifCon : CONID {$$ = gc1($1);}
+ ;
+
+ifVarCon : VARID {$$ = gc1($1);}
+ | 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] => :: [((VarId,Kind))] */
+ : ALL ifForall IMPLIES {$$=gc3($2);}
+ | {$$=gc0(NIL);}
+ ;
+ifInstHd /* { Class aType } :: ((ConId, Type)) */
+ : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
+ zpair($2,$3)));}
+ ;
+
+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(zpair($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.
+*/
+
+ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
+ : {$$ = gc0(NIL);}
+ | '=' ifConstrL {$$ = gc2($2);}
+ ;
+ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
+ : ifConstr {$$ = gc1(singleton($1));}
+ | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
+ ;
+ifConstr /* ((ConId,[((Type,VarId,Int))])) */
+ : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
+ | ifConData '{' ifDataNamedFieldL '}'
+ {$$ = gc4(zpair($1,$3));}
+ ;
+ifDataAnonFieldL /* [((Type,VarId,Int))] */
+ : {$$=gc0(NIL);}
+ | ifDataAnonField ifDataAnonFieldL
+ {$$=gc2(cons($1,$2));}
+ ;
+ifDataNamedFieldL /* [((Type,VarId,Int))] */
+ : {$$=gc0(NIL);}
+ | ifDataNamedField {$$=gc1(cons($1,NIL));}
+ | ifDataNamedField ',' ifDataNamedFieldL
+ {$$=gc3(cons($1,$3));}
+ ;
+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,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))] */
+ : { $$ = 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 */
+ ;
+
+
+/*- Interface newtype declararions ------------------------*/
+ifNewTypeConstr /* ((ConId,Type)) */
+ : '=' ifCon ifAType { $$ = gc3(zpair($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); }
+ ;
+
+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); }
+ | '(' 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)); }
+ ;
+
+
+/*- KW's usage stuff --------------------------------------*/
+ifUsage : '-' { $$ = gc1(NIL); }
+ | '!' { $$ = gc1(NIL); }
+ | ifVar { $$ = gc1(NIL); }
+ ;
+
+
+/*- 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); }
+ ;
+
+
+/*- 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)); }
;
+ifVersionList
+ : {$$=gc0(NIL);}
+ | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
+ | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
+ ;
+
+
/*- Haskell module header/import parsing: -----------------------------------
- * Syntax for Haskell modules (module headers and imports) is parsed but
- * most of it is ignored. However, module names in import declarations
- * are used, of course, if import chasing is turned on.
+ * Module chasing is now totally different from Classic Hugs98. We parse
+ * the entire syntax tree. Subsequent passes over the tree collect and
+ * chase imports; we no longer attempt to do so whilst parsing.
*-------------------------------------------------------------------------*/
/* In Haskell 1.2, the default module header was "module Main where"
* In 1.3, this changed to "module Main(main) where".
* We use the 1.2 header because it breaks much less pre-module code.
+ * STG Hugs, 15 March 00: disallow default headers (pro tem).
*/
-topModule : startMain begin modBody end {
- setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
- $$ = gc3($3);
- }
- | TMODULE modname expspec WHERE '{' modBody end
- {setExportList($3); $$ = gc7($6);}
+topModule : TMODULE modname expspec WHERE '{' modBody end
+ {$$=gc7(ap(M_MODULE,
+ ztriple($2,$3,$6)));}
+ | TMODULE modname WHERE '{' modBody end
+ {$$=gc6(ap(M_MODULE,
+ ztriple(
+ $2,
+ singleton(ap(MODULEENT,$2)),
+ $5)));}
+
+ | begin modBody end {ConId fakeNm = mkCon(module(
+ moduleBeingParsed).text);
+ $$ = gc2(ap(M_MODULE,
+ ztriple(fakeNm,
+ singleton(ap(MODULEENT,fakeNm)),
+ $2)));}
+
| TMODULE error {syntaxError("module definition");}
;
-/* To implement the Haskell module system, we have to keep track of the
- * current module. We rely on the use of LALR parsing to ensure that this
- * side effect happens before any declarations within the module.
- */
-startMain : /* empty */ {startModule(conMain);
- $$ = gc0(NIL);}
- ;
-modname : CONID {startModule($1); $$ = gc1(NIL);}
- ;
-modid : CONID {$$ = $1;}
- | STRINGLIT { extern String scriptFile;
- String modName = findPathname(scriptFile,textToStr(textOf($1)));
- if (modName) { /* fillin pathname if known */
- $$ = mkStr(findText(modName));
- } else {
- $$ = $1;
- }
- }
+
+modname : CONID {$$ = gc1($1);}
;
-modBody : topDecls {$$ = $1;}
- | impDecls chase {$$ = gc2(NIL);}
- | impDecls ';' chase topDecls {$$ = gc4($4);}
+modid : CONID {$$ = gc1($1);}
+ ;
+modBody : topDecls {$$ = gc1($1);}
+ | impDecls {$$ = gc1($1);}
+ | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));}
;
/*- Exports: --------------------------------------------------------------*/
-expspec : /* empty */ {$$ = gc0(exportSelf());}
- | '(' ')' {$$ = gc2(NIL);}
+expspec : '(' ')' {$$ = gc2(NIL);}
| '(' exports ')' {$$ = gc3($2);}
| '(' exports ',' ')' {$$ = gc4($2);}
;
/*- 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));}
| 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));}
/*- 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;}
;
/*- 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");}
| 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));}
;
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));}
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
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));}
| '(' tupCommas ')' {$$ = gc3($2);}
| '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
| '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
-/*#if TREX*/
| '(' tfields ')' {
#if TREX
$$ = gc3(revOnto($2,typeNoRow));
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)));}
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*/
| 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));}
| 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;}
;
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,
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));}
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)));}
| 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)));}
/*- 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);
* 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()
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 "`->'";
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 "`]'";
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 :
return tup;
}
-static List local checkContext(con) /* validate context */
+static List local checkCtxt(con) /* validate context */
Type con; {
mapOver(checkPred, con);
return con;
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;
}
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; {
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
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff