* 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.6 $
- * $Date: 1999/06/07 17:22:41 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/17 16:57:42 $
* ------------------------------------------------------------------------*/
%{
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 INTERFACE REQUIRES UNSAFE INSTIMPORT
+%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
+%token INSTIMPORT DYNAMIC CCALL STDCALL
%%
/*- Top level script/module structure -------------------------------------*/
start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
+ | CONTEXT context {inputContext = $2; sp-=1;}
| SCRIPT topModule {valDefns = $2; sp-=1;}
| INTERFACE iface {sp-=1;}
| error {syntaxError("input");}
| INSTIMPORT CONID {$$=gc2(NIL);}
- | EXPORT CONID ifEntities { addGHCExports($2,$3);
+ | UUEXPORT CONID ifEntities { addGHCExports($2,$3);
$$=gc3(NIL);}
| NUMLIT INFIXL optDigit varid_or_conid
;
ifEntity
: ifEntityOcc {$$=gc1($1);}
- | ifEntityOcc ifStuffInside {$$=gc2($1);}
- | ifEntityOcc '|' ifStuffInside {$$=gc3($1);}
- /* exporting datacons but not tycon */
+ | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));}
;
ifEntityOcc
: ifVar { $$ = gc1($1); }
: '{' ifValOccs '}' { $$ = gc3($2); }
;
ifValOccs
- : ifValOcc { $$ = gc1(singleton($1)); }
- | ifValOcc ifValOccs { $$ = gc2(cons($1,$2)); }
- ;
-ifValOcc
- : ifVar {$$ = gc1($1); }
- | ifCon {$$ = gc1($1); }
+ : { $$ = gc0(NIL); }
+ | ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
+ | ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
;
version_list_junk
: {$$=gc0(NIL);}
/*- Processing definitions of primitives ----------------------------------*/
topDecl : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
- {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
- | FOREIGN EXPORT callconv ext_name qvarid COCO type
- {foreignExport($1,$4,$5,$7); sp-=7;}
+ {foreignImport($1,$3,pair($4,$5),$7,$9); sp-=9;}
+ | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
+ {foreignExport($1,$3,$4,$5,$7); sp-=7;}
;
-callconv : var {$$ = gc1(NIL); /* ignored */ }
+callconv : CCALL {$$ = gc1(textCcall);}
+ | STDCALL {$$ = gc1(textStdcall);}
+ | /* empty */ {$$ = gc0(NIL);}
;
ext_loc : STRINGLIT {$$ = $1;}
;
/*- 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)));}
case DEFAULT : keyword("default");
case IMPORT : keyword("import");
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 "`->'";
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