[project @ 2000-03-22 18:14:22 by sewardj]
[ghc-hetmet.git] / ghc / interpreter / parser.y
1
2 /* --------------------------------------------------------------------------
3  * Hugs parser (included as part of input.c)
4  *
5  * Expect 6 shift/reduce conflicts when passing this grammar through yacc,
6  * but don't worry; they should all be resolved in an appropriate manner.
7  *
8  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
9  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
10  * Technology, 1994-1999, All rights reserved.  It is distributed as
11  * free software under the license in the file "License", which is
12  * included in the distribution.
13  *
14  * $RCSfile: parser.y,v $
15  * $Revision: 1.26 $
16  * $Date: 2000/03/22 18:14:22 $
17  * ------------------------------------------------------------------------*/
18
19 %{
20 #ifndef lint
21 #define lint
22 #endif
23 #define sigdecl(l,vs,t)          ap(SIGDECL,triple(l,vs,t))
24 #define fixdecl(l,ops,a,p)       ap(FIXDECL,\
25                                     triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
26 #define grded(gs)                ap(GUARDED,gs)
27 #define only(t)                  ap(ONLY,t)
28 #define letrec(bs,e)             (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
29 #define qualify(ps,t)            (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
30 #define yyerror(s)               /* errors handled elsewhere */
31 #define YYSTYPE                  Cell
32
33 static Cell   local gcShadow     ( Int,Cell );
34 static Void   local syntaxError  ( String );
35 static String local unexpected   ( Void );
36 static Cell   local checkPrec    ( Cell );
37 static Void   local fixDefn      ( Syntax,Cell,Cell,List );
38 static Cell   local buildTuple   ( List );
39 static List   local checkCtxt    ( List );
40 static Cell   local checkPred    ( Cell );
41 static Pair   local checkDo      ( List );
42 static Cell   local checkTyLhs   ( Cell );
43 #if !TREX
44 static Void   local noTREX       ( String );
45 #endif
46 #if !IPARAM
47 static Void   local noIP         ( String );
48 #endif
49
50 /* For the purposes of reasonably portable garbage collection, it is
51  * necessary to simulate the YACC stack on the Hugs stack to keep
52  * track of all intermediate constructs.  The lexical analyser
53  * pushes a token onto the stack for each token that is found, with
54  * these elements being removed as reduce actions are performed,
55  * taking account of look-ahead tokens as described by gcShadow()
56  * below.
57  *
58  * Of the non-terminals used below, only start, topDecl & begin
59  * do not leave any values on the Hugs stack.  The same is true for the
60  * terminals EXPR and SCRIPT.  At the end of a successful parse, there
61  * should only be one element left on the stack, containing the result
62  * of the parse.
63  */
64
65 #define gc0(e)                  gcShadow(0,e)
66 #define gc1(e)                  gcShadow(1,e)
67 #define gc2(e)                  gcShadow(2,e)
68 #define gc3(e)                  gcShadow(3,e)
69 #define gc4(e)                  gcShadow(4,e)
70 #define gc5(e)                  gcShadow(5,e)
71 #define gc6(e)                  gcShadow(6,e)
72 #define gc7(e)                  gcShadow(7,e)
73 #define gc8(e)                  gcShadow(8,e)
74 #define gc9(e)                  gcShadow(9,e)
75
76 %}
77
78 %token EXPR       CONTEXT    SCRIPT
79 %token CASEXP     OF         DATA       TYPE       IF
80 %token THEN       ELSE       WHERE      LET        IN
81 %token INFIXN     INFIXL     INFIXR     FOREIGN    TNEWTYPE
82 %token DEFAULT    DERIVING   DO         TCLASS     TINSTANCE
83 /*#if IPARAM*/
84 %token WITH DLET
85 /*#endif*/
86 %token REPEAT     ALL        NUMLIT     CHARLIT    STRINGLIT
87 %token VAROP      VARID      CONOP      CONID
88 %token QVAROP     QVARID     QCONOP     QCONID
89 /*#if TREX*/
90 %token RECSELID   IPVARID
91 /*#endif*/
92 %token COCO       '='        UPTO       '@'        '\\'
93 %token '|'        '-'        FROM       ARROW      '~'
94 %token '!'        IMPLIES    '('        ','        ')'
95 %token '['        ';'        ']'        '`'        '.'
96 %token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD
97 %token EXPORT     UUEXPORT   INTERFACE  REQUIRES   UNSAFE     
98 %token INSTIMPORT DYNAMIC    CCALL      STDKALL
99 %token UTL        UTR        UUUSAGE
100 %token PRIVILEGED
101
102 %%
103 /*- Top level script/module structure -------------------------------------*/
104
105 start     : EXPR exp wherePart      {inputExpr    = letrec($3,$2); sp-=2;}
106           | CONTEXT context         {inputContext = $2;            sp-=1;}
107           | SCRIPT topModule        {drop(); push($2);}
108           | INTERFACE iface         {sp-=1;}
109           | error                   {syntaxError("input");}
110           ;
111
112
113 /*- GHC interface file parsing: -------------------------------------------*/
114
115 /* Reading in an interface file is surprisingly like reading
116  * a normal Haskell module: we read in a bunch of declarations,
117  * construct symbol table entries, etc.  The "only" differences
118  * are that there's no syntactic sugar to deal with and we don't
119  * have to read in expressions.
120  */
121
122 /*- Top-level interface files -----------------------------*/
123 iface     : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls 
124                                         {$$ = gc7(ap(I_INTERFACE, 
125                                                      zpair($2,$7))); }
126           | INTERFACE error             {syntaxError("interface file");}
127           ;
128
129 ifTopDecls:                             {$$=gc0(NIL);}
130           | ifTopDecl ';' ifTopDecls    {$$=gc3(cons($1,$3));}
131           ;
132
133 ifTopDecl    
134           : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList
135                                         {$$=gc7(ap(I_IMPORT,zpair($2,$7))); }
136
137           | INSTIMPORT CONID            {$$=gc2(ap(I_INSTIMPORT,NIL));}
138
139           | UUEXPORT CONID ifEntities   {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
140
141           | NUMLIT INFIXL optDigit ifVarCon
142                                         {$$=gc4(ap(I_FIXDECL,
143                                             ztriple($3,mkInt(LEFT_ASS),$4)));}
144           | NUMLIT INFIXR optDigit ifVarCon
145                                         {$$=gc4(ap(I_FIXDECL,
146                                             ztriple($3,mkInt(RIGHT_ASS),$4)));}
147           | NUMLIT INFIXN optDigit ifVarCon
148                                         {$$=gc4(ap(I_FIXDECL,
149                                             ztriple($3,mkInt(NON_ASS),$4)));}
150
151           | TINSTANCE ifCtxInst ifInstHdL '=' ifVar
152                                         {$$=gc5(ap(I_INSTANCE,
153                                                    z5ble($1,$2,$3,$5,NIL)));}
154
155           | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
156                                         {$$=gc6(ap(I_TYPE,
157                                                    z4ble($2,$3,$4,$6)));}
158
159           | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
160                                         {$$=gc6(ap(I_DATA,
161                                                    z5ble($2,$3,$4,$5,$6)));}
162
163           | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
164                                         {$$=gc6(ap(I_NEWTYPE,
165                                                    z5ble($2,$3,$4,$5,$6)));}
166
167           | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
168                                         {$$=gc6(ap(I_CLASS,
169                                                    z5ble($2,$3,$4,
170                                                          singleton($5),$6)));}
171
172           | NUMLIT ifVar COCO ifType
173                                         {$$=gc4(ap(I_VALUE,
174                                                    ztriple($3,$2,$4)));}
175
176           | error                       { syntaxError(
177                                              "interface declaration"); }
178           ;
179
180
181 /*- Top-level misc interface stuff ------------------------*/
182 ifOrphans : '!'                         {$$=gc1(NIL);}
183           |                             {$$=gc0(NIL);}
184 ifIsBoot  : '@'                         {$$=gc1(NIL);}
185           |                             {$$=gc0(NIL);}
186           ;
187 ifOptCOCO : COCO                        {$$=gc1(NIL);}
188           |                             {$$=gc0(NIL);}
189           ;
190 ifCheckVersion
191           : NUMLIT                      {$$ = gc1(NIL); }
192           ;
193
194
195
196 /*- Interface variable and constructor ids ----------------*/
197 ifTyvar   : VARID                       {$$ = $1;}
198           ;
199 ifVar     : VARID                       {$$ = gc1($1);}
200           ;
201 ifCon     : CONID                       {$$ = gc1($1);}
202           ;
203
204 ifVarCon  : VARID                       {$$ = gc1($1);}
205           | CONID                       {$$ = gc1($1);}
206           ;
207
208 ifQCon    : CONID                       {$$ = gc1($1);}
209           | QCONID                      {$$ = gc1($1);}
210           ;
211 ifConData : ifCon                       {$$ = gc1($1);}
212           | '(' ')'                     {$$ = gc2(typeUnit);}
213           | '[' ']'                     {$$ = gc2(typeList);}
214           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
215           ;
216 ifTCName  : CONID                       { $$ = gc1($1); }
217           | CONOP                       { $$ = gc1($1); }
218           | '(' ARROW ')'               { $$ = gc3(typeArrow); }
219           | '[' ']'                     { $$ = gc1(typeList);  }
220           ; 
221 ifQTCName : ifTCName                    { $$ = gc1($1); }
222           | QCONID                      { $$ = gc1($1); }
223           | QCONOP                      { $$ = gc1($1); }
224           ; 
225
226
227 /*- Interface contexts ------------------------------------*/
228 ifCtxInst /* __forall [a b] =>     :: [((VarId,Kind))] */
229           : ALL ifForall IMPLIES        {$$=gc3($2);}
230           |                             {$$=gc0(NIL);}
231           ;
232 ifInstHd /* { Class aType }    :: ((ConId, Type)) */
233           : '{' ifQCon ifAType '}'      {$$=gc4(ap(DICTAP,
234                                                 zpair($2,$3)));}
235           ;
236
237 ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
238           : ifInstHd ARROW ifInstHdL    {$$=gc3(ap($1,$3));}
239           | ifInstHd                    {$$=gc1($1);}
240           ;
241
242 ifCtxDecl /* {M.C1 a, C2 b} =>  :: [(QConId, VarId)] */ 
243           : ifCtxDeclT IMPLIES          { $$ = gc2($1);  }
244           |                             { $$ = gc0(NIL); }
245           ;                                     
246 ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */ 
247           :                             { $$ = gc0(NIL); }
248           | '{' ifCtxDeclL '}'          { $$ = gc3($2);  }
249           ;                                     
250
251 ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
252           : ifCtxDeclLE ',' ifCtxDeclL  {$$=gc3(cons($1,$3));}
253           | ifCtxDeclLE                 {$$=gc1(cons($1,NIL));}
254           |                             {$$=gc0(NIL);}
255           ;
256 ifCtxDeclLE /* M.C1 a   :: (QConId,VarId) */
257           : ifQCon ifTyvar              {$$=gc2(zpair($1,$2));}
258           ;
259
260
261 /*- Interface data declarations - constructor lists -------*/
262 /* The (Type,VarId,Int) are (field type, name (or NIL), strictness).
263    Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
264    indicates a strict field (!type) as in standard H98, and 
265    mkInt(2) indicates unpacked -- a GHC extension.
266 */
267
268 ifConstrs /* = Con1 | ... | ConN  :: [((ConId,[((Type,VarId,Int))]))] */
269           :                             {$$ = gc0(NIL);}
270           | '=' ifConstrL               {$$ = gc2($2);}
271           ;
272 ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
273           : ifConstr                    {$$ = gc1(singleton($1));}
274           | ifConstr '|' ifConstrL      {$$ = gc3(cons($1,$3));}
275           ;
276 ifConstr /* ((ConId,[((Type,VarId,Int))])) */
277           : ifConData ifDataAnonFieldL  {$$ = gc2(zpair($1,$2));}
278           | ifConData '{' ifDataNamedFieldL '}' 
279                                         {$$ = gc4(zpair($1,$3));}
280           ;
281 ifDataAnonFieldL /* [((Type,VarId,Int))] */
282           :                             {$$=gc0(NIL);}
283           | ifDataAnonField ifDataAnonFieldL
284                                         {$$=gc2(cons($1,$2));}
285           ;
286 ifDataNamedFieldL /* [((Type,VarId,Int))] */
287           :                             {$$=gc0(NIL);}
288           | ifDataNamedField            {$$=gc1(cons($1,NIL));}
289           | ifDataNamedField ',' ifDataNamedFieldL 
290                                         {$$=gc3(cons($1,$3));}
291           ;
292 ifDataAnonField /* ((Type,VarId,Int)) */
293           : ifAType                     {$$=gc1(ztriple($1,NIL,mkInt(0)));}
294           | '!' ifAType                 {$$=gc2(ztriple($2,NIL,mkInt(1)));}
295           | '!' '!' ifAType             {$$=gc3(ztriple($3,NIL,mkInt(2)));}
296           ;
297 ifDataNamedField  /* ((Type,VarId,Int)) */
298           : ifVar COCO ifAType          {$$=gc3(ztriple($3,$1,mkInt(0)));}
299           | ifVar COCO '!' ifAType      {$$=gc4(ztriple($4,$1,mkInt(1)));}
300           | ifVar COCO '!' '!' ifAType  {$$=gc5(ztriple($5,$1,mkInt(2)));}
301           ;
302
303
304 /*- Interface class declarations - methods ----------------*/
305 ifCmeths /* [((VarId,Type))] */
306           :                             { $$ = gc0(NIL); }
307           | WHERE '{' ifCmethL '}'      { $$ = gc4($3); }
308           ;
309 ifCmethL /* [((VarId,Type))] */
310           : ifCmeth                     { $$ = gc1(singleton($1)); }
311           | ifCmeth ';' ifCmethL        { $$ = gc3(cons($1,$3));    }
312           ;
313 ifCmeth /* ((VarId,Type)) */
314           : ifVar     COCO ifType       { $$ = gc3(zpair($1,$3)); }
315           | ifVar '=' COCO ifType       { $$ = gc4(zpair($1,$4)); } 
316                                               /* has default method */
317           ;
318
319
320 /*- Interface newtype declararions ------------------------*/
321 ifNewTypeConstr /* ((ConId,Type)) */
322           : '=' ifCon ifAType           { $$ = gc3(zpair($2,$3)); }
323           ;
324
325
326 /*- Interface type expressions ----------------------------*/
327 ifType    : ALL ifForall ifCtxDeclT IMPLIES ifType 
328                                         { if ($3 == NIL)
329                                            $$=gc5($5); else
330                                            $$=gc5(pair(QUAL,pair($3,$5)));
331                                         }
332           | ifBType ARROW ifType        { $$ = gc3(fn($1,$3)); }
333           | ifBType                     { $$ = gc1($1); }
334           ;                                     
335 ifForall  /* [((VarId,Kind))] */
336           : '[' ifKindedTyvarL ']'      { $$ = gc3($2); }
337           ;
338
339 ifTypeL2  /* [Type], 2 or more */
340           : ifType ',' ifType           { $$ = gc3(doubleton($1,$3)); }
341           | ifType ',' ifTypeL2         { $$ = gc3(cons($1,$3));      }
342           ;
343
344 ifTypeL   /* [Type], 0 or more */
345           : ifType ',' ifTypeL          { $$ = gc3(cons($1,$3)); }
346           | ifType                      { $$ = gc1(singleton($1)); }
347           |                             { $$ = gc0(NIL); }
348           ;
349
350 ifBType   : ifAType                     { $$ = gc1($1);        } 
351           | ifBType ifAType             { $$ = gc2(ap($1,$2)); }
352           | UUUSAGE ifUsage ifAType     { $$ = gc3($3); }
353           ;
354
355 ifAType   : ifQTCName                   { $$ = gc1($1); }
356           | ifTyvar                     { $$ = gc1($1); }
357           | '(' ')'                     { $$ = gc2(typeUnit); }
358           | '(' ifTypeL2 ')'            { $$ = gc3(buildTuple(reverse($2))); }
359           | '[' ifType ']'              { $$ = gc3(ap(mkCon(tycon(typeList).text),
360                                                       $2));}
361           | '{' ifQTCName ifAType '}'   { $$ = gc4(ap(DICTAP,
362                                                       pair($2,$3))); }
363           | '(' ifType ')'              { $$ = gc3($2); }
364           | UTL ifTypeL UTR             { $$ = gc3(ap(UNBOXEDTUP,$2)); }
365           ;
366
367
368 /*- KW's usage stuff --------------------------------------*/
369 ifUsage   : '-'                         { $$ = gc1(NIL); }
370           | '!'                         { $$ = gc1(NIL); }
371           | ifVar                       { $$ = gc1(NIL); }
372           ;
373
374
375 /*- Interface kinds ---------------------------------------*/
376 ifKindedTyvarL /* [((VarId,Kind))] */
377           :                              { $$ = gc0(NIL);         }
378           | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
379           ;
380 ifKindedTyvar /* ((VarId,Kind)) */
381           : ifTyvar                     { $$ = gc1(zpair($1,STAR)); }
382           | ifTyvar COCO ifAKind        { $$ = gc3(zpair($1,$3));   }
383           ; 
384 ifKind    : ifAKind                     { $$ = gc1($1);        }
385           | ifAKind ARROW ifKind        { $$ = gc3(ap($1,$3)); }
386           ;
387 ifAKind   : VAROP                       { $$ = gc1(STAR); } 
388                                             /* should be '*' */
389           | '(' ifKind ')'              { $$ = gc3($2);   }
390           ;
391
392
393 /*- Interface version/export/import stuff -----------------*/
394 ifEntities                                      
395           :                             { $$ = gc0(NIL);         }
396           | ifEntity ifEntities         { $$ = gc2(cons($1,$2)); }
397           ;
398 ifEntity
399           : ifEntityOcc                 {$$=gc1($1);}
400           | ifEntityOcc ifStuffInside   {$$=gc2(zpair($1,$2));}
401           ;
402 ifEntityOcc
403           : ifVar                       { $$ = gc1($1); }
404           | ifCon                       { $$ = gc1($1); }
405           | ARROW                       { $$ = gc1(typeArrow); }
406           | '(' ARROW ')'               { $$ = gc3(typeArrow); }  
407                                         /* why allow both? */
408           ;
409 ifStuffInside
410           : '{' ifValOccs '}'           { $$ = gc3($2); }
411           ;
412 ifValOccs
413           :                             { $$ = gc0(NIL); }
414           | ifVar ifValOccs             { $$ = gc2(cons($1,$2));   }
415           | ifCon ifValOccs             { $$ = gc2(cons($1,$2));   }
416           ;
417
418 ifVersionList
419           :                             {$$=gc0(NIL);}
420           | VARID NUMLIT ifVersionList  {$$=gc3(cons($1,$3));} 
421           | CONID NUMLIT ifVersionList  {$$=gc3(cons($1,$3));}
422           ;
423
424
425 /*- Haskell module header/import parsing: -----------------------------------
426  * Module chasing is now totally different from Classic Hugs98.  We parse
427  * the entire syntax tree.  Subsequent passes over the tree collect and
428  * chase imports; we no longer attempt to do so whilst parsing.
429  *-------------------------------------------------------------------------*/
430
431 /* In Haskell 1.2, the default module header was "module Main where"
432  * In 1.3, this changed to "module Main(main) where".
433  * We use the 1.2 header because it breaks much less pre-module code.
434  * STG Hugs, 15 March 00: disallow default headers (pro tem).
435  */
436 topModule : TMODULE modname expspec WHERE '{' modBody end
437                                         {$$=gc7(ap(M_MODULE,
438                                                    ztriple($2,$3,$6)));}
439           | TMODULE modname WHERE '{' modBody end
440                                         {$$=gc6(ap(M_MODULE,
441                                             ztriple(
442                                               $2,
443                                               singleton(ap(MODULEENT,$2)),
444                                               $5)));}
445           | TMODULE error               {syntaxError("module definition");}
446           ;
447
448 modname   : CONID                       {$$ = gc1($1);}
449           ;
450 modid     : CONID                       {$$ = gc1($1);}
451           ;
452 modBody   : topDecls                    {$$ = gc1($1);}
453           | impDecls                    {$$ = gc1($1);}
454           | impDecls ';' topDecls       {$$ = gc3(appendOnto($1,$3));}
455           ;
456
457 /*- Exports: --------------------------------------------------------------*/
458
459 expspec   : '(' ')'                     {$$ = gc2(NIL);}
460           | '(' exports ')'             {$$ = gc3($2);}
461           | '(' exports ',' ')'         {$$ = gc4($2);}
462           ;
463 exports   : exports ',' export          {$$ = gc3(cons($3,$1));}
464           | export                      {$$ = gc1(singleton($1));}
465           ;
466 /* The qcon should be qconid.  
467  * Relaxing the rule lets us explicitly export (:) from the Prelude.
468  */
469 export    : qvar                        {$$ = $1;}
470           | qcon                        {$$ = $1;}
471           | qconid '(' UPTO ')'         {$$ = gc4(pair($1,DOTDOT));}
472           | qconid '(' qnames ')'       {$$ = gc4(pair($1,$3));}
473           | TMODULE modid               {$$ = gc2(ap(MODULEENT,$2));}
474           ;
475 qnames    : /* empty */                 {$$ = gc0(NIL);}
476           | ','                         {$$ = gc1(NIL);}
477           | qnames1                     {$$ = $1;}
478           | qnames1 ','                 {$$ = gc2($1);}
479           ;
480 qnames1   : qnames1 ',' qname           {$$ = gc3(cons($3,$1));}
481           | qname                       {$$ = gc1(singleton($1));}
482           ;
483 qname     : qvar                        {$$ = $1;}
484           | qcon                        {$$ = $1;}
485           ;
486
487 /*- Import declarations: --------------------------------------------------*/
488
489 impDecls  : impDecls ';' impDecl        {$$ = gc3(appendOnto($3,$1));}
490           | impDecl                     {$$ = gc1($1);}
491           ;
492
493 /* Note that qualified import ignores the import list. */
494 impDecl   : IMPORT modid impspec        {$$=gc3(doubleton(
495                                               ap(M_IMPORT_Q,zpair($2,$2)),
496                                               ap(M_IMPORT_UNQ,zpair($2,$3))
497                                             ));}
498           | IMPORT modid ASMOD modid impspec
499                                         {$$=gc5(doubleton(
500                                               ap(M_IMPORT_Q,zpair($2,$4)),
501                                               ap(M_IMPORT_UNQ,zpair($2,$5))
502                                          ));}
503           | IMPORT QUALIFIED modid ASMOD modid impspec
504                                         {$$=gc6(singleton(
505                                                ap(M_IMPORT_Q,zpair($3,$5))
506                                             ));}
507           | IMPORT QUALIFIED modid impspec
508                                         {$$=gc4(singleton(
509                                                ap(M_IMPORT_Q,zpair($3,$3))
510                                             ));}
511           | IMPORT PRIVILEGED modid '(' imports ')'
512                                         {$$=gc6(singleton(
513                                                ap(M_IMPORT_UNQ,
514                                                   zpair($3,ap(STAR,$5)))));}
515           | IMPORT error                {syntaxError("import declaration");}
516           ;
517 impspec   : /* empty */                 {$$ = gc0(DOTDOT);}
518           | HIDING '(' imports ')'      {$$ = gc4(ap(HIDDEN,$3));}
519           | '(' imports ')'             {$$ = gc3($2);}
520           ;
521 imports   : /* empty */                 {$$ = gc0(NIL);}
522           | ','                         {$$ = gc1(NIL);}
523           | imports1                    {$$ = $1;}
524           | imports1 ','                {$$ = gc2($1);}
525           ;
526 imports1  : imports1 ',' import         {$$ = gc3(cons($3,$1));}
527           | import                      {$$ = gc1(singleton($1));}
528           ;
529 import    : var                         {$$ = $1;}
530           | CONID                       {$$ = $1;}
531           | CONID '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
532           | CONID '(' names ')'         {$$ = gc4(pair($1,$3));}
533           ;
534 names     : /* empty */                 {$$ = gc0(NIL);}
535           | ','                         {$$ = gc1(NIL);}
536           | names1                      {$$ = $1;}
537           | names1 ','                  {$$ = gc2($1);}
538           ;
539 names1    : names1 ',' name             {$$ = gc3(cons($3,$1));}
540           | name                        {$$ = gc1(singleton($1));}
541           ;
542 name      : var                         {$$ = $1;}
543           | con                         {$$ = $1;}
544           ;
545
546 /*- Top-level declarations: -----------------------------------------------*/
547
548 topDecls : /* empty */                  {$$=gc0(NIL);}
549          | topDecl ';' topDecls         {$$=gc3(cons($1,$3));}
550          | decl    ';' topDecls         {$$=gc3(cons(ap(M_VALUE,$1),$3));}
551          | topDecl                      {$$=gc1(cons($1,NIL));}
552          | decl                         {$$=gc1(cons(ap(M_VALUE,$1),NIL));}
553          ;
554
555 /*- Type declarations: ----------------------------------------------------*/
556
557 topDecl   : TYPE tyLhs '=' type         {$$=gc4(ap(M_TYCON,
558                                                    z4ble($3,$2,$4,
559                                                          SYNONYM)));}
560           | TYPE tyLhs '=' type IN invars
561                                         {$$=gc6(ap(M_TYCON,
562                                                    z4ble($3,$2,ap($4,$6),
563                                                          RESTRICTSYN)));}
564           | TYPE error                  {syntaxError("type definition");}
565           | DATA btype2 '=' constrs deriving
566                                         {$$=gc5(ap(M_TYCON,
567                                                 z4ble($3,checkTyLhs($2),
568                                                       ap(rev($4),$5),
569                                                       DATATYPE)));}
570           | DATA context IMPLIES tyLhs '=' constrs deriving
571                                         {$$=gc7(ap(M_TYCON,
572                                                    z4ble($5,$4,
573                                                       ap(qualify($2,rev($6)),$7),
574                                                       DATATYPE)));}
575           | DATA btype2                 {$$=gc2(ap(M_TYCON,
576                                                    z4ble($1,checkTyLhs($2),
577                                                       ap(NIL,NIL),DATATYPE)));}
578           | DATA context IMPLIES tyLhs  {$$=gc4(ap(M_TYCON,
579                                                   z4ble($1,$4,
580                                                         ap(qualify($2,NIL),NIL),
581                                                         DATATYPE)));}
582           | DATA error                  {syntaxError("data definition");}
583           | TNEWTYPE btype2 '=' nconstr deriving
584                                         {$$=gc5(ap(M_TYCON,
585                                                    z4ble($3,checkTyLhs($2),
586                                                          ap($4,$5),NEWTYPE)));}
587           | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
588                                         {$$=gc7(ap(M_TYCON,
589                                                    z4ble($5,$4,
590                                                          ap(qualify($2,$6),$7),
591                                                          NEWTYPE)));}
592           | TNEWTYPE error              {syntaxError("newtype definition");}
593           ;
594 tyLhs     : tyLhs varid                 {$$ = gc2(ap($1,$2));}
595           | CONID                       {$$ = $1;}
596           | error                       {syntaxError("type defn lhs");}
597           ;
598 invars    : invars ',' invar            {$$ = gc3(cons($3,$1));}
599           | invar                       {$$ = gc1(cons($1,NIL));}
600           ;
601 invar     : var COCO topType            {$$ = gc3(sigdecl($2,singleton($1),
602                                                                        $3));}
603           | var                         {$$ = $1;}
604           ;
605 constrs   : constrs '|' pconstr         {$$ = gc3(cons($3,$1));}
606           | pconstr                     {$$ = gc1(cons($1,NIL));}
607           ;
608 pconstr   : ALL varids '.' qconstr      {$$ = gc4(ap(POLYTYPE,
609                                                      pair(rev($2),$4)));}
610           | qconstr                     {$$ = $1;}
611           ;
612 qconstr   : context IMPLIES constr      {$$ = gc3(qualify($1,$3));}
613           | constr                      {$$ = $1;}
614           ;
615 constr    : '!' btype conop bbtype      {$$ = gc4(ap(ap($3,bang($2)),$4));}
616           | btype1    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
617           | btype2    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
618           | bpolyType conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
619           | btype2                      {$$ = $1;}
620           | btype3                      {$$ = $1;}
621           | btype4                      {$$ = $1;}
622           | con '{' fieldspecs '}'      {$$ = gc4(ap(LABC,pair($1,rev($3))));}
623           | con '{' '}'                 {$$ = gc3(ap(LABC,pair($1,NIL)));}
624           | error                       {syntaxError("data type definition");}
625           ;
626 btype3    : btype2 '!' atype            {$$ = gc3(ap($1,bang($3)));}
627           | btype3 '!' atype            {$$ = gc3(ap($1,bang($3)));}
628           | btype3 atype                {$$ = gc2(ap($1,$2));}
629           ;
630 btype4    : btype2 bpolyType            {$$ = gc2(ap($1,$2));}
631           | btype3 bpolyType            {$$ = gc2(ap($1,$2));}
632           | btype4 bpolyType            {$$ = gc2(ap($1,$2));}
633           | btype4 atype                {$$ = gc2(ap($1,$2));}
634           | btype4 '!' atype            {$$ = gc3(ap($1,bang($3)));}
635           ;
636 bbtype    : '!' btype                   {$$ = gc2(bang($2));}
637           | btype                       {$$ = $1;}
638           | bpolyType                   {$$ = $1;}
639           ;
640 nconstr   : pconstr                     {$$ = gc1(singleton($1));}
641           ;
642 fieldspecs: fieldspecs ',' fieldspec    {$$ = gc3(cons($3,$1));}
643           | fieldspec                   {$$ = gc1(cons($1,NIL));}
644           ;
645 fieldspec : vars COCO polyType          {$$ = gc3(pair(rev($1),$3));}
646           | vars COCO type              {$$ = gc3(pair(rev($1),$3));}
647           | vars COCO '!' type          {$$ = gc4(pair(rev($1),bang($4)));}
648           ;
649 deriving  : /* empty */                 {$$ = gc0(NIL);}
650           | DERIVING qconid             {$$ = gc2(singleton($2));}
651           | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
652           ;
653 derivs0   : /* empty */                 {$$ = gc0(NIL);}
654           | derivs                      {$$ = gc1(rev($1));}
655           ;
656 derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
657           | qconid                      {$$ = gc1(singleton($1));}
658           ;
659
660 /*- Processing definitions of primitives ----------------------------------*/
661
662 topDecl   : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type 
663                {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));}
664           | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type 
665                {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));}
666           | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type 
667                {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));}
668           ;
669
670 callconv  : CCALL                {$$ = gc1(textCcall);}
671           | STDKALL              {$$ = gc1(textStdcall);}
672           | /* empty */          {$$ = gc0(NIL);}
673           ;
674 ext_loc   : STRINGLIT            {$$ = $1;}
675           ;
676 ext_name  : STRINGLIT            {$$ = $1;}
677           ;
678 unsafe_flag: /* empty */         {$$ = gc0(NIL);}
679           | UNSAFE               {$$ = gc1(NIL); /* ignored */ }
680           ;
681
682
683 /*- Class declarations: ---------------------------------------------------*/
684
685 topDecl   : TCLASS crule fds wherePart  {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));}
686           | TINSTANCE irule wherePart   {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));}
687           | DEFAULT '(' dtypes ')'      {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));}
688           | TCLASS error                {syntaxError("class declaration");}
689           | TINSTANCE error             {syntaxError("instance declaration");}
690           | DEFAULT error               {syntaxError("default declaration");}
691           ;
692 crule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
693           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
694           ;
695 irule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
696           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
697           ;
698 dtypes    : /* empty */                 {$$ = gc0(NIL);}
699           | dtypes1                     {$$ = gc1(rev($1));}
700           ;
701 dtypes1   : dtypes1 ',' type            {$$ = gc3(cons($3,$1));}
702           | type                        {$$ = gc1(cons($1,NIL));}
703           ;
704
705 fds       : /* empty */                 {$$ = gc0(NIL);}
706           | '|' fds1                    {h98DoesntSupport(row,"dependent parameters");
707                                          $$ = gc2(rev($2));}
708           ;
709 fds1      : fds1 ',' fd                 {$$ = gc3(cons($3,$1));}
710           | fd                          {$$ = gc1(cons($1,NIL));}
711           | 
712           ;
713 fd        : varids0 ARROW varids0       {$$ = gc3(pair(rev($1),rev($3)));}
714           ;
715 varids0   : /* empty */                 {$$ = gc0(NIL);}
716           | varids0 varid               {$$ = gc2(cons($2,$1));}
717           ;
718   
719   /*- Type expressions: -----------------------------------------------------*/
720   
721 topType   : ALL varids '.' topType0     {$$ = gc4(ap(POLYTYPE,
722                                                      pair(rev($2),$4)));}
723           | topType0                    {$$ = $1;}
724           ;
725 topType0  : context IMPLIES topType1    {$$ = gc3(qualify($1,$3));}
726           | topType1                    {$$ = $1;}
727           ;
728 topType1  : bpolyType ARROW topType1    {$$ = gc3(fn($1,$3));}
729           | btype1    ARROW topType1    {$$ = gc3(fn($1,$3));}
730           | btype2    ARROW topType1    {$$ = gc3(fn($1,$3));}
731           | btype                       {$$ = $1;}
732           ;
733 polyType  : ALL varids '.' sigType      {$$ = gc4(ap(POLYTYPE,
734                                                      pair(rev($2),$4)));}
735           | context IMPLIES type        {$$ = gc3(qualify($1,$3));}
736           | bpolyType                   {$$ = $1;}
737           ;
738 bpolyType : '(' polyType ')'            {$$ = gc3($2);}
739           ;
740 varids    : varids varid                {$$ = gc2(cons($2,$1));}
741           | varid                       {$$ = gc1(singleton($1));}
742           ;
743 sigType   : context IMPLIES type        {$$ = gc3(qualify($1,$3));}
744           | type                        {$$ = $1;}
745           ;
746 context   : '(' ')'                     {$$ = gc2(NIL);}
747           | btype2                      {$$ = gc1(singleton(checkPred($1)));}
748           | '(' btype2 ')'              {$$ = gc3(singleton(checkPred($2)));}
749           | '(' btypes2 ')'             {$$ = gc3(checkCtxt(rev($2)));}
750 /*#if TREX*/
751           | lacks                       {$$ = gc1(singleton($1));}
752           | '(' lacks1 ')'              {$$ = gc3(checkCtxt(rev($2)));}
753           ;
754 lacks     : varid '\\' varid            {
755 #if TREX
756                                          $$ = gc3(ap(mkExt(textOf($3)),$1));
757 #else
758                                          noTREX("a type context");
759 #endif
760                                         }
761           | IPVARID COCO type           {
762 #if IPARAM
763                                          $$ = gc3(pair(mkIParam($1),$3));
764 #else
765                                          noIP("a type context");
766 #endif
767                                         }
768           ;
769 lacks1    : btypes2 ',' lacks           {$$ = gc3(cons($3,$1));}
770           | lacks1  ',' btype2          {$$ = gc3(cons($3,$1));}
771           | lacks1  ',' lacks           {$$ = gc3(cons($3,$1));}
772           | btype2  ',' lacks           {$$ = gc3(cons($3,cons($1,NIL)));}
773           | lacks                       {$$ = gc1(singleton($1));}
774           ;
775 /*#endif*/
776
777 type      : type1                       {$$ = $1;}
778           | btype2                      {$$ = $1;}
779           ;
780 type1     : btype1                      {$$ = $1;}
781           | btype1 ARROW type           {$$ = gc3(fn($1,$3));}
782           | btype2 ARROW type           {$$ = gc3(fn($1,$3));}
783           | error                       {syntaxError("type expression");}
784           ;
785 btype     : btype1                      {$$ = $1;}
786           | btype2                      {$$ = $1;}
787           ;
788 btype1    : btype1 atype                {$$ = gc2(ap($1,$2));}
789           | atype1                      {$$ = $1;}
790           ;
791 btype2    : btype2 atype                {$$ = gc2(ap($1,$2));}
792           | qconid                      {$$ = $1;}
793           ;
794 atype     : atype1                      {$$ = $1;}
795           | qconid                      {$$ = $1;}
796           ;
797 atype1    : varid                       {$$ = $1;}
798           | '(' ')'                     {$$ = gc2(typeUnit);}
799           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
800           | '(' type1 ')'               {$$ = gc3($2);}
801           | '(' btype2 ')'              {$$ = gc3($2);}
802           | '(' tupCommas ')'           {$$ = gc3($2);}
803           | '(' btypes2 ')'             {$$ = gc3(buildTuple($2));}
804           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
805           | '(' tfields ')'             {
806 #if TREX
807                                          $$ = gc3(revOnto($2,typeNoRow));
808 #else
809                                          noTREX("a type");
810 #endif
811                                         }
812           | '(' tfields '|' type ')'    {
813 #if TREX
814                                          $$ = gc5(revOnto($2,$4));
815 #else
816                                          noTREX("a type");
817 #endif
818                                         }
819           | '[' type ']'                {$$ = gc3(ap(typeList,$2));}
820           | '[' ']'                     {$$ = gc2(typeList);}
821           | '_'                         {h98DoesntSupport(row,"anonymous type variables");
822                                          $$ = gc1(inventVar());}
823           ;
824 btypes2   : btypes2 ',' btype2          {$$ = gc3(cons($3,$1));}
825           | btype2  ',' btype2          {$$ = gc3(cons($3,cons($1,NIL)));}
826           ;
827 typeTuple : type1     ',' type          {$$ = gc3(cons($3,cons($1,NIL)));}
828           | btype2    ',' type1         {$$ = gc3(cons($3,cons($1,NIL)));}
829           | btypes2   ',' type1         {$$ = gc3(cons($3,$1));}
830           | typeTuple ',' type          {$$ = gc3(cons($3,$1));}
831           ;
832 /*#if TREX*/
833 tfields   : tfields ',' tfield          {$$ = gc3(cons($3,$1));}
834           | tfield                      {$$ = gc1(singleton($1));}
835           ;
836 tfield    : varid COCO type             {h98DoesntSupport(row,"extensible records");
837                                          $$ = gc3(ap(mkExt(textOf($1)),$3));}
838           ;
839 /*#endif*/
840
841 /*- Value declarations: ---------------------------------------------------*/
842
843 gendecl   : INFIXN optDigit ops         {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
844           | INFIXN error                {syntaxError("fixity decl");}
845           | INFIXL optDigit ops         {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
846           | INFIXL error                {syntaxError("fixity decl");}
847           | INFIXR optDigit ops         {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
848           | INFIXR error                {syntaxError("fixity decl");}
849           | vars COCO topType           {$$ = gc3(sigdecl($2,$1,$3));}
850           | vars COCO error             {syntaxError("type signature");}
851           ;
852 optDigit  : NUMLIT                      {$$ = gc1(checkPrec($1));}
853           | /* empty */                 {$$ = gc0(mkInt(DEF_PREC));}
854           ;
855 ops       : ops ',' op                  {$$ = gc3(cons($3,$1));}
856           | op                          {$$ = gc1(singleton($1));}
857           ;
858 vars      : vars ',' var                {$$ = gc3(cons($3,$1));}
859           | var                         {$$ = gc1(singleton($1));}
860           ;
861 decls     : '{' decls0 end              {$$ = gc3($2);}
862           | '{' decls1 end              {$$ = gc3($2);}
863           ;
864 decls0    : /* empty */                 {$$ = gc0(NIL);}
865           | decls0 ';'                  {$$ = gc2($1);}
866           | decls1 ';'                  {$$ = gc2($1);}
867           ;
868 decls1    : decls0 decl                 {$$ = gc2(cons($2,$1));}
869           ;
870 decl      : gendecl                     {$$ = $1;}
871           | funlhs rhs                  {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
872           | funlhs COCO type rhs        {$$ = gc4(ap(FUNBIND,
873                                                      pair($1,ap(RSIGN,
874                                                                 ap($4,$3)))));}
875           | pat0 rhs                    {$$ = gc2(ap(PATBIND,pair($1,$2)));}
876           ;
877 funlhs    : funlhs0                     {$$ = $1;}
878           | funlhs1                     {$$ = $1;}
879           | npk                         {$$ = $1;}
880           ;
881 funlhs0   : pat10_vI varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
882           | infixPat varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
883           | NUMLIT   varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
884           | var      varop_pl pat0      {$$ = gc3(ap2($2,$1,$3));}
885           | var      '+'      pat0_INT  {$$ = gc3(ap2(varPlus,$1,$3));}
886           ;
887 funlhs1   : '(' funlhs0 ')' apat        {$$ = gc4(ap($2,$4));}
888           | '(' funlhs1 ')' apat        {$$ = gc4(ap($2,$4));}
889           | '(' npk     ')' apat        {$$ = gc4(ap($2,$4));}
890           | var     apat                {$$ = gc2(ap($1,$2));}
891           | funlhs1 apat                {$$ = gc2(ap($1,$2));}
892           ;
893 rhs       : rhs1 wherePart              {$$ = gc2(letrec($2,$1));}
894           | error                       {syntaxError("declaration");}
895           ;
896 rhs1      : '=' exp                     {$$ = gc2(pair($1,$2));}
897           | gdrhs                       {$$ = gc1(grded(rev($1)));}
898           ;
899 gdrhs     : gdrhs gddef                 {$$ = gc2(cons($2,$1));}
900           | gddef                       {$$ = gc1(singleton($1));}
901           ;
902 gddef     : '|' exp0 '=' exp            {$$ = gc4(pair($3,pair($2,$4)));}
903           ;
904 wherePart : /* empty */                 {$$ = gc0(NIL);}
905           | WHERE decls                 {$$ = gc2($2);}
906           ;
907
908 /*- Patterns: -------------------------------------------------------------*/
909
910 pat       : npk                         {$$ = $1;}
911           | pat_npk                     {$$ = $1;}
912           ;
913 pat_npk   : pat0 COCO type              {$$ = gc3(ap(ESIGN,pair($1,$3)));}
914           | pat0                        {$$ = $1;}
915           ;
916 npk       : var '+' NUMLIT              {$$ = gc3(ap2(varPlus,$1,$3));}
917           ;
918 pat0      : var                         {$$ = $1;}
919           | NUMLIT                      {$$ = $1;}
920           | pat0_vI                     {$$ = $1;}
921           ;
922 pat0_INT  : var                         {$$ = $1;}
923           | pat0_vI                     {$$ = $1;}
924           ;
925 pat0_vI   : pat10_vI                    {$$ = $1;}
926           | infixPat                    {$$ = gc1(ap(INFIX,$1));}
927           ;
928 infixPat  : '-' pat10                   {$$ = gc2(ap(NEG,only($2)));}
929           | '-' error                   {syntaxError("pattern");}
930           | var qconop pat10            {$$ = gc3(ap(ap($2,only($1)),$3));}
931           | var qconop '-' pat10        {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
932           | NUMLIT qconop pat10         {$$ = gc3(ap(ap($2,only($1)),$3));}
933           | NUMLIT qconop '-' pat10     {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
934           | pat10_vI qconop pat10       {$$ = gc3(ap(ap($2,only($1)),$3));}
935           | pat10_vI qconop '-' pat10   {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
936           | infixPat qconop pat10       {$$ = gc3(ap(ap($2,$1),$3));}
937           | infixPat qconop '-' pat10   {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
938           ;
939 pat10     : fpat                        {$$ = $1;}
940           | apat                        {$$ = $1;}
941           ;
942 pat10_vI  : fpat                        {$$ = $1;}
943           | apat_vI                     {$$ = $1;}
944           ;
945 fpat      : fpat apat                   {$$ = gc2(ap($1,$2));}
946           | gcon apat                   {$$ = gc2(ap($1,$2));}
947           ;
948 apat      : NUMLIT                      {$$ = $1;}
949           | var                         {$$ = $1;}
950           | apat_vI                     {$$ = $1;}
951           ;
952 apat_vI   : var '@' apat                {$$ = gc3(ap(ASPAT,pair($1,$3)));}
953           | gcon                        {$$ = $1;}
954           | qcon '{' patbinds '}'       {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
955           | CHARLIT                     {$$ = $1;}
956           | STRINGLIT                   {$$ = $1;}
957           | '_'                         {$$ = gc1(WILDCARD);}
958           | '(' pat_npk ')'             {$$ = gc3($2);}
959           | '(' npk ')'                 {$$ = gc3($2);}
960           | '(' pats2 ')'               {$$ = gc3(buildTuple($2));}
961           | '[' pats1 ']'               {$$ = gc3(ap(FINLIST,rev($2)));}
962           | '~' apat                    {$$ = gc2(ap(LAZYPAT,$2));}
963 /*#if TREX*/
964           | '(' patfields ')'           {
965 #if TREX
966                                          $$ = gc3(revOnto($2,nameNoRec));
967 #else
968                                          $$ = gc3(NIL);
969 #endif
970                                         }
971           | '(' patfields '|' pat ')'   {$$ = gc5(revOnto($2,$4));}
972 /*#endif TREX*/
973           ;
974 pats2     : pats2 ',' pat               {$$ = gc3(cons($3,$1));}
975           | pat ',' pat                 {$$ = gc3(cons($3,singleton($1)));}
976           ;
977 pats1     : pats1 ',' pat               {$$ = gc3(cons($3,$1));}
978           | pat                         {$$ = gc1(singleton($1));}
979           ;
980 patbinds  : /* empty */                 {$$ = gc0(NIL);}
981           | patbinds1                   {$$ = gc1(rev($1));}
982           ;
983 patbinds1 : patbinds1 ',' patbind       {$$ = gc3(cons($3,$1));}
984           | patbind                     {$$ = gc1(singleton($1));}
985           ;
986 patbind   : qvar '=' pat                {$$ = gc3(pair($1,$3));}
987           | var                         {$$ = $1;}
988           ;
989 /*#if TREX*/
990 patfields : patfields ',' patfield      {$$ = gc3(cons($3,$1));}
991           | patfield                    {$$ = gc1(singleton($1));}
992           ;
993 patfield  : varid '=' pat               {
994 #if TREX
995                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
996 #else
997                                          noTREX("a pattern");
998 #endif
999                                         }
1000           ;
1001 /*#endif TREX*/
1002
1003 /*- Expressions: ----------------------------------------------------------*/
1004
1005 exp       : exp_err                     {$$ = $1;}
1006           | error                       {syntaxError("expression");}
1007           ;
1008 exp_err   : exp0a COCO sigType          {$$ = gc3(ap(ESIGN,pair($1,$3)));}
1009           | exp0a WITH dbinds           {
1010 #if IPARAM
1011                                          $$ = gc3(ap(WITHEXP,pair($1,$3)));
1012 #else
1013                                          noIP("an expression");
1014 #endif
1015                                         }
1016           | exp0                        {$$ = $1;}
1017           ;
1018 exp0      : exp0a                       {$$ = $1;}
1019           | exp0b                       {$$ = $1;}
1020           ;
1021 exp0a     : infixExpa                   {$$ = gc1(ap(INFIX,$1));}
1022           | exp10a                      {$$ = $1;}
1023           ;
1024 exp0b     : infixExpb                   {$$ = gc1(ap(INFIX,$1));}
1025           | exp10b                      {$$ = $1;}
1026           ;
1027 infixExpa : infixExpa qop '-' exp10a    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1028           | infixExpa qop exp10a        {$$ = gc3(ap(ap($2,$1),$3));}
1029           | '-' exp10a                  {$$ = gc2(ap(NEG,only($2)));}
1030           | exp10a qop '-' exp10a       {$$ = gc4(ap(NEG,
1031                                                      ap(ap($2,only($1)),$4)));}
1032           | exp10a qop exp10a           {$$ = gc3(ap(ap($2,only($1)),$3));}
1033           ;
1034 infixExpb : infixExpa qop '-' exp10b    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1035           | infixExpa qop exp10b        {$$ = gc3(ap(ap($2,$1),$3));}
1036           | '-' exp10b                  {$$ = gc2(ap(NEG,only($2)));}
1037           | exp10a qop '-' exp10b       {$$ = gc4(ap(NEG,
1038                                                      ap(ap($2,only($1)),$4)));}
1039           | exp10a qop exp10b           {$$ = gc3(ap(ap($2,only($1)),$3));}
1040           ;
1041 exp10a    : CASEXP exp OF '{' alts end  {$$ = gc6(ap(CASE,pair($2,rev($5))));}
1042           | DO '{' stmts end            {$$ = gc4(ap(DOCOMP,checkDo($3)));}
1043           | appExp                      {$$ = $1;}
1044           ;
1045 exp10b    : '\\' pats ARROW exp         {$$ = gc4(ap(LAMBDA,      
1046                                                      pair(rev($2),
1047                                                           pair($3,$4))));}
1048           | LET decls IN exp            {$$ = gc4(letrec($2,$4));}
1049           | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
1050           | DLET dbinds IN exp          {
1051 #if IPARAM
1052                                          $$ = gc4(ap(WITHEXP,pair($4,$2)));
1053 #else
1054                                          noIP("an expression");
1055 #endif
1056                                         }
1057           ;
1058 pats      : pats apat                   {$$ = gc2(cons($2,$1));}
1059           | apat                        {$$ = gc1(cons($1,NIL));}
1060           ;
1061 appExp    : appExp aexp                 {$$ = gc2(ap($1,$2));}
1062           | aexp                        {$$ = $1;}
1063           ;
1064 aexp      : qvar                        {$$ = $1;}
1065           | qvar '@' aexp               {$$ = gc3(ap(ASPAT,pair($1,$3)));}
1066           | '~' aexp                    {$$ = gc2(ap(LAZYPAT,$2));}
1067           | IPVARID                     {$$ = $1;}
1068           | '_'                         {$$ = gc1(WILDCARD);}
1069           | gcon                        {$$ = $1;}
1070           | qcon '{' fbinds '}'         {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
1071           | aexp '{' fbinds '}'         {$$ = gc4(ap(UPDFLDS,
1072                                                      triple($1,NIL,$3)));}
1073           | NUMLIT                      {$$ = $1;}
1074           | CHARLIT                     {$$ = $1;}
1075           | STRINGLIT                   {$$ = $1;}
1076           | REPEAT                      {$$ = $1;}
1077           | '(' exp ')'                 {$$ = gc3($2);}
1078           | '(' exps2 ')'               {$$ = gc3(buildTuple($2));}
1079 /*#if TREX*/
1080           | '(' vfields ')'             {
1081 #if TREX
1082                                          $$ = gc3(revOnto($2,nameNoRec));
1083 #else
1084                                          $$ = gc3(NIL);
1085 #endif
1086                                         }
1087           | '(' vfields '|' exp ')'     {$$ = gc5(revOnto($2,$4));}
1088           | RECSELID                    {$$ = $1;}
1089 /*#endif*/
1090           | '[' list ']'                {$$ = gc3($2);}
1091           | '(' exp10a qop ')'          {$$ = gc4(ap($3,$2));}
1092           | '(' qvarop_mi exp0 ')'      {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1093           | '(' qconop exp0 ')'         {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1094           ;
1095 exps2     : exps2 ',' exp               {$$ = gc3(cons($3,$1));}
1096           | exp ',' exp                 {$$ = gc3(cons($3,cons($1,NIL)));}
1097           ;
1098 /*#if TREX*/
1099 vfields   : vfields ',' vfield          {$$ = gc3(cons($3,$1));}
1100           | vfield                      {$$ = gc1(singleton($1));}
1101           ;
1102 vfield    : varid '=' exp               {
1103 #if TREX
1104                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
1105 #else
1106                                          noTREX("an expression");
1107 #endif
1108                                         }
1109           ;
1110 /*#endif*/
1111 alts      : alts1                       {$$ = $1;}
1112           | alts1 ';'                   {$$ = gc2($1);}
1113           ;
1114 alts1     : alts1 ';' alt               {$$ = gc3(cons($3,$1));}
1115           | alt                         {$$ = gc1(cons($1,NIL));}
1116           ;
1117 alt       : pat altRhs wherePart        {$$ = gc3(pair($1,letrec($3,$2)));}
1118           ;
1119 altRhs    : guardAlts                   {$$ = gc1(grded(rev($1)));}
1120           | ARROW exp                   {$$ = gc2(pair($1,$2));}
1121           | error                       {syntaxError("case expression");}
1122           ;
1123 guardAlts : guardAlts guardAlt          {$$ = gc2(cons($2,$1));}
1124           | guardAlt                    {$$ = gc1(cons($1,NIL));}
1125           ;
1126 guardAlt  : '|' exp0 ARROW exp          {$$ = gc4(pair($3,pair($2,$4)));}
1127           ;
1128 stmts     : stmts1 ';'                  {$$ = gc2($1);}
1129           | stmts1                      {$$ = $1;}
1130           ;
1131 stmts1    : stmts1 ';' stmt             {$$ = gc3(cons($3,$1));}
1132           | stmt                        {$$ = gc1(cons($1,NIL));}
1133           ;
1134 stmt      : exp_err FROM exp            {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1135           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1136 /*        | IF exp                      {$$ = gc2(ap(BOOLQUAL,$2));}*/
1137           | exp_err                     {$$ = gc1(ap(DOQUAL,$1));}
1138           ;
1139 fbinds    : /* empty */                 {$$ = gc0(NIL);}
1140           | fbinds1                     {$$ = gc1(rev($1));}
1141           ;
1142 fbinds1   : fbinds1 ',' fbind           {$$ = gc3(cons($3,$1));}
1143           | fbind                       {$$ = gc1(singleton($1));}
1144           ;
1145 fbind     : var                         {$$ = $1;}
1146           | qvar '=' exp                {$$ = gc3(pair($1,$3));}
1147           ;
1148
1149 dbinds    : '{' dbs0 end                {$$ = gc3($2);}
1150           | '{' dbs1 end                {$$ = gc3($2);}
1151           ;
1152 dbs0      : /* empty */                 {$$ = gc0(NIL);}
1153           | dbs0 ';'                    {$$ = gc2($1);}
1154           | dbs1 ';'                    {$$ = gc2($1);}
1155           ;
1156 dbs1      : dbs0 dbind                  {$$ = gc2(cons($2,$1));}
1157           ;
1158 dbind     : IPVARID '=' exp             {$$ = gc3(pair($1,$3));}
1159           ;
1160
1161 /*- List Expressions: -------------------------------------------------------*/
1162
1163 list      : exp                         {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
1164           | exps2                       {$$ = gc1(ap(FINLIST,rev($1)));}
1165           | exp '|' quals               {$$ = gc3(ap(COMP,pair($1,rev($3))));}
1166           | exp         UPTO exp        {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
1167           | exp ',' exp UPTO            {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
1168           | exp         UPTO            {$$ = gc2(ap(nameFrom,$1));}
1169           | exp ',' exp UPTO exp        {$$ = gc5(ap(ap(ap(nameFromThenTo,
1170                                                                 $1),$3),$5));}
1171           ;
1172 quals     : quals ',' qual              {$$ = gc3(cons($3,$1));}
1173           | qual                        {$$ = gc1(cons($1,NIL));}
1174           ;
1175 qual      : exp FROM exp                {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1176           | exp                         {$$ = gc1(ap(BOOLQUAL,$1));}
1177           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1178           ;
1179
1180 /*- Identifiers and symbols: ----------------------------------------------*/
1181
1182 gcon      : qcon                        {$$ = $1;}
1183           | '(' ')'                     {$$ = gc2(nameUnit);}
1184           | '[' ']'                     {$$ = gc2(nameNil);}
1185           | '(' tupCommas ')'           {$$ = gc3($2);}
1186           ;
1187 tupCommas : tupCommas ','               {$$ = gc2(mkTuple(tupleOf($1)+1));}
1188           | ','                         {$$ = gc1(mkTuple(2));}
1189           ;
1190 varid     : VARID                       {$$ = $1;}
1191           | HIDING                      {$$ = gc1(varHiding);}
1192           | QUALIFIED                   {$$ = gc1(varQualified);}
1193           | ASMOD                       {$$ = gc1(varAsMod);}
1194           | PRIVILEGED                  {$$ = gc1(varPrivileged);}
1195           ;
1196 qconid    : QCONID                      {$$ = $1;}
1197           | CONID                       {$$ = $1;}
1198           ;
1199 var       : varid                       {$$ = $1;}
1200           | '(' VAROP ')'               {$$ = gc3($2);}
1201           | '(' '+' ')'                 {$$ = gc3(varPlus);}
1202           | '(' '-' ')'                 {$$ = gc3(varMinus);}
1203           | '(' '!' ')'                 {$$ = gc3(varBang);}
1204           | '(' '.' ')'                 {$$ = gc3(varDot);}
1205           ;
1206 qvar      : QVARID                      {$$ = $1;}
1207           | '(' QVAROP ')'              {$$ = gc3($2);}
1208           | var                         {$$ = $1;}
1209           ;
1210 con       : CONID                       {$$ = $1;}
1211           | '(' CONOP ')'               {$$ = gc3($2);}
1212           ;
1213 qcon      : QCONID                      {$$ = $1;}
1214           | '(' QCONOP ')'              {$$ = gc3($2);}
1215           | con                         {$$ = $1;}
1216           ;
1217 varop     : '+'                         {$$ = gc1(varPlus);}
1218           | '-'                         {$$ = gc1(varMinus);}
1219           | varop_mipl                  {$$ = $1;}
1220           ;
1221 varop_mi  : '+'                         {$$ = gc1(varPlus);}
1222           | varop_mipl                  {$$ = $1;}
1223           ;
1224 varop_pl  : '-'                         {$$ = gc1(varMinus);}
1225           | varop_mipl                  {$$ = $1;}
1226           ;
1227 varop_mipl: VAROP                       {$$ = $1;}
1228           | '`' varid '`'               {$$ = gc3($2);}
1229           | '!'                         {$$ = gc1(varBang);}
1230           | '.'                         {$$ = gc1(varDot);}
1231           ;
1232 qvarop    : '-'                         {$$ = gc1(varMinus);}
1233           | qvarop_mi                   {$$ = $1;}
1234           ;
1235 qvarop_mi : QVAROP                      {$$ = $1;}
1236           | '`' QVARID '`'              {$$ = gc3($2);}
1237           | varop_mi                    {$$ = $1;}
1238           ;
1239
1240 conop     : CONOP                       {$$ = $1;}
1241           | '`' CONID  '`'              {$$ = gc3($2);}
1242           ;
1243 qconop    : QCONOP                      {$$ = $1;}
1244           | '`' QCONID '`'              {$$ = gc3($2);}
1245           | conop                       {$$ = $1;}
1246           ;
1247 op        : varop                       {$$ = $1;}
1248           | conop                       {$$ = $1;}
1249           ;
1250 qop       : qvarop                      {$$ = $1;}
1251           | qconop                      {$$ = $1;}
1252           ;
1253
1254 /*- Stuff from STG hugs ---------------------------------------------------*/
1255
1256 qvarid    : varid1                      {$$ = gc1($1);}
1257           | QVARID                      {$$ = gc1($1);}
1258
1259 varid1    : VARID                       {$$ = gc1($1);}
1260           | HIDING                      {$$ = gc1(varHiding);}
1261           | QUALIFIED                   {$$ = gc1(varQualified);}
1262           | ASMOD                       {$$ = gc1(varAsMod);}
1263           | PRIVILEGED                  {$$ = gc1(varPrivileged);}
1264           ;
1265
1266 /*- Tricks to force insertion of leading and closing braces ---------------*/
1267
1268 end       : '}'                         {$$ = $1;}
1269           | error                       {yyerrok; 
1270                                          if (offsideON && canUnOffside()) {
1271                                              unOffside();
1272                                              /* insert extra token on stack*/
1273                                              push(NIL);
1274                                              pushed(0) = pushed(1);
1275                                              pushed(1) = mkInt(column);
1276                                          }
1277                                          else
1278                                              syntaxError("definition");
1279                                         }
1280           ;
1281
1282 /*-------------------------------------------------------------------------*/
1283
1284 %%
1285
1286 static Cell local gcShadow(n,e)         /* keep parsed fragments on stack  */
1287 Int  n;
1288 Cell e; {
1289     /* If a look ahead token is held then the required stack transformation
1290      * is:
1291      *   pushed: n               1     0          1     0
1292      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
1293      *                                top()            top()
1294      *
1295      * Otherwise, the transformation is:
1296      *   pushed: n-1             0        0
1297      *           x1  |  ...  |  xn  ===>  e
1298      *                         top()     top()
1299      */
1300     if (yychar>=0) {
1301         pushed(n-1) = top();
1302         pushed(n)   = e;
1303     }
1304     else
1305         pushed(n-1) = e;
1306     sp -= (n-1);
1307     return e;
1308 }
1309
1310 static Void local syntaxError(s)        /* report on syntax error          */
1311 String s; {
1312     ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1313     EEND;
1314 }
1315
1316 static String local unexpected() {     /* find name for unexpected token   */
1317     static char buffer[100];
1318     static char *fmt = "%s \"%s\"";
1319     static char *kwd = "keyword";
1320
1321     switch (yychar) {
1322         case 0         : return "end of input";
1323
1324 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1325         case INFIXL    : keyword("infixl");
1326         case INFIXR    : keyword("infixr");
1327         case INFIXN    : keyword("infix");
1328         case FOREIGN   : keyword("foreign");
1329         case UNSAFE    : keyword("unsafe");
1330         case TINSTANCE : keyword("instance");
1331         case TCLASS    : keyword("class");
1332         case CASEXP    : keyword("case");
1333         case OF        : keyword("of");
1334         case IF        : keyword("if");
1335         case THEN      : keyword("then");
1336         case ELSE      : keyword("else");
1337         case WHERE     : keyword("where");
1338         case TYPE      : keyword("type");
1339         case DATA      : keyword("data");
1340         case TNEWTYPE  : keyword("newtype");
1341         case LET       : keyword("let");
1342         case IN        : keyword("in");
1343         case DERIVING  : keyword("deriving");
1344         case DEFAULT   : keyword("default");
1345         case IMPORT    : keyword("import");
1346         case TMODULE   : keyword("module");
1347           /* AJG: Hugs98/Classic use the keyword forall
1348                   rather than __forall.
1349                   Agree on one or the other
1350           */
1351         case ALL       : keyword("__forall");
1352 #if IPARAM
1353         case DLET      : keyword("dlet");
1354         case WITH      : keyword("with");
1355 #endif
1356 #undef keyword
1357
1358         case ARROW     : return "`->'";
1359         case '='       : return "`='";
1360         case COCO      : return "`::'";
1361         case '-'       : return "`-'";
1362         case '!'       : return "`!'";
1363         case ','       : return "comma";
1364         case '@'       : return "`@'";
1365         case '('       : return "`('";
1366         case ')'       : return "`)'";
1367         case '{'       : return "`{', possibly due to bad layout";
1368         case '}'       : return "`}', possibly due to bad layout";
1369         case '_'       : return "`_'";
1370         case '|'       : return "`|'";
1371         case '.'       : return "`.'";
1372         case ';'       : return "`;', possibly due to bad layout";
1373         case UPTO      : return "`..'";
1374         case '['       : return "`['";
1375         case ']'       : return "`]'";
1376         case FROM      : return "`<-'";
1377         case '\\'      : return "backslash (lambda)";
1378         case '~'       : return "tilde";
1379         case '`'       : return "backquote";
1380 #if TREX
1381         case RECSELID  : sprintf(buffer,"selector \"#%s\"",
1382                                  textToStr(extText(snd(yylval))));
1383                          return buffer;
1384 #endif
1385 #if IPARAM
1386         case IPVARID   : sprintf(buffer,"implicit parameter \"?%s\"",
1387                                  textToStr(textOf(yylval)));
1388                          return buffer;
1389 #endif
1390         case VAROP     :
1391         case VARID     :
1392         case CONOP     :
1393         case CONID     : sprintf(buffer,"symbol \"%s\"",
1394                                  textToStr(textOf(yylval)));
1395                          return buffer;
1396         case QVAROP    :
1397         case QVARID    :
1398         case QCONOP    : 
1399         case QCONID    : sprintf(buffer,"symbol \"%s\"",
1400                                  identToStr(yylval));
1401                          return buffer;
1402         case HIDING    : return "symbol \"hiding\"";
1403         case QUALIFIED : return "symbol \"qualified\"";
1404         case PRIVILEGED : return "symbol \"privileged\"";
1405         case ASMOD     : return "symbol \"as\"";
1406         case NUMLIT    : return "numeric literal";
1407         case CHARLIT   : return "character literal";
1408         case STRINGLIT : return "string literal";
1409         case IMPLIES   : return "`=>'";
1410         default        : return "token";
1411     }
1412 }
1413
1414 static Cell local checkPrec(p)          /* Check for valid precedence value*/
1415 Cell p; {
1416     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1417         ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1418                     MIN_PREC, MAX_PREC
1419         EEND;
1420     }
1421     return p;
1422 }
1423
1424 static Cell local buildTuple(tup)       /* build tuple (x1,...,xn) from    */
1425 List tup; {                             /* list [xn,...,x1]                */
1426     Int  n = 0;
1427     Cell t = tup;
1428     Cell x;
1429
1430     do {                                /*    .                    .       */
1431         x      = fst(t);                /*   / \                  / \      */
1432         fst(t) = snd(t);                /*  xn  .                .   xn    */
1433         snd(t) = x;                     /*       .    ===>      .          */
1434         x      = t;                     /*        .            .           */
1435         t      = fun(x);                /*         .          .            */
1436         n++;                            /*        / \        / \           */
1437     } while (nonNull(t));               /*       x1  NIL   (n)  x1         */
1438     fst(x) = mkTuple(n);
1439     return tup;
1440 }
1441
1442 static List local checkCtxt(con)     /* validate context                */
1443 Type con; {
1444     mapOver(checkPred, con);
1445     return con;
1446 }
1447
1448 static Cell local checkPred(c)          /* check that type expr is a valid */
1449 Cell c; {                               /* constraint                      */
1450     Cell cn = getHead(c);
1451 #if TREX
1452     if (isExt(cn) && argCount==1)
1453         return c;
1454 #endif
1455 #if IPARAM
1456     if (isIP(cn))
1457         return c;
1458 #endif
1459     if (!isQCon(cn) /*|| argCount==0*/)
1460         syntaxError("class expression");
1461     return c;
1462 }
1463
1464 static Pair local checkDo(dqs)          /* convert reversed list of dquals */
1465 List dqs; {                             /* to an (expr,quals) pair         */
1466     if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1467         ERRMSG(row) "Last generator in do {...} must be an expression"
1468         EEND;
1469     }
1470     fst(dqs) = snd(fst(dqs));           /* put expression in fst of pair   */
1471     snd(dqs) = rev(snd(dqs));           /* & reversed list of quals in snd */
1472     return dqs;
1473 }
1474
1475 static Cell local checkTyLhs(c)         /* check that lhs is of the form   */
1476 Cell c; {                               /* T a1 ... a                      */
1477     Cell tlhs = c;
1478     while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
1479         tlhs = fun(tlhs);
1480     }
1481     if (whatIs(tlhs)!=CONIDCELL) {
1482         ERRMSG(row) "Illegal left hand side in datatype definition"
1483         EEND;
1484     }
1485     return c;
1486 }
1487
1488
1489 #if !TREX
1490 static Void local noTREX(where)
1491 String where; {
1492     ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1493     ERRTEXT     "(TREX is disabled in this build of Hugs)"
1494     EEND;
1495 }
1496 #endif
1497 #if !IPARAM
1498 static Void local noIP(where)
1499 String where; {
1500     ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
1501     ERRTEXT     "(Implicit Parameters are disabled in this build of Hugs)"
1502     EEND;
1503 }
1504 #endif
1505
1506 /*-------------------------------------------------------------------------*/