2010-10-06 Mikael Morin <mikael@gcc.gnu.org>

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

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 0777046..f6ceae9 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -242,7 +242,7 @@ match_hollerith_constant (gfc_expr **result)
   locus old_loc;
   gfc_expr *e = NULL;
   const char *msg;
-  int num;
+  int num, pad;
   int i;  
 
   old_loc = gfc_current_locus;
@@ -279,7 +279,10 @@ match_hollerith_constant (gfc_expr **result)
          e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
                                     &gfc_current_locus);
 
-         e->representation.string = XCNEWVEC (char, num + 1);
+         /* Calculate padding needed to fit default integer memory.  */
+         pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
+
+         e->representation.string = XCNEWVEC (char, num + pad + 1);
 
          for (i = 0; i < num; i++)
            {
@@ -294,8 +297,13 @@ match_hollerith_constant (gfc_expr **result)
              e->representation.string[i] = (unsigned char) c;
            }
 
-         e->representation.string[num] = '\0';
-         e->representation.length = num;
+         /* Now pad with blanks and end with a null char.  */
+         for (i = 0; i < pad; i++)
+           e->representation.string[num + i] = ' ';
+
+         e->representation.string[num + i] = '\0';
+         e->representation.length = num + pad;
+         e->ts.u.pad = pad;
 
          *result = e;
          return MATCH_YES;
@@ -1999,7 +2007,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
 
-  ref = expr->ref;
   sym = expr->symtree->n.sym;
   attr = sym->attr;
 
@@ -2023,7 +2030,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
     *ts = sym->ts;
 
-  for (; ref; ref = ref->next)
+  for (ref = expr->ref; ref; ref = ref->next)
     switch (ref->type)
       {
       case REF_ARRAY:
@@ -2088,6 +2095,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
   attr.pointer = pointer;
   attr.allocatable = allocatable;
   attr.target = target;
+  attr.save = sym->attr.save;
 
   return attr;
 }
@@ -2977,17 +2985,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
-      if (sym->attr.is_protected && sym->attr.use_assoc)
-       {
-         gfc_error ("Assigning to PROTECTED variable at %C");
-         return MATCH_ERROR;
-       }
-      if (sym->assoc && !sym->assoc->variable)
-       {
-         gfc_error ("'%s' associated to expression can't appear in a variable"
-                    " definition context at %C", sym->name);
-         return MATCH_ERROR;
-       }
+      /* Everything is alright.  */
       break;
 
     case FL_UNKNOWN:
@@ -3019,22 +3017,24 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 
     case FL_PARAMETER:
       if (equiv_flag)
-       gfc_error ("Named constant at %C in an EQUIVALENCE");
-      else
-       gfc_error ("Cannot assign to a named constant at %C");
-      return MATCH_ERROR;
+       {
+         gfc_error ("Named constant at %C in an EQUIVALENCE");
+         return MATCH_ERROR;
+       }
+      /* Otherwise this is checked for and an error given in the
+        variable definition context checks.  */
       break;
 
     case FL_PROCEDURE:
       /* Check for a nonrecursive function result variable.  */
       if (sym->attr.function
-          && !sym->attr.external
-          && sym->result == sym
-          && (gfc_is_function_return_value (sym, gfc_current_ns)
-              || (sym->attr.entry
-                  && sym->ns == gfc_current_ns)
-              || (sym->attr.entry
-                  && sym->ns == gfc_current_ns->parent)))
+         && !sym->attr.external
+         && sym->result == sym
+         && (gfc_is_function_return_value (sym, gfc_current_ns)
+             || (sym->attr.entry
+                 && sym->ns == gfc_current_ns)
+             || (sym->attr.entry
+                 && sym->ns == gfc_current_ns->parent)))
        {
          /* If a function result is a derived type, then the derived
             type may still have to be resolved.  */