[Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

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  <pault@gcc.gnu.org>

    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  <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/ptr_func_assign_1.f08: New test.
    * gfortran.dg/ptr_func_assign_2.f08: New test.

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2992 bytes --]

It helps to attach the patch :-)

Paul

On 6 September 2015 at 13:42, Paul Richard Thomas
<paul.richard.thomas@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?
>
> Cheers
>
> Paul
>
> 2015-09-06  Paul Thomas  <pault@gcc.gnu.org>
>
>     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  <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/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

[-- Attachment #2: submit_2.diff --]
[-- Type: text/plain, Size: 18042 bytes --]

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  <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
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  <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 "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)

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Mikael Morin]

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.thomas@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. ;-)

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

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.morin@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.thomas@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

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 11238 bytes --]

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  <pault@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  <pault@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.morin@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.thomas@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.morin@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.thomas@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

[-- Attachment #2: resubmit.diff --]
[-- Type: text/plain, Size: 23756 bytes --]

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  <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
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  <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 "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.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
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.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" }
+   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

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Mikael Morin]

Hello Paul,

Le 25/09/2015 14:21, Paul Richard Thomas a écrit :
> 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  <pault@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.
This has disappeared?

>      * 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.
>

> Index: gcc/fortran/parse.c
> ===================================================================
> *** gcc/fortran/parse.c	(revision 227854)
> --- gcc/fortran/parse.c	(working copy)

> *************** 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);
> !     }
I think that for better error reporting (avoid unclassifiable 
statement), the gfc_notification_std can be dropped, as there is a 
specific gfc_notify_std guarding resolution.

Same for the rest of the condition.  gfc_match_ptr_fcn_assign carrefully 
restores existing errors upon failure, so I would rather use it more often.

So, can you try removing the condition completely (and use the match 
macro above again)?  that should improve errors in ptr_func_assign_2, 
and hopefully not regress.
If it does regress, let's keep it as is.



> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c	(revision 227854)
> --- 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.  */
> +   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);
Nit: Usually, we don't put the 'F2008:' prefix.
Also may be explicit a bit more: "function result as assigned-to 
variable" or something alike.

Anyway, those are nits, and the rest looks good to me.
So, with the above comments, the patch is OK as far as I'm concerned.
Thanks

Mikael

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

Dear Mikael,

....snip...

>>      * io.c (next_char_not_space): Change tab warning to warning now
>>      to prevent locus being lost.
>
> This has disappeared?

duuh! Thanks


....snip....

> I think that for better error reporting (avoid unclassifiable statement),
> the gfc_notification_std can be dropped, as there is a specific
> gfc_notify_std guarding resolution.

That's true - I'll check it out right now.

>
> Same for the rest of the condition.  gfc_match_ptr_fcn_assign carrefully
> restores existing errors upon failure, so I would rather use it more often.
>
> So, can you try removing the condition completely (and use the match macro
> above again)?  that should improve errors in ptr_func_assign_2, and
> hopefully not regress.
> If it does regress, let's keep it as is.

It does regress - that's why it is the way it is. Fortunately,
MATCH_ERROR for statement functions would produce pretty much the same
result in pointer function assignments. The regression is in
recursive_statement_functions.f90, which just gets hopelessly tangled
up in error recovery.

....snip....

> Nit: Usually, we don't put the 'F2008:' prefix.
> Also may be explicit a bit more: "function result as assigned-to variable"
> or something alike.

Nits or not, they are good points :-)

>
> Anyway, those are nits, and the rest looks good to me.
> So, with the above comments, the patch is OK as far as I'm concerned.
> Thanks

OK - I'll try to do the honours tonight.

Thanks for the reviews.

Paul

Re: [Patch, fortran] PR40054 and PR63921 - Implement pointer function assignment - redux

[Paul Richard Thomas]

Committed as revision 228222. Thanks for all the help.

I'll update the fortran documentation tomorrow.

Cheers

Paul

On 28 September 2015 at 20:22, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear Mikael,
>
> ....snip...
>
>>>      * io.c (next_char_not_space): Change tab warning to warning now
>>>      to prevent locus being lost.
>>
>> This has disappeared?
>
> duuh! Thanks
>
>
> ....snip....
>
>> I think that for better error reporting (avoid unclassifiable statement),
>> the gfc_notification_std can be dropped, as there is a specific
>> gfc_notify_std guarding resolution.
>
> That's true - I'll check it out right now.
>
>>
>> Same for the rest of the condition.  gfc_match_ptr_fcn_assign carrefully
>> restores existing errors upon failure, so I would rather use it more often.
>>
>> So, can you try removing the condition completely (and use the match macro
>> above again)?  that should improve errors in ptr_func_assign_2, and
>> hopefully not regress.
>> If it does regress, let's keep it as is.
>
> It does regress - that's why it is the way it is. Fortunately,
> MATCH_ERROR for statement functions would produce pretty much the same
> result in pointer function assignments. The regression is in
> recursive_statement_functions.f90, which just gets hopelessly tangled
> up in error recovery.
>
> ....snip....
>
>> Nit: Usually, we don't put the 'F2008:' prefix.
>> Also may be explicit a bit more: "function result as assigned-to variable"
>> or something alike.
>
> Nits or not, they are good points :-)
>
>>
>> Anyway, those are nits, and the rest looks good to me.
>> So, with the above comments, the patch is OK as far as I'm concerned.
>> Thanks
>
> OK - I'll try to do the honours tonight.
>
> Thanks for the reviews.
>
> Paul



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx