1 /**********************************************************************
4 * Syntax-related Utility Functions *
7 **********************************************************************/
13 #include "constants.h"
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...
27 #include "hsparser-DPH.tab.h"
29 #include "hsparser.tab.h"
30 #endif /* Data Parallel Haskell */
33 extern short icontexts;
35 extern unsigned endlineno, startlineno;
36 extern BOOLEAN hashIds, etags;
38 /* Forward Declarations */
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 *));
47 tree fns[MAX_CONTEXTS] = { NULL };
48 short samefn[MAX_CONTEXTS] = { 0 };
49 tree prevpatt[MAX_CONTEXTS] = { NULL };
51 BOOLEAN inpat = FALSE;
53 static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
54 static BOOLEAN checksig PROTO((BOOLEAN, binding));
57 check infix value in range 0..9
66 sscanf(vals,"%d",&value);
68 if (value < 0 || value > 9)
71 value = value < 0 ? 0 : 9;
72 fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
80 Check Previous Pattern usage
88 hsperror("\"'\" used before a function definition");
96 SAMEFN = (hashIds && fn == (char *)FN) || (FN != NULL && strcmp(fn,gident(FN)) == 0);
99 printf("%u\n",startlineno);
101 fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,fn);
107 Check that a list of types is a list of contexts
113 checkcontext(context)
119 while (tlist(context) == lcons)
121 ty = (ttype) lhd(context);
122 valid = tttype(ty) == tname;
126 valid = tlist(tl) != lnil && tlist(ltl(tl)) == lnil && tttype((ttype) lhd(tl)) == namedtvar;
130 hsperror("Not a valid context");
132 context = ltl(context);
141 hsperror("syntax error");
144 /* ------------------------------------------------------------------------
148 patternOrExpr(int wanted, tree e)
149 /* see utils.h for what args are */
153 case ident: /* a pattern or expr */
157 error_if_expr_wanted(wanted, "wildcard in expression");
161 switch (tliteral(glit(e))) {
171 break; /* pattern or expr */
174 error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
176 default: /* the others only occur in pragmas */
177 hsperror("not a valid literal pattern or expression");
182 { tree sub = gnexp(e);
183 if (ttree(sub) != lit) {
184 error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
186 literal l = glit(sub);
188 if (tliteral(l) != integer && tliteral(l) != floatr) {
189 error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
192 patternOrExpr(wanted, sub);
201 is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
202 patternOrExpr(wanted, f);
203 patternOrExpr(wanted, a);
208 error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
209 patternOrExpr(wanted, gase(e));
213 error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
214 patternOrExpr(wanted, glazyp(e));
218 patternOrExpr(wanted, gplusp(e));
223 tree f = ginfun((struct Sap *)e),
224 a1 = ginarg1((struct Sap *)e),
225 a2 = ginarg2((struct Sap *)e);
227 struct Splusp *e_plus;
229 patternOrExpr(wanted, a1);
230 patternOrExpr(wanted, a2);
232 if (wanted == LEGIT_PATT) {
233 if (ttree(f) == ident && strcmp(id_to_string(gident(f)),"+")==0) {
235 if(ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
236 hsperror("non-integer in (n+k) pattern");
238 if(ttree(a1) == wildp || (ttree(a1) == ident && !isconstr(gident(a1))))
241 e_plus = (struct Splusp *) e;
242 *Rgplusp(e_plus) = a1;
243 *Rgplusi(e_plus) = glit(a2);
246 hsperror("non-variable in (n+k) pattern");
249 if(ttree(f) == ident && !isconstr(gident(f)))
250 hsperror("variable application in pattern");
259 for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
260 patternOrExpr(wanted, lhd(tup));
265 case par: /* parenthesised */
266 patternOrExpr(wanted, gpare(e));
272 for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
273 patternOrExpr(wanted, lhd(l));
282 for (pids = gprocid(e); tlist(pids) == lcons; pids = ltl(pids)) {
283 patternOrExpr(wanted, lhd(pids));
285 patternOrExpr(wanted, gprocdata(e));
301 error_if_patt_wanted(wanted, "unexpected construct in a pattern");
305 hsperror("not a pattern or expression");
310 is_conapp_patt(int wanted, tree f, tree a)
312 if (wanted == LEGIT_EXPR)
313 return; /* that was easy */
318 if (isconstr(gident(f)))
320 patternOrExpr(wanted, a);
324 char errbuf[ERR_BUF_SIZE];
325 sprintf(errbuf,"not a constructor application -- %s",gident(f));
330 is_conapp_patt(wanted, gfun(f), garg(f));
331 patternOrExpr(wanted, a);
335 is_conapp_patt(wanted, gpare(f), a);
340 char errbuf[ERR_BUF_SIZE];
341 sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
347 hsperror("not a constructor application");
352 error_if_expr_wanted(int wanted, char *msg)
354 if (wanted == LEGIT_EXPR)
359 error_if_patt_wanted(int wanted, char *msg)
361 if (wanted == LEGIT_PATT)
365 /* ---------------------------------------------------------------------- */
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. */
376 switch (tliteral(glit(e))) {
388 hsperror("Literal is not a valid LHS");
403 patternOrExpr(LEGIT_PATT, e);
408 /* This change might break ap infixop below. BEWARE.
409 return (isconstr(gident(e)));
415 /* do not "unparen", otherwise the error
416 fromInteger ((x,y) {-no comma-} z)
419 tree fn = function(e);
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);
424 if(ttree(fn) == ident)
425 return(isconstr(gident(fn)));
427 else if(ttree(fn) == tinfixop)
428 return(is_patt_or_fun(fn, TRUE/*still at "outer level"*/));
431 hsperror("Not a legal pattern binding in LHS");
436 tree f = ginfun((struct Sap *)e),
437 a1 = unparen(ginarg1((struct Sap *)e)),
438 a2 = unparen(ginarg2((struct Sap *)e));
440 struct Splusp *e_plus;
442 /* Even function definitions must have pattern arguments */
443 patternOrExpr(LEGIT_PATT, a1);
444 patternOrExpr(LEGIT_PATT, a2);
446 if (ttree(f) == ident)
448 if(strcmp(id_to_string(gident(f)),"+")==0 && ttree(a1) == ident)
450 /* n+k is a function at the top level */
451 if(outer_level || ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
455 e_plus = (struct Splusp *) e;
456 *Rgplusp(e_plus) = a1;
457 *Rgplusi(e_plus) = glit(a2);
461 return(isconstr(gident(f)));
465 hsperror("Strange infix op");
469 return(is_patt_or_fun(gpare(e), FALSE /*no longer at "outer level"*/));
471 /* Anything else must be an illegal LHS */
473 hsperror("Not a valid LHS");
476 abort(); /* should never get here */
480 /* interface for the outside world */
485 return(is_patt_or_fun(e, TRUE /*outer-level*/));
489 Return the function at the root of a series of applications.
499 patternOrExpr(LEGIT_PATT, garg(e));
500 return(function(gfun(e)));
503 return(function(gpare(e)));
515 while (ttree(e) == par)
523 Extend a function by adding a new definition to its list of bindings.
531 /* fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
532 if(tbinding(bind) == abind)
533 bind = gabindsnd(bind);
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));
540 fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
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
551 Note: Prefix negation has the same precedence as infix minus.
552 The algorithm must thus take account of explicit negates.
560 fprintf(stderr,"precparse %x\n",ttree(t));
563 if(ttree(t) == tinfixop)
565 tree left = ginarg1((struct Sap *)t);
569 fprintf(stderr,"precparse:t=");ptree(t);printf("\nleft=");ptree(left);printf("\n");
573 if(ttree(left) == negate)
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. */
579 if(pprecedence(ntabpos) < pprecedence(ttabpos))
581 tree right = ginarg2((struct Sap *)t);
583 gnexp(t) = mkinfixop(tid,gnexp(left),right);
587 else if(ttree(left) == tinfixop)
589 id lid = gident(ginfun((struct Sap *)left)),
590 tid = gident(ginfun((struct Sap *)t));
592 struct infix *lefttabpos = infixlookup(lid),
593 *ttabpos = infixlookup(tid);
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));
602 if (pprecedence(lefttabpos) < pprecedence(ttabpos))
603 rearrangeprec(left,t);
605 else if (pprecedence(lefttabpos) == pprecedence(ttabpos))
607 if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
608 rearrangeprec(left,t);
610 else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
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));
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.
632 rearrangeprec(tree t1, tree t2)
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;
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;
648 createpat(guards,where)
657 func = install_literal("");
659 /* I don't think I need to allocate func here -- KH */
660 return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
668 /* partain: want a more magical symbol ???
669 return(ldub(mkbool(1),expr));
671 return(ldub(mkident(install_literal("__o")),expr)); /* __otherwise */
679 char *p = xmalloc(strlen(i)+2);
687 /* UNUSED: at the moment */
689 checkmodname(import,interface)
690 id import, interface;
692 if(strcmp(import,interface) != 0)
694 char errbuf[ERR_BUF_SIZE];
695 sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import);
702 Check the ordering of declarations in a cbody.
703 All signatures must appear before any declarations.
710 /* The ordering must be correct for a singleton */
711 if(tbinding(decls)!=abind)
714 checkorder2(decls,TRUE);
718 checkorder2(decls,sigs)
722 while(tbinding(decls)==abind)
724 /* Perform a left-traversal if necessary */
725 binding left = gabindfst(decls);
726 if(tbinding(left)==abind)
727 sigs = checkorder2(left,sigs);
729 sigs = checksig(sigs,left);
730 decls = gabindsnd(decls);
733 return(checksig(sigs,decls));
742 BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
744 hsperror("Signature appears after definition in class body");
751 Check the precedence of a pattern or expression to ensure that
752 sections and function definitions have the correct parse.
756 checkprec(exp,fn,right)
761 if(ttree(exp) == tinfixop)
763 struct infix *ftabpos = infixlookup(fn);
764 struct infix *etabpos = infixlookup(gident(ginfun((struct Sap *)exp)));
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)))))
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))));