#include "constants.h"
#include "utils.h"
#include "tree.h"
+#include "list.h"
#include "hsparser.tab.h"
/*
- Check Previous Pattern usage
+ We've found a function definition. See if it defines the
+ same function as the previous definition (at this indentation level).
+ If so, set SAMEFN.
+ Set FN to the name of the function.
*/
void
-checksamefn(fn)
- qid fn;
+checksamefn(lhs)
+ tree lhs;
{
- char *this = qid_to_string(fn);
- char *was = (FN==NULL) ? NULL : qid_to_string(FN);
+ tree fn;
+ qid fn_id;
+ char *this, *was;
+
+ fn = function(lhs);
+
+ if (ttree(fn) == ident) {
+ fn_id = gident((struct Sident *) fn);
+ }
+ else if (ttree(fn) == infixap) {
+ fn_id = ginffun((struct Sinfixap *) fn);
+ }
+ else {
+ fprintf( stderr, "Wierd funlhs" );
+ return;
+ }
+ this = qid_to_string(fn_id);
+ was = (FN==NULL) ? NULL : qid_to_string(FN);
SAMEFN = (was != NULL && strcmp(this,was) == 0);
+ FN = fn_id;
if(!SAMEFN && etags)
#if 1/*etags*/
expORpat(wanted, glazyp(e));
break;
+ case plusp:
+ break;
+
case lit:
switch (tliteral(glit(e))) {
case integer:
case clitlit:
error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+ break;
default: /* the others only occur in pragmas */
hsperror("not a valid literal pattern or expression");
}
break;
+ case utuple:
+ {
+ list tup;
+ for (tup = gutuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+ expORpat(wanted, lhd(tup));
+ }
+ }
+ break;
+
case llist:
{
list l;
}
break;
+ case restr: /* type sig */
+ expORpat(wanted, grestre(e));
+ break;
+
case par: /* parenthesised */
expORpat(wanted, gpare(e));
break;
- case restr:
case lambda:
case let:
case casee:
/* ---------------------------------------------------------------------- */
+
BOOLEAN /* return TRUE if LHS is a pattern */
lhs_is_patt(tree e)
{
case llist:
case tuple:
case negate:
+ case record:
expORpat(LEGIT_PATT, e);
return TRUE;
case ap:
{
tree f = function(e);
- tree a = garg(e); /* do not "unparen", otherwise the error
- fromInteger ((x,y) {-no comma-} z)
- will be missed.
- */
- /* definitions must have pattern arguments */
+/* These lines appear to duplicate what's in function(e).
+ Nuked SLPJ May 97
+
+ tree a = garg(e); -- do not "unparen", otherwise the error
+ -- fromInteger ((x,y) {-no comma-} z)
+ -- will be missed.
+
+ -- definitions must have pattern arguments
expORpat(LEGIT_PATT, a);
+*/
if(ttree(f) == ident)
return(isconstr(qid_to_string(gident(f))));
return(lhs_is_patt(f));
else
- hsperror("Not a legal pattern binding in LHS");
+ hsperror("Syntax error: not a legal pattern binding in LHS");
}
case infixap:
/* Anything else must be an illegal LHS */
default:
- hsperror("Not a valid LHS");
+ hsperror("Syntax error: not a valid LHS");
}
abort(); /* should never get here */
/*
- Return the function at the root of a series of applications.
+ Return the function at the root of a series of applications,
+ checking on the way that the arguments are patterns.
*/
tree
if(tbinding(bind) == abind)
bind = gabindsnd(bind);
- if(tbinding(bind) == pbind)
+ /* if(tbinding(bind) == pbind)
gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
- else if(tbinding(bind) == fbind)
- gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
- else
- fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
-}
-
+
+ else */
-pbinding
-createpat(guards,where)
- pbinding guards;
- binding where;
-{
- qid func;
-
- if(FN != NULL)
- func = FN;
+ if(tbinding(bind) == fbind)
+ gfbindm(bind) = lconc(gfbindm(bind), gfbindm(rule));
else
- func = mknoqual(install_literal(""));
-
- return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
+ fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
}
hsperror("syntax error: unexpected ! in type");
checknobangs(gtapp((struct Stapp *)app));
- }
+ }
+}
+
+/* Check that a type is of the form
+ C a1 a2 .. an
+ where n>=1, and the ai are all type variables
+ This is used to check that a class decl is well formed.
+*/
+void
+check_class_decl_head_help( app, n )
+ ttype app;
+ int n; /* Number of args so far */
+{
+ switch (tttype(app)) {
+ case tapp:
+ /* Check the arg is a type variable */
+ switch (tttype (gtarg((struct Stapp *) app))) {
+ case namedtvar: break;
+ default: hsperror("Class declaration head must use only type variables");
+ }
+
+ /* Check the fun part */
+ check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 );
+ break;
+
+ case tname:
+ /* Class name; check there is at least one argument */
+ if (n==0) {
+ hsperror("Class must have at least one argument");
+ }
+ break;
+
+ default:
+ hsperror("Illegal syntax in class declaration head");
+ }
}
+void
+check_class_decl_head( app )
+ ttype app;
+{ check_class_decl_head_help( app, 0 ); }
+
+
/*
Splits a tycon application into its constructor and a list of types.
qid *tyc;
list *tys;
{
- if(tttype(app) == tapp)
- {
+ switch (tttype(app)) {
+ case tapp:
splittyconapp(gtapp((struct Stapp *)app), tyc, tys);
*tys = lapp(*tys, gtarg((struct Stapp *)app));
- }
- else if(tttype(app) == tname)
- {
+ break;
+
+ case tname:
+ case namedtvar:
*tyc = gtypeid((struct Stname *)app);
*tys = Lnil;
- }
- else
- {
- hsperror("panic: splittyconap: bad tycon application (no tycon)");
+ break;
+
+ default:
+ hsperror("bad left argument to constructor op");
}
}
#endif /* 0 */
+
+
+/* Reverse a list, in place */
+
+list reverse_list( l )
+ list l;
+{
+ list temp, acc = Lnil;
+
+ while (tlist( l ) != lnil) {
+ temp = ltl( l );
+ ltl( l ) = acc;
+ acc = l;
+ l = temp;
+ }
+ return( acc );
+}
projects / ghc-hetmet.git / blobdiff