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  * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
   9  * Haskell Group 1994-99, and is distributed as Open Source software
  10  * under the Artistic License; see the file "Artistic" that is included
  11  * in the distribution for details.
  12  *
  13  * $RCSfile: parser.y,v $
  14  * $Revision: 1.4 $
  15  * $Date: 1999/03/09 14:51:09 $
  16  * ------------------------------------------------------------------------*/
  17
  18 %{
  19 #ifndef lint
  20 #define lint
  21 #endif
  22 #define defTycon(n,l,lhs,rhs,w)  tyconDefn(intOf(l),lhs,rhs,w); sp-=n
  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 bang(t)                  ap(BANG,t)
  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 #if IGNORE_MODULES
  32 #define exportSelf()             NIL
  33 #else
  34 #define exportSelf()             singleton(ap(MODULEENT,mkCon(module(currentModule).text)))
  35 #endif
  36 #define yyerror(s)               /* errors handled elsewhere */
  37 #define YYSTYPE                  Cell
  38
  39 static Cell   local gcShadow     Args((Int,Cell));
  40 static Void   local syntaxError  Args((String));
  41 static String local unexpected   Args((Void));
  42 static Cell   local checkPrec    Args((Cell));
  43 static Cell   local buildTuple   Args((List));
  44 static List   local checkContext Args((List));
  45 static Cell   local checkPred    Args((Cell));
  46 static Pair   local checkDo      Args((List));
  47 static Cell   local checkTyLhs   Args((Cell));
  48 #if !TREX
  49 static Void   local noTREX       Args((String));
  50 #endif
  51
  52 /* For the purposes of reasonably portable garbage collection, it is
  53  * necessary to simulate the YACC stack on the Hugs stack to keep
  54  * track of all intermediate constructs.  The lexical analyser
  55  * pushes a token onto the stack for each token that is found, with
  56  * these elements being removed as reduce actions are performed,
  57  * taking account of look-ahead tokens as described by gcShadow()
  58  * below.
  59  *
  60  * Of the non-terminals used below, only start, topDecl & begin
  61  * do not leave any values on the Hugs stack.  The same is true for the
  62  * terminals EXPR and SCRIPT.  At the end of a successful parse, there
  63  * should only be one element left on the stack, containing the result
  64  * of the parse.
  65  */
  66
  67 #define gc0(e)                  gcShadow(0,e)
  68 #define gc1(e)                  gcShadow(1,e)
  69 #define gc2(e)                  gcShadow(2,e)
  70 #define gc3(e)                  gcShadow(3,e)
  71 #define gc4(e)                  gcShadow(4,e)
  72 #define gc5(e)                  gcShadow(5,e)
  73 #define gc6(e)                  gcShadow(6,e)
  74 #define gc7(e)                  gcShadow(7,e)
  75
  76 %}
  77
  78 %token EXPR       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 REPEAT     ALL        NUMLIT     CHARLIT    STRINGLIT
  84 %token VAROP      VARID      CONOP      CONID
  85 %token QVAROP     QVARID     QCONOP     QCONID
  86 /*#if TREX*/
  87 %token RECSELID
  88 /*#endif*/
  89 %token COCO       '='        UPTO       '@'        '\\'
  90 %token '|'        '-'        FROM       ARROW      '~'
  91 %token '!'        IMPLIES    '('        ','        ')'
  92 %token '['        ';'        ']'        '`'        '.'
  93 %token TMODULE    IMPORT     HIDING     QUALIFIED  ASMOD
  94 %token EXPORT     UNSAFE
  95
  96 %%
  97 /*- Top level script/module structure -------------------------------------*/
  98
  99 start     : EXPR exp wherePart          {inputExpr = letrec($3,$2); sp-=2;}
 100           | SCRIPT topModule            {valDefns  = $2;            sp-=1;}
 101           | error                       {syntaxError("input");}
 102           ;
 103
 104 /*- Haskell module header/import parsing: -----------------------------------
 105  * Syntax for Haskell modules (module headers and imports) is parsed but
 106  * most of it is ignored.  However, module names in import declarations
 107  * are used, of course, if import chasing is turned on.
 108  *-------------------------------------------------------------------------*/
 109
 110 /* In Haskell 1.2, the default module header was "module Main where"
 111  * In 1.3, this changed to "module Main(main) where".
 112  * We use the 1.2 header because it breaks much less pre-module code.
 113  */
 114 topModule : startMain begin modBody end {
 115                                          setExportList(singleton(ap(MODULEENT,mkCon(module(currentModule).text))));
 116                                          $$ = gc3($3);
 117                                         }
 118           | TMODULE modname expspec WHERE '{' modBody end
 119                                         {setExportList($3);   $$ = gc7($6);}
 120           | TMODULE error               {syntaxError("module definition");}
 121           ;
 122 /* To implement the Haskell module system, we have to keep track of the
 123  * current module.  We rely on the use of LALR parsing to ensure that this
 124  * side effect happens before any declarations within the module.
 125  */
 126 startMain : /* empty */                 {startModule(conMain);
 127                                          $$ = gc0(NIL);}
 128           ;
 129 modname   : CONID                       {startModule($1); $$ = gc1(NIL);}
 130           ;
 131 modid     : CONID                       {$$ = $1;}
 132           | STRINGLIT                   { extern String scriptFile;
 133                                           String modName = findPathname(scriptFile,textToStr(textOf($1)));
 134                                           if (modName) { /* fillin pathname if known */
 135                                               $$ = mkStr(findText(modName));
 136                                           } else {
 137                                               $$ = $1;
 138                                           }
 139                                         }
 140           ;
 141 modBody   : topDecls                    {$$ = $1;}
 142           | impDecls chase              {$$ = gc2(NIL);}
 143           | impDecls ';' chase topDecls {$$ = gc4($4);}
 144           ;
 145
 146 /*- Exports: --------------------------------------------------------------*/
 147
 148 expspec   : /* empty */                 {$$ = gc0(exportSelf());}
 149           | '(' ')'                     {$$ = gc2(NIL);}
 150           | '(' exports ')'             {$$ = gc3($2);}
 151           | '(' exports ',' ')'         {$$ = gc4($2);}
 152           ;
 153 exports   : exports ',' export          {$$ = gc3(cons($3,$1));}
 154           | export                      {$$ = gc1(singleton($1));}
 155           ;
 156 /* The qcon should be qconid.
 157  * Relaxing the rule lets us explicitly export (:) from the Prelude.
 158  */
 159 export    : qvar                        {$$ = $1;}
 160           | qcon                        {$$ = $1;}
 161           | qconid '(' UPTO ')'         {$$ = gc4(pair($1,DOTDOT));}
 162           | qconid '(' qnames ')'       {$$ = gc4(pair($1,$3));}
 163           | TMODULE modid               {$$ = gc2(ap(MODULEENT,$2));}
 164           ;
 165 qnames    : /* empty */                 {$$ = gc0(NIL);}
 166           | ','                         {$$ = gc1(NIL);}
 167           | qnames1                     {$$ = $1;}
 168           | qnames1 ','                 {$$ = gc2($1);}
 169           ;
 170 qnames1   : qnames1 ',' qname           {$$ = gc3(cons($3,$1));}
 171           | qname                       {$$ = gc1(singleton($1));}
 172           ;
 173 qname     : qvar                        {$$ = $1;}
 174           | qcon                        {$$ = $1;}
 175           ;
 176
 177 /*- Import declarations: --------------------------------------------------*/
 178
 179 impDecls  : impDecls ';' impDecl        {imps = cons($3,imps); $$=gc3(NIL);}
 180           | impDecl                     {imps = singleton($1); $$=gc1(NIL);}
 181           ;
 182 chase     : /* empty */                 {if (chase(imps)) {
 183                                              clearStack();
 184                                              onto(imps);
 185                                              done();
 186                                              closeAnyInput();
 187                                              return 0;
 188                                          }
 189                                          $$ = gc0(NIL);
 190                                         }
 191           ;
 192 /* Note that qualified import ignores the import list. */
 193 impDecl   : IMPORT modid impspec        {addQualImport($2,$2);
 194                                          addUnqualImport($2,$3);
 195                                          $$ = gc3($2);}
 196           | IMPORT modid ASMOD modid impspec
 197                                         {addQualImport($2,$4);
 198                                          addUnqualImport($2,$5);
 199                                          $$ = gc5($2);}
 200           | IMPORT QUALIFIED modid ASMOD modid impspec
 201                                         {addQualImport($3,$5);
 202                                          $$ = gc6($3);}
 203           | IMPORT QUALIFIED modid impspec
 204                                         {addQualImport($3,$3);
 205                                          $$ = gc4($3);}
 206           | IMPORT error                {syntaxError("import declaration");}
 207           ;
 208 impspec   : /* empty */                 {$$ = gc0(DOTDOT);}
 209           | HIDING '(' imports ')'      {$$ = gc4(ap(HIDDEN,$3));}
 210           | '(' imports ')'             {$$ = gc3($2);}
 211           ;
 212 imports   : /* empty */                 {$$ = gc0(NIL);}
 213           | ','                         {$$ = gc1(NIL);}
 214           | imports1                    {$$ = $1;}
 215           | imports1 ','                {$$ = gc2($1);}
 216           ;
 217 imports1  : imports1 ',' import         {$$ = gc3(cons($3,$1));}
 218           | import                      {$$ = gc1(singleton($1));}
 219           ;
 220 import    : var                         {$$ = $1;}
 221           | CONID                       {$$ = $1;}
 222           | CONID '(' UPTO ')'          {$$ = gc4(pair($1,DOTDOT));}
 223           | CONID '(' names ')'         {$$ = gc4(pair($1,$3));}
 224           ;
 225 names     : /* empty */                 {$$ = gc0(NIL);}
 226           | ','                         {$$ = gc1(NIL);}
 227           | names1                      {$$ = $1;}
 228           | names1 ','                  {$$ = gc2($1);}
 229           ;
 230 names1    : names1 ',' name             {$$ = gc3(cons($3,$1));}
 231           | name                        {$$ = gc1(singleton($1));}
 232           ;
 233 name      : var                         {$$ = $1;}
 234           | con                         {$$ = $1;}
 235           ;
 236
 237 /*- Top-level declarations: -----------------------------------------------*/
 238
 239 topDecls  : /* empty */                 {$$ = gc0(NIL);}
 240           | ';'                         {$$ = gc1(NIL);}
 241           | topDecls1                   {$$ = $1;}
 242           | topDecls1 ';'               {$$ = gc2($1);}
 243           ;
 244 topDecls1 : topDecls1 ';' topDecl       {$$ = gc2($1);}
 245           | topDecls1 ';' decl          {$$ = gc3(cons($3,$1));}
 246           | topDecl                     {$$ = gc0(NIL);}
 247           | decl                        {$$ = gc1(cons($1,NIL));}
 248           ;
 249
 250 /*- Type declarations: ----------------------------------------------------*/
 251
 252 topDecl   : TYPE tyLhs '=' type         {defTycon(4,$3,$2,$4,SYNONYM);}
 253           | TYPE tyLhs '=' type IN invars
 254                                         {defTycon(6,$3,$2,
 255                                                     ap($4,$6),RESTRICTSYN);}
 256           | TYPE error                  {syntaxError("type definition");}
 257           | DATA btype2 '=' constrs deriving
 258                                         {defTycon(5,$3,checkTyLhs($2),
 259                                                     ap(rev($4),$5),DATATYPE);}
 260           | DATA context IMPLIES tyLhs '=' constrs deriving
 261                                         {defTycon(7,$5,$4,
 262                                                   ap(qualify($2,rev($6)),
 263                                                      $7),DATATYPE);}
 264           | DATA btype2                 {defTycon(2,$1,checkTyLhs($2),
 265                                                     ap(NIL,NIL),DATATYPE);}
 266           | DATA context IMPLIES tyLhs  {defTycon(4,$1,$4,
 267                                                   ap(qualify($2,NIL),
 268                                                      NIL),DATATYPE);}
 269           | DATA error                  {syntaxError("data definition");}
 270           | TNEWTYPE btype2 '=' nconstr deriving
 271                                         {defTycon(5,$3,checkTyLhs($2),
 272                                                     ap($4,$5),NEWTYPE);}
 273           | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
 274                                         {defTycon(7,$5,$4,
 275                                                   ap(qualify($2,$6),
 276                                                      $7),NEWTYPE);}
 277           | TNEWTYPE error              {syntaxError("newtype definition");}
 278           ;
 279 tyLhs     : tyLhs varid                 {$$ = gc2(ap($1,$2));}
 280           | CONID                       {$$ = $1;}
 281           | error                       {syntaxError("type defn lhs");}
 282           ;
 283 invars    : invars ',' invar            {$$ = gc3(cons($3,$1));}
 284           | invar                       {$$ = gc1(cons($1,NIL));}
 285           ;
 286 invar     : var COCO topType            {$$ = gc3(sigdecl($2,singleton($1),
 287                                                                         $3));}
 288           | var                         {$$ = $1;}
 289           ;
 290 constrs   : constrs '|' pconstr         {$$ = gc3(cons($3,$1));}
 291           | pconstr                     {$$ = gc1(cons($1,NIL));}
 292           ;
 293 pconstr   : ALL varids '.' qconstr      {$$ = gc4(ap(POLYTYPE,
 294                                                      pair(rev($2),$4)));}
 295           | qconstr                     {$$ = $1;}
 296           ;
 297 qconstr   : context IMPLIES constr      {$$ = gc3(qualify($1,$3));}
 298           | constr                      {$$ = $1;}
 299           ;
 300 constr    : '!' btype conop bbtype      {$$ = gc4(ap(ap($3,bang($2)),$4));}
 301           | btype1    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 302           | btype2    conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 303           | bpolyType conop bbtype      {$$ = gc3(ap(ap($2,$1),$3));}
 304           | btype2                      {$$ = $1;}
 305           | btype3                      {$$ = $1;}
 306           | btype4                      {$$ = $1;}
 307           | con '{' fieldspecs '}'      {$$ = gc4(ap(LABC,pair($1,rev($3))));}
 308           | con '{' '}'                 {$$ = gc3(ap(LABC,pair($1,NIL)));}
 309           | error                       {syntaxError("data type definition");}
 310           ;
 311 btype3    : btype2 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 312           | btype3 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 313           | btype3 atype                {$$ = gc2(ap($1,$2));}
 314           ;
 315 btype4    : btype2 bpolyType            {$$ = gc2(ap($1,$2));}
 316           | btype3 bpolyType            {$$ = gc2(ap($1,$2));}
 317           | btype4 bpolyType            {$$ = gc2(ap($1,$2));}
 318           | btype4 atype                {$$ = gc2(ap($1,$2));}
 319           | btype4 '!' atype            {$$ = gc3(ap($1,bang($3)));}
 320           ;
 321 bbtype    : '!' btype                   {$$ = gc2(bang($2));}
 322           | btype                       {$$ = $1;}
 323           | bpolyType                   {$$ = $1;}
 324           ;
 325 nconstr   : pconstr                     {$$ = gc1(singleton($1));}
 326           ;
 327 fieldspecs: fieldspecs ',' fieldspec    {$$ = gc3(cons($3,$1));}
 328           | fieldspec                   {$$ = gc1(cons($1,NIL));}
 329           ;
 330 fieldspec : vars COCO polyType          {$$ = gc3(pair(rev($1),$3));}
 331           | vars COCO type              {$$ = gc3(pair(rev($1),$3));}
 332           | vars COCO '!' type          {$$ = gc4(pair(rev($1),bang($4)));}
 333           ;
 334 deriving  : /* empty */                 {$$ = gc0(NIL);}
 335           | DERIVING qconid             {$$ = gc2(singleton($2));}
 336           | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
 337           ;
 338 derivs0   : /* empty */                 {$$ = gc0(NIL);}
 339           | derivs                      {$$ = gc1(rev($1));}
 340           ;
 341 derivs    : derivs ',' qconid           {$$ = gc3(cons($3,$1));}
 342           | qconid                      {$$ = gc1(singleton($1));}
 343           ;
 344
 345 /*- Processing definitions of primitives ----------------------------------*/
 346
 347 topDecl   : FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
 348                                         {foreignImport($1,pair($4,$5),$7,$9); sp-=9;}
 349           | FOREIGN EXPORT callconv ext_name qvarid COCO type
 350                                         {foreignExport($1,$4,$5,$7); sp-=7;}
 351           ;
 352
 353 callconv  : var                  {$$ = gc1(NIL); /* ignored */ }
 354           ;
 355 ext_loc   : STRINGLIT            {$$ = $1;}
 356           ;
 357 ext_name  : STRINGLIT            {$$ = $1;}
 358           ;
 359 unsafe_flag: /* empty */         {$$ = gc0(NIL);}
 360           | UNSAFE               {$$ = gc1(NIL); /* ignored */ }
 361           ;
 362
 363
 364 /*- Class declarations: ---------------------------------------------------*/
 365
 366 topDecl   : TCLASS crule wherePart      {classDefn(intOf($1),$2,$3); sp-=3;}
 367           | TINSTANCE irule wherePart   {instDefn(intOf($1),$2,$3);  sp-=3;}
 368           | DEFAULT '(' dtypes ')'      {defaultDefn(intOf($1),$3);  sp-=4;}
 369           | TCLASS error                {syntaxError("class declaration");}
 370           | TINSTANCE error             {syntaxError("instance declaration");}
 371           | DEFAULT error               {syntaxError("default declaration");}
 372           ;
 373 crule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 374           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 375           ;
 376 irule     : context IMPLIES btype2      {$$ = gc3(pair($1,checkPred($3)));}
 377           | btype2                      {$$ = gc1(pair(NIL,checkPred($1)));}
 378           ;
 379 dtypes    : /* empty */                 {$$ = gc0(NIL);}
 380           | dtypes1                     {$$ = gc1(rev($1));}
 381           ;
 382 dtypes1   : dtypes1 ',' type            {$$ = gc3(cons($3,$1));}
 383           | type                        {$$ = gc1(cons($1,NIL));}
 384           ;
 385
 386 /*- Type expressions: -----------------------------------------------------*/
 387
 388 topType   : context IMPLIES topType1    {$$ = gc3(qualify($1,$3));}
 389           | topType1                    {$$ = $1;}
 390           ;
 391 topType1  : bpolyType ARROW topType1    {$$ = gc3(fn($1,$3));}
 392           | btype1    ARROW topType1    {$$ = gc3(fn($1,$3));}
 393           | btype2    ARROW topType1    {$$ = gc3(fn($1,$3));}
 394           | btype                       {$$ = $1;}
 395           ;
 396 polyType  : ALL varids '.' sigType      {$$ = gc4(ap(POLYTYPE,
 397                                                      pair(rev($2),$4)));}
 398           | bpolyType                   {$$ = $1;}
 399           ;
 400 bpolyType : '(' polyType ')'            {$$ = gc3($2);}
 401           ;
 402 varids    : varids ',' varid            {$$ = gc3(cons($3,$1));}
 403           | varid                       {$$ = gc1(singleton($1));}
 404           ;
 405 sigType   : context IMPLIES type        {$$ = gc3(qualify($1,$3));}
 406           | type                        {$$ = $1;}
 407           ;
 408 context   : '(' ')'                     {$$ = gc2(NIL);}
 409           | btype2                      {$$ = gc1(singleton(checkPred($1)));}
 410           | '(' btype2 ')'              {$$ = gc3(singleton(checkPred($2)));}
 411           | '(' btypes2 ')'             {$$ = gc3(checkContext(rev($2)));}
 412 /*#if TREX*/
 413           | lacks                       {$$ = gc1(singleton($1));}
 414           | '(' lacks1 ')'              {$$ = gc3(checkContext(rev($2)));}
 415           ;
 416 lacks     : varid '\\' varid            {
 417 #if TREX
 418                                          $$ = gc3(ap(mkExt(textOf($3)),$1));
 419 #else
 420                                          noTREX("a type context");
 421 #endif
 422                                         }
 423           ;
 424 lacks1    : btypes2 ',' lacks           {$$ = gc3(cons($3,$1));}
 425           | lacks1  ',' btype2          {$$ = gc3(cons($3,$1));}
 426           | lacks1  ',' lacks           {$$ = gc3(cons($3,$1));}
 427           | btype2  ',' lacks           {$$ = gc3(cons($3,cons($1,NIL)));}
 428           | lacks                       {$$ = gc1(singleton($1));}
 429           ;
 430 /*#endif*/
 431
 432 type      : type1                       {$$ = $1;}
 433           | btype2                      {$$ = $1;}
 434           ;
 435 type1     : btype1                      {$$ = $1;}
 436           | btype1 ARROW type           {$$ = gc3(fn($1,$3));}
 437           | btype2 ARROW type           {$$ = gc3(fn($1,$3));}
 438           | error                       {syntaxError("type expression");}
 439           ;
 440 btype     : btype1                      {$$ = $1;}
 441           | btype2                      {$$ = $1;}
 442           ;
 443 btype1    : btype1 atype                {$$ = gc2(ap($1,$2));}
 444           | atype1                      {$$ = $1;}
 445           ;
 446 btype2    : btype2 atype                {$$ = gc2(ap($1,$2));}
 447           | qconid                      {$$ = $1;}
 448           ;
 449 atype     : atype1                      {$$ = $1;}
 450           | qconid                      {$$ = $1;}
 451           ;
 452 atype1    : varid                       {$$ = $1;}
 453           | '(' ')'                     {$$ = gc2(typeUnit);}
 454           | '(' ARROW ')'               {$$ = gc3(typeArrow);}
 455           | '(' type1 ')'               {$$ = gc3($2);}
 456           | '(' btype2 ')'              {$$ = gc3($2);}
 457           | '(' tupCommas ')'           {$$ = gc3($2);}
 458           | '(' btypes2 ')'             {$$ = gc3(buildTuple($2));}
 459           | '(' typeTuple ')'           {$$ = gc3(buildTuple($2));}
 460 /*#if TREX*/
 461           | '(' tfields ')'             {
 462 #if TREX
 463                                          $$ = gc3(revOnto($2,typeNoRow));
 464 #else
 465                                          noTREX("a type");
 466 #endif
 467                                         }
 468           | '(' tfields '|' type ')'    {$$ = gc5(revOnto($2,$4));}
 469 /*#endif*/
 470           | '[' type ']'                {$$ = gc3(ap(typeList,$2));}
 471           | '[' ']'                     {$$ = gc2(typeList);}
 472           | '_'                         {$$ = gc1(inventVar());}
 473           ;
 474 btypes2   : btypes2 ',' btype2          {$$ = gc3(cons($3,$1));}
 475           | btype2  ',' btype2          {$$ = gc3(cons($3,cons($1,NIL)));}
 476           ;
 477 typeTuple : type1     ',' type          {$$ = gc3(cons($3,cons($1,NIL)));}
 478           | btype2    ',' type1         {$$ = gc3(cons($3,cons($1,NIL)));}
 479           | btypes2   ',' type1         {$$ = gc3(cons($3,$1));}
 480           | typeTuple ',' type          {$$ = gc3(cons($3,$1));}
 481           ;
 482 /*#if TREX*/
 483 tfields   : tfields ',' tfield          {$$ = gc3(cons($3,$1));}
 484           | tfield                      {$$ = gc1(singleton($1));}
 485           ;
 486 tfield    : varid COCO type             {$$ = gc3(ap(mkExt(textOf($1)),$3));}
 487           ;
 488 /*#endif*/
 489
 490 /*- Value declarations: ---------------------------------------------------*/
 491
 492 gendecl   : INFIXN optDigit ops         {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
 493           | INFIXN error                {syntaxError("fixity decl");}
 494           | INFIXL optDigit ops         {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
 495           | INFIXL error                {syntaxError("fixity decl");}
 496           | INFIXR optDigit ops         {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
 497           | INFIXR error                {syntaxError("fixity decl");}
 498           | vars COCO topType           {$$ = gc3(sigdecl($2,$1,$3));}
 499           | vars COCO error             {syntaxError("type signature");}
 500           ;
 501 optDigit  : NUMLIT                      {$$ = gc1(checkPrec($1));}
 502           | /* empty */                 {$$ = gc0(mkInt(DEF_PREC));}
 503           ;
 504 ops       : ops ',' op                  {$$ = gc3(cons($3,$1));}
 505           | op                          {$$ = gc1(singleton($1));}
 506           ;
 507 vars      : vars ',' var                {$$ = gc3(cons($3,$1));}
 508           | var                         {$$ = gc1(singleton($1));}
 509           ;
 510 decls     : '{' decls0 end              {$$ = gc3($2);}
 511           | '{' decls1 end              {$$ = gc3($2);}
 512           ;
 513 decls0    : /* empty */                 {$$ = gc0(NIL);}
 514           | decls0 ';'                  {$$ = gc2($1);}
 515           | decls1 ';'                  {$$ = gc2($1);}
 516           ;
 517 decls1    : decls0 decl                 {$$ = gc2(cons($2,$1));}
 518           ;
 519 decl      : gendecl                     {$$ = $1;}
 520           | funlhs rhs                  {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
 521           | funlhs COCO type rhs        {$$ = gc4(ap(FUNBIND,
 522                                                      pair($1,ap(RSIGN,
 523                                                                 ap($4,$3)))));}
 524           | pat0 rhs                    {$$ = gc2(ap(PATBIND,pair($1,$2)));}
 525           ;
 526 funlhs    : funlhs0                     {$$ = $1;}
 527           | funlhs1                     {$$ = $1;}
 528           | npk                         {$$ = $1;}
 529           ;
 530 funlhs0   : pat10_vI varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 531           | infixPat varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 532           | NUMLIT   varop    pat0      {$$ = gc3(ap2($2,$1,$3));}
 533           | var      varop_pl pat0      {$$ = gc3(ap2($2,$1,$3));}
 534           | var      '+'      pat0_INT  {$$ = gc3(ap2(varPlus,$1,$3));}
 535           ;
 536 funlhs1   : '(' funlhs0 ')' apat        {$$ = gc4(ap($2,$4));}
 537           | '(' funlhs1 ')' apat        {$$ = gc4(ap($2,$4));}
 538           | '(' npk     ')' apat        {$$ = gc4(ap($2,$4));}
 539           | var     apat                {$$ = gc2(ap($1,$2));}
 540           | funlhs1 apat                {$$ = gc2(ap($1,$2));}
 541           ;
 542 rhs       : rhs1 wherePart              {$$ = gc2(letrec($2,$1));}
 543           | error                       {syntaxError("declaration");}
 544           ;
 545 rhs1      : '=' exp                     {$$ = gc2(pair($1,$2));}
 546           | gdrhs                       {$$ = gc1(grded(rev($1)));}
 547           ;
 548 gdrhs     : gdrhs gddef                 {$$ = gc2(cons($2,$1));}
 549           | gddef                       {$$ = gc1(singleton($1));}
 550           ;
 551 gddef     : '|' exp0 '=' exp            {$$ = gc4(pair($3,pair($2,$4)));}
 552           ;
 553 wherePart : /* empty */                 {$$ = gc0(NIL);}
 554           | WHERE decls                 {$$ = gc2($2);}
 555           ;
 556
 557 /*- Patterns: -------------------------------------------------------------*/
 558
 559 pat       : npk                         {$$ = $1;}
 560           | pat_npk                     {$$ = $1;}
 561           ;
 562 pat_npk   : pat0 COCO type              {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 563           | pat0                        {$$ = $1;}
 564           ;
 565 npk       : var '+' NUMLIT              {$$ = gc3(ap2(varPlus,$1,$3));}
 566           ;
 567 pat0      : var                         {$$ = $1;}
 568           | NUMLIT                      {$$ = $1;}
 569           | pat0_vI                     {$$ = $1;}
 570           ;
 571 pat0_INT  : var                         {$$ = $1;}
 572           | pat0_vI                     {$$ = $1;}
 573           ;
 574 pat0_vI   : pat10_vI                    {$$ = $1;}
 575           | infixPat                    {$$ = gc1(ap(INFIX,$1));}
 576           ;
 577 infixPat  : '-' pat10                   {$$ = gc2(ap(NEG,only($2)));}
 578           | var qconop pat10            {$$ = gc3(ap(ap($2,only($1)),$3));}
 579           | var qconop '-' pat10        {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 580           | NUMLIT qconop pat10         {$$ = gc3(ap(ap($2,only($1)),$3));}
 581           | NUMLIT qconop '-' pat10     {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 582           | pat10_vI qconop pat10       {$$ = gc3(ap(ap($2,only($1)),$3));}
 583           | pat10_vI qconop '-' pat10   {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
 584           | infixPat qconop pat10       {$$ = gc3(ap(ap($2,$1),$3));}
 585           | infixPat qconop '-' pat10   {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 586           ;
 587 pat10     : fpat                        {$$ = $1;}
 588           | apat                        {$$ = $1;}
 589           ;
 590 pat10_vI  : fpat                        {$$ = $1;}
 591           | apat_vI                     {$$ = $1;}
 592           ;
 593 fpat      : fpat apat                   {$$ = gc2(ap($1,$2));}
 594           | gcon apat                   {$$ = gc2(ap($1,$2));}
 595           ;
 596 apat      : NUMLIT                      {$$ = $1;}
 597           | var                         {$$ = $1;}
 598           | apat_vI                     {$$ = $1;}
 599           ;
 600 apat_vI   : var '@' apat                {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 601           | gcon                        {$$ = $1;}
 602           | qcon '{' patbinds '}'       {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 603           | CHARLIT                     {$$ = $1;}
 604           | STRINGLIT                   {$$ = $1;}
 605           | '_'                         {$$ = gc1(WILDCARD);}
 606           | '(' pat_npk ')'             {$$ = gc3($2);}
 607           | '(' npk ')'                 {$$ = gc3($2);}
 608           | '(' pats2 ')'               {$$ = gc3(buildTuple($2));}
 609           | '[' pats1 ']'               {$$ = gc3(ap(FINLIST,rev($2)));}
 610           | '~' apat                    {$$ = gc2(ap(LAZYPAT,$2));}
 611 /*#if TREX*/
 612           | '(' patfields ')'           {
 613 #if TREX
 614                                          $$ = gc3(revOnto($2,nameNoRec));
 615 #else
 616                                          $$ = gc3(NIL);
 617 #endif
 618                                         }
 619           | '(' patfields '|' pat ')'   {$$ = gc5(revOnto($2,$4));}
 620 /*#endif TREX*/
 621           ;
 622 pats2     : pats2 ',' pat               {$$ = gc3(cons($3,$1));}
 623           | pat ',' pat                 {$$ = gc3(cons($3,singleton($1)));}
 624           ;
 625 pats1     : pats1 ',' pat               {$$ = gc3(cons($3,$1));}
 626           | pat                         {$$ = gc1(singleton($1));}
 627           ;
 628 patbinds  : /* empty */                 {$$ = gc0(NIL);}
 629           | patbinds1                   {$$ = gc1(rev($1));}
 630           ;
 631 patbinds1 : patbinds1 ',' patbind       {$$ = gc3(cons($3,$1));}
 632           | patbind                     {$$ = gc1(singleton($1));}
 633           ;
 634 patbind   : qvar '=' pat                {$$ = gc3(pair($1,$3));}
 635           | var                         {$$ = $1;}
 636           ;
 637 /*#if TREX*/
 638 patfields : patfields ',' patfield      {$$ = gc3(cons($3,$1));}
 639           | patfield                    {$$ = gc1(singleton($1));}
 640           ;
 641 patfield  : varid '=' pat               {
 642 #if TREX
 643                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
 644 #else
 645                                          noTREX("a pattern");
 646 #endif
 647                                         }
 648           ;
 649 /*#endif TREX*/
 650
 651 /*- Expressions: ----------------------------------------------------------*/
 652
 653 exp       : exp_err                     {$$ = $1;}
 654           | error                       {syntaxError("expression");}
 655           ;
 656 exp_err   : exp0a COCO sigType          {$$ = gc3(ap(ESIGN,pair($1,$3)));}
 657           | exp0                        {$$ = $1;}
 658           ;
 659 exp0      : exp0a                       {$$ = $1;}
 660           | exp0b                       {$$ = $1;}
 661           ;
 662 exp0a     : infixExpa                   {$$ = gc1(ap(INFIX,$1));}
 663           | exp10a                      {$$ = $1;}
 664           ;
 665 exp0b     : infixExpb                   {$$ = gc1(ap(INFIX,$1));}
 666           | exp10b                      {$$ = $1;}
 667           ;
 668 infixExpa : infixExpa qop '-' exp10a    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 669           | infixExpa qop exp10a        {$$ = gc3(ap(ap($2,$1),$3));}
 670           | '-' exp10a                  {$$ = gc2(ap(NEG,only($2)));}
 671           | exp10a qop '-' exp10a       {$$ = gc4(ap(NEG,
 672                                                      ap(ap($2,only($1)),$4)));}
 673           | exp10a qop exp10a           {$$ = gc3(ap(ap($2,only($1)),$3));}
 674           ;
 675 infixExpb : infixExpa qop '-' exp10b    {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
 676           | infixExpa qop exp10b        {$$ = gc3(ap(ap($2,$1),$3));}
 677           | '-' exp10b                  {$$ = gc2(ap(NEG,only($2)));}
 678           | exp10a qop '-' exp10b       {$$ = gc4(ap(NEG,
 679                                                      ap(ap($2,only($1)),$4)));}
 680           | exp10a qop exp10b           {$$ = gc3(ap(ap($2,only($1)),$3));}
 681           ;
 682 exp10a    : CASEXP exp OF '{' alts end  {$$ = gc6(ap(CASE,pair($2,rev($5))));}
 683           | DO '{' stmts end            {$$ = gc4(ap(DOCOMP,checkDo($3)));}
 684           | appExp                      {$$ = $1;}
 685           ;
 686 exp10b    : '\\' pats ARROW exp         {$$ = gc4(ap(LAMBDA,
 687                                                      pair(rev($2),
 688                                                           pair($3,$4))));}
 689           | LET decls IN exp            {$$ = gc4(letrec($2,$4));}
 690           | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
 691           ;
 692 pats      : pats apat                   {$$ = gc2(cons($2,$1));}
 693           | apat                        {$$ = gc1(cons($1,NIL));}
 694           ;
 695 appExp    : appExp aexp                 {$$ = gc2(ap($1,$2));}
 696           | aexp                        {$$ = $1;}
 697           ;
 698 aexp      : qvar                        {$$ = $1;}
 699           | qvar '@' aexp               {$$ = gc3(ap(ASPAT,pair($1,$3)));}
 700           | '~' aexp                    {$$ = gc2(ap(LAZYPAT,$2));}
 701           | '_'                         {$$ = gc1(WILDCARD);}
 702           | gcon                        {$$ = $1;}
 703           | qcon '{' fbinds '}'         {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
 704           | aexp '{' fbinds '}'         {$$ = gc4(ap(UPDFLDS,
 705                                                      triple($1,NIL,$3)));}
 706           | NUMLIT                      {$$ = $1;}
 707           | CHARLIT                     {$$ = $1;}
 708           | STRINGLIT                   {$$ = $1;}
 709           | REPEAT                      {$$ = $1;}
 710           | '(' exp ')'                 {$$ = gc3($2);}
 711           | '(' exps2 ')'               {$$ = gc3(buildTuple($2));}
 712 /*#if TREX*/
 713           | '(' vfields ')'             {
 714 #if TREX
 715                                          $$ = gc3(revOnto($2,nameNoRec));
 716 #else
 717                                          $$ = gc3(NIL);
 718 #endif
 719                                         }
 720           | '(' vfields '|' exp ')'     {$$ = gc5(revOnto($2,$4));}
 721           | RECSELID                    {$$ = $1;}
 722 /*#endif*/
 723           | '[' list ']'                {$$ = gc3($2);}
 724           | '(' exp10a qop ')'          {$$ = gc4(ap($3,$2));}
 725           | '(' qvarop_mi exp0 ')'      {$$ = gc4(ap(ap(nameFlip,$2),$3));}
 726           | '(' qconop exp0 ')'         {$$ = gc4(ap(ap(nameFlip,$2),$3));}
 727           ;
 728 exps2     : exps2 ',' exp               {$$ = gc3(cons($3,$1));}
 729           | exp ',' exp                 {$$ = gc3(cons($3,cons($1,NIL)));}
 730           ;
 731 /*#if TREX*/
 732 vfields   : vfields ',' vfield          {$$ = gc3(cons($3,$1));}
 733           | vfield                      {$$ = gc1(singleton($1));}
 734           ;
 735 vfield    : varid '=' exp               {
 736 #if TREX
 737                                          $$ = gc3(ap(mkExt(textOf($1)),$3));
 738 #else
 739                                          noTREX("an expression");
 740 #endif
 741                                         }
 742           ;
 743 /*#endif*/
 744 alts      : alts1                       {$$ = $1;}
 745           | alts1 ';'                   {$$ = gc2($1);}
 746           ;
 747 alts1     : alts1 ';' alt               {$$ = gc3(cons($3,$1));}
 748           | alt                         {$$ = gc1(cons($1,NIL));}
 749           ;
 750 alt       : pat altRhs wherePart        {$$ = gc3(pair($1,letrec($3,$2)));}
 751           ;
 752 altRhs    : guardAlts                   {$$ = gc1(grded(rev($1)));}
 753           | ARROW exp                   {$$ = gc2(pair($1,$2));}
 754           | error                       {syntaxError("case expression");}
 755           ;
 756 guardAlts : guardAlts guardAlt          {$$ = gc2(cons($2,$1));}
 757           | guardAlt                    {$$ = gc1(cons($1,NIL));}
 758           ;
 759 guardAlt  : '|' exp0 ARROW exp          {$$ = gc4(pair($3,pair($2,$4)));}
 760           ;
 761 stmts     : stmts1 ';'                  {$$ = gc2($1);}
 762           | stmts1                      {$$ = $1;}
 763           ;
 764 stmts1    : stmts1 ';' stmt             {$$ = gc3(cons($3,$1));}
 765           | stmt                        {$$ = gc1(cons($1,NIL));}
 766           ;
 767 stmt      : exp_err FROM exp            {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
 768           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
 769 /*        | IF exp                      {$$ = gc2(ap(BOOLQUAL,$2));}*/
 770           | exp_err                     {$$ = gc1(ap(DOQUAL,$1));}
 771           ;
 772 fbinds    : /* empty */                 {$$ = gc0(NIL);}
 773           | fbinds1                     {$$ = gc1(rev($1));}
 774           ;
 775 fbinds1   : fbinds1 ',' fbind           {$$ = gc3(cons($3,$1));}
 776           | fbind                       {$$ = gc1(singleton($1));}
 777           ;
 778 fbind     : var                         {$$ = $1;}
 779           | qvar '=' exp                {$$ = gc3(pair($1,$3));}
 780           ;
 781
 782 /*- List Expressions: -------------------------------------------------------*/
 783
 784 list      : exp                         {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
 785           | exps2                       {$$ = gc1(ap(FINLIST,rev($1)));}
 786           | exp '|' quals               {$$ = gc3(ap(COMP,pair($1,rev($3))));}
 787           | exp         UPTO exp        {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
 788           | exp ',' exp UPTO            {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
 789           | exp         UPTO            {$$ = gc2(ap(nameFrom,$1));}
 790           | exp ',' exp UPTO exp        {$$ = gc5(ap(ap(ap(nameFromThenTo,
 791                                                                 $1),$3),$5));}
 792           ;
 793 quals     : quals ',' qual              {$$ = gc3(cons($3,$1));}
 794           | qual                        {$$ = gc1(cons($1,NIL));}
 795           ;
 796 qual      : exp FROM exp                {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
 797           | exp                         {$$ = gc1(ap(BOOLQUAL,$1));}
 798           | LET decls                   {$$ = gc2(ap(QWHERE,$2));}
 799           ;
 800
 801 /*- Identifiers and symbols: ----------------------------------------------*/
 802
 803 gcon      : qcon                        {$$ = $1;}
 804           | '(' ')'                     {$$ = gc2(nameUnit);}
 805           | '[' ']'                     {$$ = gc2(nameNil);}
 806           | '(' tupCommas ')'           {$$ = gc3($2);}
 807           ;
 808 tupCommas : tupCommas ','               {$$ = gc2(mkTuple(tupleOf($1)+1));}
 809           | ','                         {$$ = gc1(mkTuple(2));}
 810           ;
 811 varid     : VARID                       {$$ = $1;}
 812           | HIDING                      {$$ = gc1(varHiding);}
 813           | QUALIFIED                   {$$ = gc1(varQualified);}
 814           | ASMOD                       {$$ = gc1(varAsMod);}
 815           ;
 816 qconid    : QCONID                      {$$ = $1;}
 817           | CONID                       {$$ = $1;}
 818           ;
 819 var       : varid                       {$$ = $1;}
 820           | '(' VAROP ')'               {$$ = gc3($2);}
 821           | '(' '+' ')'                 {$$ = gc3(varPlus);}
 822           | '(' '-' ')'                 {$$ = gc3(varMinus);}
 823           | '(' '!' ')'                 {$$ = gc3(varBang);}
 824           | '(' '.' ')'                 {$$ = gc3(varDot);}
 825           ;
 826 qvar      : QVARID                      {$$ = $1;}
 827           | '(' QVAROP ')'              {$$ = gc3($2);}
 828           | var                         {$$ = $1;}
 829           ;
 830 con       : CONID                       {$$ = $1;}
 831           | '(' CONOP ')'               {$$ = gc3($2);}
 832           ;
 833 qcon      : QCONID                      {$$ = $1;}
 834           | '(' QCONOP ')'              {$$ = gc3($2);}
 835           | con                         {$$ = $1;}
 836           ;
 837 varop     : '+'                         {$$ = gc1(varPlus);}
 838           | '-'                         {$$ = gc1(varMinus);}
 839           | varop_mipl                  {$$ = $1;}
 840           ;
 841 varop_mi  : '+'                         {$$ = gc1(varPlus);}
 842           | varop_mipl                  {$$ = $1;}
 843           ;
 844 varop_pl  : '-'                         {$$ = gc1(varMinus);}
 845           | varop_mipl                  {$$ = $1;}
 846           ;
 847 varop_mipl: VAROP                       {$$ = $1;}
 848           | '`' varid '`'               {$$ = gc3($2);}
 849           | '!'                         {$$ = gc1(varBang);}
 850           | '.'                         {$$ = gc1(varDot);}
 851           ;
 852 qvarop    : '-'                         {$$ = gc1(varMinus);}
 853           | qvarop_mi                   {$$ = $1;}
 854           ;
 855 qvarop_mi : QVAROP                      {$$ = $1;}
 856           | '`' QVARID '`'              {$$ = gc3($2);}
 857           | varop_mi                    {$$ = $1;}
 858           ;
 859
 860 conop     : CONOP                       {$$ = $1;}
 861           | '`' CONID  '`'              {$$ = gc3($2);}
 862           ;
 863 qconop    : QCONOP                      {$$ = $1;}
 864           | '`' QCONID '`'              {$$ = gc3($2);}
 865           | conop                       {$$ = $1;}
 866           ;
 867 op        : varop                       {$$ = $1;}
 868           | conop                       {$$ = $1;}
 869           ;
 870 qop       : qvarop                      {$$ = $1;}
 871           | qconop                      {$$ = $1;}
 872           ;
 873
 874 /*- Stuff from STG hugs ---------------------------------------------------*/
 875
 876 qvarid    : varid1                      {$$ = gc1($1);}
 877           | QVARID                      {$$ = gc1($1);}
 878
 879 varid1    : VARID                       {$$ = gc1($1);}
 880           | HIDING                      {$$ = gc1(varHiding);}
 881           | QUALIFIED                   {$$ = gc1(varQualified);}
 882           | ASMOD                       {$$ = gc1(varAsMod);}
 883           ;
 884
 885 /*- Tricks to force insertion of leading and closing braces ---------------*/
 886
 887 begin     : error                       {yyerrok; goOffside(startColumn);}
 888           ;
 889                                         /* deal with trailing semicolon    */
 890 end       : '}'                         {$$ = $1;}
 891           | error                       {yyerrok;
 892                                          if (canUnOffside()) {
 893                                              unOffside();
 894                                              /* insert extra token on stack*/
 895                                              push(NIL);
 896                                              pushed(0) = pushed(1);
 897                                              pushed(1) = mkInt(column);
 898                                          }
 899                                          else
 900                                              syntaxError("definition");
 901                                         }
 902           ;
 903
 904 /*-------------------------------------------------------------------------*/
 905
 906 %%
 907
 908 static Cell local gcShadow(n,e)         /* keep parsed fragments on stack  */
 909 Int  n;
 910 Cell e; {
 911     /* If a look ahead token is held then the required stack transformation
 912      * is:
 913      *   pushed: n               1     0          1     0
 914      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
 915      *                                top()            top()
 916      *
 917      * Othwerwise, the transformation is:
 918      *   pushed: n-1             0        0
 919      *           x1  |  ...  |  xn  ===>  e
 920      *                         top()     top()
 921      */
 922     if (yychar>=0) {
 923         pushed(n-1) = top();
 924         pushed(n)   = e;
 925     }
 926     else
 927         pushed(n-1) = e;
 928     sp -= (n-1);
 929     return e;
 930 }
 931
 932 static Void local syntaxError(s)        /* report on syntax error          */
 933 String s; {
 934     ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
 935     EEND;
 936 }
 937
 938 static String local unexpected() {     /* find name for unexpected token   */
 939     static char buffer[100];
 940     static char *fmt = "%s \"%s\"";
 941     static char *kwd = "keyword";
 942
 943     switch (yychar) {
 944         case 0         : return "end of input";
 945
 946 #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
 947         case INFIXL    : keyword("infixl");
 948         case INFIXR    : keyword("infixr");
 949         case INFIXN    : keyword("infix");
 950         case FOREIGN   : keyword("foreign");
 951         case UNSAFE    : keyword("unsafe");
 952         case TINSTANCE : keyword("instance");
 953         case TCLASS    : keyword("class");
 954         case CASEXP    : keyword("case");
 955         case OF        : keyword("of");
 956         case IF        : keyword("if");
 957         case THEN      : keyword("then");
 958         case ELSE      : keyword("else");
 959         case WHERE     : keyword("where");
 960         case TYPE      : keyword("type");
 961         case DATA      : keyword("data");
 962         case TNEWTYPE  : keyword("newtype");
 963         case LET       : keyword("let");
 964         case IN        : keyword("in");
 965         case DERIVING  : keyword("deriving");
 966         case DEFAULT   : keyword("default");
 967         case IMPORT    : keyword("import");
 968         case TMODULE   : keyword("module");
 969         case ALL       : keyword("forall");
 970 #undef keyword
 971
 972         case ARROW     : return "`->'";
 973         case '='       : return "`='";
 974         case COCO      : return "`::'";
 975         case '-'       : return "`-'";
 976         case '!'       : return "`!'";
 977         case ','       : return "comma";
 978         case '@'       : return "`@'";
 979         case '('       : return "`('";
 980         case ')'       : return "`)'";
 981         case '{'       : return "`{'";
 982         case '}'       : return "`}'";
 983         case '_'       : return "`_'";
 984         case '|'       : return "`|'";
 985         case '.'       : return "`.'";
 986         case ';'       : return "`;'";
 987         case UPTO      : return "`..'";
 988         case '['       : return "`['";
 989         case ']'       : return "`]'";
 990         case FROM      : return "`<-'";
 991         case '\\'      : return "backslash (lambda)";
 992         case '~'       : return "tilde";
 993         case '`'       : return "backquote";
 994 #if TREX
 995         case RECSELID  : sprintf(buffer,"selector \"#%s\"",
 996                                  textToStr(extText(snd(yylval))));
 997                          return buffer;
 998 #endif
 999         case VAROP     :
1000         case VARID     :
1001         case CONOP     :
1002         case CONID     : sprintf(buffer,"symbol \"%s\"",
1003                                  textToStr(textOf(yylval)));
1004                          return buffer;
1005         case QVAROP    :
1006         case QVARID    :
1007         case QCONOP    :
1008         case QCONID    : sprintf(buffer,"symbol \"%s\"",
1009                                  identToStr(yylval));
1010                          return buffer;
1011         case HIDING    : return "symbol \"hiding\"";
1012         case QUALIFIED : return "symbol \"qualified\"";
1013         case ASMOD     : return "symbol \"as\"";
1014         case NUMLIT    : return "numeric literal";
1015         case CHARLIT   : return "character literal";
1016         case STRINGLIT : return "string literal";
1017         case IMPLIES   : return "`=>'";
1018         default        : return "token";
1019     }
1020 }
1021
1022 static Cell local checkPrec(p)          /* Check for valid precedence value*/
1023 Cell p; {
1024     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
1025         ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
1026                     MIN_PREC, MAX_PREC
1027         EEND;
1028     }
1029     return p;
1030 }
1031
1032 static Cell local buildTuple(tup)       /* build tuple (x1,...,xn) from    */
1033 List tup; {                             /* list [xn,...,x1]                */
1034     Int  n = 0;
1035     Cell t = tup;
1036     Cell x;
1037
1038     do {                                /*    .                    .       */
1039         x      = fst(t);                /*   / \                  / \      */
1040         fst(t) = snd(t);                /*  xn  .                .   xn    */
1041         snd(t) = x;                     /*       .    ===>      .          */
1042         x      = t;                     /*        .            .           */
1043         t      = fun(x);                /*         .          .            */
1044         n++;                            /*        / \        / \           */
1045     } while (nonNull(t));               /*       x1  NIL   (n)  x1         */
1046     fst(x) = mkTuple(n);
1047     return tup;
1048 }
1049
1050 static List local checkContext(con)     /* validate context                */
1051 Type con; {
1052     mapOver(checkPred, con);
1053     return con;
1054 }
1055
1056 static Cell local checkPred(c)          /* check that type expr is a valid */
1057 Cell c; {                               /* constraint                      */
1058     Cell cn = getHead(c);
1059 #if TREX
1060     if (isExt(cn) && argCount==1)
1061         return c;
1062 #endif
1063     if (!isQCon(cn) || argCount==0)
1064         syntaxError("class expression");
1065     return c;
1066 }
1067
1068 static Pair local checkDo(dqs)          /* convert reversed list of dquals */
1069 List dqs; {                             /* to an (expr,quals) pair         */
1070     if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
1071         ERRMSG(row) "Last generator in do {...} must be an expression"
1072         EEND;
1073     }
1074     fst(dqs) = snd(fst(dqs));           /* put expression in fst of pair   */
1075     snd(dqs) = rev(snd(dqs));           /* & reversed list of quals in snd */
1076     return dqs;
1077 }
1078
1079 static Cell local checkTyLhs(c)         /* check that lhs is of the form   */
1080 Cell c; {                               /* T a1 ... a                      */
1081     Cell tlhs = c;
1082     while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL)
1083         tlhs = fun(tlhs);
1084     switch (whatIs(tlhs)) {
1085         case CONIDCELL  : return c;
1086
1087         default :
1088             ERRMSG(row) "Illegal left hand side in datatype definition"
1089             EEND;
1090     }
1091     return 0; /* NOTREACHED */
1092 }
1093
1094 #if !TREX
1095 static Void local noTREX(where)
1096 String where; {
1097     ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
1098     ERRTEXT     "(TREX is disabled in this build of Hugs)"
1099     EEND;
1100 }
1101 #endif
1102
1103 /*-------------------------------------------------------------------------*/