* dependency.c (gfc_check_dependency): Remove unused vars and nvars

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

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c55b142..92a7dc0 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1,6 +1,6 @@
 /* Routines for manipulation of expression nodes.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
-   Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software 
+   Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -1821,7 +1821,7 @@ gfc_check_conformance (const char *optype_msgid,
 
       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
        {
-         gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
+         gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
                     _(optype_msgid), &op1->where, d + 1,
                     (int) mpz_get_si (op1_size),
                     (int) mpz_get_si (op2_size));
@@ -1859,6 +1859,14 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
       return FAILURE;
     }
 
+  if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
+    {
+      gfc_error ("'%s' in the assignment at %L cannot be an l-value "
+                "since it is a procedure", sym->name, &lvalue->where);
+      return FAILURE;
+    }
+
+
   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
     {
       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
@@ -1944,6 +1952,15 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
       return FAILURE;
     }
 
+  if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
+       && lvalue->symtree->n.sym->attr.use_assoc)
+    {
+      gfc_error ("'%s' in the pointer assignment at %L cannot be an "
+                "l-value since it is a procedure",
+                lvalue->symtree->n.sym->name, &lvalue->where);
+      return FAILURE;
+    }
+
   attr = gfc_variable_attr (lvalue, NULL);
   if (!attr.pointer)
     {
@@ -1980,6 +1997,16 @@ gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
       return FAILURE;
     }
 
+  if (lvalue->ts.type == BT_CHARACTER
+       && lvalue->ts.cl->length && rvalue->ts.cl->length
+       && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
+                                     rvalue->ts.cl->length)) == 1)
+    {
+      gfc_error ("Different character lengths in pointer "
+                "assignment at %L", &lvalue->where);
+      return FAILURE;
+    }
+
   attr = gfc_expr_attr (rvalue);
   if (!attr.target && !attr.pointer)
     {
@@ -2110,3 +2137,73 @@ gfc_get_variable_expr (gfc_symtree * var)
   return e;
 }
 
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
+
+void
+gfc_expr_set_symbols_referenced (gfc_expr * expr)
+{
+  gfc_actual_arglist *arg;
+  gfc_constructor *c;
+  gfc_ref *ref;
+  int i;
+
+  if (!expr) return;
+
+  switch (expr->expr_type)
+    {
+    case EXPR_OP:
+      gfc_expr_set_symbols_referenced (expr->value.op.op1);
+      gfc_expr_set_symbols_referenced (expr->value.op.op2);
+      break;
+
+    case EXPR_FUNCTION:
+      for (arg = expr->value.function.actual; arg; arg = arg->next)
+        gfc_expr_set_symbols_referenced (arg->expr);
+      break;
+
+    case EXPR_VARIABLE:
+      gfc_set_sym_referenced (expr->symtree->n.sym);
+      break;
+
+    case EXPR_CONSTANT:
+    case EXPR_NULL:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = expr->value.constructor; c; c = c->next)
+        gfc_expr_set_symbols_referenced (c->expr);
+      break;
+
+    default:
+      gcc_unreachable ();
+      break;
+    }
+
+    for (ref = expr->ref; ref; ref = ref->next)
+      switch (ref->type)
+        {
+        case REF_ARRAY:
+          for (i = 0; i < ref->u.ar.dimen; i++)
+            {
+              gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
+              gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
+              gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
+            }
+          break;
+           
+        case REF_COMPONENT:
+          break;
+           
+        case REF_SUBSTRING:
+          gfc_expr_set_symbols_referenced (ref->u.ss.start);
+          gfc_expr_set_symbols_referenced (ref->u.ss.end);
+          break;
+           
+        default:
+          gcc_unreachable ();
+          break;
+        }
+}