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