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.
I had a stupid amount of trouble with the test fmt_tab_1.f90. I have
no idea why but the gfc_warning no longer showed the offending line,
although the line number in the error message was OK. Changing to
gfc_warning_now fixed the problem. Also, I can see no reason why this
should be dg-run and so changed to dg-compile. Finally, I set
-std=legacy to stop the generic error associated with tabs.
Bootstraps and regtests on x86_64/FC21 - OK for trunk?
Now back to trying to get my head round parameterized derived types!
Cheers
Paul
2015-08-26 Paul Thomas <pa...@gcc.gnu.org>
* decl.c (get_proc_name): Return if statement function is
found.
* 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, otherwise if standard embraces F2008 try to match a
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.
* 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-08-26 Paul Thomas <pa...@gcc.gnu.org>
* gfortran.dg/fmt_tab_1.f90: Change from run to compile and set
standard as legacy.
* gfortran.dg/ptr_func_assign_1.f08: New test.
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 227118)
--- 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/io.c
===================================================================
*** gcc/fortran/io.c (revision 227118)
--- gcc/fortran/io.c (working copy)
*************** next_char_not_space (bool *error)
*** 200,206 ****
if (c == '\t')
{
if (gfc_option.allow_std & GFC_STD_GNU)
! gfc_warning (0, "Extension: Tab character in format at %C");
else
{
gfc_error ("Extension: Tab character in format at %C");
--- 200,206 ----
if (c == '\t')
{
if (gfc_option.allow_std & GFC_STD_GNU)
! gfc_warning_now (0, "Extension: Tab character in format at %C");
else
{
gfc_error ("Extension: Tab character in format at %C");
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 227118)
--- 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,5000 ----
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.function && sym->result->attr.pointer))
+ 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_NO)
+ goto undo_error;
+
+ gfc_free_error (&old_error);
+
+ if (m == MATCH_ERROR)
+ 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_NO)
+ goto undo_error;
+
+ gfc_free_error (&old_error);
+
+ if (m == MATCH_ERROR)
+ return m;
+
+ 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 227118)
--- 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 227118)
--- 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 ****
--- 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);
+ }
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
*************** loop:
*** 3008,3013 ****
--- 3017,3023 ----
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 ****
--- 3146,3153 ----
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 ****
--- 3381,3388 ----
ts->type = BT_UNKNOWN;
}
+ in_specification_block = false;
+
return st;
}
*************** gfc_parse_file (void)
*** 5584,5589 ****
--- 5598,5604 ----
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 227118)
--- gcc/fortran/resolve.c (working copy)
*************** get_temp_from_expr (gfc_expr *e, gfc_nam
*** 9737,9746 ****
/* 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
--- 9737,9746 ----
/* This function could be expanded to support other expression type
but this is not needed here. */
/* Obtain the arrayspec for the temporary. */
! if (e->rank && e->expr_type != EXPR_ARRAY
! && e->expr_type != EXPR_FUNCTION)
{
aref = gfc_find_array_ref (e);
if (e->expr_type == EXPR_VARIABLE
*************** get_temp_from_expr (gfc_expr *e, gfc_nam
*** 9772,9777 ****
--- 9772,9786 ----
if (as->type == AS_DEFERRED)
tmp->n.sym->attr.allocatable = 1;
}
+ else if (e->expr_type == EXPR_ARRAY
+ || (e->rank && e->expr_type == EXPR_FUNCTION))
+ {
+ tmp->n.sym->as = gfc_get_array_spec ();
+ tmp->n.sym->as->type = AS_DEFERRED;
+ tmp->n.sym->as->rank = 1;
+ 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 ****
--- 10142,10178 ----
}
+ /* 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 void
+ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
+ {
+ gfc_expr *tmp_ptr_expr;
+ gfc_code *this_code;
+
+ 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;
+ }
+
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
*************** gfc_resolve_code (gfc_code *code, gfc_na
*** 10318,10323 ****
--- 10358,10371 ----
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
+ if (code->expr1->expr_type == EXPR_FUNCTION
+ && code->expr1->symtree->n.sym->result->attr.pointer)
+ {
+ resolve_ptr_fcn_assign (&code, ns);
+ code = code->next;
+ break;
+ }
+
if (!gfc_check_vardef_context (code->expr1, false, false, false,
_("assignment")))
break;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 227118)
--- 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 227118)
--- 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 "-std=legacy" }
! PR fortran/32987
program TestFormat
write (*, 10)
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,96 ----
+ ! { 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
+ 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
+ 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%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
+ 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
