From: Paul Thomas Date: Mon, 28 Sep 2015 21:18:38 +0000 (+0000) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=79124116d6046ff960b0737f31a64f7c563cc9a7;p=gcc.git [multiple changes] 2015-09-28 Paul Thomas 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 Paul Thomas 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 PR fortran/40054 PR fortran/63921 * gfortran.dg/ptr_func_assign_3.f08: New test. * gfortran.dg/ptr_func_assign_4.f08: New test. From-SVN: r228222 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5159b8b4326..2830c912b03 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2015-09-28 Paul Thomas + + 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 * f95-lang.c (DEF_FUNCTION_TYPE_VAR_6): New. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 6829d178c92..39c1136b68b 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -901,6 +901,8 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) return rc; sym = *result; + if (sym->attr.proc == PROC_ST_FUNCTION) + return rc; if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 3a0ef4d8f55..9a27fa98baa 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4822,6 +4822,15 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, 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 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 523e9b2a7f5..a50ec2d1351 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -4886,7 +4886,6 @@ match gfc_match_st_function (void) { gfc_error_buffer old_error; - gfc_symbol *sym; gfc_expr *expr; match m; @@ -4931,6 +4930,66 @@ undo_error: } +/* 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. */ diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 91c9825c94d..1b51a889cd8 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -107,6 +107,7 @@ match gfc_match_namelist (void); 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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f8d84de306a..6f3d24ba2ce 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -141,7 +141,7 @@ use_modules (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 @@ -287,6 +287,7 @@ end_of_block: return ST_GET_FCN_CHARACTERISTICS; } +static bool in_specification_block; /* This is the primary 'decode_statement'. */ static gfc_statement @@ -344,7 +345,7 @@ decode_statement (void) return ST_FUNCTION; else if (m == MATCH_ERROR) reject_statement (); - else + else gfc_undo_symbols (); gfc_current_locus = old_locus; } @@ -356,7 +357,18 @@ decode_statement (void) 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); @@ -910,7 +922,7 @@ decode_gcc_attribute (void) /* 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; @@ -1013,7 +1025,7 @@ next_free (void) } 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) @@ -1044,9 +1056,9 @@ next_free (void) return decode_oacc_directive (); } } - gcc_unreachable (); + gcc_unreachable (); } - + if (at_bol && c == ';') { if (!(gfc_option.allow_std & GFC_STD_F2008)) @@ -1132,7 +1144,7 @@ next_fixed (void) case '*': c = gfc_next_char_literal (NONSTRING); - + if (TOLOWER (c) == 'g') { for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING)) @@ -1246,7 +1258,7 @@ blank_line: 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; @@ -2168,8 +2180,8 @@ gfc_ascii_statement (gfc_statement st) /* 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; @@ -2708,7 +2720,7 @@ endType: } seen_sequence = 1; - gfc_add_sequence (&gfc_current_block ()->attr, + gfc_add_sequence (&gfc_current_block ()->attr, gfc_current_block ()->name, NULL); break; @@ -2771,7 +2783,7 @@ endType: coarray = true; sym->attr.coarray_comp = 1; } - + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp && !c->attr.pointer) { @@ -2851,7 +2863,7 @@ endType: /* Parse an ENUM. */ - + static void parse_enum (void) { @@ -2942,7 +2954,7 @@ loop: 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 (); @@ -3008,6 +3020,7 @@ loop: 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 @@ -3139,6 +3152,8 @@ parse_spec (gfc_statement st) 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 (); @@ -3199,14 +3214,14 @@ loop: 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 @@ -3372,6 +3387,8 @@ declSt: ts->type = BT_UNKNOWN; } + in_specification_block = false; + return st; } @@ -3768,7 +3785,7 @@ done: 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; @@ -3783,7 +3800,7 @@ gfc_check_do_variable (gfc_symtree *st) 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 @@ -3842,7 +3859,7 @@ parse_critical_block (void) 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" @@ -4356,7 +4373,7 @@ parse_oacc_structured_block (gfc_statement acc_st) 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"); @@ -4415,7 +4432,7 @@ parse_oacc_loop (gfc_statement acc_st) 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"); @@ -4971,8 +4988,8 @@ parse_contained (int module) "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) @@ -5173,11 +5190,11 @@ contains: 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; } @@ -5592,6 +5609,7 @@ gfc_parse_file (void) if (gfc_at_eof ()) goto done; + in_specification_block = true; loop: gfc_init_2 (); st = next_statement (); @@ -5718,7 +5736,7 @@ prog_units: /* 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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6ae086ad0f7..5822cb0e435 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9735,12 +9735,10 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) 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 @@ -9772,6 +9770,16 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) 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; @@ -10133,6 +10141,66 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) } +/* 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. */ @@ -10228,7 +10296,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) 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); @@ -10318,6 +10386,14 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) && 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; @@ -10332,6 +10408,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) /* 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); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0f33608aa61..35a3496c08b 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -1541,9 +1541,19 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t, 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; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index da9954dd703..db28ecf5c55 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,22 @@ +2015-09-28 Paul Thomas + + 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 + + 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 Sebastian Pop diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 index cd95da20377..f58e388c2f7 100644 --- a/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_tab_1.f90 @@ -1,4 +1,5 @@ -! { dg-do run } +! { dg-do compile } +! { dg-options -Wno-error=tabs } ! PR fortran/32987 program TestFormat write (*, 10) diff --git a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 index 17acf86fb8e..560d8865aa7 100644 --- a/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 +++ b/gcc/testsuite/gfortran.dg/fmt_tab_2.f90 @@ -3,5 +3,5 @@ ! 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 diff --git a/gcc/testsuite/gfortran.dg/function_types_3.f90 b/gcc/testsuite/gfortran.dg/function_types_3.f90 index e8347251441..9ec4793463b 100644 --- a/gcc/testsuite/gfortran.dg/function_types_3.f90 +++ b/gcc/testsuite/gfortran.dg/function_types_3.f90 @@ -15,5 +15,5 @@ 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 diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 new file mode 100644 index 00000000000..58efb812fd0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_1.f08 @@ -0,0 +1,112 @@ +! { dg-do run } +! +! Tests implementation of F2008 feature: pointer function assignments. +! +! Contributed by Paul Thomas +! +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 diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 new file mode 100644 index 00000000000..bb84b213f1d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_2.f08 @@ -0,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 +! +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 diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 new file mode 100644 index 00000000000..4d56afbe789 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_3.f08 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Tests corrections to implementation of pointer function assignments. +! +! Contributed by Mikael Morin +! +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 diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 new file mode 100644 index 00000000000..46ef2ac5566 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_4.f08 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Tests correction to implementation of pointer function assignments. +! +! Contributed by Mikael Morin +! +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