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