* 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.5 $
- * $Date: 1999/04/27 10:06:58 $
+ * $Revision: 1.21 $
+ * $Date: 2000/01/05 18:05:34 $
* ------------------------------------------------------------------------*/
%{
#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 exportSelf() singleton(ap(MODULEENT, \
+ mkCon(module(currentModule).text)))
#define yyerror(s) /* errors handled elsewhere */
#define YYSTYPE Cell
static Void local syntaxError Args((String));
static String local unexpected Args((Void));
static Cell local checkPrec Args((Cell));
+static Void local fixDefn Args((Syntax,Cell,Cell,List));
static Cell local buildTuple Args((List));
-static List local checkContext Args((List));
+static List local checkCtxt Args((List));
static Cell local checkPred Args((Cell));
static Pair local checkDo Args((List));
static Cell local checkTyLhs Args((Cell));
#if !TREX
static Void local noTREX Args((String));
#endif
+#if !IPARAM
+static Void local noIP Args((String));
+#endif
/* For the purposes of reasonably portable garbage collection, it is
* necessary to simulate the YACC stack on the Hugs stack to keep
%}
-%token EXPR SCRIPT
+%token EXPR CONTEXT SCRIPT
%token CASEXP OF DATA TYPE IF
%token THEN ELSE WHERE LET IN
%token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
%token DEFAULT DERIVING DO TCLASS TINSTANCE
+/*#if IPARAM*/
+%token WITH DLET
+/*#endif*/
%token REPEAT ALL NUMLIT CHARLIT STRINGLIT
%token VAROP VARID CONOP CONID
%token QVAROP QVARID QCONOP QCONID
/*#if TREX*/
-%token RECSELID
+%token RECSELID IPVARID
/*#endif*/
%token COCO '=' UPTO '@' '\\'
%token '|' '-' FROM ARROW '~'
%token '!' IMPLIES '(' ',' ')'
%token '[' ';' ']' '`' '.'
%token TMODULE IMPORT HIDING QUALIFIED ASMOD
-%token EXPORT UNSAFE
+%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
+%token INSTIMPORT DYNAMIC CCALL 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");}
;
+
+/*- 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 ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
+ {$$ = gc7(ap(I_INTERFACE,
+ zpair($2,$7))); }
+ | INTERFACE error {syntaxError("interface file");}
+ ;
+
+ifTopDecls: {$$=gc0(NIL);}
+ | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
+ ;
+
+ifTopDecl
+ : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList
+ {$$=gc6(ap(I_IMPORT,zpair($2,$6))); }
+
+ | 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);}
+ ;
+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(fn($1,$3)); }
+ ;
+ifAKind : VAROP { $$ = gc1(STAR); }
+ /* should be '*' */
+ | '(' ifKind ')' { $$ = gc3($2); }
+ ;
+
+
+/*- Interface version/export/import stuff -----------------*/
+ifEntities
+ : { $$ = gc0(NIL); }
+ | ifEntity ifEntities { $$ = gc2(cons($1,$2)); }
+ ;
+ifEntity
+ : ifEntityOcc {$$=gc1($1);}
+ | ifEntityOcc ifStuffInside {$$=gc2(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
* We use the 1.2 header because it breaks much less pre-module code.
*/
topModule : startMain begin modBody end {
- setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
+ setExportList(singleton(
+ ap(MODULEENT,
+ mkCon(module(currentModule).text)
+ )));
$$ = gc3($3);
}
| TMODULE modname expspec WHERE '{' modBody end
;
modid : CONID {$$ = $1;}
| STRINGLIT { extern String scriptFile;
- String modName = findPathname(scriptFile,textToStr(textOf($1)));
- if (modName) { /* fillin pathname if known */
+ String modName
+ = findPathname(scriptFile,
+ textToStr(textOf($1)));
+ if (modName) {
+ /* fillin pathname if known */
$$ = mkStr(findText(modName));
} else {
$$ = $1;
| TYPE error {syntaxError("type definition");}
| DATA btype2 '=' constrs deriving
{defTycon(5,$3,checkTyLhs($2),
- ap(rev($4),$5),DATATYPE);}
+ ap(rev($4),$5),DATATYPE);}
| DATA context IMPLIES tyLhs '=' constrs deriving
{defTycon(7,$5,$4,
ap(qualify($2,rev($6)),
| 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
+ {foreignImport($1,$3,NIL,$6,$8); sp-=8;}
+ | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
+ {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;}
+ | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
+ {foreignExport($1,$3,$4,$5,$7); sp-=7;}
;
-callconv : var {$$ = gc1(NIL); /* ignored */ }
+callconv : CCALL {$$ = gc1(textCcall);}
+ | STDKALL {$$ = gc1(textStdcall);}
+ | /* empty */ {$$ = gc0(NIL);}
;
ext_loc : STRINGLIT {$$ = $1;}
;
/*- Class declarations: ---------------------------------------------------*/
-topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
+topDecl : TCLASS crule fds wherePart {classDefn(intOf($1),$2,$4,$3); sp-=4;}
| TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
| DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
| TCLASS error {syntaxError("class declaration");}
| 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;}
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);
}
- return 0; /* NOTREACHED */
+ 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; {
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