It helps to attach the patch :-)
Paul
On 6 September 2015 at 13:42, Paul Richard Thomas
<[email protected]> 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?
>
> Cheers
>
> Paul
>
> 2015-09-06 Paul Thomas <[email protected]>
>
> PR fortran/40054
> PR fortran/63921
> * decl.c (get_proc_name): Return if statement function is
> found.
> * 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 other
> expressions than variables and constants as rvalues.
> (resolve_ptr_fcn_assign): New function.
> (gfc_resolve_code): Call resolve_ptr_fcn_assign.
> * 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-06 Paul Thomas <[email protected]>
>
> PR fortran/40054
> PR fortran/63921
> * 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.
> * gfortran.dg/ptr_func_assign_2.f08: New test.
--
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 227508)
--- 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/match.c
===================================================================
*** gcc/fortran/match.c (revision 227508)
--- 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 227508)
--- 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 227508)
--- 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)
*** 5589,5594 ****
--- 5603,5609 ----
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 227508)
--- 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);
+ /* Return true because we want a break after the call. */
+ 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;
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 227508)
--- 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/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 <[email protected]>
+ !
+ 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 <[email protected]>
+ !
+ 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/fmt_tab_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/fmt_tab_1.f90 (revision 227508)
--- 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)
