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