diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 21 | ||||
| -rw-r--r-- | gcc/fortran/Make-lang.in | 4 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 7 |
8 files changed, 58 insertions, 12 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 732b0f7a497..819113b3802 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,24 @@ +2008-12-02 Jakub Jelinek <jakub@redhat.com> + Diego Novillo <dnovillo@google.com> + + * Make-lang.in (install-finclude-dir): Use mkinstalldirs + and don't remove the finclude directory beforehand. + +2008-12-02 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36704 + PR fortran/38290 + * decl.c (match_result): Result may be a standard variable or a + procedure pointer. + * expr.c (gfc_check_pointer_assign): Additional checks for procedure + pointer assignments. + * primary.c (gfc_match_rvalue): Bugfix for procedure pointer + assignments. + * resolve.c (resolve_function): Check for attr.subroutine. + * symbol.c (check_conflict): Addtional checks for RESULT statements. + * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure + pointers as function result. + 2008-12-01 Mikael Morin <mikael.morin@tele2.fr> PR fortran/38252 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 0335a212144..62887329347 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -211,9 +211,7 @@ doc/gfc-internals.pdf: $(GFC_INTERNALS_TEXI) # Create or recreate the gfortran private include file directory. install-finclude-dir: installdirs - -rm -rf $(DESTDIR)$(libsubdir)/finclude - mkdir $(DESTDIR)$(libsubdir)/finclude - -chmod a+rx $(DESTDIR)$(libsubdir)/finclude + $(mkinstalldirs) -m a+rx $(DESTDIR)$(libsubdir)/finclude # # Install hooks: # f951 is installed elsewhere as part of $(COMPILERS). diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 14ccb6081a8..f6677fe42e0 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3974,8 +3974,7 @@ match_result (gfc_symbol *function, gfc_symbol **result) if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; - if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE - || gfc_add_result (&r->attr, r->name, NULL) == FAILURE) + if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 4017cf91f33..b94e5ac0b87 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3112,9 +3112,30 @@ 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. */ + /* Checks on rvalue for procedure pointer assignments. */ if (lvalue->symtree->n.sym->attr.proc_pointer) - return SUCCESS; + { + attr = gfc_expr_attr (rvalue); + if (!((rvalue->expr_type == EXPR_NULL) + || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) + || (rvalue->expr_type == EXPR_VARIABLE + && attr.flavor == FL_PROCEDURE))) + { + gfc_error ("Invalid procedure pointer assignment at %L", + &rvalue->where); + return FAILURE; + } + if (rvalue->expr_type == EXPR_VARIABLE + && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN + && !gfc_compare_interfaces (lvalue->symtree->n.sym, + rvalue->symtree->n.sym, 0)) + { + gfc_error ("Interfaces don't match " + "in procedure pointer assignment at %L", &rvalue->where); + return FAILURE; + } + return SUCCESS; + } if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index f3e1b038918..032fa9024b4 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2509,11 +2509,10 @@ gfc_match_rvalue (gfc_expr **result) if (gfc_matching_procptr_assignment) { gfc_gobble_whitespace (); - if (sym->attr.function && gfc_peek_ascii_char () == '(') + if (gfc_peek_ascii_char () == '(') /* Parse functions returning a procptr. */ goto function0; - if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE; if (gfc_is_intrinsic (sym, 0, gfc_current_locus) || gfc_is_intrinsic (sym, 1, gfc_current_locus)) sym->attr.intrinsic = 1; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6ccbe12859a..0b6fe4c13a9 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2327,7 +2327,7 @@ resolve_function (gfc_expr *expr) return FAILURE; } - if (sym && sym->attr.flavor == FL_VARIABLE) + if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) { gfc_error ("'%s' at %L is not a function", sym->name, &expr->where); return FAILURE; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 4e81b89e2b0..7c79ef80afa 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -618,7 +618,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; case FL_VARIABLE: + break; + case FL_NAMELIST: + conf2 (result); break; case FL_PROCEDURE: @@ -672,6 +675,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (result); if (attr->intent != INTENT_UNKNOWN) { @@ -698,6 +702,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); + conf2 (result); break; default: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index de629646ec8..e1ff5aadde5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1613,8 +1613,8 @@ gfc_sym_type (gfc_symbol * sym) tree type; int byref; - /* Procedure Pointers inside COMMON blocks. */ - if (sym->attr.proc_pointer && sym->attr.in_common) + /* Procedure Pointers inside COMMON blocks or as function result. */ + if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result)) { /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ sym->attr.proc_pointer = 0; @@ -2143,6 +2143,9 @@ gfc_get_function_type (gfc_symbol * sym) type = gfc_typenode_for_spec (&sym->ts); sym->ts.kind = gfc_default_real_kind; } + else if (sym->result && sym->result->attr.proc_pointer) + /* Procedure pointer return values. */ + type = gfc_sym_type (sym->result); else type = gfc_sym_type (sym); |