procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2015-09-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40054
	PR fortran/63921
	* decl.c (get_proc_name): Return if statement function is
	found.
	* expr.c (gfc_check_vardef_context): Add error return for
	derived type expression lacking the derived type itself.
	* match.c (gfc_match_ptr_fcn_assign): New function.
	* match.h : Add prototype for gfc_match_ptr_fcn_assign.
	* parse.c : Add static flag 'in_specification_block'.
	(decode_statement): If in specification block match a statement
	function, then, if no error arising from statement function
	matching, try to match pointer function assignment.
	(parse_interface): Set 'in_specification_block' on exiting from
	parse_spec.
	(parse_spec): Set and then reset 'in_specification_block'.
	(gfc_parse_file): Set 'in_specification_block'.
	* resolve.c (get_temp_from_expr): Extend to include functions
	and array constructors as rvalues..
	(resolve_ptr_fcn_assign): New function.
	(gfc_resolve_code): Call it on finding a pointer function as an
	lvalue. If valid or on error, go back to start of resolve_code.
	* symbol.c (gfc_add_procedure): Add a sentence to the error to
	flag up the ambiguity between a statement function and pointer
	function assignment at the end of the specification block.

2015-09-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40054
	PR fortran/63921
	* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
	standard as legacy.
	* gfortran.dg/fmt_tab_2.f90: Add extra tab error.
	* gfortran.dg/function_types_3.f90: Change error message to
	"Type inaccessible...."
	* gfortran.dg/ptr_func_assign_1.f08: New test.
	* gfortran.dg/ptr_func_assign_2.f08: New test.

2015-09-25  Mikael Morin  <mikael.morin@sfr.fr>

	PR fortran/40054
	PR fortran/63921
	* gfortran.dg/ptr_func_assign_3.f08: New test.
	* gfortran.dg/ptr_func_assign_4.f08: New test.

From-SVN: r228222
This commit is contained in:
Paul Thomas 2015-09-28 21:18:38 +00:00
parent 3e32ee19a5
commit 79124116d6
16 changed files with 566 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
gcc/fortran/ChangeLog
View file

@ -1,3 +1,30 @@
2015-09-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/40054
PR fortran/63921
* decl.c (get_proc_name): Return if statement function is
found.
* expr.c (gfc_check_vardef_context): Add error return for
derived type expression lacking the derived type itself.
* match.c (gfc_match_ptr_fcn_assign): New function.
* match.h : Add prototype for gfc_match_ptr_fcn_assign.
* parse.c : Add static flag 'in_specification_block'.
(decode_statement): If in specification block match a statement
function, then, if no error arising from statement function
matching, try to match pointer function assignment.
(parse_interface): Set 'in_specification_block' on exiting from
parse_spec.
(parse_spec): Set and then reset 'in_specification_block'.
(gfc_parse_file): Set 'in_specification_block'.
* resolve.c (get_temp_from_expr): Extend to include functions
and array constructors as rvalues..
(resolve_ptr_fcn_assign): New function.
(gfc_resolve_code): Call it on finding a pointer function as an
lvalue. If valid or on error, go back to start of resolve_code.
* symbol.c (gfc_add_procedure): Add a sentence to the error to
flag up the ambiguity between a statement function and pointer
function assignment at the end of the specification block.
2015-09-28 Nathan Sidwell <nathan@codesourcery.com>
* f95-lang.c (DEF_FUNCTION_TYPE_VAR_6): New.

2
gcc/fortran/decl.c
View file

@ -901,6 +901,8 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
return rc;
sym = *result;
if (sym->attr.proc == PROC_ST_FUNCTION)
return rc;
if (sym->attr.module_procedure
&& sym->attr.if_source == IFSRC_IFBODY)

9
gcc/fortran/expr.c
View file

@ -4822,6 +4822,15 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
return false;
}
if (e->ts.type == BT_DERIVED
&& e->ts.u.derived == NULL)
{
if (context)
gfc_error ("Type inaccessible in variable definition context (%s) "
"at %L", context, &e->where);
return false;
}
/* F2008, C1303. */
if (!alloc_obj
&& (attr.lock_comp

61
gcc/fortran/match.c
View file

@ -4886,7 +4886,6 @@ match
gfc_match_st_function (void)
{
gfc_error_buffer old_error;
gfc_symbol *sym;
gfc_expr *expr;
match m;
@ -4931,6 +4930,66 @@ undo_error:
}
/* Match an assignment to a pointer function (F2008). This could, in
general be ambiguous with a statement function. In this implementation
it remains so if it is the first statement after the specification
block. */
match
gfc_match_ptr_fcn_assign (void)
{
gfc_error_buffer old_error;
locus old_loc;
gfc_symbol *sym;
gfc_expr *expr;
match m;
char name[GFC_MAX_SYMBOL_LEN + 1];
old_loc = gfc_current_locus;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
gfc_find_symbol (name, NULL, 1, &sym);
if (sym && sym->attr.flavor != FL_PROCEDURE)
return MATCH_NO;
gfc_push_error (&old_error);
if (sym && sym->attr.function)
goto match_actual_arglist;
gfc_current_locus = old_loc;
m = gfc_match_symbol (&sym, 0);
if (m != MATCH_YES)
return m;
if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
goto undo_error;
match_actual_arglist:
gfc_current_locus = old_loc;
m = gfc_match (" %e", &expr);
if (m != MATCH_YES)
goto undo_error;
new_st.op = EXEC_ASSIGN;
new_st.expr1 = expr;
expr = NULL;
m = gfc_match (" = %e%t", &expr);
if (m != MATCH_YES)
goto undo_error;
new_st.expr2 = expr;
return MATCH_YES;
undo_error:
gfc_pop_error (&old_error);
return MATCH_NO;
}
/***************** SELECT CASE subroutines ******************/
/* Free a single case structure. */

1
gcc/fortran/match.h
View file

@ -107,6 +107,7 @@ match gfc_match_namelist (void);
match gfc_match_module (void);
match gfc_match_equivalence (void);
match gfc_match_st_function (void);
match gfc_match_ptr_fcn_assign (void);
match gfc_match_case (void);
match gfc_match_select (void);
match gfc_match_select_type (void);

74
gcc/fortran/parse.c
View file

@ -141,7 +141,7 @@ use_modules (void)
for the specification statements in a function, whose
characteristics are deferred into the specification statements.
eg.: INTEGER (king = mykind) foo ()
USE mymodule, ONLY mykind.....
USE mymodule, ONLY mykind.....
The KIND parameter needs a return after USE or IMPORT, whereas
derived type declarations can occur anywhere, up the executable
block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
@ -287,6 +287,7 @@ end_of_block:
return ST_GET_FCN_CHARACTERISTICS;
}
static bool in_specification_block;
/* This is the primary 'decode_statement'. */
static gfc_statement
@ -344,7 +345,7 @@ decode_statement (void)
return ST_FUNCTION;
else if (m == MATCH_ERROR)
reject_statement ();
else
else
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
@ -356,7 +357,18 @@ decode_statement (void)
match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
if (in_specification_block)
{
m = match_word (NULL, gfc_match_st_function, &old_locus);
if (m == MATCH_YES)
return ST_STATEMENT_FUNCTION;
}
if (!(in_specification_block && m == MATCH_ERROR))
{
match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
}
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
@ -910,7 +922,7 @@ decode_gcc_attribute (void)
/* Assert next length characters to be equal to token in free form. */
static void
static void
verify_token_free (const char* token, int length, bool last_was_use_stmt)
{
int i;
@ -1013,7 +1025,7 @@ next_free (void)
}
else if (c == '$')
{
/* Since both OpenMP and OpenACC directives starts with
/* Since both OpenMP and OpenACC directives starts with
!$ character sequence, we must check all flags combinations */
if ((flag_openmp || flag_openmp_simd)
&& !flag_openacc)
@ -1044,9 +1056,9 @@ next_free (void)
return decode_oacc_directive ();
}
}
gcc_unreachable ();
gcc_unreachable ();
}
if (at_bol && c == ';')
{
if (!(gfc_option.allow_std & GFC_STD_F2008))
@ -1132,7 +1144,7 @@ next_fixed (void)
case '*':
c = gfc_next_char_literal (NONSTRING);
if (TOLOWER (c) == 'g')
{
for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
@ -1246,7 +1258,7 @@ blank_line:
if (digit_flag)
gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
&label_locus);
gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
@ -2168,8 +2180,8 @@ gfc_ascii_statement (gfc_statement st)
/* Create a symbol for the main program and assign it to ns->proc_name. */
static void
static void
main_program_symbol (gfc_namespace *ns, const char *name)
{
gfc_symbol *main_program;
@ -2708,7 +2720,7 @@ endType:
}
seen_sequence = 1;
gfc_add_sequence (&gfc_current_block ()->attr,
gfc_add_sequence (&gfc_current_block ()->attr,
gfc_current_block ()->name, NULL);
break;
@ -2771,7 +2783,7 @@ endType:
coarray = true;
sym->attr.coarray_comp = 1;
}
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
&& !c->attr.pointer)
{
@ -2851,7 +2863,7 @@ endType:
/* Parse an ENUM. */
static void
parse_enum (void)
{
@ -2942,7 +2954,7 @@ loop:
gfc_new_block->attr.pointer = 0;
gfc_new_block->attr.proc_pointer = 1;
}
if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL))
{
reject_statement ();
@ -3008,6 +3020,7 @@ loop:
decl:
/* Read data declaration statements. */
st = parse_spec (ST_NONE);
in_specification_block = true;
/* Since the interface block does not permit an IMPLICIT statement,
the default type for the function or the result must be taken
@ -3139,6 +3152,8 @@ parse_spec (gfc_statement st)
bool bad_characteristic = false;
gfc_typespec *ts;
in_specification_block = true;
verify_st_order (&ss, ST_NONE, false);
if (st == ST_NONE)
st = next_statement ();
@ -3199,14 +3214,14 @@ loop:
case ST_NONE:
break;
default:
gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
gfc_ascii_statement (st));
reject_statement ();
break;
}
/* If we find a statement that can not be followed by an IMPLICIT statement
(and thus we can expect to see none any further), type the function result
if it has not yet been typed. Be careful not to give the END statement
@ -3372,6 +3387,8 @@ declSt:
ts->type = BT_UNKNOWN;
}
in_specification_block = false;
return st;
}
@ -3768,7 +3785,7 @@ done:
context that causes it to become redefined. If the symbol is an
iterator, we generate an error message and return nonzero. */
int
int
gfc_check_do_variable (gfc_symtree *st)
{
gfc_state_data *s;
@ -3783,7 +3800,7 @@ gfc_check_do_variable (gfc_symtree *st)
return 0;
}
/* Checks to see if the current statement label closes an enddo.
Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
@ -3842,7 +3859,7 @@ parse_critical_block (void)
gfc_state_data s, *sd;
gfc_statement st;
for (sd = gfc_state_stack; sd; sd = sd->previous)
for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
gfc_error_now (is_oacc (sd)
? "CRITICAL block inside of OpenACC region at %C"
@ -4356,7 +4373,7 @@ parse_oacc_structured_block (gfc_statement acc_st)
gfc_code *cp, *np;
gfc_state_data s, *sd;
for (sd = gfc_state_stack; sd; sd = sd->previous)
for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_CRITICAL)
gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
@ -4415,7 +4432,7 @@ parse_oacc_loop (gfc_statement acc_st)
gfc_code *cp, *np;
gfc_state_data s, *sd;
for (sd = gfc_state_stack; sd; sd = sd->previous)
for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_CRITICAL)
gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
@ -4971,8 +4988,8 @@ parse_contained (int module)
"ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
sym->name,
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
sym->name,
&gfc_new_block->declared_at))
{
if (st == ST_FUNCTION)
@ -5173,11 +5190,11 @@ contains:
done:
gfc_current_ns->code = gfc_state_stack->head;
if (gfc_state_stack->state == COMP_PROGRAM
|| gfc_state_stack->state == COMP_MODULE
|| gfc_state_stack->state == COMP_SUBROUTINE
|| gfc_state_stack->state == COMP_MODULE
|| gfc_state_stack->state == COMP_SUBROUTINE
|| gfc_state_stack->state == COMP_FUNCTION
|| gfc_state_stack->state == COMP_BLOCK)
gfc_current_ns->oacc_declare_clauses
gfc_current_ns->oacc_declare_clauses
= gfc_state_stack->ext.oacc_declare_clauses;
}
@ -5592,6 +5609,7 @@ gfc_parse_file (void)
if (gfc_at_eof ())
goto done;
in_specification_block = true;
loop:
gfc_init_2 ();
st = next_statement ();
@ -5718,7 +5736,7 @@ prog_units:
/* Do the resolution. */
resolve_all_program_units (gfc_global_ns_list);
/* Do the parse tree dump. */
/* Do the parse tree dump. */
gfc_current_ns
= flag_dump_fortran_original ? gfc_global_ns_list : NULL;

89
gcc/fortran/resolve.c
View file

@ -9735,12 +9735,10 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
ref = NULL;
aref = NULL;
/* This function could be expanded to support other expression type
but this is not needed here. */
gcc_assert (e->expr_type == EXPR_VARIABLE);
/* Obtain the arrayspec for the temporary. */
if (e->rank)
if (e->rank && e->expr_type != EXPR_ARRAY
&& e->expr_type != EXPR_FUNCTION
&& e->expr_type != EXPR_OP)
{
aref = gfc_find_array_ref (e);
if (e->expr_type == EXPR_VARIABLE
@ -9772,6 +9770,16 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
if (as->type == AS_DEFERRED)
tmp->n.sym->attr.allocatable = 1;
}
else if (e->rank && (e->expr_type == EXPR_ARRAY
|| e->expr_type == EXPR_FUNCTION
|| e->expr_type == EXPR_OP))
{
tmp->n.sym->as = gfc_get_array_spec ();
tmp->n.sym->as->type = AS_DEFERRED;
tmp->n.sym->as->rank = e->rank;
tmp->n.sym->attr.allocatable = 1;
tmp->n.sym->attr.dimension = 1;
}
else
tmp->n.sym->attr.dimension = 0;
@ -10133,6 +10141,66 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
}
/* F2008: Pointer function assignments are of the form:
ptr_fcn (args) = expr
This function breaks these assignments into two statements:
temporary_pointer => ptr_fcn(args)
temporary_pointer = expr */
static bool
resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
{
gfc_expr *tmp_ptr_expr;
gfc_code *this_code;
gfc_component *comp;
gfc_symbol *s;
if ((*code)->expr1->expr_type != EXPR_FUNCTION)
return false;
/* Even if standard does not support this feature, continue to build
the two statements to avoid upsetting frontend_passes.c. */
gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at "
"%L", &(*code)->loc);
comp = gfc_get_proc_ptr_comp ((*code)->expr1);
if (comp)
s = comp->ts.interface;
else
s = (*code)->expr1->symtree->n.sym;
if (s == NULL || !s->result->attr.pointer)
{
gfc_error ("The function result on the lhs of the assignment at "
"%L must have the pointer attribute.",
&(*code)->expr1->where);
(*code)->op = EXEC_NOP;
return false;
}
tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns);
/* get_temp_from_expression is set up for ordinary assignments. To that
end, where array bounds are not known, arrays are made allocatable.
Change the temporary to a pointer here. */
tmp_ptr_expr->symtree->n.sym->attr.pointer = 1;
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
this_code->next = (*code)->next;
(*code)->next = this_code;
(*code)->op = EXEC_POINTER_ASSIGN;
(*code)->expr2 = (*code)->expr1;
(*code)->expr1 = tmp_ptr_expr;
return true;
}
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
@ -10228,7 +10296,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
if (omp_workshare_save != -1)
omp_workshare_flag = omp_workshare_save;
}
start:
t = true;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
@ -10318,6 +10386,14 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
/* If this is a pointer function in an lvalue variable context,
the new code will have to be resolved afresh. This is also the
case with an error, where the code is transformed into NOP to
prevent ICEs downstream. */
if (resolve_ptr_fcn_assign (&code, ns)
|| code->op == EXEC_NOP)
goto start;
if (!gfc_check_vardef_context (code->expr1, false, false, false,
_("assignment")))
break;
@ -10332,6 +10408,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
&& code->expr1->ts.u.derived
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);

12
gcc/fortran/symbol.c
View file

@ -1541,9 +1541,19 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
{
gfc_error ("%s procedure at %L is already declared as %s procedure",
if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
&& !gfc_notification_std (GFC_STD_F2008))
gfc_error ("%s procedure at %L is already declared as %s "
"procedure. \nF2008: A pointer function assignment "
"is ambiguous if it is the first executable statement "
"after the specification block. Please add any other "
"kind of executable statement before it. FIXME",
gfc_code2string (procedures, t), where,
gfc_code2string (procedures, attr->proc));
else
gfc_error ("%s procedure at %L is already declared as %s "
"procedure", gfc_code2string (procedures, t), where,
gfc_code2string (procedures, attr->proc));
return false;
}

19
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,22 @@
2015-09-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/40054
PR fortran/63921
* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
standard as legacy.
* gfortran.dg/fmt_tab_2.f90: Add extra tab error.
* gfortran.dg/function_types_3.f90: Change error message to
"Type inaccessible...."
* gfortran.dg/ptr_func_assign_1.f08: New test.
* gfortran.dg/ptr_func_assign_2.f08: New test.
2015-09-25 Mikael Morin <mikael.morin@sfr.fr>
PR fortran/40054
PR fortran/63921
* gfortran.dg/ptr_func_assign_3.f08: New test.
* gfortran.dg/ptr_func_assign_4.f08: New test.
2015-09-28 Aditya Kumar <aditya.k7@samsung.com>
Sebastian Pop <s.pop@samsung.com>

3
gcc/testsuite/gfortran.dg/fmt_tab_1.f90
View file

@ -1,4 +1,5 @@
! { dg-do run }
! { dg-do compile }
! { dg-options -Wno-error=tabs }
! PR fortran/32987
program TestFormat
write (*, 10)

2
gcc/testsuite/gfortran.dg/fmt_tab_2.f90
View file

@ -3,5 +3,5 @@
! PR fortran/32987
program TestFormat
write (*, 10) ! { dg-error "FORMAT label 10 at .1. not defined" }
10 format ('Hello ', 'bug!') ! { dg-error "Extension: Tab character in format" }
10 format ('Hello ', 'bug!') ! { dg-error "Extension: Tab character in format|Nonconforming tab character" }
end

2
gcc/testsuite/gfortran.dg/function_types_3.f90
View file

@ -15,5 +15,5 @@ end
! PR 50403: SIGSEGV in gfc_use_derived
type(f) function f() ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" }
f=110 ! { dg-error "Unclassifiable statement" }
f=110 ! { dg-error "Type inaccessible in variable definition context" }
end

112
gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 Normal file
View file

@ -0,0 +1,112 @@
! { dg-do run }
!
! Tests implementation of F2008 feature: pointer function assignments.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module fcn_bar
contains
function bar (arg, idx) result (res)
integer, pointer :: res
integer, target :: arg(:)
integer :: idx
res => arg (idx)
res = 99
end function
end module
module fcn_mydt
type mydt
integer, allocatable, dimension (:) :: i
contains
procedure, pass :: create
procedure, pass :: delete
procedure, pass :: fill
procedure, pass :: elem_fill
end type
contains
subroutine create (this, sz)
class(mydt) :: this
integer :: sz
if (allocated (this%i)) deallocate (this%i)
allocate (this%i(sz))
this%i = 0
end subroutine
subroutine delete (this)
class(mydt) :: this
if (allocated (this%i)) deallocate (this%i)
end subroutine
function fill (this, idx) result (res)
integer, pointer :: res(:)
integer :: lb, ub
class(mydt), target :: this
integer :: idx
lb = idx
ub = lb + size(this%i) - 1
res => this%i(lb:ub)
end function
function elem_fill (this, idx) result (res)
integer, pointer :: res
class(mydt), target :: this
integer :: idx
res => this%i(idx)
end function
end module
use fcn_bar
use fcn_mydt
integer, target :: a(3) = [1,2,3]
integer, pointer :: b
integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
type(mydt) :: dt
foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
if (any (a .ne. [1,2,3])) call abort
! Assignment to pointer result is after procedure call.
foo (a) = 77
! Assignment within procedure applies.
b => foo (a)
if (b .ne. 99) call abort
! Use of index for assignment.
bar (a, 2) = 99
if (any (a .ne. [99,99,3])) call abort
! Make sure that statement function still works!
if (foobar (10) .ne. 100) call abort
bar (a, 3) = foobar (9)
if (any (a .ne. [99,99,81])) call abort
! Try typebound procedure
call dt%create (6)
dt%elem_fill (3) = 42
if (dt%i(3) .ne. 42) call abort
dt%elem_fill (3) = 42 + dt%elem_fill (3) ! PR63921 style assignment
if (dt%i(3) .ne. 84) call abort
dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)
if (dt%i(3) .ne. 0) call abort
! Array is now reset
dt%fill (3) = ifill ! Check with array variable rhs
dt%fill (1) = [2,1] ! Check with array constructor rhs
if (any (dt%i .ne. [2,1,ifill])) call abort
dt%fill (1) = footoo (size (dt%i, 1)) ! Check with array function rhs
if (any (dt%i .ne. [6,5,4,3,2,1])) call abort
dt%fill (3) = ifill + dt%fill (3) ! Array version of PR63921 assignment
if (any (dt%i .ne. [6,5,6,10,21,62])) call abort
call dt%delete
contains
function foo (arg)
integer, pointer :: foo
integer, target :: arg(:)
foo => arg (1)
foo = 99
end function
function footoo (arg) result(res)
integer :: arg
integer :: res(arg)
res = [(arg - i, i = 0, arg - 1)]
end function
end

113
gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 Normal file
View file

@ -0,0 +1,113 @@
! { dg-do compile }
! { dg-options -std=f2003 }
!
! Is a copy of ptr_func_assign_1.f08 with checks for F2008 standard.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module fcn_bar
contains
function bar (arg, idx) result (res)
integer, pointer :: res
integer, target :: arg(:)
integer :: idx
res => arg (idx)
res = 99
end function
end module
module fcn_mydt
type mydt
integer, allocatable, dimension (:) :: i
contains
procedure, pass :: create
procedure, pass :: delete
procedure, pass :: fill
procedure, pass :: elem_fill
end type
contains
subroutine create (this, sz)
class(mydt) :: this
integer :: sz
if (allocated (this%i)) deallocate (this%i)
allocate (this%i(sz))
this%i = 0
end subroutine
subroutine delete (this)
class(mydt) :: this
if (allocated (this%i)) deallocate (this%i)
end subroutine
function fill (this, idx) result (res)
integer, pointer :: res(:)
integer :: lb, ub
class(mydt), target :: this
integer :: idx
lb = idx
ub = lb + size(this%i) - 1
res => this%i(lb:ub)
end function
function elem_fill (this, idx) result (res)
integer, pointer :: res
class(mydt), target :: this
integer :: idx
res => this%i(idx)
end function
end module
use fcn_bar
use fcn_mydt
integer, target :: a(3) = [1,2,3]
integer, pointer :: b
integer :: foobar, z, i, ifill(4) = [2, 7, 19, 61], ifill2(2) = [1,2]
type(mydt) :: dt
foobar (z) = z**2 ! { dg-warning "Obsolescent feature: Statement function" }
if (any (a .ne. [1,2,3])) call abort
! Assignment to pointer result is after procedure call.
foo (a) = 77 ! { dg-error "Pointer procedure assignment" }
! Assignment within procedure applies.
b => foo (a)
if (b .ne. 99) call abort
! Use of index for assignment.
bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
if (any (a .ne. [99,99,3])) call abort
! Make sure that statement function still works!
if (foobar (10) .ne. 100) call abort
bar (a, 3) = foobar (9)! { dg-error "Pointer procedure assignment" }
if (any (a .ne. [99,99,81])) call abort
! Try typebound procedure
call dt%create (6)
dt%elem_fill (3) = 42 ! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 42) call abort
dt%elem_fill (3) = 42 + dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 84) call abort
dt%elem_fill (3) = dt%elem_fill (3) - dt%elem_fill (3)! { dg-error "Pointer procedure assignment" }
if (dt%i(3) .ne. 0) call abort
! Array is now reset
dt%fill (3) = ifill ! { dg-error "Pointer procedure assignment" }
dt%fill (1) = [2,1] ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [2,1,ifill])) call abort
dt%fill (1) = footoo (size (dt%i, 1)) ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [6,5,4,3,2,1])) call abort
dt%fill (3) = ifill + dt%fill (3) ! { dg-error "Pointer procedure assignment" }
if (any (dt%i .ne. [6,5,6,10,21,62])) call abort
call dt%delete
contains
function foo (arg)
integer, pointer :: foo
integer, target :: arg(:)
foo => arg (1)
foo = 99
end function
function footoo (arg) result(res)
integer :: arg
integer :: res(arg)
res = [(arg - i, i = 0, arg - 1)]
end function
end

52
gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 Normal file
View file

@ -0,0 +1,52 @@
! { dg-do run }
!
! Tests corrections to implementation of pointer function assignments.
!
! Contributed by Mikael Morin <mikael.morin@sfr.fr>
!
module m
implicit none
type dt
integer :: data
contains
procedure assign_dt
generic :: assignment(=) => assign_dt
end type
contains
subroutine assign_dt(too, from)
class(dt), intent(out) :: too
type(dt), intent(in) :: from
too%data = from%data + 1
end subroutine
end module m
program p
use m
integer, parameter :: b = 3
integer, target :: a = 2
type(dt), target :: tdt
type(dt) :: sdt = dt(1)
func (arg=b) = 1 ! This was rejected as an unclassifiable statement
if (a /= 1) call abort
func (b + b - 3) = -1
if (a /= -1) call abort
dtfunc () = sdt ! Check that defined assignment is resolved
if (tdt%data /= 2) call abort
contains
function func(arg) result(r)
integer, pointer :: r
integer :: arg
if (arg == 3) then
r => a
else
r => null()
end if
end function func
function dtfunc() result (r)
type(dt), pointer :: r
r => tdt
end function
end program p

27
gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 Normal file
View file

@ -0,0 +1,27 @@
! { dg-do compile }
!
! Tests correction to implementation of pointer function assignments.
!
! Contributed by Mikael Morin <mikael.morin@sfr.fr>
!
program p
integer, target :: a(3) = 2
integer :: b(3, 3) = 1
integer :: c
c = 3
func (b(2, 2)) = b ! { dg-error "Different ranks" }
func (c) = b ! { dg-error "Different ranks" }
contains
function func(arg) result(r)
integer, pointer :: r(:)
integer :: arg
if (arg == 1) then
r => a
else
r => null()
end if
end function func
end program p