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