diff -uNr gcc-4061.orig/gcc/fortran/decl.c gcc-4061/gcc/fortran/decl.c --- gcc-4061.orig/gcc/fortran/decl.c 2004-10-16 06:02:51.000000000 +0900 +++ gcc-4061/gcc/fortran/decl.c 2005-05-28 21:17:44.000000000 +0900 @@ -2350,8 +2350,7 @@ || gfc_add_function (&entry->attr, NULL) == FAILURE) return MATCH_ERROR; - entry->result = proc->result; - + entry->result = entry; } else { @@ -2365,6 +2364,8 @@ || gfc_add_entry (&entry->attr, NULL) == FAILURE || gfc_add_function (&entry->attr, NULL) == FAILURE) return MATCH_ERROR; + + entry->result = result; } if (proc->attr.recursive && result == NULL) diff -uNr gcc-4061.orig/gcc/fortran/gfortran.h gcc-4061/gcc/fortran/gfortran.h --- gcc-4061.orig/gcc/fortran/gfortran.h 2004-11-11 10:14:34.000000000 +0900 +++ gcc-4061/gcc/fortran/gfortran.h 2005-05-28 21:17:44.000000000 +0900 @@ -420,6 +420,9 @@ /* Set if this is the master function for a procedure with multiple entry points. */ unsigned entry_master:1; + /* Set if this is the master function for a function with multiple + entry points where characteristics of the entry points differ. */ + unsigned mixed_entry_master:1; /* Set if a function must always be referenced by an explicit interface. */ unsigned always_explicit:1; diff -uNr gcc-4061.orig/gcc/fortran/resolve.c gcc-4061/gcc/fortran/resolve.c --- gcc-4061.orig/gcc/fortran/resolve.c 2004-11-11 10:14:35.000000000 +0900 +++ gcc-4061/gcc/fortran/resolve.c 2005-05-28 21:29:25.000000000 +0900 @@ -372,7 +372,6 @@ out what is going on. */ snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", master_count++, ns->proc_name->name); - name[GFC_MAX_SYMBOL_LEN] = '\0'; gfc_get_ha_symbol (name, &proc); gcc_assert (proc != NULL); @@ -381,8 +380,93 @@ gfc_add_subroutine (&proc->attr, NULL); else { +#if 0 gfc_add_function (&proc->attr, NULL); gfc_internal_error ("TODO: Functions with alternate entry points"); +#else + gfc_symbol *sym; + gfc_typespec *ts, *fts; + + gfc_add_function (&proc->attr, NULL); + proc->result = proc; + fts = &ns->entries->sym->result->ts; + if (fts->type == BT_UNKNOWN) + fts = gfc_get_default_type (ns->entries->sym->result, NULL); + for (el = ns->entries->next; el; el = el->next) + { + ts = &el->sym->result->ts; + if (ts->type == BT_UNKNOWN) + ts = gfc_get_default_type (el->sym->result, NULL); + if (! gfc_compare_types (ts, fts) + || (el->sym->result->attr.dimension + != ns->entries->sym->result->attr.dimension) + || (el->sym->result->attr.pointer + != ns->entries->sym->result->attr.pointer)) + break; + } + + if (el == NULL) + { + sym = ns->entries->sym->result; + /* All result types the same. */ + proc->ts = *fts; + if (sym->attr.dimension) + gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); + if (sym->attr.pointer) + gfc_add_pointer (&proc->attr, NULL); + } + else + { + /* Otherwise the result will be passed through an union by + reference. */ + proc->attr.mixed_entry_master = 1; + for (el = ns->entries; el; el = el->next) + { + sym = el->sym->result; + if (sym->attr.dimension) + gfc_error ("%s result %s can't be an array in FUNCTION %s at %L", + el == ns->entries ? "FUNCTION" : "ENTRY", sym->name, + ns->entries->sym->name, &sym->declared_at); + else if (sym->attr.pointer) + gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L", + el == ns->entries ? "FUNCTION" : "ENTRY", sym->name, + ns->entries->sym->name, &sym->declared_at); + else + { + ts = &sym->ts; + if (ts->type == BT_UNKNOWN) + ts = gfc_get_default_type (sym, NULL); + switch (ts->type) + { + case BT_INTEGER: + if (ts->kind == gfc_default_integer_kind) + sym = NULL; + break; + case BT_REAL: + if (ts->kind == gfc_default_real_kind + || ts->kind == gfc_default_double_kind) + sym = NULL; + break; + case BT_COMPLEX: + if (ts->kind == gfc_default_complex_kind) + sym = NULL; + break; + case BT_LOGICAL: + if (ts->kind == gfc_default_logical_kind) + sym = NULL; + break; + default: + break; + } + if (sym) + gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L", + el == ns->entries ? "FUNCTION" : "ENTRY", sym->name, + gfc_typename (ts), ns->entries->sym->name, + &sym->declared_at); + } + } + } +#endif } proc->attr.access = ACCESS_PRIVATE; proc->attr.entry_master = 1; diff -uNr gcc-4061.orig/gcc/fortran/trans-array.c gcc-4061/gcc/fortran/trans-array.c --- gcc-4061.orig/gcc/fortran/trans-array.c 2004-11-11 10:14:35.000000000 +0900 +++ gcc-4061/gcc/fortran/trans-array.c 2005-05-28 21:17:44.000000000 +0900 @@ -3414,7 +3414,9 @@ /* Only do the entry/initialization code if the arg is present. */ dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master; + optional_arg = (sym->attr.optional + || (sym->ns->proc_name->attr.entry_master + && sym->attr.dummy)); if (optional_arg) { tmp = gfc_conv_expr_present (sym); diff -uNr gcc-4061.orig/gcc/fortran/trans-decl.c gcc-4061/gcc/fortran/trans-decl.c --- gcc-4061.orig/gcc/fortran/trans-decl.c 2004-11-11 10:14:36.000000000 +0900 +++ gcc-4061/gcc/fortran/trans-decl.c 2005-05-28 21:17:45.000000000 +0900 @@ -716,6 +716,10 @@ { sym->backend_decl = DECL_ARGUMENTS (sym->ns->proc_name->backend_decl); + /* For entry master function skip over the __entry + argument. */ + if (sym->ns->proc_name->attr.entry_master) + sym->backend_decl = TREE_CHAIN (sym->backend_decl); } /* Dummy variables should already have been created. */ @@ -1348,12 +1352,24 @@ args = tree_cons (NULL_TREE, tmp, NULL_TREE); string_args = NULL_TREE; - /* TODO: Pass return by reference parameters. */ - if (ns->proc_name->attr.function) - gfc_todo_error ("Functons with multiple entry points"); - + if (thunk_sym->attr.function) + { + if (gfc_return_by_reference (ns->proc_name)) + { + tree ref = DECL_ARGUMENTS (current_function_decl); + args = tree_cons (NULL_TREE, ref, args); + if (ns->proc_name->ts.type == BT_CHARACTER) + args = tree_cons (NULL_TREE, TREE_CHAIN (ref), + args); + } + } + for (formal = ns->proc_name->formal; formal; formal = formal->next) { + /* Ignore alternate returns. */ + if (formal->sym == NULL) + continue; + /* We don't have a clever way of identifying arguments, so resort to a brute-force search. */ for (thunk_formal = thunk_sym->formal; @@ -1392,7 +1408,47 @@ args = chainon (args, nreverse (string_args)); tmp = ns->proc_name->backend_decl; tmp = gfc_build_function_call (tmp, args); - /* TODO: function return value. */ + if (ns->proc_name->attr.mixed_entry_master) + { + tree union_decl, field; + tree master_type = TREE_TYPE (ns->proc_name->backend_decl); + + union_decl = build_decl (VAR_DECL, get_identifier ("__result"), + TREE_TYPE (master_type)); + DECL_ARTIFICIAL (union_decl) = 1; + DECL_EXTERNAL (union_decl) = 0; + TREE_PUBLIC (union_decl) = 0; + TREE_USED (union_decl) = 1; + layout_decl (union_decl, 0); + pushdecl (union_decl); + + DECL_CONTEXT (union_decl) = current_function_decl; + tmp = build2 (MODIFY_EXPR, + TREE_TYPE (union_decl), + union_decl, tmp); + gfc_add_expr_to_block (&body, tmp); + + for (field = TYPE_FIELDS (TREE_TYPE (union_decl)); + field; field = TREE_CHAIN (field)) + if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), + thunk_sym->result->name) == 0) + break; + gcc_assert (field != NULL_TREE); + tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field, + NULL_TREE); + tmp = build2 (MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (current_function_decl)), + DECL_RESULT (current_function_decl), tmp); + tmp = build1_v (RETURN_EXPR, tmp); + } + else if (TREE_TYPE (DECL_RESULT (current_function_decl)) + != void_type_node) + { + tmp = build2 (MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (current_function_decl)), + DECL_RESULT (current_function_decl), tmp); + tmp = build1_v (RETURN_EXPR, tmp); + } gfc_add_expr_to_block (&body, tmp); /* Finish off this function and send it for code generation. */ @@ -1421,10 +1477,19 @@ points and the master function. Clear them so that they are recreated for each function. */ for (formal = thunk_sym->formal; formal; formal = formal->next) + if (formal->sym != NULL) /* Ignore alternate returns. */ + { + formal->sym->backend_decl = NULL_TREE; + if (formal->sym->ts.type == BT_CHARACTER) + formal->sym->ts.cl->backend_decl = NULL_TREE; + } + + if (thunk_sym->attr.function) { - formal->sym->backend_decl = NULL_TREE; - if (formal->sym->ts.type == BT_CHARACTER) - formal->sym->ts.cl->backend_decl = NULL_TREE; + if (thunk_sym->ts.type == BT_CHARACTER) + thunk_sym->ts.cl->backend_decl = NULL_TREE; + if (thunk_sym->result->ts.type == BT_CHARACTER) + thunk_sym->result->ts.cl->backend_decl = NULL_TREE; } } @@ -1459,6 +1524,29 @@ char name[GFC_MAX_SYMBOL_LEN + 10]; + if (sym + && sym->ns->proc_name->backend_decl == current_function_decl + && sym->ns->proc_name->attr.mixed_entry_master + && sym != sym->ns->proc_name) + { + decl = gfc_get_fake_result_decl (sym->ns->proc_name); + if (decl) + { + tree field; + + for (field = TYPE_FIELDS (TREE_TYPE (decl)); + field; field = TREE_CHAIN (field)) + if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), + sym->name) == 0) + break; + + gcc_assert (field != NULL_TREE); + decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, + NULL_TREE); + } + return decl; + } + if (current_fake_result_decl != NULL_TREE) return current_fake_result_decl; @@ -1476,7 +1564,11 @@ if (gfc_return_by_reference (sym)) { - decl = DECL_ARGUMENTS (sym->backend_decl); + decl = DECL_ARGUMENTS (current_function_decl); + + if (sym->ns->proc_name->backend_decl == current_function_decl + && sym->ns->proc_name->attr.entry_master) + decl = TREE_CHAIN (decl); TREE_USED (decl) = 1; if (sym->as) @@ -1893,11 +1985,17 @@ { if (!current_fake_result_decl) { - warning ("Function does not return a value"); - return fnbody; + gfc_entry_list *el = NULL; + if (proc_sym->attr.entry_master) + { + for (el = proc_sym->ns->entries; el; el = el->next) + if (el->sym != el->sym->result) + break; + } + if (el == NULL) + warning (0, "Function does not return a value"); } - - if (proc_sym->as) + else if (proc_sym->as) { fnbody = gfc_trans_dummy_array_bias (proc_sym, current_fake_result_decl, @@ -2186,6 +2284,19 @@ gfc_generate_contained_functions (ns); + if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) + { + /* Copy length backend_decls to all entry point result + symbols. */ + gfc_entry_list *el; + tree backend_decl; + + gfc_conv_const_charlen (ns->proc_name->ts.cl); + backend_decl = ns->proc_name->result->ts.cl->backend_decl; + for (el = ns->entries; el; el = el->next) + el->sym->result->ts.cl->backend_decl = backend_decl; + } + /* Translate COMMON blocks. */ gfc_trans_common (ns); diff -uNr gcc-4061.orig/gcc/fortran/trans-expr.c gcc-4061/gcc/fortran/trans-expr.c --- gcc-4061.orig/gcc/fortran/trans-expr.c 2004-11-11 10:14:36.000000000 +0900 +++ gcc-4061/gcc/fortran/trans-expr.c 2005-05-28 21:17:45.000000000 +0900 @@ -310,11 +310,43 @@ } else { + tree se_expr = NULL_TREE; + se->expr = gfc_get_symbol_decl (sym); + /* Special case for assigning the return value of a function. + Self recursive functions must have an explicit return value. */ + if (se->expr == current_function_decl && sym->attr.function + && (sym->result == sym)) + se_expr = gfc_get_fake_result_decl (sym); + + /* Similarly for alternate entry points. */ + else if (sym->attr.function && sym->attr.entry + && (sym->result == sym) + && sym->ns->proc_name->backend_decl == current_function_decl) + { + gfc_entry_list *el = NULL; + + for (el = sym->ns->entries; el; el = el->next) + if (sym == el->sym) + { + se_expr = gfc_get_fake_result_decl (sym); + break; + } + } + + else if (sym->attr.result + && sym->ns->proc_name->backend_decl == current_function_decl + && sym->ns->proc_name->attr.entry_master + && !gfc_return_by_reference (sym->ns->proc_name)) + se_expr = gfc_get_fake_result_decl (sym); + + if (se_expr) + se->expr = se_expr; + /* Procedure actual arguments. */ - if (sym->attr.flavor == FL_PROCEDURE - && se->expr != current_function_decl) + else if (sym->attr.flavor == FL_PROCEDURE + && se->expr != current_function_decl) { gcc_assert (se->want_pointer); if (!sym->attr.dummy) @@ -325,14 +357,6 @@ return; } - /* Special case for assigning the return value of a function. - Self recursive functions must have an explicit return value. */ - if (se->expr == current_function_decl && sym->attr.function - && (sym->result == sym)) - { - se->expr = gfc_get_fake_result_decl (sym); - } - /* Dereference scalar dummy variables. */ if (sym->attr.dummy && sym->ts.type != BT_CHARACTER diff -uNr gcc-4061.orig/gcc/fortran/trans-types.c gcc-4061/gcc/fortran/trans-types.c --- gcc-4061.orig/gcc/fortran/trans-types.c 2004-10-16 06:02:54.000000000 +0900 +++ gcc-4061/gcc/fortran/trans-types.c 2005-05-28 21:17:45.000000000 +0900 @@ -1448,6 +1448,50 @@ return 0; } +static tree +gfc_get_mixed_entry_union (gfc_namespace *ns) +{ + tree type; + tree decl; + tree fieldlist; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_entry_list *el, *el2; + + gcc_assert (ns->proc_name->attr.mixed_entry_master); + gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0); + + snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7); + + /* Build the type node. */ + type = make_node (UNION_TYPE); + + TYPE_NAME (type) = get_identifier (name); + fieldlist = NULL; + + for (el = ns->entries; el; el = el->next) + { + /* Search for duplicates. */ + for (el2 = ns->entries; el2 != el; el2 = el2->next) + if (el2->sym->result == el->sym->result) + break; + + if (el == el2) + { + decl = build_decl (FIELD_DECL, + get_identifier (el->sym->result->name), + gfc_sym_type (el->sym->result)); + DECL_CONTEXT (decl) = type; + fieldlist = chainon (fieldlist, decl); + } + } + + /* Finish off the type. */ + TYPE_FIELDS (type) = fieldlist; + + gfc_finish_type (type); + return type; +} + tree gfc_get_function_type (gfc_symbol * sym) { @@ -1550,6 +1594,8 @@ type = integer_type_node; else if (!sym->attr.function || gfc_return_by_reference (sym)) type = void_type_node; + else if (sym->attr.mixed_entry_master) + type = gfc_get_mixed_entry_union (sym->ns); else type = gfc_sym_type (sym); diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.dg/entry_4.f90 gcc-4061/gcc/testsuite/gfortran.dg/entry_4.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.dg/entry_4.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.dg/entry_4.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,28 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +function f1 () result (r) ! { dg-error "can't be a POINTER" } +integer, pointer :: r +real e1 +allocate (r) +r = 6 +return +entry e1 () +e1 = 12 +entry e1a () +e1a = 13 +end function +function f2 () +integer, dimension (2, 7, 6) :: e2 ! { dg-error "can't be an array" } +f2 = 6 +return +entry e2 () +e2 (:, :, :) = 2 +end function +integer*8 function f3 () ! { dg-error "can't be of type" } +complex*16 e3 ! { dg-error "can't be of type" } +f3 = 1 +return +entry e3 () +e3 = 2 +entry e3a () +e3a = 3 +end function diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,74 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer a, b, f1, e1 + f1 = 15 + a + return + entry e1 (b) + e1 = 42 + b + end function + function f2 () + real f2, e2 + entry e2 () + e2 = 45 + end function + function f3 () + double precision a, b, f3, e3 + entry e3 () + f3 = 47 + end function + function f4 (a) result (r) + double precision a, b, r, s + r = 15 + a + return + entry e4 (b) result (s) + s = 42 + b + end function + function f5 () result (r) + integer r, s + entry e5 () result (s) + r = 45 + end function + function f6 () result (r) + real r, s + entry e6 () result (s) + s = 47 + end function + function f7 () + entry e7 () + e7 = 163 + end function + function f8 () result (r) + entry e8 () + e8 = 115 + end function + function f9 () + entry e9 () result (r) + r = 119 + end function + + program entrytest + integer f1, e1, f5, e5 + real f2, e2, f6, e6, f7, e7, f8, e8, f9, e9 + double precision f3, e3, f4, e4, d + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 () .ne. 45) call abort () + if (e2 () .ne. 45) call abort () + if (f3 () .ne. 47) call abort () + if (e3 () .ne. 47) call abort () + d = 17 + if (f4 (d) .ne. 32) call abort () + if (e4 (d) .ne. 59) call abort () + if (f5 () .ne. 45) call abort () + if (e5 () .ne. 45) call abort () + if (f6 () .ne. 47) call abort () + if (e6 () .ne. 47) call abort () + if (f7 () .ne. 163) call abort () + if (e7 () .ne. 163) call abort () + if (f8 () .ne. 115) call abort () + if (e8 () .ne. 115) call abort () + if (f9 () .ne. 119) call abort () + if (e9 () .ne. 119) call abort () + end diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,51 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + character*(*) function f1 (str, i, j) + character str*(*), e1*(*), e2*(*) + integer i, j + f1 = str (i:j) + return + entry e1 (str, i, j) + i = i + 1 + entry e2 (str, i, j) + j = j - 1 + e2 = str (i:j) + end function + + character*5 function f3 () + character e3*(*), e4*(*) + integer i + f3 = 'ABCDE' + return + entry e3 (i) + entry e4 (i) + if (i .gt. 0) then + e3 = 'abcde' + else + e4 = 'UVWXY' + endif + end function + + program entrytest + character f1*16, e1*16, e2*16, str*16, ret*16 + character f3*5, e3*5, e4*5 + integer i, j + str = 'ABCDEFGHIJ' + i = 2 + j = 6 + ret = f1 (str, i, j) + if ((i .ne. 2) .or. (j .ne. 6)) call abort () + if (ret .ne. 'BCDEF') call abort () + ret = e1 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 5)) call abort () + if (ret .ne. 'CDE') call abort () + ret = e2 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 4)) call abort () + if (ret .ne. 'CD') call abort () + if (f3 () .ne. 'ABCDE') call abort () + if (e3 (1) .ne. 'abcde') call abort () + if (e4 (1) .ne. 'abcde') call abort () + if (e3 (0) .ne. 'UVWXY') call abort () + if (e4 (0) .ne. 'UVWXY') call abort () + end program diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,40 @@ + subroutine f1 (n, *, i) + integer n, i + if (i .ne. 42) call abort () + entry e1 (n, *) + if (n .eq. 1) return 1 + if (n .eq. 2) return + return + entry e2 (n, i, *, *, *) + if (i .ne. 46) call abort () + if (n .ge. 4) return + return n + entry e3 (n, i) + if ((i .ne. 48) .or. (n .ne. 61)) call abort () + end subroutine + + program alt_return + implicit none + + call f1 (1, *10, 42) +20 continue + call abort () +10 continue + call f1 (2, *20, 42) + call f1 (3, *20, 42) + call e1 (2, *20) + call e1 (1, *30) + call abort () +30 continue + call e2 (1, 46, *40, *20, *20) + call abort () +40 continue + call e2 (2, 46, *20, *50, *20) + call abort () +50 continue + call e2 (3, 46, *20, *20, *60) + call abort () +60 continue + call e2 (4, 46, *20, *20, *20) + call e3 (61, 48) + end program diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,64 @@ +! Test alternate entry points for functions when the result types +! of all entry points don't match + + integer function f1 (a) + integer a, b + double precision e1 + f1 = 15 + a + return + entry e1 (b) + e1 = 42 + b + end function + complex function f2 (a) + integer a + logical e2 + entry e2 (a) + if (a .gt. 0) then + e2 = a .lt. 46 + else + f2 = 45 + endif + end function + function f3 (a) result (r) + integer a, b + real r + logical s + complex c + r = 15 + a + return + entry e3 (b) result (s) + s = b .eq. 42 + return + entry g3 (b) result (c) + c = b + 11 + end function + function f4 (a) result (r) + logical r + integer a, s + double precision t + entry e4 (a) result (s) + entry g4 (a) result (t) + r = a .lt. 0 + if (a .eq. 0) s = 16 + a + if (a .gt. 0) t = 17 + a + end function + + program entrytest + integer f1, e4 + real f3 + double precision e1, g4 + logical e2, e3, f4 + complex f2, g3 + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 (0) .ne. 45) call abort () + if (.not. e2 (45)) call abort () + if (e2 (46)) call abort () + if (f3 (17) .ne. 32) call abort () + if (.not. e3 (42)) call abort () + if (e3 (41)) call abort () + if (g3 (12) .ne. 23) call abort () + if (.not. f4 (-5)) call abort () + if (e4 (0) .ne. 16) call abort () + if (g4 (2) .ne. 19) call abort () + end diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,51 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (str, i, j) result (r) + character str*(*), r1*(*), r2*(*), r*(*) + integer i, j + r = str (i:j) + return + entry e1 (str, i, j) result (r1) + i = i + 1 + entry e2 (str, i, j) result (r2) + j = j - 1 + r2 = str (i:j) + end function + + function f3 () result (r) + character r3*5, r4*5, r*5 + integer i + r = 'ABCDE' + return + entry e3 (i) result (r3) + entry e4 (i) result (r4) + if (i .gt. 0) then + r3 = 'abcde' + else + r4 = 'UVWXY' + endif + end function + + program entrytest + character f1*16, e1*16, e2*16, str*16, ret*16 + character f3*5, e3*5, e4*5 + integer i, j + str = 'ABCDEFGHIJ' + i = 2 + j = 6 + ret = f1 (str, i, j) + if ((i .ne. 2) .or. (j .ne. 6)) call abort () + if (ret .ne. 'BCDEF') call abort () + ret = e1 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 5)) call abort () + if (ret .ne. 'CDE') call abort () + ret = e2 (str, i, j) + if ((i .ne. 3) .or. (j .ne. 4)) call abort () + if (ret .ne. 'CD') call abort () + if (f3 () .ne. 'ABCDE') call abort () + if (e3 (1) .ne. 'abcde') call abort () + if (e4 (1) .ne. 'abcde') call abort () + if (e3 (0) .ne. 'UVWXY') call abort () + if (e4 (0) .ne. 'UVWXY') call abort () + end program diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,109 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer, dimension (2, 2) :: a, b, f1, e1 + f1 (:, :) = 15 + a (1, 1) + return + entry e1 (b) + e1 (:, :) = 42 + b (1, 1) + end function + function f2 () + real, dimension (2, 2) :: f2, e2 + entry e2 () + e2 (:, :) = 45 + end function + function f3 () + double precision, dimension (2, 2) :: a, b, f3, e3 + entry e3 () + f3 (:, :) = 47 + end function + function f4 (a) result (r) + double precision, dimension (2, 2) :: a, b, r, s + r (:, :) = 15 + a (1, 1) + return + entry e4 (b) result (s) + s (:, :) = 42 + b (1, 1) + end function + function f5 () result (r) + integer, dimension (2, 2) :: r, s + entry e5 () result (s) + r (:, :) = 45 + end function + function f6 () result (r) + real, dimension (2, 2) :: r, s + entry e6 () result (s) + s (:, :) = 47 + end function + + program entrytest + interface + function f1 (a) + integer, dimension (2, 2) :: a, f1 + end function + function e1 (b) + integer, dimension (2, 2) :: b, e1 + end function + function f2 () + real, dimension (2, 2) :: f2 + end function + function e2 () + real, dimension (2, 2) :: e2 + end function + function f3 () + double precision, dimension (2, 2) :: f3 + end function + function e3 () + double precision, dimension (2, 2) :: e3 + end function + function f4 (a) + double precision, dimension (2, 2) :: a, f4 + end function + function e4 (b) + double precision, dimension (2, 2) :: b, e4 + end function + function f5 () + integer, dimension (2, 2) :: f5 + end function + function e5 () + integer, dimension (2, 2) :: e5 + end function + function f6 () + real, dimension (2, 2) :: f6 + end function + function e6 () + real, dimension (2, 2) :: e6 + end function + end interface + integer, dimension (2, 2) :: i, j + real, dimension (2, 2) :: r + double precision, dimension (2, 2) :: d, e + i (:, :) = 6 + j = f1 (i) + if (any (j .ne. 21)) call abort () + i (:, :) = 7 + j = e1 (i) + j (:, :) = 49 + if (any (j .ne. 49)) call abort () + r = f2 () + if (any (r .ne. 45)) call abort () + r = e2 () + if (any (r .ne. 45)) call abort () + e = f3 () + if (any (e .ne. 47)) call abort () + e = e3 () + if (any (e .ne. 47)) call abort () + d (:, :) = 17 + e = f4 (d) + if (any (e .ne. 32)) call abort () + e = e4 (d) + if (any (e .ne. 59)) call abort () + j = f5 () + if (any (j .ne. 45)) call abort () + j = e5 () + if (any (j .ne. 45)) call abort () + r = f6 () + if (any (r .ne. 47)) call abort () + r = e6 () + if (any (r .ne. 47)) call abort () + end diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,106 @@ +! Test alternate entry points for functions when the result types +! of all entry points match + + function f1 (a) + integer a, b + integer, pointer :: f1, e1 + allocate (f1) + f1 = 15 + a + return + entry e1 (b) + allocate (e1) + e1 = 42 + b + end function + function f2 () + real, pointer :: f2, e2 + entry e2 () + allocate (e2) + e2 = 45 + end function + function f3 () + double precision, pointer :: f3, e3 + entry e3 () + allocate (f3) + f3 = 47 + end function + function f4 (a) result (r) + double precision a, b + double precision, pointer :: r, s + allocate (r) + r = 15 + a + return + entry e4 (b) result (s) + allocate (s) + s = 42 + b + end function + function f5 () result (r) + integer, pointer :: r, s + entry e5 () result (s) + allocate (r) + r = 45 + end function + function f6 () result (r) + real, pointer :: r, s + entry e6 () result (s) + allocate (s) + s = 47 + end function + + program entrytest + interface + function f1 (a) + integer a + integer, pointer :: f1 + end function + function e1 (b) + integer b + integer, pointer :: e1 + end function + function f2 () + real, pointer :: f2 + end function + function e2 () + real, pointer :: e2 + end function + function f3 () + double precision, pointer :: f3 + end function + function e3 () + double precision, pointer :: e3 + end function + function f4 (a) + double precision a + double precision, pointer :: f4 + end function + function e4 (b) + double precision b + double precision, pointer :: e4 + end function + function f5 () + integer, pointer :: f5 + end function + function e5 () + integer, pointer :: e5 + end function + function f6 () + real, pointer :: f6 + end function + function e6 () + real, pointer :: e6 + end function + end interface + double precision d + if (f1 (6) .ne. 21) call abort () + if (e1 (7) .ne. 49) call abort () + if (f2 () .ne. 45) call abort () + if (e2 () .ne. 45) call abort () + if (f3 () .ne. 47) call abort () + if (e3 () .ne. 47) call abort () + d = 17 + if (f4 (d) .ne. 32) call abort () + if (e4 (d) .ne. 59) call abort () + if (f5 () .ne. 45) call abort () + if (e5 () .ne. 45) call abort () + if (f6 () .ne. 47) call abort () + if (e6 () .ne. 47) call abort () + end diff -uNr gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 --- gcc-4061.orig/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 2005-05-28 21:17:45.000000000 +0900 +++ gcc-4061/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 2005-05-28 21:17:45.000000000 +0900 @@ -0,0 +1,24 @@ +module m +type t + integer i + real x (5) +end type t +end module m + +function f (i) + use m + type (t) :: f,g + f % i = i + return + entry g (x) + g%x = x +end function f + +use m +type (t) :: f, g, res + +res = f (42) +if (res%i /= 42) call abort () +res = g (1.) +if (any (res%x /= 1.)) call abort () +end