2011-01-23 Tobias Burnus <burnus@net-b.de>
PR fortran/47339
PR fortran/43062
* match.c (gfc_match_namelist): Allow assumed-length characters.
* resolve.c (resolve_fl_namelist): Adapt and add error messages.
* symbol.c (check_conflict): Allow allocatables in NML for F2003.
* trans-io.c (nml_get_addr_expr,transfer_namelist_element):
Changes due to that change.
2011-01-23 Tobias Burnus <burnus@net-b.de>
PR fortran/47339
PR fortran/43062
* fortran.dg/namelist_69.f90: New test.
* fortran.dg/namelist_70.f90: New test.
* fortran.dg/namelist_assumed_char.f90: Modify dg-error, augment test.
* fortran.dg/namelist_3.f90: Adapt test.
* fortran.dg/namelist_34.f90: Ditto.
* fortran.dg/namelist_35.f90: Ditto.
* fortran.dg/namelist_5.f90: Ditto.
* fortran.dg/namelist_63.f90: Ditto.
* gfortran.dg/alloc_comp_constraint_1.f90: Ditto.
@@ -4030,13 +4030,6 @@ gfc_match_namelist (void)
gfc_error_check ();
}
- if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
- {
- gfc_error ("Assumed character length '%s' in namelist '%s' at "
- "%C is not allowed", sym->name, group_name->name);
- gfc_error_check ();
- }
-
nl = gfc_get_namelist ();
nl->sym = sym;
sym->refs++;
@@ -11726,40 +11726,64 @@ resolve_fl_namelist (gfc_symbol *sym)
for (nl = sym->namelist; nl; nl = nl->next)
{
- /* Reject namelist arrays of assumed shape. */
+ /* Check again, the check in match only works if NAMELIST comes
+ after the decl. */
+ if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+ {
+ gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+ "allowed", nl->sym->name, sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
- "must not have assumed shape in namelist "
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with assumed shape in namelist "
"'%s' at %L", nl->sym->name, sym->name,
&sym->declared_at) == FAILURE)
- return FAILURE;
+ return FAILURE;
- /* Reject namelist arrays that are not constant shape. */
- if (is_non_constant_shape_array (nl->sym))
- {
- gfc_error ("NAMELIST array object '%s' must have constant "
- "shape in namelist '%s' at %L", nl->sym->name,
- sym->name, &sym->declared_at);
- return FAILURE;
- }
+ if (is_non_constant_shape_array (nl->sym)
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+ "object '%s' with nonconstant shape in namelist "
+ "'%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
- /* Namelist objects cannot have allocatable or pointer components. */
- if (nl->sym->ts.type != BT_DERIVED)
- continue;
+ if (nl->sym->ts.type == BT_CHARACTER
+ && (nl->sym->ts.u.cl->length == NULL
+ || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' with nonconstant character length in "
+ "namelist '%s' at %L", nl->sym->name, sym->name,
+ &sym->declared_at) == FAILURE)
+ return FAILURE;
- if (nl->sym->ts.u.derived->attr.alloc_comp)
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ if (nl->sym->ts.type == BT_CLASS)
{
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have ALLOCATABLE components",
- nl->sym->name, sym->name, &sym->declared_at);
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+ "polymorphic and requires a defined input/output "
+ "procedure", nl->sym->name, sym->name, &sym->declared_at);
return FAILURE;
}
- if (nl->sym->ts.u.derived->attr.pointer_comp)
+ if (nl->sym->ts.type == BT_DERIVED
+ && (nl->sym->ts.u.derived->attr.alloc_comp
+ || nl->sym->ts.u.derived->attr.pointer_comp))
{
- gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
- "have POINTER components",
- nl->sym->name, sym->name, &sym->declared_at);
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object "
+ "'%s' in namelist '%s' at %L with ALLOCATABLE "
+ "or POINTER components", nl->sym->name,
+ sym->name, &sym->declared_at) == FAILURE)
+ return FAILURE;
+
+ /* FIXME: Once UDDTIO is implemented, the following can be
+ removed. */
+ gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+ "ALLOCATABLE or POINTER components and thus requires "
+ "a defined input/output procedure", nl->sym->name,
+ sym->name, &sym->declared_at);
return FAILURE;
}
}
@@ -390,6 +390,14 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
goto conflict_std;
}
+ if (attr->in_namelist && (attr->allocatable || attr->pointer))
+ {
+ a1 = in_namelist;
+ a2 = attr->allocatable ? allocatable : pointer;
+ standard = GFC_STD_F2003;
+ goto conflict_std;
+ }
+
/* Check for attributes not allowed in a BLOCK DATA. */
if (gfc_current_state () == COMP_BLOCK_DATA)
{
@@ -495,9 +503,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
conf (in_equivalence, allocatable);
conf (in_equivalence, threadprivate);
- conf (in_namelist, pointer);
- conf (in_namelist, allocatable);
-
conf (entry, result);
conf (function, subroutine);
@@ -1463,6 +1463,7 @@ nml_full_name (const char* var_name, const char* cmp_name)
return full_name;
}
+
/* nml_get_addr_expr builds an address expression from the
gfc_symbol or gfc_component backend_decl's. An offset is
provided so that the address of an element of an array of
@@ -1475,9 +1476,6 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
{
tree decl = NULL_TREE;
tree tmp;
- tree itmp;
- int array_flagged;
- int dummy_arg_flagged;
if (sym)
{
@@ -1503,18 +1501,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
/* Build indirect reference, if dummy argument. */
- dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
-
- itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
- tmp) : tmp;
-
- /* If an array, set flag and use indirect ref. if built. */
-
- array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
- && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
-
- if (array_flagged)
- tmp = itmp;
+ if (POINTER_TYPE_P (TREE_TYPE(tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
/* Treat the component of a derived type, using base_addr for
the derived type. */
@@ -1523,29 +1511,27 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
base_addr, tmp, NULL_TREE);
- /* If we have a derived type component, a reference to the first
- element of the array is built. This is done so that base_addr,
- used in the build of the component reference, always points to
- a RECORD_TYPE. */
-
- if (array_flagged)
- tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
-
- /* Now build the address expression. */
-
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_array_data (tmp);
+ else
+ {
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- /* If scalar dummy, resolve indirect reference now. */
+ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
- if (dummy_arg_flagged && !array_flagged)
- tmp = build_fold_indirect_ref_loc (input_location,
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location,
tmp);
+ }
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
return tmp;
}
+
/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
@@ -1565,6 +1551,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree tmp;
tree dtype;
tree dt_parm_addr;
+ tree decl = NULL_TREE;
int n_dim;
int itype;
int rank = 0;
@@ -1588,7 +1575,10 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
if (rank)
{
- dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
+ decl = (sym) ? sym->backend_decl : c->backend_decl;
+ if (sym && sym->attr.dummy)
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+ dt = TREE_TYPE (decl);
dtype = gfc_get_dtype (dt);
}
else
@@ -1622,9 +1612,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
iocall[IOCALL_SET_NML_VAL_DIM], 5,
dt_parm_addr,
IARG (n_dim),
- GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
- GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
- GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
+ gfc_conv_array_stride (decl, n_dim),
+ gfc_conv_array_lbound (decl, n_dim),
+ gfc_conv_array_ubound (decl, n_dim));
gfc_add_expr_to_block (block, tmp);
}
@@ -13,7 +13,7 @@ program main
type(foo) :: a
type(bar) :: b
- namelist /blah/ a ! { dg-error "cannot have ALLOCATABLE components" }
+ namelist /blah/ a ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" }
write (*, *) a ! { dg-error "cannot have ALLOCATABLE components" }
@@ -1,7 +1,8 @@
! { dg-do compile }
+! { dg-options "-std=f95" }
! Check that a pointer cannot be a member of a namelist
program namelist_3
integer,pointer :: x
allocate (x)
- namelist /n/ x ! { dg-error "NAMELIST attribute conflicts with POINTER attribute" "" }
+ namelist /n/ x ! { dg-error "NAMELIST attribute with POINTER attribute" "" }
end program namelist_3
@@ -23,8 +23,8 @@ USE types
type(tp1) :: t1
type(tp3) :: t3
- namelist /a/ t1 ! { dg-error "cannot have POINTER components" }
- namelist /b/ t3 ! { dg-error "cannot have POINTER components" }
+ namelist /a/ t1 ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" }
+ namelist /b/ t3 ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" }
END MODULE
! { dg-final { cleanup-modules "types nml" } }
@@ -7,5 +7,5 @@
subroutine test(cha)
implicit none
character(len=10) :: cha(:)
- namelist /z/ cha ! { dg-error "must not have assumed shape" }
+ namelist /z/ cha ! { dg-error "with assumed shape in namelist" }
end subroutine test
@@ -1,4 +1,6 @@
! { dg-do compile }
+! { dg-options "-std=f95" }
+!
! Tests the fix for PR25054 in which namelist objects with non-constant
! shape were allowed.
!
@@ -6,8 +8,8 @@
!
SUBROUTINE S1(I)
integer :: a,b(I)
- NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape" }
+ NAMELIST /NLIST/ a,b ! { dg-error "with nonconstant shape" }
a=1 ; b=2
write(6,NML=NLIST)
END SUBROUTINE S1
-END
\ No newline at end of file
+END
@@ -24,5 +24,5 @@ type region_struct
end type
type (c_struct) curve(10)
-namelist / params / curve ! { dg-error "NAMELIST object .curve. in namelist .params. at .1. cannot have POINTER components" }
+namelist / params / curve ! { dg-error "ALLOCATABLE or POINTER components and thus requires a defined input/output" }
end program
@@ -1,7 +1,20 @@
! { dg-do compile }
+! { dg-options "-std=f95" }
+
! PR30481 Assumed size character is not allowed in namelist.
! Test case from PR, submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
+!
+! Modifications for PR fortran/47339 / PR fortran/43062:
+! Add -std=f95, add bar()
+!
subroutine foo(c)
character*(*) c
- namelist /abc/ c ! { dg-error "Assumed character length" }
+ namelist /abc/ c ! { dg-error "nonconstant character length in namelist" }
end subroutine
+
+subroutine bar(d,n)
+ integer :: n
+ character(len=n) d
+ namelist /abcd/ d ! { dg-error "nonconstant character length in namelist" }
+end subroutine bar
+
@@ -0,0 +1,233 @@
+! { dg-do run }
+!
+! PR fortran/47339
+! PR fortran/43062
+!
+! Run-time test for Fortran 2003 NAMELISTS
+! Version for non-strings
+!
+program nml_test
+ implicit none
+
+ character(len=1000) :: str
+
+ integer, allocatable :: a(:)
+ integer, allocatable :: b
+ integer, pointer :: ap(:)
+ integer, pointer :: bp
+ integer :: c
+ integer :: d(3)
+
+ type t
+ integer :: c1
+ integer :: c2(3)
+ end type t
+ type(t) :: e,f(2)
+ type(t),allocatable :: g,h(:)
+ type(t),pointer :: i,j(:)
+
+ namelist /nml/ a, b, c, d, ap, bp,e,f,g,h,i,j
+
+ a = [1,2]
+ allocate(b,ap(2),bp)
+ ap = [98, 99]
+ b = 7
+ bp = 101
+ c = 8
+ d = [-1, -2, -3]
+
+ e%c1 = -701
+ e%c2 = [-702,-703,-704]
+ f(1)%c1 = 33001
+ f(2)%c1 = 33002
+ f(1)%c2 = [44001,44002,44003]
+ f(2)%c2 = [44011,44012,44013]
+
+ allocate(g,h(2),i,j(2))
+
+ g%c1 = -601
+ g%c2 = [-602,6703,-604]
+ h(1)%c1 = 35001
+ h(2)%c1 = 35002
+ h(1)%c2 = [45001,45002,45003]
+ h(2)%c2 = [45011,45012,45013]
+
+ i%c1 = -501
+ i%c2 = [-502,-503,-504]
+ j(1)%c1 = 36001
+ j(2)%c1 = 36002
+ j(1)%c2 = [46001,46002,46003]
+ j(2)%c2 = [46011,46012,46013]
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml)
+
+ ! RESET NAMELIST
+ a = [-1,-1]
+ ap = [-1, -1]
+ b = -1
+ bp = -1
+ c = -1
+ d = [-1, -1, -1]
+
+ e%c1 = -1
+ e%c2 = [-1,-1,-1]
+ f(1)%c1 = -1
+ f(2)%c1 = -1
+ f(1)%c2 = [-1,-1,-1]
+ f(2)%c2 = [-1,-1,-1]
+
+ g%c1 = -1
+ g%c2 = [-1,-1,-1]
+ h(1)%c1 = -1
+ h(2)%c1 = -1
+ h(1)%c2 = [-1,-1,-1]
+ h(2)%c2 = [-1,-1,-1]
+
+ i%c1 = -1
+ i%c2 = [-1,-1,-1]
+ j(1)%c1 = -1
+ j(2)%c1 = -1
+ j(1)%c2 = [-1,-1,-1]
+ j(2)%c2 = [-1,-1,-1]
+
+ ! Read back
+ read(str,nml=nml)
+
+ ! Check result
+ if (any (a /= [1,2])) call abort()
+ if (any (ap /= [98, 99])) call abort()
+ if (b /= 7) call abort()
+ if (bp /= 101) call abort()
+ if (c /= 8) call abort()
+ if (any (d /= [-1, -2, -3])) call abort()
+
+ if (e%c1 /= -701) call abort()
+ if (any (e%c2 /= [-702,-703,-704])) call abort()
+ if (f(1)%c1 /= 33001) call abort()
+ if (f(2)%c1 /= 33002) call abort()
+ if (any (f(1)%c2 /= [44001,44002,44003])) call abort()
+ if (any (f(2)%c2 /= [44011,44012,44013])) call abort()
+
+ if (g%c1 /= -601) call abort()
+ if (any(g%c2 /= [-602,6703,-604])) call abort()
+ if (h(1)%c1 /= 35001) call abort()
+ if (h(2)%c1 /= 35002) call abort()
+ if (any (h(1)%c2 /= [45001,45002,45003])) call abort()
+ if (any (h(2)%c2 /= [45011,45012,45013])) call abort()
+
+ if (i%c1 /= -501) call abort()
+ if (any (i%c2 /= [-502,-503,-504])) call abort()
+ if (j(1)%c1 /= 36001) call abort()
+ if (j(2)%c1 /= 36002) call abort()
+ if (any (j(1)%c2 /= [46001,46002,46003])) call abort()
+ if (any (j(2)%c2 /= [46011,46012,46013])) call abort()
+
+ ! Check argument passing (dummy processing)
+ call test2(a,b,c,d,ap,bp,e,f,g,h,i,j,2)
+
+contains
+ subroutine test2(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n)
+ integer, allocatable :: x1(:)
+ integer, allocatable :: x2
+ integer, pointer :: x1p(:)
+ integer, pointer :: x2p
+ integer :: x3
+ integer :: x4(3)
+ integer :: n
+ integer :: x5(n)
+ type(t) :: x6,x7(2)
+ type(t),allocatable :: x8,x9(:)
+ type(t),pointer :: x10,x11(:)
+ type(t) :: x12(n)
+
+ namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12
+
+ x5 = [ 42, 53 ]
+
+ x12(1)%c1 = 37001
+ x12(2)%c1 = 37002
+ x12(1)%c2 = [47001,47002,47003]
+ x12(2)%c2 = [47011,47012,47013]
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml2)
+
+ ! RESET NAMELIST
+ x1 = [-1,-1]
+ x1p = [-1, -1]
+ x2 = -1
+ x2p = -1
+ x3 = -1
+ x4 = [-1, -1, -1]
+
+ x6%c1 = -1
+ x6%c2 = [-1,-1,-1]
+ x7(1)%c1 = -1
+ x7(2)%c1 = -1
+ x7(1)%c2 = [-1,-1,-1]
+ x7(2)%c2 = [-1,-1,-1]
+
+ x8%c1 = -1
+ x8%c2 = [-1,-1,-1]
+ x9(1)%c1 = -1
+ x9(2)%c1 = -1
+ x9(1)%c2 = [-1,-1,-1]
+ x9(2)%c2 = [-1,-1,-1]
+
+ x10%c1 = -1
+ x10%c2 = [-1,-1,-1]
+ x11(1)%c1 = -1
+ x11(2)%c1 = -1
+ x11(1)%c2 = [-1,-1,-1]
+ x11(2)%c2 = [-1,-1,-1]
+
+ x5 = [ -1, -1 ]
+
+ x12(1)%c1 = -1
+ x12(2)%c1 = -1
+ x12(1)%c2 = [-1,-1,-1]
+ x12(2)%c2 = [-1,-1,-1]
+
+ ! Read back
+ read(str,nml=nml2)
+
+ ! Check result
+ if (any (x1 /= [1,2])) call abort()
+ if (any (x1p /= [98, 99])) call abort()
+ if (x2 /= 7) call abort()
+ if (x2p /= 101) call abort()
+ if (x3 /= 8) call abort()
+ if (any (x4 /= [-1, -2, -3])) call abort()
+
+ if (x6%c1 /= -701) call abort()
+ if (any (x6%c2 /= [-702,-703,-704])) call abort()
+ if (x7(1)%c1 /= 33001) call abort()
+ if (x7(2)%c1 /= 33002) call abort()
+ if (any (x7(1)%c2 /= [44001,44002,44003])) call abort()
+ if (any (x7(2)%c2 /= [44011,44012,44013])) call abort()
+
+ if (x8%c1 /= -601) call abort()
+ if (any(x8%c2 /= [-602,6703,-604])) call abort()
+ if (x9(1)%c1 /= 35001) call abort()
+ if (x9(2)%c1 /= 35002) call abort()
+ if (any (x9(1)%c2 /= [45001,45002,45003])) call abort()
+ if (any (x9(2)%c2 /= [45011,45012,45013])) call abort()
+
+ if (x10%c1 /= -501) call abort()
+ if (any (x10%c2 /= [-502,-503,-504])) call abort()
+ if (x11(1)%c1 /= 36001) call abort()
+ if (x11(2)%c1 /= 36002) call abort()
+ if (any (x11(1)%c2 /= [46001,46002,46003])) call abort()
+ if (any (x11(2)%c2 /= [46011,46012,46013])) call abort()
+
+ if (any (x5 /= [ 42, 53 ])) call abort()
+
+ if (x12(1)%c1 /= 37001) call abort()
+ if (x12(2)%c1 /= 37002) call abort()
+ if (any (x12(1)%c2 /= [47001,47002,47003])) call abort()
+ if (any (x12(2)%c2 /= [47011,47012,47013])) call abort()
+ end subroutine test2
+end program nml_test
@@ -0,0 +1,451 @@
+! { dg-do run }
+!
+! PR fortran/47339
+! PR fortran/43062
+!
+! Run-time test for Fortran 2003 NAMELISTS
+! Version for non-strings
+!
+program nml_test
+ implicit none
+
+ character(len=1000) :: str
+
+ character(len=5), allocatable :: a(:)
+ character(len=5), allocatable :: b
+ character(len=5), pointer :: ap(:)
+ character(len=5), pointer :: bp
+ character(len=5) :: c
+ character(len=5) :: d(3)
+
+ type t
+ character(len=5) :: c1
+ character(len=5) :: c2(3)
+ end type t
+ type(t) :: e,f(2)
+ type(t),allocatable :: g,h(:)
+ type(t),pointer :: i,j(:)
+
+ namelist /nml/ a, b, c, d, ap, bp,e,f,g,h,i,j
+
+ a = ["aa01", "aa02"]
+ allocate(b,ap(2),bp)
+ ap = ['98', '99']
+ b = '7'
+ bp = '101'
+ c = '8'
+ d = ['-1', '-2', '-3']
+
+ e%c1 = '-701'
+ e%c2 = ['-702','-703','-704']
+ f(1)%c1 = '33001'
+ f(2)%c1 = '33002'
+ f(1)%c2 = ['44001','44002','44003']
+ f(2)%c2 = ['44011','44012','44013']
+
+ allocate(g,h(2),i,j(2))
+
+ g%c1 = '-601'
+ g%c2 = ['-602','6703','-604']
+ h(1)%c1 = '35001'
+ h(2)%c1 = '35002'
+ h(1)%c2 = ['45001','45002','45003']
+ h(2)%c2 = ['45011','45012','45013']
+
+ i%c1 = '-501'
+ i%c2 = ['-502','-503','-504']
+ j(1)%c1 = '36001'
+ j(2)%c1 = '36002'
+ j(1)%c2 = ['46001','46002','46003']
+ j(2)%c2 = ['46011','46012','46013']
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml)
+
+ ! RESET NAMELIST
+ a = repeat('X', len(a))
+ ap = repeat('X', len(ap))
+ b = repeat('X', len(b))
+ bp = repeat('X', len(bp))
+ c = repeat('X', len(c))
+ d = repeat('X', len(d))
+
+ e%c1 = repeat('X', len(e%c1))
+ e%c2 = repeat('X', len(e%c2))
+ f(1)%c1 = repeat('X', len(f(1)%c1))
+ f(2)%c1 = repeat('X', len(f(2)%c1))
+ f(1)%c2 = repeat('X', len(f(1)%c2))
+ f(2)%c2 = repeat('X', len(f(2)%c2))
+
+ g%c1 = repeat('X', len(g%c1))
+ g%c2 = repeat('X', len(g%c1))
+ h(1)%c1 = repeat('X', len(h(1)%c1))
+ h(2)%c1 = repeat('X', len(h(1)%c1))
+ h(1)%c2 = repeat('X', len(h(1)%c1))
+ h(2)%c2 = repeat('X', len(h(1)%c1))
+
+ i%c1 = repeat('X', len(i%c1))
+ i%c2 = repeat('X', len(i%c1))
+ j(1)%c1 = repeat('X', len(j(1)%c1))
+ j(2)%c1 = repeat('X', len(j(2)%c1))
+ j(1)%c2 = repeat('X', len(j(1)%c2))
+ j(2)%c2 = repeat('X', len(j(2)%c2))
+
+ ! Read back
+ read(str,nml=nml)
+
+ ! Check result
+ if (any (a /= ['aa01','aa02'])) call abort()
+ if (any (ap /= ['98', '99'])) call abort()
+ if (b /= '7') call abort()
+ if (bp /= '101') call abort()
+ if (c /= '8') call abort()
+ if (any (d /= ['-1', '-2', '-3'])) call abort()
+
+ if (e%c1 /= '-701') call abort()
+ if (any (e%c2 /= ['-702','-703','-704'])) call abort()
+ if (f(1)%c1 /= '33001') call abort()
+ if (f(2)%c1 /= '33002') call abort()
+ if (any (f(1)%c2 /= ['44001','44002','44003'])) call abort()
+ if (any (f(2)%c2 /= ['44011','44012','44013'])) call abort()
+
+ if (g%c1 /= '-601') call abort()
+ if (any(g%c2 /= ['-602','6703','-604'])) call abort()
+ if (h(1)%c1 /= '35001') call abort()
+ if (h(2)%c1 /= '35002') call abort()
+ if (any (h(1)%c2 /= ['45001','45002','45003'])) call abort()
+ if (any (h(2)%c2 /= ['45011','45012','45013'])) call abort()
+
+ if (i%c1 /= '-501') call abort()
+ if (any (i%c2 /= ['-502','-503','-504'])) call abort()
+ if (j(1)%c1 /= '36001') call abort()
+ if (j(2)%c1 /= '36002') call abort()
+ if (any (j(1)%c2 /= ['46001','46002','46003'])) call abort()
+ if (any (j(2)%c2 /= ['46011','46012','46013'])) call abort()
+
+ ! Check argument passing (dummy processing)
+ call test2(a,b,c,d,ap,bp,e,f,g,h,i,j,2)
+! FIXME: b excluded because of PR 47421.
+! call test3(a,b,c,d,ap,bp,e,f,g,h,i,j,2,len(a))
+ call test3(a, c,d,ap,bp,e,f,g,h,i,j,2,len(a))
+ call test4(a,b,c,d,ap,bp,e,f,g,h,i,j,2)
+
+contains
+ subroutine test2(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n)
+ character(len=5), allocatable :: x1(:)
+ character(len=5), allocatable :: x2
+ character(len=5), pointer :: x1p(:)
+ character(len=5), pointer :: x2p
+ character(len=5) :: x3
+ character(len=5) :: x4(3)
+ integer :: n
+ character(len=5) :: x5(n)
+ type(t) :: x6,x7(2)
+ type(t),allocatable :: x8,x9(:)
+ type(t),pointer :: x10,x11(:)
+ type(t) :: x12(n)
+
+ namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12
+
+ x5 = [ 'x5-42', 'x5-53' ]
+
+ x12(1)%c1 = '37001'
+ x12(2)%c1 = '37002'
+ x12(1)%c2 = ['47001','47002','47003']
+ x12(2)%c2 = ['47011','47012','47013']
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml2)
+
+ ! RESET NAMELIST
+ x1 = repeat('X', len(x1))
+ x1p = repeat('X', len(x1p))
+ x2 = repeat('X', len(x2))
+ x2p = repeat('X', len(x2p))
+ x3 = repeat('X', len(x3))
+ x4 = repeat('X', len(x4))
+
+ x6%c1 = repeat('X', len(x6%c1))
+ x6%c2 = repeat('X', len(x6%c2))
+ x7(1)%c1 = repeat('X', len(x7(1)%c1))
+ x7(2)%c1 = repeat('X', len(x7(2)%c1))
+ x7(1)%c2 = repeat('X', len(x7(1)%c2))
+ x7(2)%c2 = repeat('X', len(x7(2)%c2))
+
+ x8%c1 = repeat('X', len(x8%c1))
+ x8%c2 = repeat('X', len(x8%c1))
+ x9(1)%c1 = repeat('X', len(x9(1)%c1))
+ x9(2)%c1 = repeat('X', len(x9(1)%c1))
+ x9(1)%c2 = repeat('X', len(x9(1)%c1))
+ x9(2)%c2 = repeat('X', len(x9(1)%c1))
+
+ x10%c1 = repeat('X', len(x10%c1))
+ x10%c2 = repeat('X', len(x10%c1))
+ x11(1)%c1 = repeat('X', len(x11(1)%c1))
+ x11(2)%c1 = repeat('X', len(x11(2)%c1))
+ x11(1)%c2 = repeat('X', len(x11(1)%c2))
+ x11(2)%c2 = repeat('X', len(x11(2)%c2))
+
+ x5 = repeat('X', len(x5))
+
+ x12(1)%c1 = repeat('X', len(x12(2)%c2))
+ x12(2)%c1 = repeat('X', len(x12(2)%c2))
+ x12(1)%c2 = repeat('X', len(x12(2)%c2))
+ x12(2)%c2 = repeat('X', len(x12(2)%c2))
+
+ ! Read back
+ read(str,nml=nml2)
+
+ ! Check result
+ if (any (x1 /= ['aa01','aa02'])) call abort()
+ if (any (x1p /= ['98', '99'])) call abort()
+ if (x2 /= '7') call abort()
+ if (x2p /= '101') call abort()
+ if (x3 /= '8') call abort()
+ if (any (x4 /= ['-1', '-2', '-3'])) call abort()
+
+ if (x6%c1 /= '-701') call abort()
+ if (any (x6%c2 /= ['-702','-703','-704'])) call abort()
+ if (x7(1)%c1 /= '33001') call abort()
+ if (x7(2)%c1 /= '33002') call abort()
+ if (any (x7(1)%c2 /= ['44001','44002','44003'])) call abort()
+ if (any (x7(2)%c2 /= ['44011','44012','44013'])) call abort()
+
+ if (x8%c1 /= '-601') call abort()
+ if (any(x8%c2 /= ['-602','6703','-604'])) call abort()
+ if (x9(1)%c1 /= '35001') call abort()
+ if (x9(2)%c1 /= '35002') call abort()
+ if (any (x9(1)%c2 /= ['45001','45002','45003'])) call abort()
+ if (any (x9(2)%c2 /= ['45011','45012','45013'])) call abort()
+
+ if (x10%c1 /= '-501') call abort()
+ if (any (x10%c2 /= ['-502','-503','-504'])) call abort()
+ if (x11(1)%c1 /= '36001') call abort()
+ if (x11(2)%c1 /= '36002') call abort()
+ if (any (x11(1)%c2 /= ['46001','46002','46003'])) call abort()
+ if (any (x11(2)%c2 /= ['46011','46012','46013'])) call abort()
+
+ if (any (x5 /= [ 'x5-42', 'x5-53' ])) call abort()
+
+ if (x12(1)%c1 /= '37001') call abort()
+ if (x12(2)%c1 /= '37002') call abort()
+ if (any (x12(1)%c2 /= ['47001','47002','47003'])) call abort()
+ if (any (x12(2)%c2 /= ['47011','47012','47013'])) call abort()
+ end subroutine test2
+
+! FIXME: x2 excluded because of PR 47421.
+! subroutine test3(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n,ll)
+ subroutine test3(x1, x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n,ll)
+ integer :: n, ll
+ character(len=ll), allocatable :: x1(:)
+! FIXME: x2 excluded because of PR 47421.
+! character(len=ll), allocatable :: x2
+ character(len=ll), pointer :: x1p(:)
+ character(len=ll), pointer :: x2p
+ character(len=ll) :: x3
+ character(len=ll) :: x4(3)
+ character(len=ll) :: x5(n)
+ type(t) :: x6,x7(2)
+ type(t),allocatable :: x8,x9(:)
+ type(t),pointer :: x10,x11(:)
+ type(t) :: x12(n)
+
+! FIXME: x2 excluded because of PR 47421.
+! namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12
+ namelist /nml2/ x1, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12
+
+ x5 = [ 'x5-42', 'x5-53' ]
+
+ x12(1)%c1 = '37001'
+ x12(2)%c1 = '37002'
+ x12(1)%c2 = ['47001','47002','47003']
+ x12(2)%c2 = ['47011','47012','47013']
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml2)
+
+ ! RESET NAMELIST
+ x1 = repeat('X', len(x1))
+ x1p = repeat('X', len(x1p))
+
+! FIXME: x2 excluded because of PR 47421.
+! x2 = repeat('X', len(x2))
+ x2p = repeat('X', len(x2p))
+ x3 = repeat('X', len(x3))
+ x4 = repeat('X', len(x4))
+
+ x6%c1 = repeat('X', len(x6%c1))
+ x6%c2 = repeat('X', len(x6%c2))
+ x7(1)%c1 = repeat('X', len(x7(1)%c1))
+ x7(2)%c1 = repeat('X', len(x7(2)%c1))
+ x7(1)%c2 = repeat('X', len(x7(1)%c2))
+ x7(2)%c2 = repeat('X', len(x7(2)%c2))
+
+ x8%c1 = repeat('X', len(x8%c1))
+ x8%c2 = repeat('X', len(x8%c1))
+ x9(1)%c1 = repeat('X', len(x9(1)%c1))
+ x9(2)%c1 = repeat('X', len(x9(1)%c1))
+ x9(1)%c2 = repeat('X', len(x9(1)%c1))
+ x9(2)%c2 = repeat('X', len(x9(1)%c1))
+
+ x10%c1 = repeat('X', len(x10%c1))
+ x10%c2 = repeat('X', len(x10%c1))
+ x11(1)%c1 = repeat('X', len(x11(1)%c1))
+ x11(2)%c1 = repeat('X', len(x11(2)%c1))
+ x11(1)%c2 = repeat('X', len(x11(1)%c2))
+ x11(2)%c2 = repeat('X', len(x11(2)%c2))
+
+ x5 = repeat('X', len(x5))
+
+ x12(1)%c1 = repeat('X', len(x12(2)%c2))
+ x12(2)%c1 = repeat('X', len(x12(2)%c2))
+ x12(1)%c2 = repeat('X', len(x12(2)%c2))
+ x12(2)%c2 = repeat('X', len(x12(2)%c2))
+
+ ! Read back
+ read(str,nml=nml2)
+
+ ! Check result
+ if (any (x1 /= ['aa01','aa02'])) call abort()
+ if (any (x1p /= ['98', '99'])) call abort()
+! FIXME: x2 excluded because of PR 47421.
+! if (x2 /= '7') call abort()
+ if (x2p /= '101') call abort()
+ if (x3 /= '8') call abort()
+ if (any (x4 /= ['-1', '-2', '-3'])) call abort()
+
+ if (x6%c1 /= '-701') call abort()
+ if (any (x6%c2 /= ['-702','-703','-704'])) call abort()
+ if (x7(1)%c1 /= '33001') call abort()
+ if (x7(2)%c1 /= '33002') call abort()
+ if (any (x7(1)%c2 /= ['44001','44002','44003'])) call abort()
+ if (any (x7(2)%c2 /= ['44011','44012','44013'])) call abort()
+
+ if (x8%c1 /= '-601') call abort()
+ if (any(x8%c2 /= ['-602','6703','-604'])) call abort()
+ if (x9(1)%c1 /= '35001') call abort()
+ if (x9(2)%c1 /= '35002') call abort()
+ if (any (x9(1)%c2 /= ['45001','45002','45003'])) call abort()
+ if (any (x9(2)%c2 /= ['45011','45012','45013'])) call abort()
+
+ if (x10%c1 /= '-501') call abort()
+ if (any (x10%c2 /= ['-502','-503','-504'])) call abort()
+ if (x11(1)%c1 /= '36001') call abort()
+ if (x11(2)%c1 /= '36002') call abort()
+ if (any (x11(1)%c2 /= ['46001','46002','46003'])) call abort()
+ if (any (x11(2)%c2 /= ['46011','46012','46013'])) call abort()
+
+ if (any (x5 /= [ 'x5-42', 'x5-53' ])) call abort()
+
+ if (x12(1)%c1 /= '37001') call abort()
+ if (x12(2)%c1 /= '37002') call abort()
+ if (any (x12(1)%c2 /= ['47001','47002','47003'])) call abort()
+ if (any (x12(2)%c2 /= ['47011','47012','47013'])) call abort()
+ end subroutine test3
+
+ subroutine test4(x1,x2,x3,x4,x1p,x2p,x6,x7,x8,x9,x10,x11,n)
+ character(len=*), allocatable :: x1(:)
+ character(len=*), allocatable :: x2
+ character(len=*), pointer :: x1p(:)
+ character(len=*), pointer :: x2p
+ character(len=*) :: x3
+ character(len=*) :: x4(3)
+ integer :: n
+ character(len=5) :: x5(n)
+ type(t) :: x6,x7(2)
+ type(t),allocatable :: x8,x9(:)
+ type(t),pointer :: x10,x11(:)
+ type(t) :: x12(n)
+
+ namelist /nml2/ x1, x2, x3, x4,x5,x1p,x2p,x6,x7,x8,x9,x10,x11,x12
+
+ x5 = [ 'x5-42', 'x5-53' ]
+
+ x12(1)%c1 = '37001'
+ x12(2)%c1 = '37002'
+ x12(1)%c2 = ['47001','47002','47003']
+ x12(2)%c2 = ['47011','47012','47013']
+
+ ! SAVE NAMELIST
+ str = repeat('X', len(str))
+ write(str,nml=nml2)
+
+ ! RESET NAMELIST
+ x1 = repeat('X', len(x1))
+ x1p = repeat('X', len(x1p))
+ x2 = repeat('X', len(x2))
+ x2p = repeat('X', len(x2p))
+ x3 = repeat('X', len(x3))
+ x4 = repeat('X', len(x4))
+
+ x6%c1 = repeat('X', len(x6%c1))
+ x6%c2 = repeat('X', len(x6%c2))
+ x7(1)%c1 = repeat('X', len(x7(1)%c1))
+ x7(2)%c1 = repeat('X', len(x7(2)%c1))
+ x7(1)%c2 = repeat('X', len(x7(1)%c2))
+ x7(2)%c2 = repeat('X', len(x7(2)%c2))
+
+ x8%c1 = repeat('X', len(x8%c1))
+ x8%c2 = repeat('X', len(x8%c1))
+ x9(1)%c1 = repeat('X', len(x9(1)%c1))
+ x9(2)%c1 = repeat('X', len(x9(1)%c1))
+ x9(1)%c2 = repeat('X', len(x9(1)%c1))
+ x9(2)%c2 = repeat('X', len(x9(1)%c1))
+
+ x10%c1 = repeat('X', len(x10%c1))
+ x10%c2 = repeat('X', len(x10%c1))
+ x11(1)%c1 = repeat('X', len(x11(1)%c1))
+ x11(2)%c1 = repeat('X', len(x11(2)%c1))
+ x11(1)%c2 = repeat('X', len(x11(1)%c2))
+ x11(2)%c2 = repeat('X', len(x11(2)%c2))
+
+ x5 = repeat('X', len(x5))
+
+ x12(1)%c1 = repeat('X', len(x12(2)%c2))
+ x12(2)%c1 = repeat('X', len(x12(2)%c2))
+ x12(1)%c2 = repeat('X', len(x12(2)%c2))
+ x12(2)%c2 = repeat('X', len(x12(2)%c2))
+
+ ! Read back
+ read(str,nml=nml2)
+
+ ! Check result
+ if (any (x1 /= ['aa01','aa02'])) call abort()
+ if (any (x1p /= ['98', '99'])) call abort()
+ if (x2 /= '7') call abort()
+ if (x2p /= '101') call abort()
+ if (x3 /= '8') call abort()
+ if (any (x4 /= ['-1', '-2', '-3'])) call abort()
+
+ if (x6%c1 /= '-701') call abort()
+ if (any (x6%c2 /= ['-702','-703','-704'])) call abort()
+ if (x7(1)%c1 /= '33001') call abort()
+ if (x7(2)%c1 /= '33002') call abort()
+ if (any (x7(1)%c2 /= ['44001','44002','44003'])) call abort()
+ if (any (x7(2)%c2 /= ['44011','44012','44013'])) call abort()
+
+ if (x8%c1 /= '-601') call abort()
+ if (any(x8%c2 /= ['-602','6703','-604'])) call abort()
+ if (x9(1)%c1 /= '35001') call abort()
+ if (x9(2)%c1 /= '35002') call abort()
+ if (any (x9(1)%c2 /= ['45001','45002','45003'])) call abort()
+ if (any (x9(2)%c2 /= ['45011','45012','45013'])) call abort()
+
+ if (x10%c1 /= '-501') call abort()
+ if (any (x10%c2 /= ['-502','-503','-504'])) call abort()
+ if (x11(1)%c1 /= '36001') call abort()
+ if (x11(2)%c1 /= '36002') call abort()
+ if (any (x11(1)%c2 /= ['46001','46002','46003'])) call abort()
+ if (any (x11(2)%c2 /= ['46011','46012','46013'])) call abort()
+
+ if (any (x5 /= [ 'x5-42', 'x5-53' ])) call abort()
+
+ if (x12(1)%c1 /= '37001') call abort()
+ if (x12(2)%c1 /= '37002') call abort()
+ if (any (x12(1)%c2 /= ['47001','47002','47003'])) call abort()
+ if (any (x12(2)%c2 /= ['47011','47012','47013'])) call abort()
+ end subroutine test4
+end program nml_test