ghc/compiler/parser/syntax.c

   1 /**********************************************************************
   2 *                                                                     *
   3 *                                                                     *
   4 *     Syntax-related Utility Functions                                *
   5 *                                                                     *
   6 *                                                                     *
   7 **********************************************************************/
   8
   9 #include <stdio.h>
  10 #include <ctype.h>
  11
  12 #include "hspincl.h"
  13 #include "constants.h"
  14 #include "utils.h"
  15 #include "tree.h"
  16 #include "list.h"
  17
  18 #include "hsparser.tab.h"
  19
  20 /* Imported values */
  21 extern short icontexts;
  22 extern list Lnil;
  23 extern unsigned endlineno, startlineno;
  24 extern BOOLEAN hashIds, etags;
  25
  26 /* Forward Declarations */
  27
  28 char *ineg                  PROTO((char *));
  29 static tree unparen         PROTO((tree));
  30 static void is_conapp_patt  PROTO((int, tree, tree));
  31 static void rearrangeprec   PROTO((tree, tree));
  32 static void error_if_expr_wanted PROTO((int, char *));
  33 static void error_if_patt_wanted PROTO((int, char *));
  34
  35 qid     fns[MAX_CONTEXTS] = { NULL };
  36 BOOLEAN samefn[MAX_CONTEXTS] = { FALSE };
  37 tree    prevpatt[MAX_CONTEXTS] = { NULL };
  38
  39 static BOOLEAN   checkorder2 PROTO((binding, BOOLEAN));
  40 static BOOLEAN   checksig PROTO((BOOLEAN, binding));
  41
  42 /*
  43   check infix value in range 0..9
  44 */
  45
  46
  47 int
  48 checkfixity(vals)
  49   char *vals;
  50 {
  51   int value;
  52   sscanf(vals,"%d",&value);
  53
  54   if (value < 0 || value > 9)
  55     {
  56       int oldvalue = value;
  57       value = value < 0 ? 0 : 9;
  58       fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
  59               oldvalue,value);
  60     }
  61   return(value);
  62 }
  63
  64
  65 /*
  66   Check Previous Pattern usage
  67 */
  68
  69 void
  70 checksamefn(fn)
  71   qid fn;
  72 {
  73   char *this = qid_to_string(fn);
  74   char *was  = (FN==NULL) ? NULL : qid_to_string(FN);
  75
  76   SAMEFN = (was != NULL && strcmp(this,was) == 0);
  77
  78   if(!SAMEFN && etags)
  79 #if 1/*etags*/
  80     printf("%u\n",startlineno);
  81 #else
  82     fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,this);
  83 #endif
  84 }
  85
  86
  87 /* ------------------------------------------------------------------------
  88 */
  89
  90 void
  91 expORpat(int wanted, tree e)
  92 {
  93   switch(ttree(e))
  94     {
  95       case ident: /* a pattern or expr */
  96         break;
  97
  98       case wildp:
  99         error_if_expr_wanted(wanted, "wildcard in expression");
 100         break;
 101
 102       case as:
 103         error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
 104         expORpat(wanted, gase(e));
 105         break;
 106
 107       case lazyp:
 108         error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
 109         expORpat(wanted, glazyp(e));
 110         break;
 111
 112       case plusp:
 113         break;
 114
 115       case lit:
 116         switch (tliteral(glit(e))) {
 117           case integer:
 118           case intprim:
 119           case floatr:
 120           case doubleprim:
 121           case floatprim:
 122           case string:
 123           case stringprim:
 124           case charr:
 125           case charprim:
 126             break; /* pattern or expr */
 127
 128           case clitlit:
 129             error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
 130             break;
 131
 132           default: /* the others only occur in pragmas */
 133             hsperror("not a valid literal pattern or expression");
 134         }
 135         break;
 136
 137       case negate:
 138         { tree sub = gnexp(e);
 139           if (ttree(sub) != lit) {
 140               error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
 141           } else {
 142               literal l = glit(sub);
 143
 144               if (tliteral(l) != integer && tliteral(l) != floatr) {
 145                 error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
 146               }
 147           }
 148           expORpat(wanted, sub);
 149         }
 150         break;
 151
 152       case ap:
 153         {
 154           tree f = gfun(e);
 155           tree a = garg(e);
 156
 157           is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
 158           expORpat(wanted, f);
 159           expORpat(wanted, a);
 160         }
 161         break;
 162
 163       case infixap:
 164         {
 165           qid  f  = ginffun ((struct Sinfixap *)e);
 166           tree a1 = ginfarg1((struct Sinfixap *)e);
 167           tree a2 = ginfarg2((struct Sinfixap *)e);
 168
 169           expORpat(wanted, a1);
 170           expORpat(wanted, a2);
 171
 172           if (wanted == LEGIT_PATT && !isconstr(qid_to_string(f)))
 173              hsperror("variable application in pattern");
 174         }
 175         break;
 176
 177       case record:
 178         {
 179           list field;
 180           for (field = grbinds(e); tlist(field) == lcons; field = ltl(field)) {
 181               expORpat(wanted, lhd(field));
 182           }
 183         }
 184         break;
 185
 186       case rbind:
 187         if (tmaybe(grbindexp(e)) == just)
 188             expORpat(wanted, gthing(grbindexp(e)));
 189         break;
 190
 191       case tuple:
 192         {
 193           list tup;
 194           for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
 195               expORpat(wanted, lhd(tup));
 196           }
 197         }
 198         break;
 199
 200       case llist:
 201         {
 202           list l;
 203           for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
 204               expORpat(wanted, lhd(l));
 205           }
 206         }
 207         break;
 208
 209       case par: /* parenthesised */
 210         expORpat(wanted, gpare(e));
 211         break;
 212
 213       case restr:
 214       case lambda:
 215       case let:
 216       case casee:
 217       case ife:
 218       case doe:
 219       case ccall:
 220       case scc:
 221       case rupdate:
 222       case comprh:
 223       case eenum:
 224       case lsection:
 225       case rsection:
 226         error_if_patt_wanted(wanted, "unexpected construct in a pattern");
 227         break;
 228
 229       default:
 230         hsperror("not a pattern or expression");
 231       }
 232 }
 233
 234 static void
 235 is_conapp_patt(int wanted, tree f, tree a)
 236 {
 237   if (wanted == LEGIT_EXPR)
 238      return; /* that was easy */
 239
 240   switch(ttree(f))
 241     {
 242       case ident:
 243         if (isconstr(qid_to_string(gident(f))))
 244           {
 245             expORpat(wanted, a);
 246             return;
 247           }
 248         {
 249           char errbuf[ERR_BUF_SIZE];
 250           sprintf(errbuf,"not a constructor application -- %s",qid_to_string(gident(f)));
 251           hsperror(errbuf);
 252         }
 253
 254       case ap:
 255         is_conapp_patt(wanted, gfun(f), garg(f));
 256         expORpat(wanted, a);
 257         return;
 258
 259       case par:
 260         is_conapp_patt(wanted, gpare(f), a);
 261         break;
 262
 263       case tuple:
 264         {
 265            char errbuf[ERR_BUF_SIZE];
 266            sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
 267            hsperror(errbuf);
 268         }
 269         break;
 270
 271       default:
 272         hsperror("not a constructor application");
 273       }
 274 }
 275
 276 static void
 277 error_if_expr_wanted(int wanted, char *msg)
 278 {
 279     if (wanted == LEGIT_EXPR)
 280         hsperror(msg);
 281 }
 282
 283 static void
 284 error_if_patt_wanted(int wanted, char *msg)
 285 {
 286     if (wanted == LEGIT_PATT)
 287         hsperror(msg);
 288 }
 289
 290 /* ---------------------------------------------------------------------- */
 291
 292 BOOLEAN /* return TRUE if LHS is a pattern */
 293 lhs_is_patt(tree e)
 294 {
 295   switch(ttree(e))
 296     {
 297       case lit:
 298         switch (tliteral(glit(e))) {
 299           case integer:
 300           case intprim:
 301           case floatr:
 302           case doubleprim:
 303           case floatprim:
 304           case string:
 305           case charr:
 306           case charprim:
 307           case stringprim:
 308             return TRUE;
 309           default:
 310             hsperror("Literal is not a valid LHS");
 311         }
 312
 313       case wildp:
 314         return TRUE;
 315
 316       case as:
 317       case lazyp:
 318       case llist:
 319       case tuple:
 320       case negate:
 321       case record:
 322         expORpat(LEGIT_PATT, e);
 323         return TRUE;
 324
 325       case ident:
 326         return(TRUE);
 327
 328       case ap:
 329         {
 330           tree f = function(e);
 331
 332 /*  These lines appear to duplicate what's in function(e).
 333     Nuked SLPJ May 97
 334
 335           tree a = garg(e);       -- do not "unparen", otherwise the error
 336                                   --     fromInteger ((x,y) {-no comma-} z)
 337                                   --   will be missed.
 338
 339           -- definitions must have pattern arguments
 340           expORpat(LEGIT_PATT, a);
 341 */
 342
 343           if(ttree(f) == ident)
 344             return(isconstr(qid_to_string(gident(f))));
 345
 346           else if(ttree(f) == infixap)
 347             return(lhs_is_patt(f));
 348
 349           else
 350             hsperror("Syntax error: not a legal pattern binding in LHS");
 351         }
 352
 353       case infixap:
 354         {
 355           qid  f  = ginffun((struct Sinfixap *)e);
 356           tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
 357                a2 = unparen(ginfarg2((struct Sinfixap *)e));
 358
 359           /* definitions must have pattern arguments */
 360           expORpat(LEGIT_PATT, a1);
 361           expORpat(LEGIT_PATT, a2);
 362
 363           return(isconstr(qid_to_string(f)));
 364         }
 365
 366       case par:
 367         return(lhs_is_patt(gpare(e)));
 368
 369       /* Anything else must be an illegal LHS */
 370       default:
 371         hsperror("Syntax error: not a valid LHS");
 372       }
 373
 374   abort(); /* should never get here */
 375   return(FALSE);
 376 }
 377
 378
 379 /*
 380   Return the function at the root of a series of applications,
 381   checking on the way that the arguments are patterns.
 382 */
 383
 384 tree
 385 function(e)
 386   tree e;
 387 {
 388   switch (ttree(e))
 389     {
 390       case ap:
 391         expORpat(LEGIT_PATT, garg(e));
 392         return(function(gfun(e)));
 393
 394       case par:
 395         return(function(gpare(e)));
 396
 397       default:
 398         return(e);
 399     }
 400 }
 401
 402
 403 static tree
 404 unparen(e)
 405   tree e;
 406 {
 407   while (ttree(e) == par)
 408       e = gpare(e);
 409
 410   return(e);
 411 }
 412
 413
 414 /*
 415   Extend a function by adding a new definition to its list of bindings.
 416 */
 417
 418 void
 419 extendfn(bind,rule)
 420 binding bind;
 421 binding rule;
 422 {
 423 /*  fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
 424   if(tbinding(bind) == abind)
 425     bind = gabindsnd(bind);
 426
 427   if(tbinding(bind) == pbind)
 428     gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
 429   else if(tbinding(bind) == fbind)
 430     gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
 431   else
 432     fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
 433 }
 434
 435
 436 pbinding
 437 createpat(guards,where)
 438   pbinding guards;
 439   binding where;
 440 {
 441   qid func;
 442
 443   if(FN != NULL)
 444     func = FN;
 445   else
 446     func = mknoqual(install_literal(""));
 447
 448   return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
 449 }
 450
 451
 452 char *
 453 ineg(i)
 454   char *i;
 455 {
 456   char *p = xmalloc(strlen(i)+2);
 457
 458   *p = '-';
 459   strcpy(p+1,i);
 460   return(p);
 461 }
 462
 463 /*
 464   Check the ordering of declarations in a cbody.
 465   All signatures must appear before any declarations.
 466 */
 467
 468 void
 469 checkorder(decls)
 470   binding decls;
 471 {
 472   /* The ordering must be correct for a singleton */
 473   if(tbinding(decls)!=abind)
 474     return;
 475
 476   checkorder2(decls,TRUE);
 477 }
 478
 479 static BOOLEAN
 480 checkorder2(decls,sigs)
 481   binding decls;
 482   BOOLEAN sigs;
 483 {
 484   while(tbinding(decls)==abind)
 485     {
 486       /* Perform a left-traversal if necessary */
 487       binding left = gabindfst(decls);
 488       if(tbinding(left)==abind)
 489         sigs = checkorder2(left,sigs);
 490       else
 491         sigs = checksig(sigs,left);
 492       decls = gabindsnd(decls);
 493     }
 494
 495   return(checksig(sigs,decls));
 496 }
 497
 498 static BOOLEAN
 499 checksig(sig,decl)
 500   BOOLEAN sig;
 501   binding decl;
 502 {
 503   BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
 504   if(!sig && issig)
 505     hsperror("Signature appears after definition in class body");
 506
 507   return(issig);
 508 }
 509
 510
 511 /*
 512   Check the last expression in a list of do statements.
 513 */
 514
 515 void
 516 checkdostmts(stmts)
 517   list stmts;
 518 {
 519   if (tlist(stmts) == lnil)
 520       hsperror("do expression with no statements");
 521
 522   for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
 523       ;
 524   if (ttree(lhd(stmts)) != doexp)
 525       hsperror("do statements must end with expression");
 526 }
 527
 528
 529 /*
 530   Checks there are no bangs in a tycon application.
 531 */
 532
 533 void
 534 checknobangs(app)
 535   ttype app;
 536 {
 537   if(tttype(app) == tapp)
 538     {
 539       if(tttype(gtarg((struct Stapp *)app)) == tbang)
 540         hsperror("syntax error: unexpected ! in type");
 541
 542       checknobangs(gtapp((struct Stapp *)app));
 543     }
 544 }
 545
 546
 547 /* Check that a type is of the form
 548         C a1 a2 .. an
 549    where n>=1, and the ai are all type variables
 550    This is used to check that a class decl is well formed.
 551 */
 552 void
 553 check_class_decl_head_help( app, n )
 554   ttype app;
 555   int n;        /* Number of args so far */
 556 {
 557   switch (tttype(app)) {
 558     case tapp:
 559         /* Check the arg is a type variable */
 560         switch (tttype (gtarg((struct Stapp *) app))) {
 561                 case namedtvar: break;
 562                 default: hsperror("Class declaration head must use only type variables");
 563         }
 564
 565         /* Check the fun part */
 566         check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 );
 567         break;
 568
 569     case tname:
 570         /* Class name; check there is at least one argument */
 571       if (n==0) {
 572             hsperror("Class must have at least one argument");
 573       }
 574       break;
 575
 576     default:
 577         hsperror("Illegal syntax in class declaration head");
 578   }
 579 }
 580
 581 void
 582 check_class_decl_head( app )
 583   ttype app;
 584 { check_class_decl_head_help( app, 0 ); }
 585
 586
 587
 588 /*
 589   Splits a tycon application into its constructor and a list of types.
 590 */
 591
 592 void
 593 splittyconapp(app, tyc, tys)
 594   ttype app;
 595   qid *tyc;
 596   list *tys;
 597 {
 598   switch (tttype(app)) {
 599     case tapp:
 600       splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
 601       *tys = lapp(*tys, gtarg((struct Stapp *)app));
 602       break;
 603
 604     case tname:
 605     case namedtvar:
 606       *tyc = gtypeid((struct Stname *)app);
 607       *tys = Lnil;
 608       break;
 609
 610     default:
 611       hsperror("bad left argument to constructor op");
 612     }
 613 }
 614
 615
 616 #if 0
 617
 618 Precedence Parsing Is Now Done In The Compiler !!!
 619
 620 /*
 621
 622   Precedence Parser for Haskell.  By default operators are left-associative,
 623   so it is only necessary to rearrange the parse tree where the new operator
 624   has a greater precedence than the existing one, or where two operators have
 625   the same precedence and are both right-associative. Error conditions are
 626   handled.
 627
 628   Note:  Prefix negation has the same precedence as infix minus.
 629          The algorithm must thus take account of explicit negates.
 630 */
 631
 632 void
 633 precparse(tree t)
 634 {
 635   if(ttree(t) == infixap)
 636     {
 637       tree left = ginfarg1(t);
 638
 639       if(ttree(left) == negate)
 640         {
 641           struct infix *ttabpos = infixlookup(ginffun(t));
 642           struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
 643
 644           if(pprecedence(ntabpos) < pprecedence(ttabpos))
 645             {
 646               /* (-x)*y  ==> -(x*y) */
 647               qid  lop  = ginffun(t);
 648               tree arg1 = gnexp(left);
 649               tree arg2 = ginfarg2(t);
 650
 651               t->tag = negate;
 652               gnexp(t) = left;
 653               gnxxx1(t) = NULL;
 654               gnxxx2(t) = NULL;
 655
 656               left->tag = infixap;
 657               ginffun(left)  = lop;
 658               ginfarg1(left) = arg1;
 659               ginfarg2(left) = arg2;
 660
 661               precparse(left);
 662             }
 663         }
 664
 665       else if(ttree(left) == infixap)
 666         {
 667           struct infix *ttabpos    = infixlookup(ginffun(t));
 668           struct infix *lefttabpos = infixlookup(ginffun(left));
 669
 670           if(pprecedence(lefttabpos) < pprecedence(ttabpos))
 671             rearrangeprec(left,t);
 672
 673           else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
 674             {
 675               if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
 676                 rearrangeprec(left,t);
 677
 678               else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
 679                 /* SKIP */;
 680
 681               else
 682                 {
 683                   char errbuf[ERR_BUF_SIZE];
 684                   sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
 685                           qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
 686                   hsperror(errbuf);
 687               }
 688             }
 689         }
 690     }
 691 }
 692
 693
 694 /*
 695   Rearrange a tree to effectively insert an operator in the correct place.
 696
 697   x+y*z ==parsed== (x+y)*z  ==>  x+(y*z)
 698
 699   The recursive call to precparse ensures this filters down as necessary.
 700 */
 701
 702 static void
 703 rearrangeprec(tree left, tree t)
 704 {
 705   qid top  = ginffun(left);
 706   qid lop  = ginffun(t);
 707   tree arg1 = ginfarg1(left);
 708   tree arg2 = ginfarg2(left);
 709   tree arg3 = ginfarg2(t);
 710
 711   ginffun(t)  = top;
 712   ginfarg1(t) = arg1;
 713   ginfarg2(t) = left;
 714
 715   ginffun(left)  = lop;
 716   ginfarg1(left) = arg2;
 717   ginfarg2(left) = arg3;
 718
 719   precparse(left);
 720 }
 721
 722
 723 /*
 724   Check the precedence of a pattern or expression to ensure that
 725   sections and function definitions have the correct parse.
 726 */
 727
 728 void
 729 checkprec(exp,qfn,right)
 730   tree exp;
 731   qid qfn;
 732   BOOLEAN right;
 733 {
 734   if(ttree(exp) == infixap)
 735     {
 736       struct infix *ftabpos = infixlookup(qfn);
 737       struct infix *etabpos = infixlookup(ginffun(exp));
 738
 739       if (pprecedence(etabpos) > pprecedence(ftabpos) ||
 740          (pprecedence(etabpos) == pprecedence(ftabpos) &&
 741           ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
 742           ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
 743         /* SKIP */;
 744       else
 745         {
 746           char errbuf[ERR_BUF_SIZE];
 747           sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
 748                   qid_to_string(qfn), qid_to_string(ginffun(exp)));
 749           hsperror(errbuf);
 750         }
 751     }
 752 }
 753
 754 #endif /* 0 */
 755
 756
 757
 758 /* Reverse a list, in place */
 759
 760 list reverse_list( l )
 761   list l;
 762 {
 763   list temp, acc = Lnil;
 764
 765   while (tlist( l ) != lnil) {
 766         temp = ltl( l );
 767         ltl( l ) = acc;
 768         acc = l;
 769         l = temp;
 770   }
 771   return( acc );
 772 }