OSDN Git Service

2010-11-02 Steven G. Kargl < kargl@gcc.gnu.org>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 2 Nov 2010 17:09:58 +0000 (17:09 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 2 Nov 2010 17:09:58 +0000 (17:09 +0000)
            Tobias Burnus  <burnus@net-b.de>

        PR fortran/45170
        * array.c (gfc_match_array_constructor): Reject deferred type
        parameter (DTP) in type-spec.
        * decl.c (char_len_param_value, match_char_length,
        gfc_match_char_spec, build_sym, variable_decl,
        enumerator_decl): Support DTP.
        * expr.c (check_inquiry): Fix check due to support for DTP.
        * gfortran.h (gfc_typespec): Add Boolean 'deferred'.
        * misc.c (gfc_clear_ts): Set it to false.
        * match.c (gfc_match_allocate): Support DTP.
        * resolve.c (resolve_allocate_expr): Not-implemented error for
        * DTP.
        (resolve_fl_variable): Add DTP constraint check.
        * trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
        error for DTP.

2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
            Tobias Burnus  <burnus@net-b.de>

        PR fortran/45170
        * gfortran.dg/deferred_type_param_1.f90: New.
        * gfortran.dg/deferred_type_param_2.f90: New.
        * gfortran.dg/initialization_1.f90: Update dg-errors.
        * gfortran.dg/initialization_9.f90: Update dg-errors.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@166205 138bc75d-0d04-0410-961f-82ee72b054a4

15 files changed:
gcc/fortran/ChangeLog
gcc/fortran/array.c
gcc/fortran/decl.c
gcc/fortran/expr.c
gcc/fortran/gfortran.h
gcc/fortran/match.c
gcc/fortran/misc.c
gcc/fortran/resolve.c
gcc/fortran/trans-decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/allocate_with_typespec_3.f90
gcc/testsuite/gfortran.dg/deferred_type_param_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/initialization_1.f90
gcc/testsuite/gfortran.dg/initialization_9.f90

index 58adc25..05cab00 100644 (file)
@@ -1,3 +1,21 @@
+2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
+           Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/45170
+       * array.c (gfc_match_array_constructor): Reject deferred type
+       parameter (DTP) in type-spec.
+       * decl.c (char_len_param_value, match_char_length,
+       gfc_match_char_spec, build_sym, variable_decl,
+       enumerator_decl): Support DTP.
+       * expr.c (check_inquiry): Fix check due to support for DTP.
+       * gfortran.h (gfc_typespec): Add Boolean 'deferred'.
+       * misc.c (gfc_clear_ts): Set it to false.
+       * match.c (gfc_match_allocate): Support DTP.
+       * resolve.c (resolve_allocate_expr): Not-implemented error for DTP.
+       (resolve_fl_variable): Add DTP constraint check.
+       * trans-decl.c (gfc_trans_deferred_vars): Add not-implemented
+       error for DTP.
+
 2010-11-01  Steven G. Kargl  <kargl@gcc.gnu.org>
 
        PR fortran/46152
index 8c74e70..ff0977a 100644 (file)
@@ -1035,6 +1035,13 @@ gfc_match_array_constructor (gfc_expr **result)
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
                              "including type specification at %C") == FAILURE)
            goto cleanup;
+
+         if (ts.deferred)
+           {
+             gfc_error ("Type-spec at %L cannot contain a deferred "
+                        "type parameter", &where);
+             goto cleanup;
+           }
        }
     }
 
index 009b010..14575de 100644 (file)
@@ -647,16 +647,27 @@ match_intent_spec (void)
 
 
 /* Matches a character length specification, which is either a
-   specification expression or a '*'.  */
+   specification expression, '*', or ':'.  */
 
 static match
-char_len_param_value (gfc_expr **expr)
+char_len_param_value (gfc_expr **expr, bool *deferred)
 {
   match m;
 
+  *expr = NULL;
+  *deferred = false;
+
   if (gfc_match_char ('*') == MATCH_YES)
+    return MATCH_YES;
+
+  if (gfc_match_char (':') == MATCH_YES)
     {
-      *expr = NULL;
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+                         "parameter at %C") == FAILURE)
+       return MATCH_ERROR;
+
+      *deferred = true;
+
       return MATCH_YES;
     }
 
@@ -697,11 +708,12 @@ syntax:
    char_len_param_value in parenthesis.  */
 
 static match
-match_char_length (gfc_expr **expr)
+match_char_length (gfc_expr **expr, bool *deferred)
 {
   int length;
   match m;
 
+  *deferred = false; 
   m = gfc_match_char ('*');
   if (m != MATCH_YES)
     return m;
@@ -722,7 +734,7 @@ match_char_length (gfc_expr **expr)
   if (gfc_match_char ('(') == MATCH_NO)
     goto syntax;
 
-  m = char_len_param_value (expr);
+  m = char_len_param_value (expr, deferred);
   if (m != MATCH_YES && gfc_matching_function)
     {
       gfc_undo_symbols ();
@@ -1086,7 +1098,7 @@ verify_c_interop_param (gfc_symbol *sym)
 /* Function called by variable_decl() that adds a name to the symbol table.  */
 
 static gfc_try
-build_sym (const char *name, gfc_charlen *cl,
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
           gfc_array_spec **as, locus *var_locus)
 {
   symbol_attribute attr;
@@ -1103,7 +1115,10 @@ build_sym (const char *name, gfc_charlen *cl,
     return FAILURE;
 
   if (sym->ts.type == BT_CHARACTER)
-    sym->ts.u.cl = cl;
+    {
+      sym->ts.u.cl = cl;
+      sym->ts.deferred = cl_deferred;
+    }
 
   /* Add dimension attribute if present.  */
   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
@@ -1710,6 +1725,7 @@ variable_decl (int elem)
   gfc_array_spec *as;
   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
   gfc_charlen *cl;
+  bool cl_deferred;
   locus var_locus;
   match m;
   gfc_try t;
@@ -1770,10 +1786,11 @@ variable_decl (int elem)
 
   char_len = NULL;
   cl = NULL;
+  cl_deferred = false;
 
   if (current_ts.type == BT_CHARACTER)
     {
-      switch (match_char_length (&char_len))
+      switch (match_char_length (&char_len, &cl_deferred))
        {
        case MATCH_YES:
          cl = gfc_new_charlen (gfc_current_ns, NULL);
@@ -1794,6 +1811,8 @@ variable_decl (int elem)
          else
            cl = current_ts.u.cl;
 
+         cl_deferred = current_ts.deferred;
+
          break;
 
        case MATCH_ERROR:
@@ -1869,7 +1888,7 @@ variable_decl (int elem)
      create a symbol for those yet.  If we fail to create the symbol,
      bail out.  */
   if (gfc_current_state () != COMP_DERIVED
-      && build_sym (name, cl, &as, &var_locus) == FAILURE)
+      && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;
@@ -2277,16 +2296,18 @@ gfc_match_char_spec (gfc_typespec *ts)
   gfc_charlen *cl;
   gfc_expr *len;
   match m;
+  bool deferred;
 
   len = NULL;
   seen_length = 0;
   kind = 0;
   is_iso_c = 0;
+  deferred = false;
 
   /* Try the old-style specification first.  */
   old_char_selector = 0;
 
-  m = match_char_length (&len);
+  m = match_char_length (&len, &deferred);
   if (m != MATCH_NO)
     {
       if (m == MATCH_YES)
@@ -2315,7 +2336,7 @@ gfc_match_char_spec (gfc_typespec *ts)
       if (gfc_match (" , len =") == MATCH_NO)
        goto rparen;
 
-      m = char_len_param_value (&len);
+      m = char_len_param_value (&len, &deferred);
       if (m == MATCH_NO)
        goto syntax;
       if (m == MATCH_ERROR)
@@ -2328,7 +2349,7 @@ gfc_match_char_spec (gfc_typespec *ts)
   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
   if (gfc_match (" len =") == MATCH_YES)
     {
-      m = char_len_param_value (&len);
+      m = char_len_param_value (&len, &deferred);
       if (m == MATCH_NO)
        goto syntax;
       if (m == MATCH_ERROR)
@@ -2348,7 +2369,7 @@ gfc_match_char_spec (gfc_typespec *ts)
     }
 
   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
-  m = char_len_param_value (&len);
+  m = char_len_param_value (&len, &deferred);
   if (m == MATCH_NO)
     goto syntax;
   if (m == MATCH_ERROR)
@@ -2407,6 +2428,7 @@ done:
 
   ts->u.cl = cl;
   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
+  ts->deferred = deferred;
 
   /* We have to know if it was a c interoperable kind so we can
      do accurate type checking of bind(c) procs, etc.  */
@@ -7449,7 +7471,7 @@ enumerator_decl (void)
   /* OK, we've successfully matched the declaration.  Now put the
      symbol in the current namespace. If we fail to create the symbol,
      bail out.  */
-  if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
+  if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
     {
       m = MATCH_ERROR;
       goto cleanup;
index e567c98..8dfbf73 100644 (file)
@@ -2292,10 +2292,13 @@ check_inquiry (gfc_expr *e, int not_restricted)
           with LEN, as required by the standard.  */
        if (i == 5 && not_restricted
            && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
-           && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
+           && (ap->expr->symtree->n.sym->ts.u.cl->length == NULL
+               || ap->expr->symtree->n.sym->ts.deferred))
          {
-           gfc_error ("Assumed character length variable '%s' in constant "
-                      "expression at %L", e->symtree->n.sym->name, &e->where);
+           gfc_error ("Assumed or deferred character length variable '%s' "
+                       " in constant expression at %L",
+                       ap->expr->symtree->n.sym->name,
+                       &ap->expr->where);
              return MATCH_ERROR;
          }
        else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
index b96dd64..2d0d4eb 100644 (file)
@@ -885,7 +885,7 @@ typedef struct gfc_charlen
   struct gfc_charlen *next;
   bool length_from_typespec; /* Length from explicit array ctor typespec?  */
   tree backend_decl;
-  tree passed_length; /* Length argument explicitelly passed.  */
+  tree passed_length; /* Length argument explicitly passed.  */
 
   int resolved;
 }
@@ -910,7 +910,8 @@ typedef struct
   struct gfc_symbol *interface;        /* For PROCEDURE declarations.  */
   int is_c_interop;
   int is_iso_c;
-  bt f90_type; 
+  bt f90_type;
+  bool deferred;
 }
 gfc_typespec;
 
index 1b895f0..41818e9 100644 (file)
@@ -2845,12 +2845,12 @@ gfc_match_allocate (void)
   gfc_typespec ts;
   gfc_symbol *sym;
   match m;
-  locus old_locus;
-  bool saw_stat, saw_errmsg, saw_source, saw_mold, b1, b2, b3;
+  locus old_locus, deferred_locus;
+  bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
 
   head = tail = NULL;
   stat = errmsg = source = mold = tmp = NULL;
-  saw_stat = saw_errmsg = saw_source = saw_mold = false;
+  saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
 
   if (gfc_match_char ('(') != MATCH_YES)
     goto syntax;
@@ -2879,6 +2879,13 @@ gfc_match_allocate (void)
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
                              "ALLOCATE at %L", &old_locus) == FAILURE)
            goto cleanup;
+
+         if (ts.deferred)
+           {
+             gfc_error ("Type-spec at %L cannot contain a deferred "
+                        "type parameter", &old_locus);
+             goto cleanup;
+           }
        }
       else
        {
@@ -2912,6 +2919,12 @@ gfc_match_allocate (void)
          goto cleanup;
        }
 
+      if (tail->expr->ts.deferred)
+       {
+         saw_deferred = true;
+         deferred_locus = tail->expr->where;
+       }
+
       /* The ALLOCATE statement had an optional typespec.  Check the
         constraints.  */
       if (ts.type != BT_UNKNOWN)
@@ -3095,7 +3108,6 @@ alloc_opt_list:
          break;
     }
 
-
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
 
@@ -3106,6 +3118,14 @@ alloc_opt_list:
                  &mold->where, &source->where);
       goto cleanup;
     }
+
+  /* Check F03:C623,  */
+  if (saw_deferred && ts.type == BT_UNKNOWN && !source)
+    {
+      gfc_error ("Allocate-object at %L with a deferred type parameter "
+                "requires either a type-spec or SOURCE tag", &deferred_locus);
+      goto cleanup;
+    }
   
   new_st.op = EXEC_ALLOCATE;
   new_st.expr1 = stat;
index b5e6275..397c872 100644 (file)
@@ -77,6 +77,7 @@ gfc_clear_ts (gfc_typespec *ts)
   ts->f90_type = BT_UNKNOWN;
   /* flag that says whether it's from iso_c_binding or not */
   ts->is_iso_c = 0;
+  ts->deferred = false;
 }
 
 
index 4280555..6e71e13 100644 (file)
@@ -6856,6 +6856,12 @@ check_symbols:
     }
 
 success:
+  if (e->ts.deferred)
+    {
+      gfc_error ("Support for entity at %L with deferred type parameter "
+                "not yet implemented", &e->where);
+      return FAILURE;
+    }
   return SUCCESS;
 
 failure:
@@ -9371,6 +9377,7 @@ resolve_index_expr (gfc_expr *e)
   return SUCCESS;
 }
 
+
 /* Resolve a charlen structure.  */
 
 static gfc_try
@@ -9684,6 +9691,7 @@ apply_default_init_local (gfc_symbol *sym)
   build_init_assign (sym, init);
 }
 
+
 /* Resolution of common features of flavors variable and procedure.  */
 
 static gfc_try
@@ -9847,12 +9855,22 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       return FAILURE;
     }
 
+  /* Constraints on deferred type parameter.  */
+  if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+    {
+      gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+                "requires either the pointer or allocatable attribute",
+                    sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
   if (sym->ts.type == BT_CHARACTER)
     {
       /* Make sure that character string variables with assumed length are
         dummy arguments.  */
       e = sym->ts.u.cl->length;
-      if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+      if (e == NULL && !sym->attr.dummy && !sym->attr.result
+         && !sym->ts.deferred)
        {
          gfc_error ("Entity with assumed character length at %L must be a "
                     "dummy argument or a PARAMETER", &sym->declared_at);
index 2c4ebbb..4b668c8 100644 (file)
@@ -3416,6 +3416,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
              gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
            }
        }
+      else if (sym->ts.deferred)
+       gfc_fatal_error ("Deferred type parameter not yet supported");
       else if (sym_has_alloc_comp)
        gfc_trans_deferred_array (sym, block);
       else if (sym->ts.type == BT_CHARACTER)
index d7135d8..2fcf2b2 100644 (file)
@@ -1,3 +1,12 @@
+2010-11-02  Steven G. Kargl  < kargl@gcc.gnu.org>
+           Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/45170
+       * gfortran.dg/deferred_type_param_1.f90: New.
+       * gfortran.dg/deferred_type_param_2.f90: New.
+       * gfortran.dg/initialization_1.f90: Update dg-errors.
+       * gfortran.dg/initialization_9.f90: Update dg-errors.
+
 2010-11-02  Richard Guenther  <rguenther@suse.de>
 
        PR tree-optimization/46149
index 57f8a11..13a1596 100644 (file)
@@ -23,7 +23,7 @@ subroutine implicit_none_test1
    allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1(1))       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b(1))          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_none_test1
@@ -50,7 +50,7 @@ subroutine implicit_none_test2
    allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b)          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_none_test2
@@ -76,7 +76,7 @@ subroutine implicit_test3
    allocate(real(8) :: x4(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8(1))      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1(1))       ! { dg-error "Error in type-spec" }
-   allocate(character(:) :: c1(1)) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b(1))          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_test3
@@ -101,7 +101,7 @@ subroutine implicit_test4
    allocate(real(8) :: x4)      ! { dg-error "differs from the kind type parameter" }
    allocate(real(4) :: x8)      ! { dg-error "differs from the kind type parameter" }
    allocate(double :: d1)       ! { dg-error "Error in type-spec at" }
-   allocate(character(:) :: c1) ! { dg-error "Syntax error in CHARACTER declaration" }
+   allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" }
    allocate(real :: b)          ! { dg-error "is type incompatible" }
 
 end subroutine implicit_test4
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_1.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_1.f90
new file mode 100644 (file)
index 0000000..4382fae
--- /dev/null
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+implicit none
+character(len=:), allocatable :: str(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+
+character(len=4) :: str2*(:) ! { dg-error "Fortran 2003: deferred type parameter" }
+end
diff --git a/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90 b/gcc/testsuite/gfortran.dg/deferred_type_param_2.f90
new file mode 100644 (file)
index 0000000..7bfd2a6
--- /dev/null
@@ -0,0 +1,62 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/45170
+!
+! Character deferred type parameter
+!
+
+subroutine one(x, y) ! { dg-error "Entity .y. at .1. has a deferred type parameter" }
+  implicit none
+  character(len=:), pointer :: x
+  character(len=:) :: y
+  character(len=:), allocatable, target :: str2
+  character(len=:), target :: str ! { dg-error "deferred type parameter" }
+end subroutine one
+
+subroutine two()
+  implicit none
+  character(len=:), allocatable, target :: str1(:)
+  character(len=5), save, target :: str2
+  character(len=:), pointer :: pstr => str2
+  character(len=:), pointer :: pstr2(:)
+end subroutine two
+
+subroutine three()
+!  implicit none  ! Disabled because of PR 46152
+  character(len=:), allocatable, target :: str1(:)
+  character(len=5), save, target :: str2
+  character(len=:), pointer :: pstr
+  character(len=:), pointer :: pstr2(:)
+
+  pstr => str2
+  pstr2 => str1
+  str1 = ["abc"]
+  pstr2 => str1
+
+  allocate (character(len=77) :: str1(1)) ! OK ! { dg-error "not yet implemented" }
+  allocate (pstr, source=str2)  ! OK  ! { dg-error "not yet implemented" }
+  allocate (pstr, mold=str2) ! { dg-error "requires either a type-spec or SOURCE tag" }
+  allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" }
+  allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" }
+
+  str1 = [ character(len=2) :: "abc" ]
+  str1 = [ character(len=:) :: "abc" ] ! { dg-error "cannot contain a deferred type parameter" }
+end subroutine three
+
+subroutine four()
+  implicit none
+  character(len=:), allocatable, target :: str
+  character(len=:), pointer :: pstr
+  pstr => str
+  str = "abc"
+  if(len(pstr) /= len(str) .or. len(str)/= 3) call abort()
+  str = "abcd"
+  if(len(pstr) /= len(str) .or. len(str)/= 4) call abort()
+end subroutine four
+
+subroutine five()
+character(len=4) :: str*(:)
+allocatable :: str
+end subroutine five
+
index 63035cc..3ca20ac 100644 (file)
@@ -24,7 +24,7 @@ contains
     real :: z(2, 2)
 
 ! However, this gives a warning because it is an initialization expression.
-    integer :: l1 = len (ch1)     ! { dg-warning "Assumed character length variable" }
+    integer :: l1 = len (ch1)     ! { dg-warning "Assumed or deferred character length variable" }
 
 ! These are warnings because they are gfortran extensions.
     integer :: m3 = size (x, 1)   ! { dg-error "Assumed size array" }
index 2341d40..d904047 100644 (file)
@@ -5,7 +5,7 @@
 
    integer function xstrcmp(s1)
      character*(*), intent(in) :: s1
-     integer :: n1 = len(s1)            ! { dg-error "Assumed character length variable" }
+     integer :: n1 = len(s1)  ! { dg-error "Assumed or deferred character length variable" }
      n1 = 1
      return
    end function xstrcmp