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.30 $
  16  * $Date: 2000/04/25 17:43:50 $
  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 %token MDO
  84 /*#if IPARAM*/
  85 %token WITH DLET
  86 /*#endif*/
  87 %token REPEAT     ALL        NUMLIT     CHARLIT    STRINGLIT
  88 %token VAROP      VARID      CONOP      CONID
  89 %token QVAROP     QVARID     QCONOP     QCONID
  90 /*#if TREX*/
  91 %token RECSELID   IPVARID
  92 /*#endif*/
  93 %token COCO       '='        UPTO       '@'        '\\'
  94 %token '|'        '-'        FROM       ARROW      '~'
  95 %token '!'        IMPLIES    '('        ','        ')'
  96 %token '['        ';'        ']'        '`'        '.'
  97 %token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD
  98 %token EXPORT     UUEXPORT   INTERFACE  REQUIRES   UNSAFE
  99 %token INSTIMPORT DYNAMIC    CCALL      STDKALL
 100 %token UTL        UTR        UUUSAGE
 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 STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
 124                                         {$$ = gc8(ap(I_INTERFACE,
 125                                                      zpair($3,$8))); }
 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
 446           | begin modBody end           {ConId fakeNm = mkCon(module(
 447                                             moduleBeingParsed).text);
 448                                          $$ = gc2(ap(M_MODULE,
 449                                                   ztriple(fakeNm,
 450                                                   singleton(ap(MODULEENT,fakeNm)),
 451                                                   $2)));}
 452
 453           | TMODULE error               {syntaxError("module definition");}
 454           ;
 455
 456 modname   : CONID                       {$$ = gc1($1);}
 457           ;
 458 modid     : CONID                       {$$ = gc1($1);}
 459           ;
 460 modBody   : topDecls                    {$$ = gc1($1);}
 461           | impDecls                    {$$ = gc1($1);}
 462           | impDecls ';' topDecls       {$$ = gc3(appendOnto($1,$3));}
 463           ;
 464
 465 /*- Exports: --------------------------------------------------------------*/
 466
 467 expspec   : '(' ')'                     {$$ = gc2(NIL);}
 468           | '(' exports ')'             {$$ = gc3($2);}
 469           | '(' exports ',' ')'         {$$ = gc4($2);}
 470           ;
 471 exports   : exports ',' export          {$$ = gc3(cons($3,$1));}
 472           | export                      {$$ = gc1(singleton($1));}
 473           ;
 474 /* The qcon should be qconid.
 475  * Relaxing the rule lets us explicitly export (:) from the Prelude.
 476  */
 477 export    : qvar                        {$$ = $1;}
 478           | qcon                        {$$ = $1;}
 479           | qconid '(' UPTO ')'         {$$ = gc4(pair($1,DOTDOT));}
 480           | qconid '(' qnames ')'       {$$ = gc4(pair($1,$3));}
 481           | TMODULE modid               {$$ = gc2(ap(MODULEENT,$2));}
 482           ;
 483 qnames    : /* empty */                 {$$ = gc0(NIL);}
 484           | ','                         {$$ = gc1(NIL);}
 485           | qnames1                     {$$ = $1;}
 486           | qnames1 ','                 {$$ = gc2($1);}
 487           ;
 488 qnames1   : qnames1 ',' qname           {$$ = gc3(cons($3,$1));}
 489           | qname                       {$$ = gc1(singleton($1));}
 490           ;
 491 qname     : qvar                        {$$ = $1;}
 492           | qcon                        {$$ = $1;}
 493           ;
 494
 495 /*- Import declarations: --------------------------------------------------*/
 496
 497 impDecls  : impDecls ';' impDecl        {$$ = gc3(appendOnto($3,$1));}
 498           | impDecl                     {$$ = gc1($1);}
 499           ;
 500
 501 /* Note that qualified import ignores the import list. */
 502 impDecl   : IMPORT modid impspec        {$$=gc3(doubleton(
 503                                               ap(M_IMPORT_Q,zpair($2,$2)),
 504                                               ap(M_IMPORT_UNQ,zpair($2,$3))
 505                                             ));}
 506           | IMPORT modid ASMOD modid impspec
 507                                         {$$=gc5(doubleton(
 508                                               ap(M_IMPORT_Q,zpair($2,$4)),
 509                                               ap(M_IMPORT_UNQ,zpair($2,$5))
 510                                          ));}
 511           | IMPORT QUALIFIED modid ASMOD modid impspec
 512                                         {$$=gc6(singleton(
 513                                                ap(M_IMPORT_Q,zpair($3,$5))
 514                                             ));}
 515           | IMPORT QUALIFIED modid impspec
 516                                         {$$=gc4(singleton(
 517                                                ap(M_IMPORT_Q,zpair($3,$3))
 518                                             ));}
 519           | IMPORT error                {syntaxError("import declaration");}
 520           ;
 521 impspec   : /* empty */                 {$$ = gc0(DOTDOT);}
 522           | HIDING '(' imports ')'      {$$ = gc4(ap(HIDDEN,$3));}
 523           | '(' imports ')'             {$$ = gc3($2);}
 524           ;
 525 imports   : /* empty */                 {$$ = gc0(NIL);}
 526           | ','                         {$$ = gc1(NIL);}
 527           | imports1                    {$$ = $1;}
 528           | imports1 ','                {$$ = gc2($1);}
 529           ;
 530 imports1  : imports1 ',' import         {$$ = gc3(cons($3,$1));}
 531           | import                      {$$ = gc1(singleton($1));}
 532           ;
 533 import    : var                         {$$ = $1;}
 534           | CONID                       {$$ = $1;}
 535           | CONID '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
 536           | CONID '(' names ')'         {$$ = gc4(pair($1,$3));}
 537           ;
 538 names     : /* empty */                 {$$ = gc0(NIL);}
 539           | ','                         {$$ = gc1(NIL);}
 540           | names1                      {$$ = $1;}
 541           | names1 ','                  {$$ = gc2($1);}
 542           ;
 543 names1    : names1 ',' name             {$$ = gc3(cons($3,$1));}
 544           | name                        {$$ = gc1(singleton($1));}
 545           ;
 546 name      : var                         {$$ = $1;}
 547           | con                         {$$ = $1;}
 548           ;
 549
 550 /*- Top-level declarations: -----------------------------------------------*/
 551
 552 topDecls : /* empty */                  {$$=gc0(NIL);}
 553          | topDecl ';' topDecls         {$$=gc3(cons($1,$3));}
 554          | decl    ';' topDecls         {$$=gc3(cons(ap(M_VALUE,$1),$3));}
 555          | topDecl                      {$$=gc1(cons($1,NIL));}
 556          | decl                         {$$=gc1(cons(ap(M_VALUE,$1),NIL));}
 557          ;
 558
 559 /*- Type declarations: ----------------------------------------------------*/
 560
 561 topDecl   : TYPE tyLhs '=' type         {$$=gc4(ap(M_TYCON,
 562                                                    z4ble($3,$2,$4,
 563                                                          SYNONYM)));}
 564           | TYPE tyLhs '=' type IN invars
 565                                         {$$=gc6(ap(M_TYCON,
 566                                                    z4ble($3,$2,ap($4,$6),
 567                                                          RESTRICTSYN)));}
 568           | TYPE error                  {syntaxError("type definition");}
 569           | DATA btype2 '=' constrs deriving
 570                                         {$$=gc5(ap(M_TYCON,
 571                                                 z4ble($3,checkTyLhs($2),
 572                                                       ap(rev($4),$5),
 573                                                       DATATYPE)));}
 574           | DATA context IMPLIES tyLhs '=' constrs deriving
 575                                         {$$=gc7(ap(M_TYCON,
 576                                                    z4ble($5,$4,
 577                                                       ap(qualify($2,rev($6)),$7),
 578                                                       DATATYPE)));}
 579           | DATA btype2                 {$$=gc2(ap(M_TYCON,
 580                                                    z4ble($1,checkTyLhs($2),
 581                                                       ap(NIL,NIL),DATATYPE)));}
 582           | DATA context IMPLIES tyLhs  {$$=gc4(ap(M_TYCON,
 583                                                   z4ble($1,$4,
 584                                                         ap(qualify($2,NIL),NIL),
 585                                                         DATATYPE)));}
 586           | DATA error                  {syntaxError("data definition");}
 587           | TNEWTYPE btype2 '=' nconstr deriving
 588                                         {$$=gc5(ap(M_TYCON,
 589                                                    z4ble($3,checkTyLhs($2),
 590                                                          ap($4,$5),NEWTYPE)));}
 591           | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
 592                                         {$$=gc7(ap(M_TYCON,
 593                                                    z4ble($5,$4,
 594                                                          ap(qualify($2,$6),$7),
 595                                                          NEWTYPE)));}
 596           | TNEWTYPE error              {syntaxError("newtype definition");}
 597           ;
 598 tyLhs     : tyLhs varid                 {$$ = gc2(ap($1,$2));}
 599           | CONID                       {$$ = $1;}
 600           | error                       {syntaxError("type defn lhs");}
 601           ;
 602 invars    : invars ',' invar            {$$ = gc3(cons($3,$1));}
 603           | invar                       {$$ = gc1(cons($1,NIL));}
 604           ;
 605 invar     : var COCO topType            {$$ = gc3(sigdecl($2,singleton($1),
 606                                                                        $3));}
 607           | var                         {$$ = $1;}
 608           ;
 609 constrs   : constrs '|' pconstr         {$$ = gc3(cons($3,$1));}
 610           | pconstr                     {$$ = gc1(cons($1,NIL));}
 611           ;
 612 pconstr   : ALL varids '.' qconstr      {$$ = gc4(ap(POLYTYPE,
 613                                                      pair(rev($2),$4)));}
 614           | qconstr                     {$$ = $1;}
 615           ;
 616 qconstr   : context IMPLIES constr      {$$ = gc3(qualify($1,$3));}
 617           | constr                      {$$ = $1;}
 618           ;
 619 constr    : '!' btype conop bbtype      {$$ = gc4(ap(ap($3,bang($2)),$4));}
 620           | btype1    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 621           | btype2    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 622           | bpolyType conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 623           | btype2                      {$$ = $1;}
 624           | btype3                      {$$ = $1;}
 625           | btype4                      {$$ = $1;}
 626           | con '{' fieldspecs '}'      {$$ = gc4(ap(LABC,pair($1,rev($3))));}
 627           | con '{' '}'                 {$$ = gc3(ap(LABC,pair($1,NIL)));}
 628           | error                       {syntaxError("data type definition");}
 629           ;
 630 btype3    : btype2 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 631           | btype3 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 632           | btype3 atype                {$$ = gc2(ap($1,$2));}
 633           ;
 634 btype4    : btype2 bpolyType            {$$ = gc2(ap($1,$2));}
 635           | btype3 bpolyType            {$$ = gc2(ap($1,$2));}
 636           | btype4 bpolyType            {$$ = gc2(ap($1,$2));}
 637           | btype4 atype                {$$ = gc2(ap($1,$2));}
 638           | btype4 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 639           ;
 640 bbtype    : '!' btype                   {$$ = gc2(bang($2));}
 641           | btype                       {$$ = $1;}
 642           | bpolyType                   {$$ = $1;}
 643           ;
 644 nconstr   : pconstr                     {$$ = gc1(singleton($1));}
 645           ;
 646 fieldspecs: fieldspecs ',' fieldspec    {$$ = gc3(cons($3,$1));}
 647           | fieldspec                   {$$ = gc1(cons($1,NIL));}
 648           ;
 649 fieldspec : vars COCO polyType          {$$ = gc3(pair(rev($1),$3));}
 650           | vars COCO type              {$$ = gc3(pair(rev($1),$3));}
 651           | vars COCO '!' type          {$$ = gc4(pair(rev($1),bang($4)));}
 652           ;
 653 deriving  : /* empty */                 {$$ = gc0(NIL);}
 654           | DERIVING qconid             {$$ = gc2(singleton($2));}
 655           | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
 656           ;
 657 derivs0   : /* empty */                 {$$ = gc0(NIL);}
 658           | derivs                      {$$ = gc1(rev($1));}
 659           ;
 660 derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
 661           | qconid                      {$$ = gc1(singleton($1));}
 662           ;
 663
 664 /*- Processing definitions of primitives ----------------------------------*/
 665
 666 topDecl   : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type
 667                {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));}
 668           | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
 669                {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));}
 670           | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
 671                {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));}
 672           ;
 673
 674 callconv  : CCALL                {$$ = gc1(textCcall);}
 675           | STDKALL              {$$ = gc1(textStdcall);}
 676           | /* empty */          {$$ = gc0(NIL);}
 677           ;
 678 ext_loc   : STRINGLIT            {$$ = $1;}
 679           ;
 680 ext_name  : STRINGLIT            {$$ = $1;}
 681           ;
 682 unsafe_flag: /* empty */         {$$ = gc0(NIL);}
 683           | UNSAFE               {$$ = gc1(NIL); /* ignored */ }
 684           ;
 685
 686
 687 /*- Class declarations: ---------------------------------------------------*/
 688
 689 topDecl   : TCLASS crule fds wherePart  {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));}
 690           | TINSTANCE irule wherePart   {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));}
 691           | DEFAULT '(' dtypes ')'      {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));}
 692           | TCLASS error                {syntaxError("class declaration");}
 693           | TINSTANCE error             {syntaxError("instance declaration");}
 694           | DEFAULT error               {syntaxError("default declaration");}
 695           ;
 696 crule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 697           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 698           ;
 699 irule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 700           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 701           ;
 702 dtypes    : /* empty */                 {$$ = gc0(NIL);}
 703           | dtypes1                     {$$ = gc1(rev($1));}
 704           ;
 705 dtypes1   : dtypes1 ',' type            {$$ = gc3(cons($3,$1));}
 706           | type                        {$$ = gc1(cons($1,NIL));}
 707           ;
 708
 709 fds       : /* empty */                 {$$ = gc0(NIL);}
 710           | '|' fds1                    {h98DoesntSupport(row,"dependent parameters");
 711                                          $$ = gc2(rev($2));}
 712           ;
 713 fds1      : fds1 ',' fd                 {$$ = gc3(cons($3,$1));}
 714           | fd                          {$$ = gc1(cons($1,NIL));}
 715           |
 716           ;
 717 fd        : varids0 ARROW varids0       {$$ = gc3(pair(rev($1),rev($3)));}
 718           ;
 719 varids0   : /* empty */                 {$$ = gc0(NIL);}
 720           | varids0 varid               {$$ = gc2(cons($2,$1));}
 721           ;
 722
 723   /*- Type expressions: -----------------------------------------------------*/
 724
 725 topType   : ALL varids '.' topType0     {$$ = gc4(ap(POLYTYPE,
 726                                                      pair(rev($2),$4)));}
 727           | topType0                    {$$ = $1;}
 728           ;
 729 topType0  : context IMPLIES topType1    {$$ = gc3(qualify($1,$3));}
 730           | topType1                    {$$ = $1;}
 731           ;
 732 topType1  : bpolyType ARROW topType1    {$$ = gc3(fn($1,$3));}
 733           | btype1    ARROW topType1    {$$ = gc3(fn($1,$3));}
 734           | btype2    ARROW topType1    {$$ = gc3(fn($1,$3));}
 735           | btype                       {$$ = $1;}
 736           ;
 737 polyType  : ALL varids '.' sigType      {$$ = gc4(ap(POLYTYPE,
 738                                                      pair(rev($2),$4)));}
 739           | context IMPLIES type        {$$ = gc3(qualify($1,$3));}
 740           | bpolyType                   {$$ = $1;}
 741           ;
 742 bpolyType : '(' polyType ')'            {$$ = gc3($2);}
 743           ;
 744 varids    : varids varid                {$$ = gc2(cons($2,$1));}
 745           | varid                       {$$ = gc1(singleton($1));}
 746           ;
 747 sigType   : context IMPLIES type        {$$ = gc3(qualify($1,$3));}
 748           | type                        {$$ = $1;}
 749           ;
 750 context   : '(' ')'                     {$$ = gc2(NIL);}
 751           | btype2                      {$$ = gc1(singleton(checkPred($1)));}
 752           | '(' btype2 ')'              {$$ = gc3(singleton(checkPred($2)));}
 753           | '(' btypes2 ')'             {$$ = gc3(checkCtxt(rev($2)));}
 754 /*#if TREX*/
 755           | lacks                       {$$ = gc1(singleton($1));}
 756           | '(' lacks1 ')'              {$$ = gc3(checkCtxt(rev($2)));}
 757           ;
 758 lacks     : varid '\\' varid            {
 759 #if TREX
 760                                          $$ = gc3(ap(mkExt(textOf($3)),$1));
 761 #else
 762                                          noTREX("a type context");
 763 #endif
 764                                         }
 765           | IPVARID COCO type           {
 766 #if IPARAM
 767                                          $$ = gc3(pair(mkIParam($1),$3));
 768 #else
 769                                          noIP("a type context");
 770 #endif
 771                                         }
 772           ;
 773 lacks1    : btypes2 ',' lacks           {$$ = gc3(cons($3,$1));}
 774           | lacks1  ',' btype2          {$$ = gc3(cons($3,$1));}
 775           | lacks1  ',' lacks           {$$ = gc3(cons($3,$1));}
 776           | btype2  ',' lacks           {$$ = gc3(cons($3,cons($1,NIL)));}
 777           | lacks                       {$$ = gc1(singleton($1));}
 778           ;
 779 /*#endif*/
 780
 781 type      : type1                       {$$ = $1;}
 782           | btype2                      {$$ = $1;}
 783           ;
 784 type1     : btype1                      {$$ = $1;}
 785           | btype1 ARROW type           {$$ = gc3(fn($1,$3));}
 786           | btype2 ARROW type           {$$ = gc3(fn($1,$3));}
 787           | error                       {syntaxError("type expression");}
 788           ;
 789 btype     : btype1                      {$$ = $1;}
 790           | btype2                      {$$ = $1;}
 791           ;
 792 btype1    : btype1 atype                {$$ = gc2(ap($1,$2));}
 793           | atype1                      {$$ = $1;}
 794           ;
 795 btype2    : btype2 atype                {$$ = gc2(ap($1,$2));}
 796           | qconid                      {$$ = $1;}
 797           ;
 798 atype     : atype1                      {$$ = $1;}
 799           | qconid                      {$$ = $1;}
 800           ;
 801 atype1    : varid                       {$$ = $1;}
 802           | '(' ')'                     {$$ = gc2(typeUnit);}
 803           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
 804           | '(' type1 ')'               {$$ = gc3($2);}
 805           | '(' btype2 ')'              {$$ = gc3($2);}
 806           | '(' tupCommas ')'           {$$ = gc3($2);}
 807           | '(' btypes2 ')'             {$$ = gc3(buildTuple($2));}
 808           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 809           | '(' tfields ')'             {
 810 #if TREX
 811                                          $$ = gc3(revOnto($2,typeNoRow));
 812 #else
 813                                          noTREX("a type");
 814 #endif
 815                                         }
 816           | '(' tfields '|' type ')'    {
 817 #if TREX
 818                                          $$ = gc5(revOnto($2,$4));
 819 #else
 820                                          noTREX("a type");
 821 #endif
 822                                         }
 823           | '[' type ']'                {$$ = gc3(ap(typeList,$2));}
 824           | '[' ']'                     {$$ = gc2(typeList);}
 825           | '_'                         {h98DoesntSupport(row,"anonymous type variables");
 826                                          $$ = gc1(inventVar());}
 827           ;
 828 btypes2   : btypes2 ',' btype2          {$$ = gc3(cons($3,$1));}
 829           | btype2  ',' btype2          {$$ = gc3(cons($3,cons($1,NIL)));}
 830           ;
 831 typeTuple : type1     ',' type          {$$ = gc3(cons($3,cons($1,NIL)));}
 832           | btype2    ',' type1         {$$ = gc3(cons($3,cons($1,NIL)));}
 833           | btypes2   ',' type1         {$$ = gc3(cons($3,$1));}
 834           | typeTuple ',' type          {$$ = gc3(cons($3,$1));}
 835           ;
 836 /*#if TREX*/
 837 tfields   : tfields ',' tfield          {$$ = gc3(cons($3,$1));}
 838           | tfield                      {$$ = gc1(singleton($1));}
 839           ;
 840 tfield    : varid COCO type             {h98DoesntSupport(row,"extensible records");
 841                                          $$ = gc3(ap(mkExt(textOf($1)),$3));}
 842           ;
 843 /*#endif*/
 844
 845 /*- Value declarations: ---------------------------------------------------*/
 846
 847 gendecl   : INFIXN optDigit ops         {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
 848           | INFIXN error                {syntaxError("fixity decl");}
 849           | INFIXL optDigit ops         {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
 850           | INFIXL error                {syntaxError("fixity decl");}
 851           | INFIXR optDigit ops         {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
 852           | INFIXR error                {syntaxError("fixity decl");}
 853           | vars COCO topType           {$$ = gc3(sigdecl($2,$1,$3));}
 854           | vars COCO error             {syntaxError("type signature");}
 855           ;
 856 optDigit  : NUMLIT                      {$$ = gc1(checkPrec($1));}
 857           | /* empty */                 {$$ = gc0(mkInt(DEF_PREC));}
 858           ;
 859 ops       : ops ',' op                  {$$ = gc3(cons($3,$1));}
 860           | op                          {$$ = gc1(singleton($1));}
 861           ;
 862 vars      : vars ',' var                {$$ = gc3(cons($3,$1));}
 863           | var                         {$$ = gc1(singleton($1));}
 864           ;
 865 decls     : '{' decls0 end              {$$ = gc3($2);}
 866           | '{' decls1 end              {$$ = gc3($2);}
 867           ;
 868 decls0    : /* empty */                 {$$ = gc0(NIL);}
 869           | decls0 ';'                  {$$ = gc2($1);}
 870           | decls1 ';'                  {$$ = gc2($1);}
 871           ;
 872 decls1    : decls0 decl                 {$$ = gc2(cons($2,$1));}
 873           ;
 874 decl      : gendecl                     {$$ = $1;}
 875           | funlhs rhs                  {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
 876           | funlhs COCO type rhs        {$$ = gc4(ap(FUNBIND,
 877                                                      pair($1,ap(RSIGN,
 878                                                                 ap($4,$3)))));}
 879           | pat0 rhs                    {$$ = gc2(ap(PATBIND,pair($1,$2)));}
 880           ;
 881 funlhs    : funlhs0                     {$$ = $1;}
 882           | funlhs1                     {$$ = $1;}
 883           | npk                         {$$ = $1;}
 884           ;
 885 funlhs0   : pat10_vI varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 886           | infixPat varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 887           | NUMLIT   varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 888           | var      varop_pl pat0      {$$ = gc3(ap2($2,$1,$3));}
 889           | var      '+'      pat0_INT  {$$ = gc3(ap2(varPlus,$1,$3));}
 890           ;
 891 funlhs1   : '(' funlhs0 ')' apat        {$$ = gc4(ap($2,$4));}
 892           | '(' funlhs1 ')' apat        {$$ = gc4(ap($2,$4));}
 893           | '(' npk     ')' apat        {$$ = gc4(ap($2,$4));}
 894           | var     apat                {$$ = gc2(ap($1,$2));}
 895           | funlhs1 apat                {$$ = gc2(ap($1,$2));}
 896           ;
 897 rhs       : rhs1 wherePart              {$$ = gc2(letrec($2,$1));}
 898           | error                       {syntaxError("declaration");}
 899           ;
 900 rhs1      : '=' exp                     {$$ = gc2(pair($1,$2));}
 901           | gdrhs                       {$$ = gc1(grded(rev($1)));}
 902           ;
 903 gdrhs     : gdrhs gddef                 {$$ = gc2(cons($2,$1));}
 904           | gddef                       {$$ = gc1(singleton($1));}
 905           ;
 906 gddef     : '|' exp0 '=' exp            {$$ = gc4(pair($3,pair($2,$4)));}
 907           ;
 908 wherePart : /* empty */                 {$$ = gc0(NIL);}
 909           | WHERE decls                 {$$ = gc2($2);}
 910           ;
 911
 912 /*- Patterns: -------------------------------------------------------------*/
 913
 914 pat       : npk                         {$$ = $1;}
 915           | pat_npk                     {$$ = $1;}
 916           ;
 917 pat_npk   : pat0 COCO type              {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 918           | pat0                        {$$ = $1;}
 919           ;
 920 npk       : var '+' NUMLIT              {$$ = gc3(ap2(varPlus,$1,$3));}
 921           ;
 922 pat0      : var                         {$$ = $1;}
 923           | NUMLIT                      {$$ = $1;}
 924           | pat0_vI                     {$$ = $1;}
 925           ;
 926 pat0_INT  : var                         {$$ = $1;}
 927           | pat0_vI                     {$$ = $1;}
 928           ;
 929 pat0_vI   : pat10_vI                    {$$ = $1;}
 930           | infixPat                    {$$ = gc1(ap(INFIX,$1));}
 931           ;
 932 infixPat  : '-' pat10                   {$$ = gc2(ap(NEG,only($2)));}
 933           | '-' error                   {syntaxError("pattern");}
 934           | var qconop pat10            {$$ = gc3(ap(ap($2,only($1)),$3));}
 935           | var qconop '-' pat10        {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 936           | NUMLIT qconop pat10         {$$ = gc3(ap(ap($2,only($1)),$3));}
 937           | NUMLIT qconop '-' pat10     {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 938           | pat10_vI qconop pat10       {$$ = gc3(ap(ap($2,only($1)),$3));}
 939           | pat10_vI qconop '-' pat10   {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 940           | infixPat qconop pat10       {$$ = gc3(ap(ap($2,$1),$3));}
 941           | infixPat qconop '-' pat10   {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 942           ;
 943 pat10     : fpat                        {$$ = $1;}
 944           | apat                        {$$ = $1;}
 945           ;
 946 pat10_vI  : fpat                        {$$ = $1;}
 947           | apat_vI                     {$$ = $1;}
 948           ;
 949 fpat      : fpat apat                   {$$ = gc2(ap($1,$2));}
 950           | gcon apat                   {$$ = gc2(ap($1,$2));}
 951           ;
 952 apat      : NUMLIT                      {$$ = $1;}
 953           | var                         {$$ = $1;}
 954           | apat_vI                     {$$ = $1;}
 955           ;
 956 apat_vI   : var '@' apat                {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 957           | gcon                        {$$ = $1;}
 958           | qcon '{' patbinds '}'       {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 959           | CHARLIT                     {$$ = $1;}
 960           | STRINGLIT                   {$$ = $1;}
 961           | '_'                         {$$ = gc1(WILDCARD);}
 962           | '(' pat_npk ')'             {$$ = gc3($2);}
 963           | '(' npk ')'                 {$$ = gc3($2);}
 964           | '(' pats2 ')'               {$$ = gc3(buildTuple($2));}
 965           | '[' pats1 ']'               {$$ = gc3(ap(FINLIST,rev($2)));}
 966           | '~' apat                    {$$ = gc2(ap(LAZYPAT,$2));}
 967 /*#if TREX*/
 968           | '(' patfields ')'           {
 969 #if TREX
 970                                          $$ = gc3(revOnto($2,nameNoRec));
 971 #else
 972                                          $$ = gc3(NIL);
 973 #endif
 974                                         }
 975           | '(' patfields '|' pat ')'   {$$ = gc5(revOnto($2,$4));}
 976 /*#endif TREX*/
 977           ;
 978 pats2     : pats2 ',' pat               {$$ = gc3(cons($3,$1));}
 979           | pat ',' pat                 {$$ = gc3(cons($3,singleton($1)));}
 980           ;
 981 pats1     : pats1 ',' pat               {$$ = gc3(cons($3,$1));}
 982           | pat                         {$$ = gc1(singleton($1));}
 983           ;
 984 patbinds  : /* empty */                 {$$ = gc0(NIL);}
 985           | patbinds1                   {$$ = gc1(rev($1));}
 986           ;
 987 patbinds1 : patbinds1 ',' patbind       {$$ = gc3(cons($3,$1));}
 988           | patbind                     {$$ = gc1(singleton($1));}
 989           ;
 990 patbind   : qvar '=' pat                {$$ = gc3(pair($1,$3));}
 991           | var                         {$$ = $1;}
 992           ;
 993 /*#if TREX*/
 994 patfields : patfields ',' patfield      {$$ = gc3(cons($3,$1));}
 995           | patfield                    {$$ = gc1(singleton($1));}
 996           ;
 997 patfield  : varid '=' pat               {
 998 #if TREX
 999                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
1000 #else
1001                                          noTREX("a pattern");
1002 #endif
1003                                         }
1004           ;
1005 /*#endif TREX*/
1006
1007 /*- Expressions: ----------------------------------------------------------*/
1008
1009 exp       : exp_err                     {$$ = $1;}
1010           | error                       {syntaxError("expression");}
1011           ;
1012 exp_err   : exp0a COCO sigType          {$$ = gc3(ap(ESIGN,pair($1,$3)));}
1013           | exp0a WITH dbinds           {
1014 #if IPARAM
1015                                          $$ = gc3(ap(WITHEXP,pair($1,$3)));
1016 #else
1017                                          noIP("an expression");
1018 #endif
1019                                         }
1020           | exp0                        {$$ = $1;}
1021           ;
1022 exp0      : exp0a                       {$$ = $1;}
1023           | exp0b                       {$$ = $1;}
1024           ;
1025 exp0a     : infixExpa                   {$$ = gc1(ap(INFIX,$1));}
1026           | exp10a                      {$$ = $1;}
1027           ;
1028 exp0b     : infixExpb                   {$$ = gc1(ap(INFIX,$1));}
1029           | exp10b                      {$$ = $1;}
1030           ;
1031 infixExpa : infixExpa qop '-' exp10a    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1032           | infixExpa qop exp10a        {$$ = gc3(ap(ap($2,$1),$3));}
1033           | '-' exp10a                  {$$ = gc2(ap(NEG,only($2)));}
1034           | exp10a qop '-' exp10a       {$$ = gc4(ap(NEG,
1035                                                      ap(ap($2,only($1)),$4)));}
1036           | exp10a qop exp10a           {$$ = gc3(ap(ap($2,only($1)),$3));}
1037           ;
1038 infixExpb : infixExpa qop '-' exp10b    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
1039           | infixExpa qop exp10b        {$$ = gc3(ap(ap($2,$1),$3));}
1040           | '-' exp10b                  {$$ = gc2(ap(NEG,only($2)));}
1041           | exp10a qop '-' exp10b       {$$ = gc4(ap(NEG,
1042                                                      ap(ap($2,only($1)),$4)));}
1043           | exp10a qop exp10b           {$$ = gc3(ap(ap($2,only($1)),$3));}
1044           ;
1045 exp10a    : CASEXP exp OF '{' alts end  {$$ = gc6(ap(CASE,pair($2,rev($5))));}
1046           | DO '{' stmts end            {$$ = gc4(ap(DOCOMP,checkDo($3)));}
1047           | MDO '{' stmts end           {$$ = gc4(ap(DOCOMP,checkDo($3)));}
1048           | appExp                      {$$ = $1;}
1049           ;
1050 exp10b    : '\\' pats ARROW exp         {$$ = gc4(ap(LAMBDA,
1051                                                      pair(rev($2),
1052                                                           pair($3,$4))));}
1053           | LET decls IN exp            {$$ = gc4(letrec($2,$4));}
1054           | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
1055           | DLET dbinds IN exp          {
1056 #if IPARAM
1057                                          $$ = gc4(ap(WITHEXP,pair($4,$2)));
1058 #else
1059                                          noIP("an expression");
1060 #endif
1061                                         }
1062           ;
1063 pats      : pats apat                   {$$ = gc2(cons($2,$1));}
1064           | apat                        {$$ = gc1(cons($1,NIL));}
1065           ;
1066 appExp    : appExp aexp                 {$$ = gc2(ap($1,$2));}
1067           | aexp                        {$$ = $1;}
1068           ;
1069 aexp      : qvar                        {$$ = $1;}
1070           | qvar '@' aexp               {$$ = gc3(ap(ASPAT,pair($1,$3)));}
1071           | '~' aexp                    {$$ = gc2(ap(LAZYPAT,$2));}
1072           | IPVARID                     {$$ = $1;}
1073           | '_'                         {$$ = gc1(WILDCARD);}
1074           | gcon                        {$$ = $1;}
1075           | qcon '{' fbinds '}'         {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
1076           | aexp '{' fbinds '}'         {$$ = gc4(ap(UPDFLDS,
1077                                                      triple($1,NIL,$3)));}
1078           | NUMLIT                      {$$ = $1;}
1079           | CHARLIT                     {$$ = $1;}
1080           | STRINGLIT                   {$$ = $1;}
1081           | REPEAT                      {$$ = $1;}
1082           | '(' exp ')'                 {$$ = gc3($2);}
1083           | '(' exps2 ')'               {$$ = gc3(buildTuple($2));}
1084 /*#if TREX*/
1085           | '(' vfields ')'             {
1086 #if TREX
1087                                          $$ = gc3(revOnto($2,nameNoRec));
1088 #else
1089                                          $$ = gc3(NIL);
1090 #endif
1091                                         }
1092           | '(' vfields '|' exp ')'     {$$ = gc5(revOnto($2,$4));}
1093           | RECSELID                    {$$ = $1;}
1094 /*#endif*/
1095           | '[' list ']'                {$$ = gc3($2);}
1096           | '(' exp10a qop ')'          {$$ = gc4(ap($3,$2));}
1097           | '(' qvarop_mi exp0 ')'      {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1098           | '(' qconop exp0 ')'         {$$ = gc4(ap(ap(nameFlip,$2),$3));}
1099           ;
1100 exps2     : exps2 ',' exp               {$$ = gc3(cons($3,$1));}
1101           | exp ',' exp                 {$$ = gc3(cons($3,cons($1,NIL)));}
1102           ;
1103 /*#if TREX*/
1104 vfields   : vfields ',' vfield          {$$ = gc3(cons($3,$1));}
1105           | vfield                      {$$ = gc1(singleton($1));}
1106           ;
1107 vfield    : varid '=' exp               {
1108 #if TREX
1109                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
1110 #else
1111                                          noTREX("an expression");
1112 #endif
1113                                         }
1114           ;
1115 /*#endif*/
1116 alts      : alts1                       {$$ = $1;}
1117           | alts1 ';'                   {$$ = gc2($1);}
1118           ;
1119 alts1     : alts1 ';' alt               {$$ = gc3(cons($3,$1));}
1120           | alt                         {$$ = gc1(cons($1,NIL));}
1121           ;
1122 alt       : pat altRhs wherePart        {$$ = gc3(pair($1,letrec($3,$2)));}
1123           ;
1124 altRhs    : guardAlts                   {$$ = gc1(grded(rev($1)));}
1125           | ARROW exp                   {$$ = gc2(pair($1,$2));}
1126           | error                       {syntaxError("case expression");}
1127           ;
1128 guardAlts : guardAlts guardAlt          {$$ = gc2(cons($2,$1));}
1129           | guardAlt                    {$$ = gc1(cons($1,NIL));}
1130           ;
1131 guardAlt  : '|' exp0 ARROW exp          {$$ = gc4(pair($3,pair($2,$4)));}
1132           ;
1133 stmts     : stmts1 ';'                  {$$ = gc2($1);}
1134           | stmts1                      {$$ = $1;}
1135           ;
1136 stmts1    : stmts1 ';' stmt             {$$ = gc3(cons($3,$1));}
1137           | stmt                        {$$ = gc1(cons($1,NIL));}
1138           ;
1139 stmt      : exp_err FROM exp            {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1140           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1141 /*        | IF exp                      {$$ = gc2(ap(BOOLQUAL,$2));}*/
1142           | exp_err                     {$$ = gc1(ap(DOQUAL,$1));}
1143           ;
1144 fbinds    : /* empty */                 {$$ = gc0(NIL);}
1145           | fbinds1                     {$$ = gc1(rev($1));}
1146           ;
1147 fbinds1   : fbinds1 ',' fbind           {$$ = gc3(cons($3,$1));}
1148           | fbind                       {$$ = gc1(singleton($1));}
1149           ;
1150 fbind     : var                         {$$ = $1;}
1151           | qvar '=' exp                {$$ = gc3(pair($1,$3));}
1152           ;
1153
1154 dbinds    : '{' dbs0 end                {$$ = gc3($2);}
1155           | '{' dbs1 end                {$$ = gc3($2);}
1156           ;
1157 dbs0      : /* empty */                 {$$ = gc0(NIL);}
1158           | dbs0 ';'                    {$$ = gc2($1);}
1159           | dbs1 ';'                    {$$ = gc2($1);}
1160           ;
1161 dbs1      : dbs0 dbind                  {$$ = gc2(cons($2,$1));}
1162           ;
1163 dbind     : IPVARID '=' exp             {$$ = gc3(pair($1,$3));}
1164           ;
1165
1166 /*- List Expressions: -------------------------------------------------------*/
1167
1168 list      : exp                         {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
1169           | exps2                       {$$ = gc1(ap(FINLIST,rev($1)));}
1170           | exp '|' quals               {$$ = gc3(ap(COMP,pair($1,rev($3))));}
1171           | exp         UPTO exp        {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
1172           | exp ',' exp UPTO            {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
1173           | exp         UPTO            {$$ = gc2(ap(nameFrom,$1));}
1174           | exp ',' exp UPTO exp        {$$ = gc5(ap(ap(ap(nameFromThenTo,
1175                                                                 $1),$3),$5));}
1176           ;
1177 quals     : quals ',' qual              {$$ = gc3(cons($3,$1));}
1178           | qual                        {$$ = gc1(cons($1,NIL));}
1179           ;
1180 qual      : exp FROM exp                {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
1181           | exp                         {$$ = gc1(ap(BOOLQUAL,$1));}
1182           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
1183           ;
1184
1185 /*- Identifiers and symbols: ----------------------------------------------*/
1186
1187 gcon      : qcon                        {$$ = $1;}
1188           | '(' ')'                     {$$ = gc2(nameUnit);}
1189           | '[' ']'                     {$$ = gc2(nameNil);}
1190           | '(' tupCommas ')'           {$$ = gc3($2);}
1191           ;
1192 tupCommas : tupCommas ','               {$$ = gc2(mkTuple(tupleOf($1)+1));}
1193           | ','                         {$$ = gc1(mkTuple(2));}
1194           ;
1195 varid     : VARID                       {$$ = $1;}
1196           | HIDING                      {$$ = gc1(varHiding);}
1197           | QUALIFIED                   {$$ = gc1(varQualified);}
1198           | ASMOD                       {$$ = gc1(varAsMod);}
1199           ;
1200 qconid    : QCONID                      {$$ = $1;}
1201           | CONID                       {$$ = $1;}
1202           ;
1203 var       : varid                       {$$ = $1;}
1204           | '(' VAROP ')'               {$$ = gc3($2);}
1205           | '(' '+' ')'                 {$$ = gc3(varPlus);}
1206           | '(' '-' ')'                 {$$ = gc3(varMinus);}
1207           | '(' '!' ')'                 {$$ = gc3(varBang);}
1208           | '(' '.' ')'                 {$$ = gc3(varDot);}
1209           ;
1210 qvar      : QVARID                      {$$ = $1;}
1211           | '(' QVAROP ')'              {$$ = gc3($2);}
1212           | var                         {$$ = $1;}
1213           ;
1214 con       : CONID                       {$$ = $1;}
1215           | '(' CONOP ')'               {$$ = gc3($2);}
1216           ;
1217 qcon      : QCONID                      {$$ = $1;}
1218           | '(' QCONOP ')'              {$$ = gc3($2);}
1219           | con                         {$$ = $1;}
1220           ;
1221 varop     : '+'                         {$$ = gc1(varPlus);}
1222           | '-'                         {$$ = gc1(varMinus);}
1223           | varop_mipl                  {$$ = $1;}
1224           ;
1225 varop_mi  : '+'                         {$$ = gc1(varPlus);}
1226           | varop_mipl                  {$$ = $1;}
1227           ;
1228 varop_pl  : '-'                         {$$ = gc1(varMinus);}
1229           | varop_mipl                  {$$ = $1;}
1230           ;
1231 varop_mipl: VAROP                       {$$ = $1;}
1232           | '`' varid '`'               {$$ = gc3($2);}
1233           | '!'                         {$$ = gc1(varBang);}
1234           | '.'                         {$$ = gc1(varDot);}
1235           ;
1236 qvarop    : '-'                         {$$ = gc1(varMinus);}
1237           | qvarop_mi                   {$$ = $1;}
1238           ;
1239 qvarop_mi : QVAROP                      {$$ = $1;}
1240           | '`' QVARID '`'              {$$ = gc3($2);}
1241           | varop_mi                    {$$ = $1;}
1242           ;
1243
1244 conop     : CONOP                       {$$ = $1;}
1245           | '`' CONID  '`'              {$$ = gc3($2);}
1246           ;
1247 qconop    : QCONOP                      {$$ = $1;}
1248           | '`' QCONID '`'              {$$ = gc3($2);}
1249           | conop                       {$$ = $1;}
1250           ;
1251 op        : varop                       {$$ = $1;}
1252           | conop                       {$$ = $1;}
1253           ;
1254 qop       : qvarop                      {$$ = $1;}
1255           | qconop                      {$$ = $1;}
1256           ;
1257
1258 /*- Stuff from STG hugs ---------------------------------------------------*/
1259
1260 qvarid    : varid1                      {$$ = gc1($1);}
1261           | QVARID                      {$$ = gc1($1);}
1262
1263 varid1    : VARID                       {$$ = gc1($1);}
1264           | HIDING                      {$$ = gc1(varHiding);}
1265           | QUALIFIED                   {$$ = gc1(varQualified);}
1266           | ASMOD                       {$$ = gc1(varAsMod);}
1267           ;
1268
1269 /*- Tricks to force insertion of leading and closing braces ---------------*/
1270
1271 begin     : error                       {yyerrok;
1272                                          if (offsideON) goOffside(startColumn);}
1273           ;
1274
1275 end       : '}'                         {$$ = $1;}
1276           | error                       {yyerrok;
1277                                          if (offsideON && canUnOffside()) {
1278                                              unOffside();
1279                                              /* insert extra token on stack*/
1280                                              push(NIL);
1281                                              pushed(0) = pushed(1);
1282                                              pushed(1) = mkInt(column);
1283                                          }
1284                                          else
1285                                              syntaxError("definition");
1286                                         }
1287           ;
1288
1289 /*-------------------------------------------------------------------------*/
1290
1291 %%
1292
1293 static Cell local gcShadow(n,e)         /* keep parsed fragments on stack  */
1294 Int  n;
1295 Cell e; {
1296     /* If a look ahead token is held then the required stack transformation
1297      * is:
1298      *   pushed: n               1     0          1     0
1299      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
1300      *                                top()            top()
1301      *
1302      * Otherwise, the transformation is:
1303      *   pushed: n-1             0        0
1304      *           x1  |  ...  |  xn  ===>  e
1305      *                         top()     top()
1306      */
1307     if (yychar>=0) {
1308         pushed(n-1) = top();
1309         pushed(n)   = e;
1310     }
1311     else
1312         pushed(n-1) = e;
1313     sp -= (n-1);
1314     return e;
1315 }
1316
1317 static Void local syntaxError(s)        /* report on syntax error          */
1318 String s; {
1319     ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
1320     EEND;
1321 }
1322
1323 static String local unexpected() {     /* find name for unexpected token   */
1324     static char buffer[100];
1325     static char *fmt = "%s \"%s\"";
1326     static char *kwd = "keyword";
1327
1328     switch (yychar) {
1329         case 0         : return "end of input";
1330
1331 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
1332         case INFIXL    : keyword("infixl");
1333         case INFIXR    : keyword("infixr");
1334         case INFIXN    : keyword("infix");
1335         case FOREIGN   : keyword("foreign");
1336         case UNSAFE    : keyword("unsafe");
1337         case TINSTANCE : keyword("instance");
1338         case TCLASS    : keyword("class");
1339         case CASEXP    : keyword("case");
1340         case OF        : keyword("of");
1341         case IF        : keyword("if");
1342         case THEN      : keyword("then");
1343         case ELSE      : keyword("else");
1344         case WHERE     : keyword("where");
1345         case TYPE      : keyword("type");
1346         case DATA      : keyword("data");
1347         case TNEWTYPE  : keyword("newtype");
1348         case LET       : keyword("let");
1349         case IN        : keyword("in");
1350         case DERIVING  : keyword("deriving");
1351         case DEFAULT   : keyword("default");
1352         case IMPORT    : keyword("import");
1353         case TMODULE   : keyword("module");
1354           /* AJG: Hugs98/Classic use the keyword forall
1355                   rather than __forall.
1356                   Agree on one or the other
1357           */
1358         case ALL       : keyword("__forall");
1359 #if IPARAM
1360         case DLET      : keyword("dlet");
1361         case WITH      : keyword("with");
1362 #endif
1363 #undef keyword
1364
1365         case ARROW     : return "`->'";
1366         case '='       : return "`='";
1367         case COCO      : return "`::'";
1368         case '-'       : return "`-'";
1369         case '!'       : return "`!'";
1370         case ','       : return "comma";
1371         case '@'       : return "`@'";
1372         case '('       : return "`('";
1373         case ')'       : return "`)'";
1374         case '{'       : return "`{', possibly due to bad layout";
1375         case '}'       : return "`}', possibly due to bad layout";
1376         case '_'       : return "`_'";
1377         case '|'       : return "`|'";
1378         case '.'       : return "`.'";
1379         case ';'       : return "`;', possibly due to bad layout";
1380         case UPTO      : return "`..'";
1381         case '['       : return "`['";
1382         case ']'       : return "`]'";
1383         case FROM      : return "`<-'";
1384         case '\\'      : return "backslash (lambda)";
1385         case '~'       : return "tilde";
1386         case '`'       : return "backquote";
1387 #if TREX
1388         case RECSELID  : sprintf(buffer,"selector \"#%s\"",
1389                                  textToStr(extText(snd(yylval))));
1390                          return buffer;
1391 #endif
1392 #if IPARAM
1393         case IPVARID   : sprintf(buffer,"implicit parameter \"?%s\"",
1394                                  textToStr(textOf(yylval)));
1395                          return buffer;
1396 #endif
1397         case VAROP     :
1398         case VARID     :
1399         case CONOP     :
1400         case CONID     : sprintf(buffer,"symbol \"%s\"",
1401                                  textToStr(textOf(yylval)));
1402                          return buffer;
1403         case QVAROP    :
1404         case QVARID    :
1405         case QCONOP    :
1406         case QCONID    : sprintf(buffer,"symbol \"%s\"",
1407                                  identToStr(yylval));
1408                          return buffer;
1409         case HIDING    : return "symbol \"hiding\"";
1410         case QUALIFIED : return "symbol \"qualified\"";
1411         case ASMOD     : return "symbol \"as\"";
1412         case NUMLIT    : return "numeric literal";
1413         case CHARLIT   : return "character literal";
1414         case STRINGLIT : return "string literal";
1415         case IMPLIES   : return "`=>'";
1416         default        : return "token";
1417     }
1418 }
1419
1420 static Cell local checkPrec(p)          /* Check for valid precedence value*/
1421 Cell p; {
1422     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1423         ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1424                     MIN_PREC, MAX_PREC
1425         EEND;
1426     }
1427     return p;
1428 }
1429
1430 static Cell local buildTuple(tup)       /* build tuple (x1,...,xn) from    */
1431 List tup; {                             /* list [xn,...,x1]                */
1432     Int  n = 0;
1433     Cell t = tup;
1434     Cell x;
1435
1436     do {                                /*    .                    .       */
1437         x      = fst(t);                /*   / \                  / \      */
1438         fst(t) = snd(t);                /*  xn  .                .   xn    */
1439         snd(t) = x;                     /*       .    ===>      .          */
1440         x      = t;                     /*        .            .           */
1441         t      = fun(x);                /*         .          .            */
1442         n++;                            /*        / \        / \           */
1443     } while (nonNull(t));               /*       x1  NIL   (n)  x1         */
1444     fst(x) = mkTuple(n);
1445     return tup;
1446 }
1447
1448 static List local checkCtxt(con)     /* validate context                */
1449 Type con; {
1450     mapOver(checkPred, con);
1451     return con;
1452 }
1453
1454 static Cell local checkPred(c)          /* check that type expr is a valid */
1455 Cell c; {                               /* constraint                      */
1456     Cell cn = getHead(c);
1457 #if TREX
1458     if (isExt(cn) && argCount==1)
1459         return c;
1460 #endif
1461 #if IPARAM
1462     if (isIP(cn))
1463         return c;
1464 #endif
1465     if (!isQCon(cn) /*|| argCount==0*/)
1466         syntaxError("class expression");
1467     return c;
1468 }
1469
1470 static Pair local checkDo(dqs)          /* convert reversed list of dquals */
1471 List dqs; {                             /* to an (expr,quals) pair         */
1472     if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1473         ERRMSG(row) "Last generator in do {...} must be an expression"
1474         EEND;
1475     }
1476     fst(dqs) = snd(fst(dqs));           /* put expression in fst of pair   */
1477     snd(dqs) = rev(snd(dqs));           /* & reversed list of quals in snd */
1478     return dqs;
1479 }
1480
1481 static Cell local checkTyLhs(c)         /* check that lhs is of the form   */
1482 Cell c; {                               /* T a1 ... a                      */
1483     Cell tlhs = c;
1484     while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
1485         tlhs = fun(tlhs);
1486     }
1487     if (whatIs(tlhs)!=CONIDCELL) {
1488         ERRMSG(row) "Illegal left hand side in datatype definition"
1489         EEND;
1490     }
1491     return c;
1492 }
1493
1494
1495 #if !TREX
1496 static Void local noTREX(where)
1497 String where; {
1498     ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1499     ERRTEXT     "(TREX is disabled in this build of Hugs)"
1500     EEND;
1501 }
1502 #endif
1503 #if !IPARAM
1504 static Void local noIP(where)
1505 String where; {
1506     ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
1507     ERRTEXT     "(Implicit Parameters are disabled in this build of Hugs)"
1508     EEND;
1509 }
1510 #endif
1511
1512 /*-------------------------------------------------------------------------*/