re PR fortran/23446 (Valid internal subprogram array argument declaration is not...
authorPaul Thomas <pault@gcc.gnu.org>
Mon, 17 Oct 2005 20:52:37 +0000 (20:52 +0000)
committerPaul Thomas <pault@gcc.gnu.org>
Mon, 17 Oct 2005 20:52:37 +0000 (20:52 +0000)
2005-10-17  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/23446
* gfortran.h: Primitive for gfc_is_formal_arg.
* resolve.c(gfc_is_formal_arg): New function to signal across
several function calls that formal argument lists are being
processed.
(resolve_formal_arglist): Set/reset the flag for gfc_is_formal_arg.
*expr.c(check_restricted): Add check, via gfc_is_formal_arg, if
symbol is part of an formal argument declaration.

PR fortran/21459
* decl.c (add_init_expr_to_sym): Make a new character
length for each variable, when the expression is NULL
and link to cl_list.

PR fortran/20866
* match.c (recursive_stmt_fcn): New function that tests if
a statement function resurses through itself or other other
statement functions.
(gfc_match_st_function): Call recursive_stmt_fcn to check
if this is recursive and to raise error if so.

PR fortran/20849
PR fortran/20853
* resolve.c (resolve_symbol): Errors for assumed size arrays
with default initializer and for external objects with an
initializer.

PR fortran/20837
* decl.c (match_attr_spec): Prevent PUBLIC from being used
outside a module.

2005-10-17  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/23446
* gfortran.dg/host_dummy_index_1.f90: New test.

PR fortran/21459
gfortran.dg/automatic_char_len_2.f90: New test.

PR fortran/20866
gfortran.dg/recursive_statement_functions.f90: New test.

PR fortran/20853
gfortran.dg/assumed_size_dt_dummy.f90: New test.

PR fortran/20849
gfortran.dg/external_initializer.f90: New test.

PR fortran/20837
non_module_public.f90: New test.

From-SVN: r105518

13 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/resolve.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/assumed_size_dt_dummy.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/automatic_char_len_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/external_initializer.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/host_dummy_index_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/non_module_public.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/recursive_statement_functions.f90 [new file with mode: 0644]

index dca2ef287d5d529f174b791471619ad4f412b0ca..ff6246abf2f7b0a79a643680158824394021677f 100644 (file)
@@ -1,3 +1,36 @@
+2005-10-17  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/23446
+       * gfortran.h: Primitive for gfc_is_formal_arg.
+       * resolve.c(gfc_is_formal_arg): New function to signal across
+       several function calls that formal argument lists are being
+       processed.
+       (resolve_formal_arglist): Set/reset the flag for gfc_is_formal_arg.
+       *expr.c(check_restricted): Add check, via gfc_is_formal_arg, if
+       symbol is part of an formal argument declaration.
+
+       PR fortran/21459
+       * decl.c (add_init_expr_to_sym): Make a new character
+       length for each variable, when the expression is NULL
+       and link to cl_list.
+
+       PR fortran/20866
+       * match.c (recursive_stmt_fcn): New function that tests if
+       a statement function resurses through itself or other other
+       statement functions.
+       (gfc_match_st_function): Call recursive_stmt_fcn to check
+       if this is recursive and to raise error if so.
+
+       PR fortran/20849
+       PR fortran/20853
+       * resolve.c (resolve_symbol): Errors for assumed size arrays
+       with default initializer and for external objects with an
+       initializer.
+
+       PR fortran/20837
+       * decl.c (match_attr_spec): Prevent PUBLIC from being used
+       outside a module.
+
 2005-10-16  Erik Edelmann  <erik.edelmann@iki.fi>
 
        PR 22273
index 20d1f8a2d20549c426b80d18e2c61b327de8add0..21f1089e42d28c96e8e2f0ee2276720f80fc125d 100644 (file)
@@ -746,6 +746,13 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
          /* Update symbol character length according initializer.  */
          if (sym->ts.cl->length == NULL)
            {
+             /* If there are multiple CHARACTER variables declared on
+                the same line, we don't want them to share the same
+               length.  */
+             sym->ts.cl = gfc_get_charlen ();
+             sym->ts.cl->next = gfc_current_ns->cl_list;
+             gfc_current_ns->cl_list = sym->ts.cl;
+
              if (init->expr_type == EXPR_CONSTANT)
                sym->ts.cl->length =
                        gfc_int_expr (init->value.character.length);
@@ -1867,6 +1874,20 @@ match_attr_spec (void)
          goto cleanup;
        }
 
+      if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
+            && gfc_current_state () != COMP_MODULE)
+       {
+         if (d == DECL_PRIVATE)
+           attr = "PRIVATE";
+         else
+           attr = "PUBLIC";
+
+         gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
+                    attr, &seen_at[d]);
+         m = MATCH_ERROR;
+         goto cleanup;
+       }
+
       switch (d)
        {
        case DECL_ALLOCATABLE:
index 16d35c4edb0faf533d36a224c6412dc62104da2b..ebfd8486a13e9492270f938246ab530073077120 100644 (file)
@@ -1673,12 +1673,16 @@ check_restricted (gfc_expr * e)
          break;
        }
 
+      /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
+        in resolve.c(resolve_formal_arglist).  This is done so that host associated
+        dummy array indices are accepted (PR23446).  */
       if (sym->attr.in_common
          || sym->attr.use_assoc
          || sym->attr.dummy
          || sym->ns != gfc_current_ns
          || (sym->ns->proc_name != NULL
-             && sym->ns->proc_name->attr.flavor == FL_MODULE))
+             && sym->ns->proc_name->attr.flavor == FL_MODULE)
+         || gfc_is_formal_arg ())
        {
          t = SUCCESS;
          break;
index 63b4b931c3c5ad360aeb8a55f4ced2bd925f43d1..894761367bec5dc33a13cd82a2d554563bc55ab0 100644 (file)
@@ -1805,6 +1805,7 @@ int gfc_elemental (gfc_symbol *);
 try gfc_resolve_iterator (gfc_iterator *, bool);
 try gfc_resolve_index (gfc_expr *, int);
 try gfc_resolve_dim_arg (gfc_expr *);
+int gfc_is_formal_arg (void);
 
 /* array.c */
 void gfc_free_array_spec (gfc_array_spec *);
index 3f9487414a2f9eaf60990fdaf243cce8e80a377f..eac5697c5e400cb611b2a1eaba238d5fc5a30c8e 100644 (file)
@@ -2700,6 +2700,88 @@ cleanup:
   return MATCH_ERROR;
 }
 
+/* Check that a statement function is not recursive. This is done by looking
+   for the statement function symbol(sym) by looking recursively through its
+   expression(e).  If a reference to sym is found, true is returned.  */
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+  gfc_actual_arglist *arg;
+  gfc_ref *ref;
+  int i;
+
+  if (e == NULL)
+    return false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_FUNCTION:
+      for (arg = e->value.function.actual; arg; arg = arg->next)
+       {
+         if (sym->name == arg->name
+               || recursive_stmt_fcn (arg->expr, sym))
+           return true;
+       }
+
+      /* Check the name before testing for nested recursion!  */
+      if (sym->name == e->symtree->n.sym->name)
+       return true;
+
+      /* Catch recursion via other statement functions.  */
+      if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
+           && e->symtree->n.sym->value
+           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
+       return true;
+
+      break;
+
+    case EXPR_VARIABLE:
+      if (sym->name == e->symtree->n.sym->name)
+       return true;
+      break;
+
+    case EXPR_OP:
+      if (recursive_stmt_fcn (e->value.op.op1, sym)
+           || recursive_stmt_fcn (e->value.op.op2, sym))
+       return true;
+      break;
+
+    default:
+      break;
+    }
+
+  /* Component references do not need to be checked.  */
+  if (e->ref)
+    {
+      for (ref = e->ref; ref; ref = ref->next)
+       {
+         switch (ref->type)
+           {
+           case REF_ARRAY:
+             for (i = 0; i < ref->u.ar.dimen; i++)
+               {
+                 if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
+                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
+                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
+                   return true;
+               }
+             break;
+
+           case REF_SUBSTRING:
+             if (recursive_stmt_fcn (ref->u.ss.start, sym)
+                   || recursive_stmt_fcn (ref->u.ss.end, sym))
+               return true;
+
+             break;
+
+           default:
+             break;
+           }
+       }
+    }
+  return false;
+}
+
 
 /* Match a statement function declaration.  It is so easy to match
    non-statement function statements with a MATCH_ERROR as opposed to
@@ -2734,6 +2816,13 @@ gfc_match_st_function (void)
   if (m == MATCH_ERROR)
     return m;
 
+  if (recursive_stmt_fcn (expr, sym))
+    {
+      gfc_error ("Statement function at %L is recursive",
+                &expr->where);
+      return MATCH_ERROR;
+    }
+
   sym->value = expr;
 
   return MATCH_YES;
index 5de16ba32ad5ca4d7e2e4b9ff98dd1bb81b06c2b..66ebd86381eab6818c7efa07e82218783ef286cd 100644 (file)
@@ -50,6 +50,16 @@ static code_stack *cs_base = NULL;
 
 static int forall_flag;
 
+/* Nonzero if we are processing a formal arglist. The corresponding function
+   resets the flag each time that it is read.  */
+static int formal_arg_flag = 0;
+
+int
+gfc_is_formal_arg (void)
+{
+  return formal_arg_flag;
+}
+
 /* Resolve types of formal argument lists.  These have to be done early so that
    the formal argument lists of module procedures can be copied to the
    containing module before the individual procedures are resolved
@@ -78,6 +88,8 @@ resolve_formal_arglist (gfc_symbol * proc)
       || (sym->as && sym->as->rank > 0))
     proc->attr.always_explicit = 1;
 
+  formal_arg_flag = 1;
+
   for (f = proc->formal; f; f = f->next)
     {
       sym = f->sym;
@@ -224,6 +236,7 @@ resolve_formal_arglist (gfc_symbol * proc)
             }
         }
     }
+  formal_arg_flag = 0;
 }
 
 
@@ -4301,6 +4314,26 @@ resolve_symbol (gfc_symbol * sym)
        }
     }
 
+  /* An assumed-size array with INTENT(OUT) shall not be of a type for which
+     default initialization is defined (5.1.2.4.4).  */
+  if (sym->ts.type == BT_DERIVED
+       && sym->attr.dummy
+       && sym->attr.intent == INTENT_OUT
+       && sym->as->type == AS_ASSUMED_SIZE)
+    {
+      for (c = sym->ts.derived->components; c; c = c->next)
+       {
+         if (c->initializer)
+           {
+             gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
+                        "ASSUMED SIZE and so cannot have a default initializer",
+                        sym->name, &sym->declared_at);
+             return;
+           }
+       }
+    }
+
+
   /* Ensure that derived type formal arguments of a public procedure
      are not of a private type.  */
   if (sym->attr.flavor == FL_PROCEDURE
@@ -4427,6 +4460,15 @@ resolve_symbol (gfc_symbol * sym)
       break;
 
     default:
+
+      /* An external symbol falls through to here if it is not referenced.  */
+      if (sym->attr.external && sym->value)
+       {
+         gfc_error ("External object at %L may not have an initializer",
+                    &sym->declared_at);
+         return;
+       }
+
       break;
     }
 
index 319812ac4297fd64056c4d26f7629d72908c97ac..5e1d0af3af26ee8a9f8fe96e0235fe8f321e2848 100644 (file)
@@ -1,3 +1,23 @@
+2005-10-17  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/23446
+       * gfortran.dg/host_dummy_index_1.f90: New test.
+
+       PR fortran/21459
+       gfortran.dg/automatic_char_len_2.f90: New test.
+
+       PR fortran/20866
+       gfortran.dg/recursive_statement_functions.f90: New test.
+
+       PR fortran/20853
+       gfortran.dg/assumed_size_dt_dummy.f90: New test.
+
+       PR fortran/20849
+       gfortran.dg/external_initializer.f90: New test.
+
+       PR fortran/20837
+       non_module_public.f90: New test.
+
 2005-10-17  Nathan Sidwell  <nathan@codesourcery.com>
 
        PR c++/24386
diff --git a/gcc/testsuite/gfortran.dg/assumed_size_dt_dummy.f90 b/gcc/testsuite/gfortran.dg/assumed_size_dt_dummy.f90
new file mode 100644 (file)
index 0000000..f7b5e29
--- /dev/null
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! PR20853 - No array size information for initializer.
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+MODULE TEST
+TYPE init
+INTEGER :: I=0
+END TYPE init
+CONTAINS
+SUBROUTINE try(A) ! { dg-error "cannot have a default initializer" }
+  TYPE(init), DIMENSION(*), INTENT(OUT) :: A
+END SUBROUTINE try
+END MODULE TEST
+END
diff --git a/gcc/testsuite/gfortran.dg/automatic_char_len_2.f90 b/gcc/testsuite/gfortran.dg/automatic_char_len_2.f90
new file mode 100644 (file)
index 0000000..18bb8d1
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-options "-O0" }
+!
+! Tests fix for PR21459 - This is the original example.
+!
+program format_string
+  implicit none
+  character(len=*), parameter :: rform='(F15.5)', &
+  cform="(' (', F15.5, ',' F15.5, ') ')"
+  call print_a_number(cform)
+contains
+subroutine print_a_number(style)
+  character(len=*) :: style
+  write(*, style) cmplx(42.0, 99.0) ! { dg-output "99.00000" }
+end subroutine print_a_number
+end program format_string
diff --git a/gcc/testsuite/gfortran.dg/external_initializer.f90 b/gcc/testsuite/gfortran.dg/external_initializer.f90
new file mode 100644 (file)
index 0000000..5688bbf
--- /dev/null
@@ -0,0 +1,5 @@
+! { dg-do compile }
+! PR20849 - An external symbol may not have a initializer.
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+REAL, EXTERNAL :: X=0 ! { dg-error "may not have an initializer" }
+END
diff --git a/gcc/testsuite/gfortran.dg/host_dummy_index_1.f90 b/gcc/testsuite/gfortran.dg/host_dummy_index_1.f90
new file mode 100644 (file)
index 0000000..cc045ff
--- /dev/null
@@ -0,0 +1,29 @@
+! { dg-do run }
+! Tests the fix for PR23446. Based on PR example.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+PROGRAM TST
+  INTEGER IMAX
+  INTEGER :: A(4) = 1
+  IMAX=2
+
+  CALL S(A)
+  CALL T(A)
+  CALL U(A)
+  if ( ALL(A.ne.(/2,2,3,4/))) CALL ABORT ()
+
+CONTAINS
+  SUBROUTINE S(A)
+    INTEGER A(IMAX)
+    a = 2
+  END SUBROUTINE S
+  SUBROUTINE T(A)
+    INTEGER A(3:IMAX+4)
+    A(5:IMAX+4) = 3
+  END SUBROUTINE T
+  SUBROUTINE U(A)
+    INTEGER A(2,IMAX)
+    A(2,2) = 4
+  END SUBROUTINE U
+ENDPROGRAM TST
diff --git a/gcc/testsuite/gfortran.dg/non_module_public.f90 b/gcc/testsuite/gfortran.dg/non_module_public.f90
new file mode 100644 (file)
index 0000000..cf99dd7
--- /dev/null
@@ -0,0 +1,5 @@
+! { dg-do compile }
+! PR20837 - A symbol may not be declared PUBLIC or PRIVATE outside a module.
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+integer, parameter, public :: i=1 ! { dg-error "allowed outside of a MODULE" }
+END
diff --git a/gcc/testsuite/gfortran.dg/recursive_statement_functions.f90 b/gcc/testsuite/gfortran.dg/recursive_statement_functions.f90
new file mode 100644 (file)
index 0000000..489f118
--- /dev/null
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! PR20866 - A statement function cannot be recursive.
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+  INTEGER :: i, st1, st2, st3
+  REAL :: x, z(2,2)
+  character*8 :: ch
+!
+! Test check for recursion via other statement functions, string
+! length references, function actual arguments and array index
+! references.
+  st1(i)=len(ch(st2(1):8))
+  st2(i)=max (st3(1), 4)
+  st3(i)=2 + cos (z(st1 (1), i)) ! { dg-error "is recursive" }
+  write(6,*) st1(1)
+  END
+