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

Paul Richard Thomas paul.richard.thomas@gmail.com
Sun Sep 6 17:21:00 GMT 2015


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
-------------- next part --------------
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)


More information about the Gcc-patches mailing list