[project @ 1999-01-14 17:58:41 by sof]

[ghc-hetmet.git] / ghc / compiler / parser / syntax.c

diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c
index a48b119..244e694 100644 (file)
--- a/ghc/compiler/parser/syntax.c
+++ b/ghc/compiler/parser/syntax.c
@@ -63,17 +63,37 @@ checkfixity(vals)
 
 
 /*
-  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*/
@@ -127,6 +147,7 @@ expORpat(int wanted, tree e)
 
          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");
@@ -196,6 +217,15 @@ expORpat(int wanted, tree e)
        }
        break;
 
+      case utuple:
+       {
+         list tup;
+         for (tup = gutuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+             expORpat(wanted, lhd(tup));
+         }
+       }
+       break;
+
       case llist:
        {
          list l;
@@ -205,11 +235,14 @@ expORpat(int wanted, tree e)
        }
        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:
@@ -288,6 +321,7 @@ error_if_patt_wanted(int wanted, char *msg)
 
 /* ---------------------------------------------------------------------- */
 
+
 BOOLEAN /* return TRUE if LHS is a pattern */
 lhs_is_patt(tree e)
 {
@@ -317,6 +351,7 @@ lhs_is_patt(tree e)
       case llist:
       case tuple:
       case negate:
+      case record:
        expORpat(LEGIT_PATT, e);
        return TRUE;
 
@@ -326,13 +361,17 @@ lhs_is_patt(tree e)
       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))));
@@ -341,7 +380,7 @@ lhs_is_patt(tree e)
            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:
@@ -362,7 +401,7 @@ lhs_is_patt(tree e)
 
       /* 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 */
@@ -371,7 +410,8 @@ lhs_is_patt(tree e)
 
 
 /*
-  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
@@ -417,28 +457,15 @@ binding rule;
   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));
-}
-
-
-pbinding
-createpat(guards,where)
-  pbinding guards;
-  binding where;
-{
-  qid func;
+  
+    else */
 
-  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));
 }
 
 
@@ -533,9 +560,49 @@ checknobangs(app)
        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.