2008-07-02 Janus Weil <janus@gcc.gnu.org>

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

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 87ea9e9..12987e6 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -33,7 +33,7 @@ gfc_get_expr (void)
 {
   gfc_expr *e;
 
-  e = gfc_getmem (sizeof (gfc_expr));
+  e = XCNEW (gfc_expr);
   gfc_clear_ts (&e->ts);
   e->shape = NULL;
   e->ref = NULL;
@@ -414,7 +414,7 @@ gfc_copy_expr (gfc_expr *p)
       /* Copy target representation, if it exists.  */
       if (p->representation.string)
        {
-         c = gfc_getmem (p->representation.length + 1);
+         c = XCNEWVEC (char, p->representation.length + 1);
          q->representation.string = c;
          memcpy (c, p->representation.string, (p->representation.length + 1));
        }
@@ -2573,7 +2573,8 @@ gfc_specification_expr (gfc_expr *e)
 
   if (e->ts.type != BT_INTEGER)
     {
-      gfc_error ("Expression at %L must be of INTEGER type", &e->where);
+      gfc_error ("Expression at %L must be of INTEGER type, found %s",
+                &e->where, gfc_basic_typename (e->ts.type));
       return FAILURE;
     }
 
@@ -2828,6 +2829,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
     return SUCCESS;
 
+  /* Only DATA Statements come here.  */
   if (!conform)
     {
       /* Numeric can be converted to any other numeric. And Hollerith can be
@@ -2839,13 +2841,23 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
        return SUCCESS;
 
-      gfc_error ("Incompatible types in assignment at %L; attempted assignment "
-                "of %s to %s", &rvalue->where, gfc_typename (&rvalue->ts),
-                gfc_typename (&lvalue->ts));
+      gfc_error ("Incompatible types in DATA statement at %L; attempted "
+                "conversion of %s to %s", &lvalue->where,
+                gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
 
       return FAILURE;
     }
 
+  /* Assignment is the only case where character variables of different
+     kind values can be converted into one another.  */
+  if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
+    {
+      if (lvalue->ts.kind != rvalue->ts.kind)
+       gfc_convert_chartype (rvalue, &lvalue->ts);
+
+      return SUCCESS;
+    }
+
   return gfc_convert_type (rvalue, &lvalue->ts, 1);
 }
 
@@ -2862,7 +2874,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   int is_pure;
   int pointer, check_intent_in;
 
-  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+      && !lvalue->symtree->n.sym->attr.proc_pointer)
     {
       gfc_error ("Pointer assignment target is not a POINTER at %L",
                 &lvalue->where);
@@ -2882,7 +2895,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   /* Check INTENT(IN), unless the object itself is the component or
      sub-component of a pointer.  */
   check_intent_in = 1;
-  pointer = lvalue->symtree->n.sym->attr.pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer
+             | lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
@@ -2921,6 +2935,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
+  /* TODO checks on rvalue for a procedure pointer assignment.  */
+  if (lvalue->symtree->n.sym->attr.proc_pointer)
+    return SUCCESS;
+
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
@@ -3012,7 +3030,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer)
+  if (sym->attr.pointer || sym->attr.proc_pointer)
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);