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