gcc/testsuite/

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

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index a9b47d8..ba84163 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -196,7 +196,7 @@ match_integer_constant (gfc_expr **result, int signflag)
   if (length == -1)
     return MATCH_NO;
 
-  buffer = alloca (length + 1);
+  buffer = (char *) alloca (length + 1);
   memset (buffer, '\0', length + 1);
 
   gfc_gobble_whitespace ();
@@ -276,7 +276,7 @@ match_hollerith_constant (gfc_expr **result)
          e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
                                   &gfc_current_locus);
 
-         e->representation.string = gfc_getmem (num + 1);
+         e->representation.string = XCNEWVEC (char, num + 1);
 
          for (i = 0; i < num; i++)
            {
@@ -411,7 +411,7 @@ match_boz_constant (gfc_expr **result)
 
   gfc_current_locus = old_loc;
 
-  buffer = alloca (length + 1);
+  buffer = (char *) alloca (length + 1);
   memset (buffer, '\0', length + 1);
 
   match_digits (0, radix, buffer);
@@ -562,7 +562,7 @@ done:
   gfc_current_locus = old_loc;
   gfc_gobble_whitespace ();
 
-  buffer = alloca (count + 1);
+  buffer = (char *) alloca (count + 1);
   memset (buffer, '\0', count + 1);
 
   p = buffer;
@@ -1975,8 +1975,7 @@ typedef struct gfc_structure_ctor_component
 }
 gfc_structure_ctor_component;
 
-#define gfc_get_structure_ctor_component() \
-  gfc_getmem(sizeof(gfc_structure_ctor_component))
+#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
 
 static void
 gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
@@ -2023,7 +2022,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
              comp_tail->next = gfc_get_structure_ctor_component ();
              comp_tail = comp_tail->next;
            }
-         comp_tail->name = gfc_getmem(GFC_MAX_SYMBOL_LEN + 1);
+         comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
          comp_tail->val = NULL;
          comp_tail->where = gfc_current_locus;
 
@@ -2324,6 +2323,9 @@ gfc_match_rvalue (gfc_expr **result)
        }
     }
 
+  if (gfc_matching_procptr_assignment)
+    goto procptr0;
+
   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
     goto function0;
 
@@ -2400,6 +2402,27 @@ gfc_match_rvalue (gfc_expr **result)
     /* If we're here, then the name is known to be the name of a
        procedure, yet it is not sure to be the name of a function.  */
     case FL_PROCEDURE:
+
+    /* Procedure Pointer Assignments. */
+    procptr0:
+      if (gfc_matching_procptr_assignment)
+       {
+         gfc_gobble_whitespace ();
+         if (sym->attr.function && gfc_peek_ascii_char () == '(')
+           /* Parse functions returning a procptr.  */
+           goto function0;
+
+         if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+         if (gfc_intrinsic_name (sym->name, 0)
+             || gfc_intrinsic_name (sym->name, 1))
+           sym->attr.intrinsic = 1;
+         e = gfc_get_expr ();
+         e->expr_type = EXPR_VARIABLE;
+         e->symtree = symtree;
+         m = match_varspec (e, 0);
+         break;
+       }
+
       if (sym->attr.subroutine)
        {
          gfc_error ("Unexpected use of subroutine name '%s' at %C",
@@ -2666,7 +2689,7 @@ gfc_match_rvalue (gfc_expr **result)
 }
 
 
-/* Match a variable, ie something that can be assigned to.  This
+/* Match a variable, i.e. something that can be assigned to.  This
    starts as a symbol, can be a structure component or an array
    reference.  It can be a function if the function doesn't have a
    separate RESULT variable.  If the symbol has not been previously
@@ -2691,7 +2714,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
      we force the changed_symbols mechanism to work by setting
      host_flag to 0. This prevents valid symbols that have the name
      of keywords, such as 'end', being turned into variables by
-     failed matching to assignments for, eg., END INTERFACE.  */
+     failed matching to assignments for, e.g., END INTERFACE.  */
   if (gfc_current_state () == COMP_MODULE
       || gfc_current_state () == COMP_INTERFACE
       || gfc_current_state () == COMP_CONTAINS)
@@ -2716,7 +2739,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
-      if (sym->attr.protected && sym->attr.use_assoc)
+      if (sym->attr.is_protected && sym->attr.use_assoc)
        {
          gfc_error ("Assigning to PROTECTED variable at %C");
          return MATCH_ERROR;
@@ -2781,6 +2804,9 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
          break;
        }
 
+      if (sym->attr.proc_pointer)
+       break;
+
       /* Fall through to error */
 
     default: