2005-06-01 Paul Thomas <pault@gcc.gnu.org>

[pf3gnuchains/gcc-fork.git] / gcc / fortran / resolve.c

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 35795c3..5f7a76a 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -360,7 +360,6 @@ resolve_entries (gfc_namespace * ns)
      out what is going on.  */
   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
            master_count++, ns->proc_name->name);
-  name[GFC_MAX_SYMBOL_LEN] = '\0';
   gfc_get_ha_symbol (name, &proc);
   gcc_assert (proc != NULL);
 
@@ -369,8 +368,88 @@ resolve_entries (gfc_namespace * ns)
     gfc_add_subroutine (&proc->attr, proc->name, NULL);
   else
     {
+      gfc_symbol *sym;
+      gfc_typespec *ts, *fts;
+
       gfc_add_function (&proc->attr, proc->name, NULL);
-      gfc_internal_error ("TODO: Functions with alternate entry points");
+      proc->result = proc;
+      fts = &ns->entries->sym->result->ts;
+      if (fts->type == BT_UNKNOWN)
+       fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+      for (el = ns->entries->next; el; el = el->next)
+       {
+         ts = &el->sym->result->ts;
+         if (ts->type == BT_UNKNOWN)
+           ts = gfc_get_default_type (el->sym->result, NULL);
+         if (! gfc_compare_types (ts, fts)
+             || (el->sym->result->attr.dimension
+                 != ns->entries->sym->result->attr.dimension)
+             || (el->sym->result->attr.pointer
+                 != ns->entries->sym->result->attr.pointer))
+           break;
+       }
+
+      if (el == NULL)
+       {
+         sym = ns->entries->sym->result;
+         /* All result types the same.  */
+         proc->ts = *fts;
+         if (sym->attr.dimension)
+           gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
+         if (sym->attr.pointer)
+           gfc_add_pointer (&proc->attr, NULL);
+       }
+      else
+       {
+         /* Otherwise the result will be passed through an union by
+            reference.  */
+         proc->attr.mixed_entry_master = 1;
+         for (el = ns->entries; el; el = el->next)
+           {
+             sym = el->sym->result;
+             if (sym->attr.dimension)
+               gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
+                          el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+                          ns->entries->sym->name, &sym->declared_at);
+             else if (sym->attr.pointer)
+               gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
+                          el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+                          ns->entries->sym->name, &sym->declared_at);
+             else
+               {
+                 ts = &sym->ts;
+                 if (ts->type == BT_UNKNOWN)
+                   ts = gfc_get_default_type (sym, NULL);
+                 switch (ts->type)
+                   {
+                   case BT_INTEGER:
+                     if (ts->kind == gfc_default_integer_kind)
+                       sym = NULL;
+                     break;
+                   case BT_REAL:
+                     if (ts->kind == gfc_default_real_kind
+                         || ts->kind == gfc_default_double_kind)
+                       sym = NULL;
+                     break;
+                   case BT_COMPLEX:
+                     if (ts->kind == gfc_default_complex_kind)
+                       sym = NULL;
+                     break;
+                   case BT_LOGICAL:
+                     if (ts->kind == gfc_default_logical_kind)
+                       sym = NULL;
+                     break;
+                   default:
+                     break;
+                   }
+                 if (sym)
+                   gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
+                              el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+                              gfc_typename (ts), ns->entries->sym->name,
+                              &sym->declared_at);
+               }
+           }
+       }
     }
   proc->attr.access = ACCESS_PRIVATE;
   proc->attr.entry_master = 1;
@@ -481,7 +560,7 @@ was_declared (gfc_symbol * sym)
   if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
     return 1;
 
-  if (a.allocatable || a.dimension || a.external || a.intrinsic
+  if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
       || a.optional || a.pointer || a.save || a.target
       || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
     return 1;
@@ -604,6 +683,12 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
          || sym->attr.external)
        {
 
+          if (sym->attr.proc == PROC_ST_FUNCTION)
+            {
+              gfc_error ("Statement function '%s' at %L is not allowed as an "
+                         "actual argument", sym->name, &e->where);
+            }
+
          /* If the symbol is the function that names the current (or
             parent) scope, then we really have a variable reference.  */
 
@@ -2111,6 +2196,9 @@ resolve_variable (gfc_expr * e)
   if (e->ref && resolve_ref (e) == FAILURE)
     return FAILURE;
 
+  if (e->symtree == NULL)
+    return FAILURE;
+
   sym = e->symtree->n.sym;
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     {
@@ -3695,10 +3783,17 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
          break;
 
        case EXEC_GOTO:
-          if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
-            gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
+          if (code->expr != NULL)
+           {
+             if (code->expr->ts.type != BT_INTEGER)
+               gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
                        "variable", &code->expr->where);
-          else
+             else if (code->expr->symtree->n.sym->attr.assign != 1)
+               gfc_error ("Variable '%s' has not been assigned a target label "
+                       "at %L", code->expr->symtree->n.sym->name,
+                       &code->expr->where);
+           }
+         else
             resolve_branch (code->label, code);
          break;
 
@@ -3966,6 +4061,8 @@ resolve_symbol (gfc_symbol * sym)
 
              sym->ts = sym->result->ts;
              sym->as = gfc_copy_array_spec (sym->result->as);
+             sym->attr.dimension = sym->result->attr.dimension;
+             sym->attr.pointer = sym->result->attr.pointer;
            }
        }
     }