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 /* Check that a type is of the form
 567         C a1 a2 .. an
 568    where n>=1, and the ai are all type variables
 569    This is used to check that a class decl is well formed.
 570 */
 571 void
 572 check_class_decl_head_help( app, n )
 573   ttype app;
 574   int n;        /* Number of args so far */
 575 {
 576   switch (tttype(app)) {
 577     case tapp:
 578         /* Check the arg is a type variable */
 579         switch (tttype (gtarg((struct Stapp *) app))) {
 580                 case namedtvar: break;
 581                 default: hsperror("Class declaration head must use only type variables");
 582         }
 583
 584         /* Check the fun part */
 585         check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 );
 586         break;
 587
 588     case tname:
 589         /* Class name; check there is at least one argument */
 590       if (n==0) {
 591             hsperror("Class must have at least one argument");
 592       }
 593       break;
 594
 595     default:
 596         hsperror("Illegal syntax in class declaration head");
 597   }
 598 }
 599
 600 void
 601 check_class_decl_head( app )
 602   ttype app;
 603 { check_class_decl_head_help( app, 0 ); }
 604
 605
 606
 607 /*
 608   Splits a tycon application into its constructor and a list of types.
 609 */
 610
 611 void
 612 splittyconapp(app, tyc, tys)
 613   ttype app;
 614   qid *tyc;
 615   list *tys;
 616 {
 617   switch (tttype(app)) {
 618     case tapp:
 619       splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
 620       *tys = lapp(*tys, gtarg((struct Stapp *)app));
 621       break;
 622
 623     case tname:
 624     case namedtvar:
 625       *tyc = gtypeid((struct Stname *)app);
 626       *tys = Lnil;
 627       break;
 628
 629     default:
 630       hsperror("bad left argument to constructor op");
 631     }
 632 }
 633
 634
 635 #if 0
 636
 637 Precedence Parsing Is Now Done In The Compiler !!!
 638
 639 /*
 640
 641   Precedence Parser for Haskell.  By default operators are left-associative,
 642   so it is only necessary to rearrange the parse tree where the new operator
 643   has a greater precedence than the existing one, or where two operators have
 644   the same precedence and are both right-associative. Error conditions are
 645   handled.
 646
 647   Note:  Prefix negation has the same precedence as infix minus.
 648          The algorithm must thus take account of explicit negates.
 649 */
 650
 651 void
 652 precparse(tree t)
 653 {
 654   if(ttree(t) == infixap)
 655     {
 656       tree left = ginfarg1(t);
 657
 658       if(ttree(left) == negate)
 659         {
 660           struct infix *ttabpos = infixlookup(ginffun(t));
 661           struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
 662
 663           if(pprecedence(ntabpos) < pprecedence(ttabpos))
 664             {
 665               /* (-x)*y  ==> -(x*y) */
 666               qid  lop  = ginffun(t);
 667               tree arg1 = gnexp(left);
 668               tree arg2 = ginfarg2(t);
 669
 670               t->tag = negate;
 671               gnexp(t) = left;
 672               gnxxx1(t) = NULL;
 673               gnxxx2(t) = NULL;
 674
 675               left->tag = infixap;
 676               ginffun(left)  = lop;
 677               ginfarg1(left) = arg1;
 678               ginfarg2(left) = arg2;
 679
 680               precparse(left);
 681             }
 682         }
 683
 684       else if(ttree(left) == infixap)
 685         {
 686           struct infix *ttabpos    = infixlookup(ginffun(t));
 687           struct infix *lefttabpos = infixlookup(ginffun(left));
 688
 689           if(pprecedence(lefttabpos) < pprecedence(ttabpos))
 690             rearrangeprec(left,t);
 691
 692           else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
 693             {
 694               if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
 695                 rearrangeprec(left,t);
 696
 697               else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
 698                 /* SKIP */;
 699
 700               else
 701                 {
 702                   char errbuf[ERR_BUF_SIZE];
 703                   sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
 704                           qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
 705                   hsperror(errbuf);
 706               }
 707             }
 708         }
 709     }
 710 }
 711
 712
 713 /*
 714   Rearrange a tree to effectively insert an operator in the correct place.
 715
 716   x+y*z ==parsed== (x+y)*z  ==>  x+(y*z)
 717
 718   The recursive call to precparse ensures this filters down as necessary.
 719 */
 720
 721 static void
 722 rearrangeprec(tree left, tree t)
 723 {
 724   qid top  = ginffun(left);
 725   qid lop  = ginffun(t);
 726   tree arg1 = ginfarg1(left);
 727   tree arg2 = ginfarg2(left);
 728   tree arg3 = ginfarg2(t);
 729
 730   ginffun(t)  = top;
 731   ginfarg1(t) = arg1;
 732   ginfarg2(t) = left;
 733
 734   ginffun(left)  = lop;
 735   ginfarg1(left) = arg2;
 736   ginfarg2(left) = arg3;
 737
 738   precparse(left);
 739 }
 740
 741
 742 /*
 743   Check the precedence of a pattern or expression to ensure that
 744   sections and function definitions have the correct parse.
 745 */
 746
 747 void
 748 checkprec(exp,qfn,right)
 749   tree exp;
 750   qid qfn;
 751   BOOLEAN right;
 752 {
 753   if(ttree(exp) == infixap)
 754     {
 755       struct infix *ftabpos = infixlookup(qfn);
 756       struct infix *etabpos = infixlookup(ginffun(exp));
 757
 758       if (pprecedence(etabpos) > pprecedence(ftabpos) ||
 759          (pprecedence(etabpos) == pprecedence(ftabpos) &&
 760           ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
 761           ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
 762         /* SKIP */;
 763       else
 764         {
 765           char errbuf[ERR_BUF_SIZE];
 766           sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
 767                   qid_to_string(qfn), qid_to_string(ginffun(exp)));
 768           hsperror(errbuf);
 769         }
 770     }
 771 }
 772
 773 #endif /* 0 */
 774
 775
 776
 777 /* Reverse a list, in place */
 778
 779 list reverse_list( l )
 780   list l;
 781 {
 782   list temp, acc = Lnil;
 783
 784   while (tlist( l ) != lnil) {
 785         temp = ltl( l );
 786         ltl( l ) = acc;
 787         acc = l;
 788         l = temp;
 789   }
 790   return( acc );
 791 }