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         expORpat(LEGIT_PATT, e);
 322         return TRUE;
 323
 324       case ident:
 325         return(TRUE);
 326
 327       case ap:
 328         {
 329           tree f = function(e);
 330           tree a = garg(e);       /* do not "unparen", otherwise the error
 331                                        fromInteger ((x,y) {-no comma-} z)
 332                                      will be missed.
 333                                   */
 334
 335           /* definitions must have pattern arguments */
 336           expORpat(LEGIT_PATT, a);
 337
 338           if(ttree(f) == ident)
 339             return(isconstr(qid_to_string(gident(f))));
 340
 341           else if(ttree(f) == infixap)
 342             return(lhs_is_patt(f));
 343
 344           else
 345             hsperror("Not a legal pattern binding in LHS");
 346         }
 347
 348       case infixap:
 349         {
 350           qid  f  = ginffun((struct Sinfixap *)e);
 351           tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
 352                a2 = unparen(ginfarg2((struct Sinfixap *)e));
 353
 354           /* definitions must have pattern arguments */
 355           expORpat(LEGIT_PATT, a1);
 356           expORpat(LEGIT_PATT, a2);
 357
 358           return(isconstr(qid_to_string(f)));
 359         }
 360
 361       case par:
 362         return(lhs_is_patt(gpare(e)));
 363
 364       /* Anything else must be an illegal LHS */
 365       default:
 366         hsperror("Not a valid LHS");
 367       }
 368
 369   abort(); /* should never get here */
 370   return(FALSE);
 371 }
 372
 373
 374 /*
 375   Return the function at the root of a series of applications.
 376 */
 377
 378 tree
 379 function(e)
 380   tree e;
 381 {
 382   switch (ttree(e))
 383     {
 384       case ap:
 385         expORpat(LEGIT_PATT, garg(e));
 386         return(function(gfun(e)));
 387
 388       case par:
 389         return(function(gpare(e)));
 390
 391       default:
 392         return(e);
 393     }
 394 }
 395
 396
 397 static tree
 398 unparen(e)
 399   tree e;
 400 {
 401   while (ttree(e) == par)
 402       e = gpare(e);
 403
 404   return(e);
 405 }
 406
 407
 408 /*
 409   Extend a function by adding a new definition to its list of bindings.
 410 */
 411
 412 void
 413 extendfn(bind,rule)
 414 binding bind;
 415 binding rule;
 416 {
 417 /*  fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
 418   if(tbinding(bind) == abind)
 419     bind = gabindsnd(bind);
 420
 421   if(tbinding(bind) == pbind)
 422     gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
 423   else if(tbinding(bind) == fbind)
 424     gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
 425   else
 426     fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
 427 }
 428
 429
 430 pbinding
 431 createpat(guards,where)
 432   pbinding guards;
 433   binding where;
 434 {
 435   qid func;
 436
 437   if(FN != NULL)
 438     func = FN;
 439   else
 440     func = mknoqual(install_literal(""));
 441
 442   return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
 443 }
 444
 445
 446 char *
 447 ineg(i)
 448   char *i;
 449 {
 450   char *p = xmalloc(strlen(i)+2);
 451
 452   *p = '-';
 453   strcpy(p+1,i);
 454   return(p);
 455 }
 456
 457 /*
 458   Check the ordering of declarations in a cbody.
 459   All signatures must appear before any declarations.
 460 */
 461
 462 void
 463 checkorder(decls)
 464   binding decls;
 465 {
 466   /* The ordering must be correct for a singleton */
 467   if(tbinding(decls)!=abind)
 468     return;
 469
 470   checkorder2(decls,TRUE);
 471 }
 472
 473 static BOOLEAN
 474 checkorder2(decls,sigs)
 475   binding decls;
 476   BOOLEAN sigs;
 477 {
 478   while(tbinding(decls)==abind)
 479     {
 480       /* Perform a left-traversal if necessary */
 481       binding left = gabindfst(decls);
 482       if(tbinding(left)==abind)
 483         sigs = checkorder2(left,sigs);
 484       else
 485         sigs = checksig(sigs,left);
 486       decls = gabindsnd(decls);
 487     }
 488
 489   return(checksig(sigs,decls));
 490 }
 491
 492 static BOOLEAN
 493 checksig(sig,decl)
 494   BOOLEAN sig;
 495   binding decl;
 496 {
 497   BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
 498   if(!sig && issig)
 499     hsperror("Signature appears after definition in class body");
 500
 501   return(issig);
 502 }
 503
 504
 505 /*
 506   Check the last expression in a list of do statements.
 507 */
 508
 509 void
 510 checkdostmts(stmts)
 511   list stmts;
 512 {
 513   if (tlist(stmts) == lnil)
 514       hsperror("do expression with no statements");
 515
 516   for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
 517       ;
 518   if (ttree(lhd(stmts)) != doexp)
 519       hsperror("do statements must end with expression");
 520 }
 521
 522
 523 /*
 524   Checks there are no bangs in a tycon application.
 525 */
 526
 527 void
 528 checknobangs(app)
 529   ttype app;
 530 {
 531   if(tttype(app) == tapp)
 532     {
 533       if(tttype(gtarg((struct Stapp *)app)) == tbang)
 534         hsperror("syntax error: unexpected ! in type");
 535
 536       checknobangs(gtapp((struct Stapp *)app));
 537     }
 538 }
 539
 540
 541 /*
 542   Splits a tycon application into its constructor and a list of types.
 543 */
 544
 545 void
 546 splittyconapp(app, tyc, tys)
 547   ttype app;
 548   qid *tyc;
 549   list *tys;
 550 {
 551   switch (tttype(app)) {
 552     case tapp:
 553       splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
 554       *tys = lapp(*tys, gtarg((struct Stapp *)app));
 555       break;
 556
 557     case tname:
 558     case namedtvar:
 559       *tyc = gtypeid((struct Stname *)app);
 560       *tys = Lnil;
 561       break;
 562
 563     default:
 564       hsperror("bad left argument to constructor op");
 565     }
 566 }
 567
 568
 569 #if 0
 570
 571 Precedence Parsing Is Now Done In The Compiler !!!
 572
 573 /*
 574
 575   Precedence Parser for Haskell.  By default operators are left-associative,
 576   so it is only necessary to rearrange the parse tree where the new operator
 577   has a greater precedence than the existing one, or where two operators have
 578   the same precedence and are both right-associative. Error conditions are
 579   handled.
 580
 581   Note:  Prefix negation has the same precedence as infix minus.
 582          The algorithm must thus take account of explicit negates.
 583 */
 584
 585 void
 586 precparse(tree t)
 587 {
 588   if(ttree(t) == infixap)
 589     {
 590       tree left = ginfarg1(t);
 591
 592       if(ttree(left) == negate)
 593         {
 594           struct infix *ttabpos = infixlookup(ginffun(t));
 595           struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
 596
 597           if(pprecedence(ntabpos) < pprecedence(ttabpos))
 598             {
 599               /* (-x)*y  ==> -(x*y) */
 600               qid  lop  = ginffun(t);
 601               tree arg1 = gnexp(left);
 602               tree arg2 = ginfarg2(t);
 603
 604               t->tag = negate;
 605               gnexp(t) = left;
 606               gnxxx1(t) = NULL;
 607               gnxxx2(t) = NULL;
 608
 609               left->tag = infixap;
 610               ginffun(left)  = lop;
 611               ginfarg1(left) = arg1;
 612               ginfarg2(left) = arg2;
 613
 614               precparse(left);
 615             }
 616         }
 617
 618       else if(ttree(left) == infixap)
 619         {
 620           struct infix *ttabpos    = infixlookup(ginffun(t));
 621           struct infix *lefttabpos = infixlookup(ginffun(left));
 622
 623           if(pprecedence(lefttabpos) < pprecedence(ttabpos))
 624             rearrangeprec(left,t);
 625
 626           else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
 627             {
 628               if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
 629                 rearrangeprec(left,t);
 630
 631               else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
 632                 /* SKIP */;
 633
 634               else
 635                 {
 636                   char errbuf[ERR_BUF_SIZE];
 637                   sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
 638                           qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
 639                   hsperror(errbuf);
 640               }
 641             }
 642         }
 643     }
 644 }
 645
 646
 647 /*
 648   Rearrange a tree to effectively insert an operator in the correct place.
 649
 650   x+y*z ==parsed== (x+y)*z  ==>  x+(y*z)
 651
 652   The recursive call to precparse ensures this filters down as necessary.
 653 */
 654
 655 static void
 656 rearrangeprec(tree left, tree t)
 657 {
 658   qid top  = ginffun(left);
 659   qid lop  = ginffun(t);
 660   tree arg1 = ginfarg1(left);
 661   tree arg2 = ginfarg2(left);
 662   tree arg3 = ginfarg2(t);
 663
 664   ginffun(t)  = top;
 665   ginfarg1(t) = arg1;
 666   ginfarg2(t) = left;
 667
 668   ginffun(left)  = lop;
 669   ginfarg1(left) = arg2;
 670   ginfarg2(left) = arg3;
 671
 672   precparse(left);
 673 }
 674
 675
 676 /*
 677   Check the precedence of a pattern or expression to ensure that
 678   sections and function definitions have the correct parse.
 679 */
 680
 681 void
 682 checkprec(exp,qfn,right)
 683   tree exp;
 684   qid qfn;
 685   BOOLEAN right;
 686 {
 687   if(ttree(exp) == infixap)
 688     {
 689       struct infix *ftabpos = infixlookup(qfn);
 690       struct infix *etabpos = infixlookup(ginffun(exp));
 691
 692       if (pprecedence(etabpos) > pprecedence(ftabpos) ||
 693          (pprecedence(etabpos) == pprecedence(ftabpos) &&
 694           ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
 695           ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
 696         /* SKIP */;
 697       else
 698         {
 699           char errbuf[ERR_BUF_SIZE];
 700           sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
 701                   qid_to_string(qfn), qid_to_string(ginffun(exp)));
 702           hsperror(errbuf);
 703         }
 704     }
 705 }
 706
 707 #endif /* 0 */
 708
 709
 710
 711 /* Reverse a list, in place */
 712
 713 list reverse_list( l )
 714   list l;
 715 {
 716   list temp, acc = Lnil;
 717
 718   while (tlist( l ) != lnil) {
 719         temp = ltl( l );
 720         ltl( l ) = acc;
 721         acc = l;
 722         l = temp;
 723   }
 724   return( acc );
 725 }