* 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.13 $
+ * $Date: 1999/11/17 16:57:42 $
* ------------------------------------------------------------------------*/
%{
#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 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 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");}
;
+
+/*- 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 ifName NUMLIT checkVersion WHERE ifDecls
+ {$$ = gc6(NIL); }
+ | 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); }
+ ;
+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); }
+ | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
+ { addGHCSynonym(intOf($2),$3,$4,$6);
+ $$ = gc6(NIL); }
+
+ | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
+ { addGHCDataDecl(intOf($2),
+ $3,$4,$5,$6);
+ $$ = gc6(NIL); }
+
+ | 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); }
+ | NUMLIT ifVar COCO ifType
+ { addGHCVar(intOf($3),textOf($2),$4);
+ $$ = gc4(NIL); }
+ | error { syntaxError(
+ "interface declaration"); }
+ ;
+
+
+/*- Interface variable and constructor ids ----------------*/
+ifTyvar : VARID {$$ = $1;}
+ ;
+ifVar : VARID {$$ = gc1($1);}
+ ;
+ifCon : 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] {M.C1 a, M.C2 b} => */
+ /* :: [(QConId, VarId)] */
+ : ALL ifForall ifCtxDecl {$$=gc3($3);}
+ | ALL ifForall IMPLIES {$$=gc3(NIL);}
+ | {$$=gc0(NIL);}
+ ;
+ifInstHd /* { Class aType } :: (ConId, Type) */
+ : '{' ifCon ifAType '}' {$$=gc4(pair($2,$3));}
+ ;
+
+ifCtxDecl /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
+ : { $$ = gc0(NIL); }
+ | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); }
+ ;
+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));}
+ ;
+
+
+/*- Interface data declarations - constructor lists -------*/
+ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text)],NIL)] */
+ : {$$ = gc0(NIL);}
+ | '=' ifConstrL {$$ = gc2($2);}
+ ;
+ifConstrL /* [(ConId,[(Type,Text)],NIL)] */
+ : ifConstr {$$ = gc1(singleton($1));}
+ | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
+ ;
+ifConstr /* (ConId,[(Type,Text)],NIL) */
+ : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));}
+ | ifConData '{' ifDataNamedFieldL '}'
+ {$$ = gc4(triple($1,$3,NIL));}
+ ;
+ifDataAnonFieldL /* [(Type,Text)] */
+ : {$$=gc0(NIL);}
+ | ifDataAnonField ifDataAnonFieldL
+ {$$=gc2(cons($1,$2));}
+ ;
+ifDataNamedFieldL /* [(Type,Text)] */
+ : {$$=gc0(NIL);}
+ | ifDataNamedField {$$=gc1(cons($1,NIL));}
+ | ifDataNamedField ',' ifDataNamedFieldL
+ {$$=gc3(cons($1,$3));}
+ ;
+ifDataAnonField /* (Type,Text) */
+ : ifAType {$$=gc1(pair($1,NIL));}
+ ;
+ifDataNamedField /* (Type,Text) */
+ : VARID COCO ifAType {$$=gc3(pair($3,$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(pair($1,$3)); }
+ | ifVar '=' COCO ifType { $$ = gc4(pair($1,$4)); }
+ /* has default method */
+ ;
+
+
+/*- Interface newtype declararions ------------------------*/
+ifNewTypeConstr /* (ConId,Type) */
+ : '=' ifCon ifAType { $$ = gc3(pair($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); }
+ ;
+ifTypes2 : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); }
+ | ifType ',' ifTypes2 { $$ = gc3(cons($1,$3)); }
+ ;
+ifBType : ifAType { $$ = gc1($1); }
+ | ifBType ifAType { $$ = gc2(ap($1,$2)); }
+ ;
+ifAType : ifQTCName { $$ = gc1($1); }
+ | ifTyvar { $$ = gc1($1); }
+ | '(' ')' { $$ = gc2(typeUnit); }
+ | '(' ifTypes2 ')' { $$ = gc3(buildTuple($2)); }
+ | '[' ifType ']' { $$ = gc3(ap(typeList,$2));}
+ | '{' ifQTCName ifATypes '}' { $$ = gc4(ap(DICTAP,
+ pair($2,$3))); }
+ | '(' ifType ')' { $$ = gc3($2); }
+ ;
+ifATypes : { $$ = gc0(NIL); }
+ | ifAType ifATypes { $$ = gc2(cons($1,$2)); }
+ ;
+
+
+/*- Interface kinds ---------------------------------------*/
+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)); }
+ ;
+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(pair($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)); }
+ ;
+version_list_junk
+ : {$$=gc0(NIL);}
+ | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
+ | CONID NUMLIT version_list_junk {$$=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.
* 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;}
+ {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)));}
/*- 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
/*-------------------------------------------------------------------------*/