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