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