+2015-09-28 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/40054
+ PR fortran/63921
+ * 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.
+ * 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 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-28 Nathan Sidwell <nathan@codesourcery.com>
* f95-lang.c (DEF_FUNCTION_TYPE_VAR_6): New.
return rc;
sym = *result;
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ return rc;
if (sym->attr.module_procedure
&& sym->attr.if_source == IFSRC_IFBODY)
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
gfc_match_st_function (void)
{
gfc_error_buffer old_error;
-
gfc_symbol *sym;
gfc_expr *expr;
match m;
}
+/* 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;
+}
+
+
/***************** SELECT CASE subroutines ******************/
/* Free a single case structure. */
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);
for the specification statements in a function, whose
characteristics are deferred into the specification statements.
eg.: INTEGER (king = mykind) foo ()
- USE mymodule, ONLY mykind.....
+ USE mymodule, ONLY mykind.....
The KIND parameter needs a return after USE or IMPORT, whereas
derived type declarations can occur anywhere, up the executable
block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
return ST_GET_FCN_CHARACTERISTICS;
}
+static bool in_specification_block;
/* This is the primary 'decode_statement'. */
static gfc_statement
return ST_FUNCTION;
else if (m == MATCH_ERROR)
reject_statement ();
- else
+ else
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
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);
+
+ 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))
+ {
+ 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);
/* Assert next length characters to be equal to token in free form. */
-static void
+static void
verify_token_free (const char* token, int length, bool last_was_use_stmt)
{
int i;
}
else if (c == '$')
{
- /* Since both OpenMP and OpenACC directives starts with
+ /* Since both OpenMP and OpenACC directives starts with
!$ character sequence, we must check all flags combinations */
if ((flag_openmp || flag_openmp_simd)
&& !flag_openacc)
return decode_oacc_directive ();
}
}
- gcc_unreachable ();
+ gcc_unreachable ();
}
-
+
if (at_bol && c == ';')
{
if (!(gfc_option.allow_std & GFC_STD_F2008))
case '*':
c = gfc_next_char_literal (NONSTRING);
-
+
if (TOLOWER (c) == 'g')
{
for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
if (digit_flag)
gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
&label_locus);
-
+
gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
/* Create a symbol for the main program and assign it to ns->proc_name. */
-
-static void
+
+static void
main_program_symbol (gfc_namespace *ns, const char *name)
{
gfc_symbol *main_program;
}
seen_sequence = 1;
- gfc_add_sequence (&gfc_current_block ()->attr,
+ gfc_add_sequence (&gfc_current_block ()->attr,
gfc_current_block ()->name, NULL);
break;
coarray = true;
sym->attr.coarray_comp = 1;
}
-
+
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
&& !c->attr.pointer)
{
/* Parse an ENUM. */
-
+
static void
parse_enum (void)
{
gfc_new_block->attr.pointer = 0;
gfc_new_block->attr.proc_pointer = 1;
}
- if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
+ if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL))
{
reject_statement ();
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
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 ();
case ST_NONE:
break;
-
+
default:
gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
gfc_ascii_statement (st));
reject_statement ();
break;
}
-
+
/* If we find a statement that can not be followed by an IMPLICIT statement
(and thus we can expect to see none any further), type the function result
if it has not yet been typed. Be careful not to give the END statement
ts->type = BT_UNKNOWN;
}
+ in_specification_block = false;
+
return st;
}
context that causes it to become redefined. If the symbol is an
iterator, we generate an error message and return nonzero. */
-int
+int
gfc_check_do_variable (gfc_symtree *st)
{
gfc_state_data *s;
return 0;
}
-
+
/* Checks to see if the current statement label closes an enddo.
Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
gfc_state_data s, *sd;
gfc_statement st;
- for (sd = gfc_state_stack; sd; sd = sd->previous)
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
gfc_error_now (is_oacc (sd)
? "CRITICAL block inside of OpenACC region at %C"
gfc_code *cp, *np;
gfc_state_data s, *sd;
- for (sd = gfc_state_stack; sd; sd = sd->previous)
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_CRITICAL)
gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
gfc_code *cp, *np;
gfc_state_data s, *sd;
- for (sd = gfc_state_stack; sd; sd = sd->previous)
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
if (sd->state == COMP_CRITICAL)
gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
"ambiguous", gfc_new_block->name);
else
{
- if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
- sym->name,
+ if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
+ sym->name,
&gfc_new_block->declared_at))
{
if (st == ST_FUNCTION)
done:
gfc_current_ns->code = gfc_state_stack->head;
if (gfc_state_stack->state == COMP_PROGRAM
- || gfc_state_stack->state == COMP_MODULE
- || gfc_state_stack->state == COMP_SUBROUTINE
+ || gfc_state_stack->state == COMP_MODULE
+ || gfc_state_stack->state == COMP_SUBROUTINE
|| gfc_state_stack->state == COMP_FUNCTION
|| gfc_state_stack->state == COMP_BLOCK)
- gfc_current_ns->oacc_declare_clauses
+ gfc_current_ns->oacc_declare_clauses
= gfc_state_stack->ext.oacc_declare_clauses;
}
if (gfc_at_eof ())
goto done;
+ in_specification_block = true;
loop:
gfc_init_2 ();
st = next_statement ();
/* Do the resolution. */
resolve_all_program_units (gfc_global_ns_list);
- /* Do the parse tree dump. */
+ /* Do the parse tree dump. */
gfc_current_ns
= flag_dump_fortran_original ? gfc_global_ns_list : NULL;
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)
+ 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
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;
}
+/* 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 ("The function result on the lhs of the assignment 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. */
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);
&& 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;
/* 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);
if (attr->proc != PROC_UNKNOWN && !attr->module_procedure)
{
- gfc_error ("%s procedure at %L is already declared as %s 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;
}
+2015-09-28 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/fmt_tab_2.f90: Add extra tab error.
+ * 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>
+
+ PR fortran/40054
+ PR fortran/63921
+ * gfortran.dg/ptr_func_assign_3.f08: New test.
+ * gfortran.dg/ptr_func_assign_4.f08: New test.
+
2015-09-28 Aditya Kumar <aditya.k7@samsung.com>
Sebastian Pop <s.pop@samsung.com>
-! { dg-do run }
+! { dg-do compile }
+! { dg-options -Wno-error=tabs }
! PR fortran/32987
program TestFormat
write (*, 10)
! PR fortran/32987
program TestFormat
write (*, 10) ! { dg-error "FORMAT label 10 at .1. not defined" }
- 10 format ('Hello ', 'bug!') ! { dg-error "Extension: Tab character in format" }
+ 10 format ('Hello ', 'bug!') ! { dg-error "Extension: Tab character in format|Nonconforming tab character" }
end
! 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" }
+ f=110 ! { dg-error "Type inaccessible in variable definition context" }
end
--- /dev/null
+! { 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
--- /dev/null
+! { 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 "Pointer procedure assignment" }
+
+! Assignment within procedure applies.
+ b => foo (a)
+ if (b .ne. 99) call abort
+
+! Use of index for assignment.
+ bar (a, 2) = 99 ! { dg-error "Pointer procedure assignment" }
+ 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 "Pointer procedure assignment" }
+ 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" }
+
+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
projects / gcc.git / commitdiff