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
 131           default: /* the others only occur in pragmas */
 132             hsperror("not a valid literal pattern or expression");
 133         }
 134         break;
 135
 136       case negate:
 137         { tree sub = gnexp(e);
 138           if (ttree(sub) != lit) {
 139               error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
 140           } else {
 141               literal l = glit(sub);
 142
 143               if (tliteral(l) != integer && tliteral(l) != floatr) {
 144                 error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
 145               }
 146           }
 147           expORpat(wanted, sub);
 148         }
 149         break;
 150
 151       case ap:
 152         {
 153           tree f = gfun(e);
 154           tree a = garg(e);
 155
 156           is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
 157           expORpat(wanted, f);
 158           expORpat(wanted, a);
 159         }
 160         break;
 161
 162       case infixap:
 163         {
 164           qid  f  = ginffun ((struct Sinfixap *)e);
 165           tree a1 = ginfarg1((struct Sinfixap *)e);
 166           tree a2 = ginfarg2((struct Sinfixap *)e);
 167
 168           expORpat(wanted, a1);
 169           expORpat(wanted, a2);
 170
 171           if (wanted == LEGIT_PATT && !isconstr(qid_to_string(f)))
 172              hsperror("variable application in pattern");
 173         }
 174         break;
 175
 176       case record:
 177         {
 178           list field;
 179           for (field = grbinds(e); tlist(field) == lcons; field = ltl(field)) {
 180               expORpat(wanted, lhd(field));
 181           }
 182         }
 183         break;
 184
 185       case rbind:
 186         if (tmaybe(grbindexp(e)) == just)
 187             expORpat(wanted, gthing(grbindexp(e)));
 188         break;
 189
 190       case tuple:
 191         {
 192           list tup;
 193           for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
 194               expORpat(wanted, lhd(tup));
 195           }
 196         }
 197         break;
 198
 199       case llist:
 200         {
 201           list l;
 202           for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
 203               expORpat(wanted, lhd(l));
 204           }
 205         }
 206         break;
 207
 208       case par: /* parenthesised */
 209         expORpat(wanted, gpare(e));
 210         break;
 211
 212       case restr:
 213       case lambda:
 214       case let:
 215       case casee:
 216       case ife:
 217       case doe:
 218       case ccall:
 219       case scc:
 220       case rupdate:
 221       case comprh:
 222       case eenum:
 223       case lsection:
 224       case rsection:
 225         error_if_patt_wanted(wanted, "unexpected construct in a pattern");
 226         break;
 227
 228       default:
 229         hsperror("not a pattern or expression");
 230       }
 231 }
 232
 233 static void
 234 is_conapp_patt(int wanted, tree f, tree a)
 235 {
 236   if (wanted == LEGIT_EXPR)
 237      return; /* that was easy */
 238
 239   switch(ttree(f))
 240     {
 241       case ident:
 242         if (isconstr(qid_to_string(gident(f))))
 243           {
 244             expORpat(wanted, a);
 245             return;
 246           }
 247         {
 248           char errbuf[ERR_BUF_SIZE];
 249           sprintf(errbuf,"not a constructor application -- %s",qid_to_string(gident(f)));
 250           hsperror(errbuf);
 251         }
 252
 253       case ap:
 254         is_conapp_patt(wanted, gfun(f), garg(f));
 255         expORpat(wanted, a);
 256         return;
 257
 258       case par:
 259         is_conapp_patt(wanted, gpare(f), a);
 260         break;
 261
 262       case tuple:
 263         {
 264            char errbuf[ERR_BUF_SIZE];
 265            sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
 266            hsperror(errbuf);
 267         }
 268         break;
 269
 270       default:
 271         hsperror("not a constructor application");
 272       }
 273 }
 274
 275 static void
 276 error_if_expr_wanted(int wanted, char *msg)
 277 {
 278     if (wanted == LEGIT_EXPR)
 279         hsperror(msg);
 280 }
 281
 282 static void
 283 error_if_patt_wanted(int wanted, char *msg)
 284 {
 285     if (wanted == LEGIT_PATT)
 286         hsperror(msg);
 287 }
 288
 289 /* ---------------------------------------------------------------------- */
 290
 291 BOOLEAN /* return TRUE if LHS is a pattern */
 292 lhs_is_patt(tree e)
 293 {
 294   switch(ttree(e))
 295     {
 296       case lit:
 297         switch (tliteral(glit(e))) {
 298           case integer:
 299           case intprim:
 300           case floatr:
 301           case doubleprim:
 302           case floatprim:
 303           case string:
 304           case charr:
 305           case charprim:
 306           case stringprim:
 307             return TRUE;
 308           default:
 309             hsperror("Literal is not a valid LHS");
 310         }
 311
 312       case wildp:
 313         return TRUE;
 314
 315       case as:
 316       case lazyp:
 317       case llist:
 318       case tuple:
 319       case negate:
 320         expORpat(LEGIT_PATT, e);
 321         return TRUE;
 322
 323       case ident:
 324         return(TRUE);
 325
 326       case ap:
 327         {
 328           tree f = function(e);
 329           tree a = garg(e);       /* do not "unparen", otherwise the error
 330                                        fromInteger ((x,y) {-no comma-} z)
 331                                      will be missed.
 332                                   */
 333
 334           /* definitions must have pattern arguments */
 335           expORpat(LEGIT_PATT, a);
 336
 337           if(ttree(f) == ident)
 338             return(isconstr(qid_to_string(gident(f))));
 339
 340           else if(ttree(f) == infixap)
 341             return(lhs_is_patt(f));
 342
 343           else
 344             hsperror("Not a legal pattern binding in LHS");
 345         }
 346
 347       case infixap:
 348         {
 349           qid  f  = ginffun((struct Sinfixap *)e);
 350           tree a1 = unparen(ginfarg1((struct Sinfixap *)e)),
 351                a2 = unparen(ginfarg2((struct Sinfixap *)e));
 352
 353           /* definitions must have pattern arguments */
 354           expORpat(LEGIT_PATT, a1);
 355           expORpat(LEGIT_PATT, a2);
 356
 357           return(isconstr(qid_to_string(f)));
 358         }
 359
 360       case par:
 361         return(lhs_is_patt(gpare(e)));
 362
 363       /* Anything else must be an illegal LHS */
 364       default:
 365         hsperror("Not a valid LHS");
 366       }
 367
 368   abort(); /* should never get here */
 369   return(FALSE);
 370 }
 371
 372
 373 /*
 374   Return the function at the root of a series of applications.
 375 */
 376
 377 tree
 378 function(e)
 379   tree e;
 380 {
 381   switch (ttree(e))
 382     {
 383       case ap:
 384         expORpat(LEGIT_PATT, garg(e));
 385         return(function(gfun(e)));
 386
 387       case par:
 388         return(function(gpare(e)));
 389
 390       default:
 391         return(e);
 392     }
 393 }
 394
 395
 396 static tree
 397 unparen(e)
 398   tree e;
 399 {
 400   while (ttree(e) == par)
 401       e = gpare(e);
 402
 403   return(e);
 404 }
 405
 406
 407 /*
 408   Extend a function by adding a new definition to its list of bindings.
 409 */
 410
 411 void
 412 extendfn(bind,rule)
 413 binding bind;
 414 binding rule;
 415 {
 416 /*  fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
 417   if(tbinding(bind) == abind)
 418     bind = gabindsnd(bind);
 419
 420   if(tbinding(bind) == pbind)
 421     gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
 422   else if(tbinding(bind) == fbind)
 423     gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
 424   else
 425     fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
 426 }
 427
 428
 429 pbinding
 430 createpat(guards,where)
 431   pbinding guards;
 432   binding where;
 433 {
 434   qid func;
 435
 436   if(FN != NULL)
 437     func = FN;
 438   else
 439     func = mknoqual(install_literal(""));
 440
 441   return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
 442 }
 443
 444
 445 char *
 446 ineg(i)
 447   char *i;
 448 {
 449   char *p = xmalloc(strlen(i)+2);
 450
 451   *p = '-';
 452   strcpy(p+1,i);
 453   return(p);
 454 }
 455
 456 /*
 457   Check the ordering of declarations in a cbody.
 458   All signatures must appear before any declarations.
 459 */
 460
 461 void
 462 checkorder(decls)
 463   binding decls;
 464 {
 465   /* The ordering must be correct for a singleton */
 466   if(tbinding(decls)!=abind)
 467     return;
 468
 469   checkorder2(decls,TRUE);
 470 }
 471
 472 static BOOLEAN
 473 checkorder2(decls,sigs)
 474   binding decls;
 475   BOOLEAN sigs;
 476 {
 477   while(tbinding(decls)==abind)
 478     {
 479       /* Perform a left-traversal if necessary */
 480       binding left = gabindfst(decls);
 481       if(tbinding(left)==abind)
 482         sigs = checkorder2(left,sigs);
 483       else
 484         sigs = checksig(sigs,left);
 485       decls = gabindsnd(decls);
 486     }
 487
 488   return(checksig(sigs,decls));
 489 }
 490
 491 static BOOLEAN
 492 checksig(sig,decl)
 493   BOOLEAN sig;
 494   binding decl;
 495 {
 496   BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
 497   if(!sig && issig)
 498     hsperror("Signature appears after definition in class body");
 499
 500   return(issig);
 501 }
 502
 503
 504 /*
 505   Check the last expression in a list of do statements.
 506 */
 507
 508 void
 509 checkdostmts(stmts)
 510   list stmts;
 511 {
 512   if (tlist(stmts) == lnil)
 513       hsperror("do expression with no statements");
 514
 515   for(; tlist(ltl(stmts)) != lnil; stmts = ltl(stmts))
 516       ;
 517   if (ttree(lhd(stmts)) != doexp)
 518       hsperror("do statements must end with expression");
 519 }
 520
 521
 522 /*
 523   Checks there are no bangs in a tycon application.
 524 */
 525
 526 void
 527 checknobangs(app)
 528   ttype app;
 529 {
 530   if(tttype(app) == tapp)
 531     {
 532       if(tttype(gtarg((struct Stapp *)app)) == tbang)
 533         hsperror("syntax error: unexpected ! in type");
 534
 535       checknobangs(gtapp((struct Stapp *)app));
 536     }
 537 }
 538
 539
 540 /*
 541   Splits a tycon application into its constructor and a list of types.
 542 */
 543
 544 void
 545 splittyconapp(app, tyc, tys)
 546   ttype app;
 547   qid *tyc;
 548   list *tys;
 549 {
 550   switch (tttype(app)) {
 551     case tapp:
 552       splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
 553       *tys = lapp(*tys, gtarg((struct Stapp *)app));
 554       break;
 555
 556     case tname:
 557     case namedtvar:
 558       *tyc = gtypeid((struct Stname *)app);
 559       *tys = Lnil;
 560       break;
 561
 562     default:
 563       hsperror("bad left argument to constructor op");
 564     }
 565 }
 566
 567
 568 #if 0
 569
 570 Precedence Parsing Is Now Done In The Compiler !!!
 571
 572 /*
 573
 574   Precedence Parser for Haskell.  By default operators are left-associative,
 575   so it is only necessary to rearrange the parse tree where the new operator
 576   has a greater precedence than the existing one, or where two operators have
 577   the same precedence and are both right-associative. Error conditions are
 578   handled.
 579
 580   Note:  Prefix negation has the same precedence as infix minus.
 581          The algorithm must thus take account of explicit negates.
 582 */
 583
 584 void
 585 precparse(tree t)
 586 {
 587   if(ttree(t) == infixap)
 588     {
 589       tree left = ginfarg1(t);
 590
 591       if(ttree(left) == negate)
 592         {
 593           struct infix *ttabpos = infixlookup(ginffun(t));
 594           struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
 595
 596           if(pprecedence(ntabpos) < pprecedence(ttabpos))
 597             {
 598               /* (-x)*y  ==> -(x*y) */
 599               qid  lop  = ginffun(t);
 600               tree arg1 = gnexp(left);
 601               tree arg2 = ginfarg2(t);
 602
 603               t->tag = negate;
 604               gnexp(t) = left;
 605               gnxxx1(t) = NULL;
 606               gnxxx2(t) = NULL;
 607
 608               left->tag = infixap;
 609               ginffun(left)  = lop;
 610               ginfarg1(left) = arg1;
 611               ginfarg2(left) = arg2;
 612
 613               precparse(left);
 614             }
 615         }
 616
 617       else if(ttree(left) == infixap)
 618         {
 619           struct infix *ttabpos    = infixlookup(ginffun(t));
 620           struct infix *lefttabpos = infixlookup(ginffun(left));
 621
 622           if(pprecedence(lefttabpos) < pprecedence(ttabpos))
 623             rearrangeprec(left,t);
 624
 625           else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
 626             {
 627               if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
 628                 rearrangeprec(left,t);
 629
 630               else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
 631                 /* SKIP */;
 632
 633               else
 634                 {
 635                   char errbuf[ERR_BUF_SIZE];
 636                   sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
 637                           qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
 638                   hsperror(errbuf);
 639               }
 640             }
 641         }
 642     }
 643 }
 644
 645
 646 /*
 647   Rearrange a tree to effectively insert an operator in the correct place.
 648
 649   x+y*z ==parsed== (x+y)*z  ==>  x+(y*z)
 650
 651   The recursive call to precparse ensures this filters down as necessary.
 652 */
 653
 654 static void
 655 rearrangeprec(tree left, tree t)
 656 {
 657   qid top  = ginffun(left);
 658   qid lop  = ginffun(t);
 659   tree arg1 = ginfarg1(left);
 660   tree arg2 = ginfarg2(left);
 661   tree arg3 = ginfarg2(t);
 662
 663   ginffun(t)  = top;
 664   ginfarg1(t) = arg1;
 665   ginfarg2(t) = left;
 666
 667   ginffun(left)  = lop;
 668   ginfarg1(left) = arg2;
 669   ginfarg2(left) = arg3;
 670
 671   precparse(left);
 672 }
 673
 674
 675 /*
 676   Check the precedence of a pattern or expression to ensure that
 677   sections and function definitions have the correct parse.
 678 */
 679
 680 void
 681 checkprec(exp,qfn,right)
 682   tree exp;
 683   qid qfn;
 684   BOOLEAN right;
 685 {
 686   if(ttree(exp) == infixap)
 687     {
 688       struct infix *ftabpos = infixlookup(qfn);
 689       struct infix *etabpos = infixlookup(ginffun(exp));
 690
 691       if (pprecedence(etabpos) > pprecedence(ftabpos) ||
 692          (pprecedence(etabpos) == pprecedence(ftabpos) &&
 693           ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
 694           ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
 695         /* SKIP */;
 696       else
 697         {
 698           char errbuf[ERR_BUF_SIZE];
 699           sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
 700                   qid_to_string(qfn), qid_to_string(ginffun(exp)));
 701           hsperror(errbuf);
 702         }
 703     }
 704 }
 705
 706 #endif /* 0 */
 707
 708
 709
 710 /* Reverse a list, in place */
 711
 712 list reverse_list( l )
 713   list l;
 714 {
 715   list temp, acc = Lnil;
 716
 717   while (tlist( l ) != lnil) {
 718         temp = ltl( l );
 719         ltl( l ) = acc;
 720         acc = l;
 721         l = temp;
 722   }
 723   return( acc );
 724 }