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