From: Janus Weil Date: Wed, 2 Jul 2008 19:53:37 +0000 (+0200) Subject: re PR fortran/32580 (iso_c_binding c_f_procpointer / procedure pointers) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8fb74da43bd12ea5008ba9fba2173b455d494b2c;p=gcc.git re PR fortran/32580 (iso_c_binding c_f_procpointer / procedure pointers) 2008-07-02 Janus Weil Tobias Burnus Paul Thomas PR fortran/32580 * gfortran.h (struct gfc_symbol): New member "proc_pointer". * check.c (gfc_check_associated,gfc_check_null): Implement procedure pointers. * decl.c (match_procedure_decl): Ditto. * expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto. * interface.c (compare_actual_formal): Ditto. * match.h: Ditto. * match.c (gfc_match_pointer_assignment): Ditto. * parse.c (parse_interface): Ditto. * primary.c (gfc_match_rvalue,match_variable): Ditto. * resolve.c (resolve_fl_procedure): Ditto. * symbol.c (check_conflict,gfc_add_external,gfc_add_pointer, gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto. * trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl, create_function_arglist): Ditto. * trans-expr.c (gfc_conv_variable,gfc_conv_function_val, gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto. 2008-07-02 Janus Weil Tobias Burnus PR fortran/32580 * gfortran.dg/c_f_pointer_tests_3.f90: Updated. * gfortran.dg/proc_decl_1.f90: Updated. * gfortran.dg/proc_ptr_1.f90: New. * gfortran.dg/proc_ptr_2.f90: New. * gfortran.dg/proc_ptr_3.f90: New. * gfortran.dg/proc_ptr_4.f90: New. * gfortran.dg/proc_ptr_5.f90: New. * gfortran.dg/proc_ptr_6.f90: New. * gfortran.dg/proc_ptr_7.f90: New. * gfortran.dg/proc_ptr_8.f90: New. Co-Authored-By: Paul Thomas Co-Authored-By: Tobias Burnus From-SVN: r137386 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 82c2392d14d..7b641f077ba 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2008-07-02 Janus Weil + Tobias Burnus + Paul Thomas + + PR fortran/32580 + * gfortran.h (struct gfc_symbol): New member "proc_pointer". + * check.c (gfc_check_associated,gfc_check_null): Implement + procedure pointers. + * decl.c (match_procedure_decl): Ditto. + * expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto. + * interface.c (compare_actual_formal): Ditto. + * match.h: Ditto. + * match.c (gfc_match_pointer_assignment): Ditto. + * parse.c (parse_interface): Ditto. + * primary.c (gfc_match_rvalue,match_variable): Ditto. + * resolve.c (resolve_fl_procedure): Ditto. + * symbol.c (check_conflict,gfc_add_external,gfc_add_pointer, + gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto. + * trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl, + create_function_arglist): Ditto. + * trans-expr.c (gfc_conv_variable,gfc_conv_function_val, + gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto. + 2008-07-02 Thomas Koenig PR fortran/36590 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 87d962e50a7..c0f9891bd98 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -584,7 +584,7 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y) try gfc_check_associated (gfc_expr *pointer, gfc_expr *target) { - symbol_attribute attr; + symbol_attribute attr1, attr2; int i; try t; locus *where; @@ -592,15 +592,15 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) where = &pointer->where; if (pointer->expr_type == EXPR_VARIABLE) - attr = gfc_variable_attr (pointer, NULL); + attr1 = gfc_variable_attr (pointer, NULL); else if (pointer->expr_type == EXPR_FUNCTION) - attr = pointer->symtree->n.sym->attr; + attr1 = pointer->symtree->n.sym->attr; else if (pointer->expr_type == EXPR_NULL) goto null_arg; else gcc_assert (0); /* Pointer must be a variable or a function. */ - if (!attr.pointer) + if (!attr1.pointer && !attr1.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], gfc_current_intrinsic, @@ -617,9 +617,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) goto null_arg; if (target->expr_type == EXPR_VARIABLE) - attr = gfc_variable_attr (target, NULL); + attr2 = gfc_variable_attr (target, NULL); else if (target->expr_type == EXPR_FUNCTION) - attr = target->symtree->n.sym->attr; + attr2 = target->symtree->n.sym->attr; else { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " @@ -628,7 +628,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) return FAILURE; } - if (!attr.pointer && !attr.target) + if (attr1.pointer && !attr2.pointer && !attr2.target) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER " "or a TARGET", gfc_current_intrinsic_arg[1], @@ -2071,7 +2071,7 @@ gfc_check_null (gfc_expr *mold) attr = gfc_variable_attr (mold, NULL); - if (!attr.pointer) + if (!attr.pointer && !attr.proc_pointer) { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER", gfc_current_intrinsic_arg[0], diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 869ece6c3f6..d23a32946ef 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4065,6 +4065,7 @@ match_procedure_decl (void) locus old_loc, entry_loc; gfc_symbol *sym, *proc_if = NULL; int num; + gfc_expr *initializer = NULL; old_loc = entry_loc = gfc_current_locus; @@ -4183,7 +4184,7 @@ got_ts: return MATCH_ERROR; } - if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE) + if (gfc_add_external (&sym->attr, NULL) == FAILURE) return MATCH_ERROR; if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; @@ -4203,6 +4204,40 @@ got_ts: sym->attr.function = sym->ts.interface->attr.function; } + if (gfc_match (" =>") == MATCH_YES) + { + if (!current_attr.pointer) + { + gfc_error ("Initialization at %C isn't for a pointer variable"); + m = MATCH_ERROR; + goto cleanup; + } + + m = gfc_match_null (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Pointer initialization requires a NULL() at %C"); + m = MATCH_ERROR; + } + + if (gfc_pure (NULL)) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + goto cleanup; + + if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus) + != SUCCESS) + goto cleanup; + + } + + gfc_set_sym_referenced (sym); + if (gfc_match_eos () == MATCH_YES) return MATCH_YES; if (gfc_match_char (',') != MATCH_YES) @@ -4212,6 +4247,11 @@ got_ts: syntax: gfc_error ("Syntax error in PROCEDURE statement at %C"); return MATCH_ERROR; + +cleanup: + /* Free stuff up and return. */ + gfc_free_expr (initializer); + return m; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2f7030ed833..12987e6b748 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2874,7 +2874,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) int is_pure; int pointer, check_intent_in; - if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN) + if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN + && !lvalue->symtree->n.sym->attr.proc_pointer) { gfc_error ("Pointer assignment target is not a POINTER at %L", &lvalue->where); @@ -2894,7 +2895,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) /* Check INTENT(IN), unless the object itself is the component or sub-component of a pointer. */ check_intent_in = 1; - pointer = lvalue->symtree->n.sym->attr.pointer; + pointer = lvalue->symtree->n.sym->attr.pointer + | lvalue->symtree->n.sym->attr.proc_pointer; for (ref = lvalue->ref; ref; ref = ref->next) { @@ -2933,6 +2935,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; + /* TODO checks on rvalue for a procedure pointer assignment. */ + if (lvalue->symtree->n.sym->attr.proc_pointer) + return SUCCESS; + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { gfc_error ("Different types in pointer assignment at %L; attempted " @@ -3024,7 +3030,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) lvalue.symtree->n.sym = sym; lvalue.where = sym->declared_at; - if (sym->attr.pointer) + if (sym->attr.pointer || sym->attr.proc_pointer) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5d025db869b..aa2296c72a5 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -620,7 +620,7 @@ typedef struct unsigned allocatable:1, dimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, - implied_index:1, subref_array_pointer:1; + implied_index:1, subref_array_pointer:1, proc_pointer:1; ENUM_BITFIELD (save_state) save:2; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 26b4591166a..a20319976bb 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument + is provided for a procedure pointer formal argument. */ + if (f->sym->attr.proc_pointer + && !a->expr->symtree->n.sym->attr.proc_pointer) + { + if (where) + gfc_error ("Expected a procedure pointer for argument '%s' at %L", + f->sym->name, &a->expr->where); + return 0; + } + /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is provided for a procedure formal argument. */ if (a->expr->ts.type != BT_PROCEDURE diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 6f5765f1784..d501d682475 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" +int gfc_matching_procptr_assignment = 0; /* For debugging and diagnostic purposes. Return the textual representation of the intrinsic operator OP. */ @@ -1329,6 +1330,7 @@ gfc_match_pointer_assignment (void) old_loc = gfc_current_locus; lvalue = rvalue = NULL; + gfc_matching_procptr_assignment = 0; m = gfc_match (" %v =>", &lvalue); if (m != MATCH_YES) @@ -1337,7 +1339,11 @@ gfc_match_pointer_assignment (void) goto cleanup; } + if (lvalue->symtree->n.sym->attr.proc_pointer) + gfc_matching_procptr_assignment = 1; + m = gfc_match (" %e%t", &rvalue); + gfc_matching_procptr_assignment = 0; if (m != MATCH_YES) goto cleanup; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index cf30b2730dc..21a24795664 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -33,6 +33,8 @@ extern gfc_symbol *gfc_new_block; separate. */ extern gfc_st_label *gfc_statement_label; +extern int gfc_matching_procptr_assignment; + /****************** All gfc_match* routines *****************/ /* match.c. */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index c35db2d9cf6..781efbc205d 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1992,6 +1992,11 @@ loop: new_state = COMP_SUBROUTINE; else if (st == ST_FUNCTION) new_state = COMP_FUNCTION; + if (gfc_new_block->attr.pointer) + { + gfc_new_block->attr.pointer = 0; + gfc_new_block->attr.proc_pointer = 1; + } if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, gfc_new_block->formal, NULL) == FAILURE) { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index d7236e1be01..c67f2bd1873 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2323,6 +2323,9 @@ gfc_match_rvalue (gfc_expr **result) } } + if (gfc_matching_procptr_assignment) + goto procptr0; + if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) goto function0; @@ -2399,6 +2402,27 @@ gfc_match_rvalue (gfc_expr **result) /* If we're here, then the name is known to be the name of a procedure, yet it is not sure to be the name of a function. */ case FL_PROCEDURE: + + /* Procedure Pointer Assignments. */ + procptr0: + if (gfc_matching_procptr_assignment) + { + gfc_gobble_whitespace (); + if (sym->attr.function && gfc_peek_ascii_char () == '(') + /* Parse functions returning a procptr. */ + goto function0; + + if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE; + if (gfc_intrinsic_name (sym->name, 0) + || gfc_intrinsic_name (sym->name, 1)) + sym->attr.intrinsic = 1; + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + e->symtree = symtree; + m = match_varspec (e, 0); + break; + } + if (sym->attr.subroutine) { gfc_error ("Unexpected use of subroutine name '%s' at %C", @@ -2780,6 +2804,9 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) break; } + if (sym->attr.proc_pointer) + break; + /* Fall through to error */ default: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3b798d8643c..c0ec7847747 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7330,7 +7330,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } } - if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION) + if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION + && !sym->attr.proc_pointer) { gfc_error ("Function '%s' at %L cannot have an initializer", sym->name, &sym->declared_at); @@ -7338,8 +7339,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } /* An external symbol may not have an initializer because it is taken to be - a procedure. */ - if (sym->attr.external && sym->value) + a procedure. Exception: Procedure Pointers. */ + if (sym->attr.external && sym->value && !sym->attr.proc_pointer) { gfc_error ("External object '%s' at %L may not have an initializer", sym->name, &sym->declared_at); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index cd181d4f0f1..f91ef9157c0 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -410,13 +410,19 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: - case FL_PROCEDURE: case FL_DERIVED: case FL_PARAMETER: a1 = gfc_code2string (flavors, attr->flavor); a2 = save; goto conflict; + case FL_PROCEDURE: + if (attr->proc_pointer) + break; + a1 = gfc_code2string (flavors, attr->flavor); + a2 = save; + goto conflict; + case FL_VARIABLE: case FL_NAMELIST: default: @@ -557,13 +563,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, value) conf (procedure, volatile_) conf (procedure, entry) - /* TODO: Implement procedure pointers. */ - if (attr->procedure && attr->pointer) - { - gfc_error ("Fortran 2003: Procedure pointers at %L are " - "not yet implemented in gfortran", where); - return FAILURE; - } a1 = gfc_code2string (flavors, attr->flavor); @@ -619,11 +618,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; case FL_PROCEDURE: - conf2 (intent); + if (!attr->proc_pointer) + conf2 (intent); if (attr->subroutine) { - conf2 (pointer); conf2 (target); conf2 (allocatable); conf2 (result); @@ -866,6 +865,12 @@ gfc_add_external (symbol_attribute *attr, locus *where) return FAILURE; } + if (attr->pointer && attr->if_source != IFSRC_IFBODY) + { + attr->pointer = 0; + attr->proc_pointer = 1; + } + attr->external = 1; return check_conflict (attr, NULL, where); @@ -916,7 +921,20 @@ gfc_add_pointer (symbol_attribute *attr, locus *where) if (check_used (attr, NULL, where)) return FAILURE; - attr->pointer = 1; + if (attr->pointer && !(attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE)) + { + duplicate_attr ("POINTER", where); + return FAILURE; + } + + if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) + || (attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE)) + attr->proc_pointer = 1; + else + attr->pointer = 1; + return check_conflict (attr, NULL, where); } @@ -1641,6 +1659,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE) goto fail; + if (src->proc_pointer) + dest->proc_pointer = 1; return SUCCESS; @@ -3574,7 +3594,7 @@ static void gen_fptr_param (gfc_formal_arglist **head, gfc_formal_arglist **tail, const char *module_name, - gfc_namespace *ns, const char *f_ptr_name) + gfc_namespace *ns, const char *f_ptr_name, int proc) { gfc_symbol *param_sym = NULL; gfc_symtree *param_symtree = NULL; @@ -3593,7 +3613,10 @@ gen_fptr_param (gfc_formal_arglist **head, /* Set up the necessary fields for the fptr output param sym. */ param_sym->refs++; - param_sym->attr.pointer = 1; + if (proc) + param_sym->attr.proc_pointer = 1; + else + param_sym->attr.pointer = 1; param_sym->attr.dummy = 1; param_sym->attr.use_assoc = 1; @@ -3773,21 +3796,23 @@ build_formal_args (gfc_symbol *new_proc_sym, gfc_current_ns->proc_name = new_proc_sym; /* Generate the params. */ - if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) || - (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) + if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) { gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, gfc_current_ns, "cptr", old_sym->intmod_sym_id); gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module, - gfc_current_ns, "fptr"); - + gfc_current_ns, "fptr", 1); + } + else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) + { + gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, + gfc_current_ns, "cptr", old_sym->intmod_sym_id); + gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module, + gfc_current_ns, "fptr", 0); /* If we're dealing with c_f_pointer, it has an optional third arg. */ - if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) - { - gen_shape_param (&head, &tail, - (const char *) new_proc_sym->module, - gfc_current_ns, "shape"); - } + gen_shape_param (&head, &tail,(const char *) new_proc_sym->module, + gfc_current_ns, "shape"); + } else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 686e059ec4e..e960fa026b1 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1104,6 +1104,44 @@ gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save) } +/* Declare a procedure pointer. */ + +static tree +get_proc_pointer_decl (gfc_symbol *sym) +{ + tree decl; + + decl = sym->backend_decl; + if (decl) + return decl; + + decl = build_decl (VAR_DECL, get_identifier (sym->name), + build_pointer_type (gfc_get_function_type (sym))); + + if (sym->ns->proc_name->backend_decl == current_function_decl + || sym->attr.contained) + gfc_add_decl_to_function (decl); + else + gfc_add_decl_to_parent_function (decl); + + sym->backend_decl = decl; + + if (!sym->attr.use_assoc + && (sym->attr.save != SAVE_NONE || sym->attr.data + || (sym->value && sym->ns->proc_name->attr.is_main_program))) + TREE_STATIC (decl) = 1; + + if (TREE_STATIC (decl) && sym->value) + { + /* Add static initializer. */ + DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, + TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer); + } + + return decl; +} + + /* Get a basic decl for an external function. */ tree @@ -1126,6 +1164,9 @@ gfc_get_extern_function_decl (gfc_symbol * sym) to know that. */ gcc_assert (!(sym->attr.entry || sym->attr.entry_master)); + if (sym->attr.proc_pointer) + return get_proc_pointer_decl (sym); + if (sym->attr.intrinsic) { /* Call the resolution function to get the actual name. This is @@ -1540,6 +1581,9 @@ create_function_arglist (gfc_symbol * sym) type = gfc_sym_type (f->sym); } + if (f->sym->attr.proc_pointer) + type = build_pointer_type (type); + /* Build a the argument declaration. */ parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 59a0a2d8eb7..570e07b5a06 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) else if (sym->attr.flavor == FL_PROCEDURE && se->expr != current_function_decl) { - gcc_assert (se->want_pointer); - if (!sym->attr.dummy) + if (!sym->attr.dummy && !sym->attr.proc_pointer) { gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL); se->expr = build_fold_addr_expr (se->expr); @@ -1372,6 +1371,8 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) if (sym->attr.dummy) { tmp = gfc_get_symbol_decl (sym); + if (sym->attr.proc_pointer) + tmp = build_fold_indirect_ref (tmp); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); } @@ -2498,9 +2499,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, else { gfc_conv_expr_reference (&parmse, e); - if (fsym && fsym->attr.pointer - && fsym->attr.flavor != FL_PROCEDURE - && e->expr_type != EXPR_NULL) + if (fsym && e->expr_type != EXPR_NULL + && ((fsym->attr.pointer + && fsym->attr.flavor != FL_PROCEDURE) + || fsym->attr.proc_pointer)) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -3867,6 +3869,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.want_pointer = 1; gfc_conv_expr (&rse, expr2); + + if (expr1->symtree->n.sym->attr.proc_pointer + && expr1->symtree->n.sym->attr.dummy) + lse.expr = build_fold_indirect_ref (lse.expr); + gfc_add_block_to_block (&block, &lse.pre); gfc_add_block_to_block (&block, &rse.pre); gfc_add_modify_expr (&block, lse.expr, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 607cf0fa1f1..78562ce90a1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,18 @@ +2008-07-02 Janus Weil + Tobias Burnus + + PR fortran/32580 + * gfortran.dg/c_f_pointer_tests_3.f90: Updated. + * gfortran.dg/proc_decl_1.f90: Updated. + * gfortran.dg/proc_ptr_1.f90: New. + * gfortran.dg/proc_ptr_2.f90: New. + * gfortran.dg/proc_ptr_3.f90: New. + * gfortran.dg/proc_ptr_4.f90: New. + * gfortran.dg/proc_ptr_5.f90: New. + * gfortran.dg/proc_ptr_6.f90: New. + * gfortran.dg/proc_ptr_7.f90: New. + * gfortran.dg/proc_ptr_8.f90: New. + 2008-07-02 Joseph Myers * gcc.target/arm/neon/polytypes.c: Use dg-message separately from diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 index 525af506428..3b28f52b4e7 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 @@ -14,11 +14,11 @@ program test type(c_funptr) :: cfunptr integer(4), pointer :: fptr integer(4), pointer :: fptr_array(:) -! procedure(integer(4)), pointer :: fprocptr ! TODO + procedure(integer(4)), pointer :: fprocptr call c_f_pointer(cptr, fptr) call c_f_pointer(cptr, fptr_array, [ 1 ]) -! call c_f_procpointer(cfunptr, fprocptr) ! TODO + call c_f_procpointer(cfunptr, fprocptr) end program test ! Make sure there is only a single function call: @@ -30,6 +30,6 @@ end program test ! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } } ! ! Check c_f_procpointer -! TODO { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } } TODO +! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } } ! ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/proc_decl_1.f90 b/gcc/testsuite/gfortran.dg/proc_decl_1.f90 index c01f7c6101e..3e7a3d18fb7 100644 --- a/gcc/testsuite/gfortran.dg/proc_decl_1.f90 +++ b/gcc/testsuite/gfortran.dg/proc_decl_1.f90 @@ -40,8 +40,6 @@ program prog procedure(dcos) :: my1 procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" } - procedure(),pointer:: ptr ! { dg-error "not yet implemented" } - type t procedure(),pointer:: p ! { dg-error "not yet implemented" } end type diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_1.f90 new file mode 100755 index 00000000000..fe8e201000e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_1.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! +! basic tests of PROCEDURE POINTERS +! +! Contributed by Janus Weil + +module m +contains + subroutine proc1(arg) + character (5) :: arg + arg = "proc1" + end subroutine + integer function proc2(arg) + integer, intent(in) :: arg + proc2 = arg**2 + end function + complex function proc3(re, im) + real, intent(in) :: re, im + proc3 = complex (re, im) + end function +end module + +subroutine foo1 +end subroutine + +real function foo2() + foo2=6.3 +end function + +program procPtrTest + use m, only: proc1, proc2, proc3 + character (5) :: str + PROCEDURE(proc1), POINTER :: ptr1 + PROCEDURE(proc2), POINTER :: ptr2 + PROCEDURE(proc3), POINTER :: ptr3 => NULL() + PROCEDURE(REAL), SAVE, POINTER :: ptr4 + PROCEDURE(), POINTER :: ptr5,ptr6 + + EXTERNAL :: foo1,foo2 + real :: foo2 + + if(ASSOCIATED(ptr3)) call abort() + + NULLIFY(ptr1) + if (ASSOCIATED(ptr1)) call abort() + ptr1 => proc1 + if (.not. ASSOCIATED(ptr1)) call abort() + call ptr1 (str) + if (str .ne. "proc1") call abort () + + ptr2 => NULL() + if (ASSOCIATED(ptr2)) call abort() + ptr2 => proc2 + if (.not. ASSOCIATED(ptr2,proc2)) call abort() + if (10*ptr2 (10) .ne. 1000) call abort () + + ptr3 => NULL (ptr3) + if (ASSOCIATED(ptr3)) call abort() + ptr3 => proc3 + if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort () + + ptr4 => cos + if (ptr4(0.0)/=1.0) call abort() + + ptr5 => foo1 + call ptr5() + + ptr6 => foo2 + if (ptr6()/=6.3) call abort() + +end program + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 new file mode 100755 index 00000000000..d19b81d6e47 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! checking invalid code for PROCEDURE POINTERS +! +! Contributed by Janus Weil + +PROCEDURE(REAL), POINTER :: ptr +PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" } + +ptr => cos(4.0) ! { dg-error "Invalid character" } + +ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" } + +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 new file mode 100755 index 00000000000..34d4f1625fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PROCEDURE POINTERS without the PROCEDURE statement +! +! Contributed by Janus Weil + +real function e1(x) + real :: x + print *,'e1!',x + e1 = x * 3.0 +end function + +subroutine e2(a,b) + real, intent(inout) :: a + real, intent(in) :: b + print *,'e2!',a,b + a = a + b +end subroutine + +program proc_ptr_3 + +real, external, pointer :: fp + +pointer :: sp +interface + subroutine sp(a,b) + real, intent(inout) :: a + real, intent(in) :: b + end subroutine sp +end interface + +external :: e1,e2 +real :: c = 1.2 + +fp => e1 + +if (abs(fp(2.5)-7.5)>0.01) call abort() + +sp => e2 + +call sp(c,3.4) + +if (abs(c-4.6)>0.01) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_4.f90 new file mode 100755 index 00000000000..60b9e73af82 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_4.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! PROCEDURE POINTERS & pointer-valued functions +! +! Contributed by Janus Weil + +interface + integer function f1() + end function +end interface + +interface + function f2() + integer, pointer :: f2 + end function +end interface + +interface + function pp1() + integer :: pp1 + end function +end interface +pointer :: pp1 + +pointer :: pp2 +interface + function pp2() + integer :: pp2 + end function +end interface + +pointer :: pp3 +interface + function pp3() + integer, pointer :: pp3 + end function +end interface + +interface + function pp4() + integer, pointer :: pp4 + end function +end interface +pointer :: pp4 + + +pp1 => f1 + +pp2 => pp1 + +f2 => f1 ! { dg-error "is not a variable" } + +pp3 => f2 + +pp4 => pp3 + +end \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_5.f90 new file mode 100755 index 00000000000..61cf8a35d10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_5.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! NULL() initialization for PROCEDURE POINTERS +! +! Contributed by Tobias Burnus + +program main +implicit none +call test(.true.) +call test(.false.) + +contains + +integer function hello() + hello = 42 +end function hello + +subroutine test(first) + logical :: first + integer :: i + procedure(integer), pointer :: x => null() + + if(first) then + if(associated(x)) call abort() + x => hello + else + if(.not. associated(x)) call abort() + i = x() + if(i /= 42) call abort() + end if + end subroutine test + +end program main diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_6.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_6.f90 new file mode 100755 index 00000000000..6a5c7e5f462 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_6.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PROCEDURE POINTERS as actual/formal arguments +! +! Contributed by Janus Weil + +subroutine foo(j) + INTEGER, INTENT(OUT) :: j + j = 6 +end subroutine + +program proc_ptr_6 + +PROCEDURE(),POINTER :: ptr1 +PROCEDURE(REAL),POINTER :: ptr2 +EXTERNAL foo +INTEGER :: k = 0 + +ptr1 => foo +call s_in(ptr1,k) +if (k /= 6) call abort() + +call s_out(ptr2) +if (ptr2(-3.0) /= 3.0) call abort() + +contains + +subroutine s_in(p,i) + PROCEDURE(),POINTER,INTENT(IN) :: p + INTEGER, INTENT(OUT) :: i + call p(i) +end subroutine + +subroutine s_out(p) + PROCEDURE(REAL),POINTER,INTENT(OUT) :: p + p => abs +end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_7.c b/gcc/testsuite/gfortran.dg/proc_ptr_7.c new file mode 100644 index 00000000000..7e9542fd86e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_7.c @@ -0,0 +1,10 @@ +/* Procedure pointer test. Used by proc_ptr_7.f90. + PR fortran/32580. */ + +int f(void) { + return 42; +} + +void assignf_(int(**ptr)(void)) { + *ptr = f; +} diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_7.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_7.f90 new file mode 100644 index 00000000000..8b1ea0a44b3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_7.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-additional-sources proc_ptr_7.c } +! +! PR fortran/32580 +! Procedure pointer test +! +! Contributed by Tobias Burnus + +program proc_pointer_test + use iso_c_binding, only: c_int + implicit none + + interface + subroutine assignF(f) + import c_int + procedure(Integer(c_int)), pointer :: f + end subroutine + end interface + + procedure(Integer(c_int)), pointer :: ptr + + call assignF(ptr) + if(ptr() /= 42) call abort() + + ptr => f55 + if(ptr() /= 55) call abort() + + call foo(ptr) + if(ptr() /= 65) call abort() + +contains + + subroutine foo(a) + procedure(integer(c_int)), pointer :: a + if(a() /= 55) call abort() + a => f65 + if(a() /= 65) call abort() + end subroutine foo + + integer(c_int) function f55() + f55 = 55 + end function f55 + + integer(c_int) function f65() + f65 = 65 + end function f65 +end program proc_pointer_test diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_8.c b/gcc/testsuite/gfortran.dg/proc_ptr_8.c new file mode 100644 index 00000000000..c732ff6667c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_8.c @@ -0,0 +1,14 @@ +/* Used by proc_ptr_8.f90. + PR fortran/32580. */ + +int (*funpointer)(int); + +int f(int t) +{ + return t*3; +} + +void init() +{ + funpointer=f; +} diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_8.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_8.f90 new file mode 100644 index 00000000000..80d26619bc0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_8.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-additional-sources proc_ptr_8.c } +! +! PR fortran/32580 +! Original test case +! +! Contributed by Joost VandeVondele + +MODULE X + + USE ISO_C_BINDING + INTERFACE + INTEGER(KIND=C_INT) FUNCTION mytype( a ) BIND(C) + USE ISO_C_BINDING + INTEGER(KIND=C_INT), VALUE :: a + END FUNCTION + SUBROUTINE init() BIND(C,name="init") + END SUBROUTINE + END INTERFACE + + TYPE(C_FUNPTR), BIND(C,name="funpointer") :: funpointer + +END MODULE X + +USE X +PROCEDURE(mytype), POINTER :: ptype + +CALL init() +CALL C_F_PROCPOINTER(funpointer,ptype) +if (ptype(3) /= 9) call abort() + +END + +! { dg-final { cleanup-modules "X" } }