Dear Mikael, dear all,
Please find attached a revised version of the patch that, I believe,
addresses all the comments. The patch is very much improved and these
improvements are verified by the two extra testcases. Thanks a
million!
Most of the effort involved in preparing this revised patch was
associated with getting rid of ICEs/segfaults triggered by error
recovery. The error handling in resolve_ptr_fcn_assign is still a bit
clumsy but its behaviour is more consistent.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Cheers
Paul
2015-09-25 Paul Thomas <pa...@gcc.gnu.org>
* 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.
* io.c (next_char_not_space): Change tab warning to warning now
to prevent locus being lost.
* 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 standard embraces F2008 and 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-25 Paul Thomas <pa...@gcc.gnu.org>
* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
standard as legacy.
* 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.mo...@sfr.fr>
* gfortran.dg/ptr_func_assign_3.f08: New test.
* gfortran.dg/ptr_func_assign_4.f08: New test.
On 18 September 2015 at 10:36, Paul Richard Thomas
<paul.richard.tho...@gmail.com> wrote:
> Dear Mikael,
>
> Thank you very much for the review. I'll give consideration to your
> remarks over the weekend. You will have guessed from the comment that
> I too was uneasy about forcing the break. As for your last remark,
> yes, the code rewriting is indeed in the wrong place. It should be
> rather easy to accomplish both the checks and defined assignments.
>
> Thanks again
>
> Paul
>
> On 17 September 2015 at 15:43, Mikael Morin <mikael.mo...@sfr.fr> wrote:
>> Le 06/09/2015 18:40, Paul Richard Thomas a écrit :
>>>
>>> It helps to attach the patch :-)
>>>
>>> Paul
>>>
>>> On 6 September 2015 at 13:42, Paul Richard Thomas
>>> <paul.richard.tho...@gmail.com> wrote:
>>>>
>>>> Dear All,
>>>>
>>>> The attached patch more or less implements the assignment of
>>>> expressions to the result of a pointer function. To wit:
>>>>
>>>> my_ptr_fcn (arg1, arg2...) = expr
>>>>
>>>> arg1 would usually be the target, pointed to by the function. The
>>>> patch parses these statements and resolves them into:
>>>>
>>>> temp_ptr => my_ptr_fcn (arg1, arg2...)
>>>> temp_ptr = expr
>>>>
>>>> I say more or less implemented because I have ducked one of the
>>>> headaches here. At the end of the specification block, there is an
>>>> ambiguity between statement functions and pointer function
>>>> assignments. I do not even try to resolve this ambiguity and require
>>>> that there be at least one other type of executable statement before
>>>> these beasts. This can undoubtedly be fixed but the effort seems to me
>>>> to be unwarranted at the present time.
>>>>
>>>> This version of the patch extends the coverage of allowed rvalues to
>>>> any legal expression. Also, all the problems with error.c have been
>>>> dealt with by Manuel's patch.
>>>>
>>>> I am grateful to Dominique for reminding me of PR40054 and pointing
>>>> out PR63921. After a remark of his on #gfortran, I fixed the checking
>>>> of the standard to pick up all the offending lines with F2003 and
>>>> earlier.
>>>>
>>>>
>>>> Bootstraps and regtests on FC21/x86_64 - OK for trunk?
>>>>
>> Hello Paul,
>>
>> I'm mostly concerned about the position where the code rewriting happens.
>> Details below.
>>
>> Mikael
>>
>>
>>>
>>> submit_2.diff
>>>
>>
>>> Index: gcc/fortran/parse.c
>>> ===================================================================
>>> *** gcc/fortran/parse.c (revision 227508)
>>> --- gcc/fortran/parse.c (working copy)
>>> *************** decode_statement (void)
>>> *** 356,362 ****
>>> --- 357,371 ----
>>>
>>> match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
>>> match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
>>> +
>>> + if (in_specification_block)
>>> + {
>>> match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
>>> + }
>>> + else if (!gfc_notification_std (GFC_STD_F2008))
>>> + {
>>> + match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
>>> + }
>>>
>> As match exits the function upon success, I think it makes sense to move
>> match (... gfc_match_ptr_fcn_assign ...) out of the else, namely:
>>
>> if (in_specification_block)
>> {
>> /* match statement function */
>> }
>>
>> /* match pointer fonction assignment */
>>
>> so that non-ambiguous cases are recognized with gfc_match_ptr_fcn_assign.
>> Non-ambiguous cases are for example the ones where one of the function
>> arguments is a non-variable, or a variable with a subreference, or when
>> there is one keyword argument. Example (rejected with unclassifiable
>> statement):
>>
>> program p
>> integer, parameter :: b = 3
>> integer, target :: a = 2
>>
>> func(arg=b) = 1
>> if (a /= 1) call abort
>>
>> func(b + b - 3) = -1
>> if (a /= -1) 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
>> end program p
>>
>>
>>> Index: gcc/fortran/resolve.c
>>> ===================================================================
>>> *** gcc/fortran/resolve.c (revision 227508)
>>> --- gcc/fortran/resolve.c (working copy)
>>> *************** generate_component_assignments (gfc_code
>>> *** 10133,10138 ****
>>> --- 10141,10205 ----
>>> }
>>>
>>>
>>> + /* 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. */
>>
>> I don't mind this, but maybe we should return false at the end, when an
>> error has been emitted?
>>
>>> + 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 ("F2008: The function result at %L must have "
>>> + "the pointer attribute.", &(*code)->expr1->where);
>>> + /* Return true because we want a break after the call. */
>>
>> Hum, I would rather not do this if possible. Do we really need the break?
>>
>>> + return true;
>>> + }
>>> +
>>> + 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;
>>> +
>>> + 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;
>>> +
>>> + *code = (*code)->next;
>>> + return true;
>>> + }
>>> +
>>> +
>>> /* Given a block of code, recursively resolve everything pointed to by
>>> this
>>> code block. */
>>>
>>> *************** gfc_resolve_code (gfc_code *code, gfc_na
>>> *** 10318,10323 ****
>>> --- 10385,10393 ----
>>> && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
>>> remove_caf_get_intrinsic (code->expr1);
>>>
>>> + if (resolve_ptr_fcn_assign (&code, ns))
>>> + break;
>>> +
>>> if (!gfc_check_vardef_context (code->expr1, false, false, false,
>>> _("assignment")))
>>> break;
>>
>>
>> I think the call should be added later in the pipeline, and I suspect the
>> break should be removed.
>> As it stands, the code bypasses many of the checks we do normally for
>> assignments.
>> For example, the following is accepted, despite the incompatible ranks.
>>
>> program p
>> integer, target :: a(3) = 2
>> integer :: b(3, 3) = 1
>> integer :: c
>>
>> c = 1
>> ! func(b(2, 2)) = b
>> func(c) = b
>>
>> 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
>>
>>
>> I'm also concerned about defined assignments.
>> Combining them with pointer function lhs should be possible, The code
>> rewriting just has to happen at the right place. ;-)
>
>
>
> --
> Outside of a dog, a book is a man's best friend. Inside of a dog it's
> too dark to read.
>
> Groucho Marx
--
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.
Groucho Marx
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 227854)
--- gcc/fortran/decl.c (working copy)
*************** get_proc_name (const char *name, gfc_sym
*** 901,906 ****
--- 901,908 ----
return rc;
sym = *result;
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ return rc;
if (sym->attr.module_procedure
&& sym->attr.if_source == IFSRC_IFBODY)
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 227854)
--- gcc/fortran/expr.c (working copy)
*************** gfc_check_vardef_context (gfc_expr* e, b
*** 4822,4827 ****
--- 4822,4836 ----
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
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 227854)
--- gcc/fortran/match.c (working copy)
*************** match
*** 4886,4892 ****
gfc_match_st_function (void)
{
gfc_error_buffer old_error;
-
gfc_symbol *sym;
gfc_expr *expr;
match m;
--- 4886,4891 ----
*************** gfc_match_st_function (void)
*** 4926,4931 ****
--- 4925,4990 ----
return MATCH_YES;
undo_error:
+ gfc_pop_error (&old_error);
+ return MATCH_NO;
+ }
+
+
+ /* 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;
}
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 227854)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_namelist (void);
*** 107,112 ****
--- 107,113 ----
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);
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c (revision 227854)
--- gcc/fortran/parse.c (working copy)
*************** end_of_block:
*** 287,292 ****
--- 287,293 ----
return ST_GET_FCN_CHARACTERISTICS;
}
+ static bool in_specification_block;
/* This is the primary 'decode_statement'. */
static gfc_statement
*************** decode_statement (void)
*** 356,362 ****
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);
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
--- 357,375 ----
match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
!
! 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)
! && !gfc_notification_std (GFC_STD_F2008))
! {
! 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);
*************** loop:
*** 3008,3013 ****
--- 3021,3027 ----
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
*************** parse_spec (gfc_statement st)
*** 3136,3141 ****
--- 3150,3157 ----
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 ();
*************** declSt:
*** 3369,3374 ****
--- 3385,3392 ----
ts->type = BT_UNKNOWN;
}
+ in_specification_block = false;
+
return st;
}
*************** gfc_parse_file (void)
*** 5589,5594 ****
--- 5607,5613 ----
if (gfc_at_eof ())
goto done;
+ in_specification_block = true;
loop:
gfc_init_2 ();
st = next_statement ();
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 227854)
--- gcc/fortran/resolve.c (working copy)
*************** get_temp_from_expr (gfc_expr *e, gfc_nam
*** 9735,9746 ****
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)
{
aref = gfc_find_array_ref (e);
if (e->expr_type == EXPR_VARIABLE
--- 9735,9744 ----
ref = NULL;
aref = NULL;
/* Obtain the arrayspec for the temporary. */
! 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
*************** get_temp_from_expr (gfc_expr *e, gfc_nam
*** 9772,9777 ****
--- 9770,9785 ----
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;
*************** generate_component_assignments (gfc_code
*** 10133,10138 ****
--- 10141,10205 ----
}
+ /* 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 ("F2008: The function result 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. */
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10228,10234 ****
if (omp_workshare_save != -1)
omp_workshare_flag = omp_workshare_save;
}
!
t = true;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
t = gfc_resolve_expr (code->expr1);
--- 10295,10301 ----
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);
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10318,10323 ****
--- 10385,10398 ----
&& 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;
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10332,10337 ****
--- 10407,10413 ----
/* 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);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 227854)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_add_procedure (symbol_attribute *att
*** 1541,1549 ****
if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
{
! gfc_error ("%s procedure at %L is already declared as %s procedure",
gfc_code2string (procedures, t), where,
gfc_code2string (procedures, attr->proc));
return false;
}
--- 1541,1559 ----
if (attr->proc != PROC_UNKNOWN && !attr->module_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;
}
Index: gcc/testsuite/gfortran.dg/fmt_tab_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/fmt_tab_1.f90 (revision 227854)
--- gcc/testsuite/gfortran.dg/fmt_tab_1.f90 (working copy)
***************
*** 1,4 ****
! ! { dg-do run }
! PR fortran/32987
program TestFormat
write (*, 10)
--- 1,5 ----
! ! { dg-do compile }
! ! { dg-options -Wno-error=tabs }
! PR fortran/32987
program TestFormat
write (*, 10)
Index: gcc/testsuite/gfortran.dg/function_types_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/function_types_3.f90 (revision 227854)
--- gcc/testsuite/gfortran.dg/function_types_3.f90 (working copy)
*************** end
*** 15,19 ****
! 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" }
end
--- 15,19 ----
! 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 "Type inaccessible in variable definition
context" }
end
Index: gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08
===================================================================
*** gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 (working copy)
***************
*** 0 ****
--- 1,112 ----
+ ! { dg-do run }
+ !
+ ! Tests implementation of F2008 feature: pointer function assignments.
+ !
+ ! Contributed by Paul Thomas <pa...@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
Index: gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08
===================================================================
*** gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 (working copy)
***************
*** 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 <pa...@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 "Unclassifiable statement" }
+
+ ! Assignment within procedure applies.
+ b => foo (a)
+ if (b .ne. 99) call abort
+
+ ! Use of index for assignment.
+ bar (a, 2) = 99 ! { dg-error "is not a variable" }
+ 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 "is not a variable" }
+ 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
Index: gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08
===================================================================
*** gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 (working copy)
***************
*** 0 ****
--- 1,52 ----
+ ! { dg-do run }
+ !
+ ! Tests corrections to implementation of pointer function assignments.
+ !
+ ! Contributed by Mikael Morin <mikael.mo...@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
Index: gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08
===================================================================
*** gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 (revision 0)
--- gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 (working copy)
***************
*** 0 ****
--- 1,32 ----
+ ! { dg-do compile }
+ !
+ ! Tests correction to implementation of pointer function assignments.
+ !
+ ! Contributed by Mikael Morin <mikael.mo...@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" }
+ func2 (c) = b ! { dg-error "must have the pointer attribute" }
+ 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
+ function func2(arg) result(r)
+ integer :: r(1)
+ integer :: arg
+ r = 0
+ end function func2
+ end program p
