Skip to content

R
riscv-gcc-1
Commit cadddfdd by Tobias Burnus Committed by Tobias Burnus
Options

re PR fortran/38536 (ICE with C_LOC in resolve.c due to not properly going through expr->ref) 

2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * check.c (gfc_var_strlen): Properly handle 0-sized string.
        (gfc_check_c_sizeof): Use is_c_interoperable, add checks.
        (is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
        functions.
        * expr.c (check_inquiry): Add c_sizeof, compiler_version and
        compiler_options.
        (gfc_check_pointer_assign): Refine function result check.
        gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
        GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
        GFC_ISYM_C_LOC.
        (iso_fortran_env_symbol, iso_c_binding_symbol): Handle
        NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Update prototype.
        (get_iso_c_sym): Remove.
        (gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
        * intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
        (gfc_intrinsic_sub_interface): Use it.
        (add_functions, add_subroutines): Add missing C-binding intrinsics.
        (gfc_intrinsic_func_interface): Add special case for c_loc.
        gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
        (gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
        * intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
        gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
        * iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
        functions.
        * iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
        NAMED_FUNCTION.
        * iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
        * module.c (create_intrinsic_function): Support subroutines and
        derived-type results.
        (use_iso_fortran_env_module): Update calls.
        (import_iso_c_binding_module): Ditto; update calls to
        generate_isocbinding_symbol.
        * resolve.c (find_arglists): Skip for intrinsic symbols.
        (gfc_resolve_intrinsic): Find intrinsic subs via id.
        (is_scalar_expr_ptr, gfc_iso_c_func_interface,
        set_name_and_label, gfc_iso_c_sub_interface): Remove.
        (resolve_function, resolve_specific_s0): Remove calls to those.
        (resolve_structure_cons): Fix handling.
        * symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
        generation.
        (gen_cptr_param, gen_fptr_param, gen_shape_param,
        build_formal_args, get_iso_c_sym): Remove.
        (std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Support hidden symbols and
        using c_ptr/c_funptr symtrees for nullptr defs.
        * target-memory.c (gfc_target_encode_expr): Fix handling
        of c_ptr/c_funptr.
        * trans-expr.c (conv_isocbinding_procedure): Remove.
        (gfc_conv_procedure_call): Remove call to it.
        (gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
        of c_ptr/c_funptr.
        * trans-intrinsic.c (conv_isocbinding_function,
        conv_isocbinding_subroutine): New.
        (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
        Call them.
        * trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
        * trans-types.c (gfc_typenode_for_spec,
        gfc_get_derived_type): Ditto.
        (gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.

2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * gfortran.dg/c_assoc_2.f03: Update dg-error wording.
        * gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
        * gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
        * gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
        * gfortran.dg/c_funloc_tests_2.f03: Ditto.
        * gfortran.dg/c_funloc_tests_5.f03: Ditto.
        * gfortran.dg/c_funloc_tests_6.f90: Ditto.
        * gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
        * gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
        * gfortran.dg/c_loc_tests_16.f90: Ditto.
        * gfortran.dg/c_loc_tests_4.f03: Ditto.
        * gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
        * gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
        * gfortran.dg/c_loc_tests_8.f03: Ditto.
        * gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
        * gfortran.dg/c_ptr_tests_15.f90: Ditto.
        * gfortran.dg/c_sizeof_1.f90: Fix invalid code.
        * gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
        * gfortran.dg/pr32601_1.f03: Ditto.
        * gfortran.dg/storage_size_2.f08: Remove dg-error.
        * gfortran.dg/blockdata_7.f90: New.
        * gfortran.dg/c_assoc_4.f90: New.
        * gfortran.dg/c_f_pointer_tests_6.f90: New.
        * gfortran.dg/c_f_pointer_tests_7.f90: New.
        * gfortran.dg/c_funloc_tests_8.f90: New.
        * gfortran.dg/c_loc_test_17.f90: New.
        * gfortran.dg/c_loc_test_18.f90: New.
        * gfortran.dg/c_loc_test_19.f90: New.
        * gfortran.dg/c_loc_test_20.f90: New.
        * gfortran.dg/c_sizeof_5.f90: New.
        * gfortran.dg/iso_c_binding_rename_3.f90: New.
        * gfortran.dg/transfer_resolve_2.f90: New.
        * gfortran.dg/transfer_resolve_3.f90: New.
        * gfortran.dg/transfer_resolve_4.f90: New.
        * gfortran.dg/pr32601.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_9.f03: Fix test case.

From-SVN: r197053
parent a5a4c20a
Showing with 963 additions and 347 deletions
gcc/fortran/ChangeLog
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* check.c (gfc_var_strlen): Properly handle 0-sized string.
(gfc_check_c_sizeof): Use is_c_interoperable, add checks.
(is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
functions.
* expr.c (check_inquiry): Add c_sizeof, compiler_version and
compiler_options.
(gfc_check_pointer_assign): Refine function result check.
gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
GFC_ISYM_C_LOC.
(iso_fortran_env_symbol, iso_c_binding_symbol): Handle
NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Update prototype.
(get_iso_c_sym): Remove.
(gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
* intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
(gfc_intrinsic_sub_interface): Use it.
(add_functions, add_subroutines): Add missing C-binding intrinsics.
(gfc_intrinsic_func_interface): Add special case for c_loc.
gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
(gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
* intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
* iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
functions.
* iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
NAMED_FUNCTION.
* iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
* module.c (create_intrinsic_function): Support subroutines and
derived-type results.
(use_iso_fortran_env_module): Update calls.
(import_iso_c_binding_module): Ditto; update calls to
generate_isocbinding_symbol.
* resolve.c (find_arglists): Skip for intrinsic symbols.
(gfc_resolve_intrinsic): Find intrinsic subs via id.
(is_scalar_expr_ptr, gfc_iso_c_func_interface,
set_name_and_label, gfc_iso_c_sub_interface): Remove.
(resolve_function, resolve_specific_s0): Remove calls to those.
(resolve_structure_cons): Fix handling.
* symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
generation.
(gen_cptr_param, gen_fptr_param, gen_shape_param,
build_formal_args, get_iso_c_sym): Remove.
(std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
(generate_isocbinding_symbol): Support hidden symbols and
using c_ptr/c_funptr symtrees for nullptr defs.
* target-memory.c (gfc_target_encode_expr): Fix handling
of c_ptr/c_funptr.
* trans-expr.c (conv_isocbinding_procedure): Remove.
(gfc_conv_procedure_call): Remove call to it.
(gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
of c_ptr/c_funptr.
* trans-intrinsic.c (conv_isocbinding_function,
conv_isocbinding_subroutine): New.
(gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
Call them.
* trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
* trans-types.c (gfc_typenode_for_spec,
gfc_get_derived_type): Ditto.
(gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.
2013-03-18 Tobias Burnus <burnus@net-b.de>
* gfortran.h (gfc_option_t): Remove flag_whole_file.
......
gcc/fortran/expr.c
......@@ -2256,7 +2256,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
"new_line", NULL
};
int i;
int i = 0;
gfc_actual_arglist *ap;
if (!e->value.function.isym
......@@ -2267,17 +2267,31 @@ check_inquiry (gfc_expr *e, int not_restricted)
if (e->symtree == NULL)
return MATCH_NO;
name = e->symtree->n.sym->name;
if (e->symtree->n.sym->from_intmod)
{
if (e->symtree->n.sym->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_OPTIONS
&& e->symtree->n.sym->intmod_sym_id != ISOFORTRAN_COMPILER_VERSION)
return MATCH_NO;
if (e->symtree->n.sym->from_intmod == INTMOD_ISO_C_BINDING
&& e->symtree->n.sym->intmod_sym_id != ISOCBINDING_C_SIZEOF)
return MATCH_NO;
}
else
{
name = e->symtree->n.sym->name;
functions = (gfc_option.warn_std & GFC_STD_F2003)
functions = (gfc_option.warn_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++)
if (strcmp (functions[i], name) == 0)
break;
for (i = 0; functions[i]; i++)
if (strcmp (functions[i], name) == 0)
break;
if (functions[i] == NULL)
return MATCH_ERROR;
if (functions[i] == NULL)
return MATCH_ERROR;
}
/* At this point we have an inquiry function with a variable argument. The
type of the variable might be undefined, but we need it now, because the
......@@ -3429,13 +3443,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
attr = gfc_expr_attr (rvalue);
}
/* Check for result of embracing function. */
if (sym == gfc_current_ns->proc_name
&& sym->attr.function && sym->result == sym)
if (sym->attr.function && sym->result == sym)
{
gfc_error ("Function result '%s' is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return FAILURE;
gfc_namespace *ns;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (sym == ns->proc_name)
{
gfc_error ("Function result '%s' is invalid as proc-target "
"in procedure pointer assignment at %L",
sym->name, &rvalue->where);
return FAILURE;
}
}
}
if (attr.abstract)
......
gcc/fortran/gfortran.h
......@@ -343,6 +343,11 @@ enum gfc_isym_id
GFC_ISYM_CPU_TIME,
GFC_ISYM_CSHIFT,
GFC_ISYM_CTIME,
GFC_ISYM_C_ASSOCIATED,
GFC_ISYM_C_F_POINTER,
GFC_ISYM_C_F_PROCPOINTER,
GFC_ISYM_C_FUNLOC,
GFC_ISYM_C_LOC,
GFC_ISYM_C_SIZEOF,
GFC_ISYM_DATE_AND_TIME,
GFC_ISYM_DBLE,
......@@ -610,6 +615,7 @@ gfc_reverse;
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_KINDARRAY(a,b,c,d) a,
#define NAMED_FUNCTION(a,b,c,d) a,
#define NAMED_SUBROUTINE(a,b,c,d) a,
#define NAMED_DERIVED_TYPE(a,b,c,d) a,
typedef enum
{
......@@ -621,6 +627,7 @@ iso_fortran_env_symbol;
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
#undef NAMED_DERIVED_TYPE
#define NAMED_INTCST(a,b,c,d) a,
......@@ -630,8 +637,8 @@ iso_fortran_env_symbol;
#define NAMED_CHARKNDCST(a,b,c) a,
#define NAMED_CHARCST(a,b,c) a,
#define DERIVED_TYPE(a,b,c) a,
#define PROCEDURE(a,b) a,
#define NAMED_FUNCTION(a,b,c,d) a,
#define NAMED_SUBROUTINE(a,b,c,d) a,
typedef enum
{
ISOCBINDING_INVALID = -1,
......@@ -647,8 +654,8 @@ iso_c_binding_symbol;
#undef NAMED_CHARKNDCST
#undef NAMED_CHARCST
#undef DERIVED_TYPE
#undef PROCEDURE
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
typedef enum
{
......@@ -2635,8 +2642,8 @@ gfc_try gfc_verify_c_interop_param (gfc_symbol *);
gfc_try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
gfc_try verify_bind_c_derived_type (gfc_symbol *);
gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *);
gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, const char *, int);
gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
const char *, gfc_symtree *, bool);
int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
int gfc_get_ha_symbol (const char *, gfc_symbol **);
int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
......@@ -2707,6 +2714,10 @@ int gfc_intrinsic_actual_ok (const char *, const bool);
gfc_intrinsic_sym *gfc_find_function (const char *);
gfc_intrinsic_sym *gfc_find_subroutine (const char *);
gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id);
gfc_intrinsic_sym *gfc_intrinsic_subroutine_by_id (gfc_isym_id);
gfc_isym_id gfc_isym_id_by_intmod (intmod_id, int);
gfc_isym_id gfc_isym_id_by_intmod_sym (gfc_symbol *);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
......
gcc/fortran/intrinsic.c
......@@ -810,6 +810,57 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
}
gfc_isym_id
gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
{
if (from_intmod == INTMOD_ISO_C_BINDING)
return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
switch (intmod_sym_id)
{
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
return (gfc_isym_id) c;
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
return (gfc_isym_id) c;
#include "iso-fortran-env.def"
default:
gcc_unreachable ();
}
else
{
gcc_unreachable ();
}
return (gfc_isym_id) 0;
}
gfc_isym_id
gfc_isym_id_by_intmod_sym (gfc_symbol *sym)
{
return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id);
}
gfc_intrinsic_sym *
gfc_intrinsic_subroutine_by_id (gfc_isym_id id)
{
gfc_intrinsic_sym *start = subroutines;
int n = nsub;
while (true)
{
gcc_assert (n > 0);
if (id == start->id)
return start;
start++;
n--;
}
}
gfc_intrinsic_sym *
gfc_intrinsic_function_by_id (gfc_isym_id id)
{
......@@ -2652,9 +2703,28 @@ add_functions (void)
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
/* C_SIZEOF is part of ISO_C_BINDING. */
/* The following functions are part of ISO_C_BINDING. */
add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
"C_PTR_1", BT_VOID, 0, REQUIRED,
"C_PTR_2", BT_VOID, 0, OPTIONAL);
make_from_module();
add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
BT_VOID, 0, GFC_STD_F2003,
gfc_check_c_loc, NULL, gfc_resolve_c_loc,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
BT_VOID, 0, GFC_STD_F2003,
gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
gfc_check_c_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
......@@ -3056,6 +3126,22 @@ add_subroutines (void)
pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* The following subroutines are part of ISO_C_BINDING. */
add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
"cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
"fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
"shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
make_from_module();
add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
NULL, NULL,
"cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
"fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
make_from_module();
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
......@@ -4078,8 +4164,8 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
if (expr->symtree->n.sym->intmod_sym_id)
{
int id = expr->symtree->n.sym->intmod_sym_id;
isym = specific = gfc_intrinsic_function_by_id ((gfc_isym_id) id);
gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
isym = specific = gfc_intrinsic_function_by_id (id);
}
else
isym = specific = gfc_find_function (name);
......@@ -4105,12 +4191,12 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
gfc_current_intrinsic_where = &expr->where;
/* Bypass the generic list for min and max. */
/* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */
if (isym->check.f1m == gfc_check_min_max)
{
init_arglist (isym);
if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
if (isym->check.f1m (expr->value.function.actual) == SUCCESS)
goto got_specific;
if (!error_flag)
......@@ -4192,7 +4278,14 @@ gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
name = c->symtree->n.sym->name;
isym = gfc_find_subroutine (name);
if (c->symtree->n.sym->intmod_sym_id)
{
gfc_isym_id id;
id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
isym = gfc_intrinsic_subroutine_by_id (id);
}
else
isym = gfc_find_subroutine (name);
if (isym == NULL)
return MATCH_NO;
......
gcc/fortran/intrinsic.h
......@@ -143,6 +143,11 @@ gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
gfc_try gfc_check_sizeof (gfc_expr *);
gfc_try gfc_check_c_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
gfc_try gfc_check_c_funloc (gfc_expr *);
gfc_try gfc_check_c_loc (gfc_expr *);
gfc_try gfc_check_c_sizeof (gfc_expr *);
gfc_try gfc_check_sngl (gfc_expr *);
gfc_try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
......@@ -421,6 +426,8 @@ void gfc_resolve_atomic_ref (gfc_code *);
void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_c_loc (gfc_expr *, gfc_expr *);
void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *);
void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
......
gcc/fortran/iresolve.c
......@@ -501,6 +501,20 @@ gfc_resolve_btest (gfc_expr *f, gfc_expr *i, gfc_expr *pos)
void
gfc_resolve_c_loc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
f->ts = f->value.function.isym->ts;
}
void
gfc_resolve_c_funloc (gfc_expr *f, gfc_expr *x ATTRIBUTE_UNUSED)
{
f->ts = f->value.function.isym->ts;
}
void
gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
......
gcc/fortran/iso-c-binding.def
......@@ -43,6 +43,10 @@ along with GCC; see the file COPYING3. If not see
# define NAMED_FUNCTION(a,b,c,d)
#endif
#ifndef NAMED_SUBROUTINE
# define NAMED_SUBROUTINE(a,b,c,d)
#endif
/* The arguments to NAMED_*CST are:
-- an internal name
-- the symbol name in the module, as seen by Fortran code
......@@ -165,26 +169,26 @@ DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \
DERIVED_TYPE (ISOCBINDING_NULL_FUNPTR, "c_null_funptr", \
get_int_kind_from_node (ptr_type_node))
#ifndef PROCEDURE
# define PROCEDURE(a,b)
#endif
PROCEDURE (ISOCBINDING_F_POINTER, "c_f_pointer")
PROCEDURE (ISOCBINDING_ASSOCIATED, "c_associated")
PROCEDURE (ISOCBINDING_LOC, "c_loc")
PROCEDURE (ISOCBINDING_FUNLOC, "c_funloc")
PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
/* The arguments to NAMED_FUNCTIONS are:
/* The arguments to NAMED_FUNCTIONS and NAMED_SUBROUTINES are:
-- the ISYM
-- the symbol name in the module, as seen by Fortran code
-- the Fortran standard */
NAMED_SUBROUTINE (ISOCBINDING_F_POINTER, "c_f_pointer",
GFC_ISYM_C_F_POINTER, GFC_STD_F2003)
NAMED_SUBROUTINE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer",
GFC_ISYM_C_F_PROCPOINTER, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_ASSOCIATED, "c_associated",
GFC_ISYM_C_ASSOCIATED, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_FUNLOC, "c_funloc",
GFC_ISYM_C_FUNLOC, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc",
GFC_ISYM_C_LOC, GFC_STD_F2003)
NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
#undef NAMED_INTCST
#undef NAMED_REALCST
#undef NAMED_CMPXCST
......@@ -192,5 +196,5 @@ NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
#undef NAMED_CHARCST
#undef NAMED_CHARKNDCST
#undef DERIVED_TYPE
#undef PROCEDURE
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
gcc/fortran/iso-fortran-env.def
......@@ -27,6 +27,10 @@ along with GCC; see the file COPYING3. If not see
# define NAMED_KINDARRAY(a,b,c,d)
#endif
#ifndef NAMED_SUBROUTINE
# define NAMED_SUBROUTINE(a,b,c,d)
#endif
#ifndef NAMED_FUNCTION
# define NAMED_FUNCTION(a,b,c,d)
#endif
......@@ -120,4 +124,5 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION
#undef NAMED_SUBROUTINE
#undef NAMED_DERIVED_TYPE
gcc/fortran/target-memory.c
......@@ -316,6 +316,17 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
}
case BT_DERIVED:
if (source->ts.u.derived->ts.f90_type == BT_VOID)
{
gfc_constructor *c;
gcc_assert (source->expr_type == EXPR_STRUCTURE);
c = gfc_constructor_first (source->value.constructor);
gcc_assert (c->expr->expr_type == EXPR_CONSTANT
&& c->expr->ts.type == BT_INTEGER);
return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
buffer, buffer_size);
}
return encode_derived (source, buffer, buffer_size);
default:
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
......
gcc/fortran/trans-expr.c
......@@ -3695,229 +3695,6 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
}
/* The following routine generates code for the intrinsic
procedures from the ISO_C_BINDING module:
* C_LOC (function)
* C_FUNLOC (function)
* C_F_POINTER (subroutine)
* C_F_PROCPOINTER (subroutine)
* C_ASSOCIATED (function)
One exception which is not handled here is C_F_POINTER with non-scalar
arguments. Returns 1 if the call was replaced by inline code (else: 0). */
static int
conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_actual_arglist * arg)
{
gfc_symbol *fsym;
if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
if (arg->expr->rank == 0)
gfc_conv_expr_reference (se, arg->expr);
else
{
int f;
/* This is really the actual arg because no formal arglist is
created for C_LOC. */
fsym = arg->expr->symtree->n.sym;
/* We should want it to do g77 calling convention. */
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
}
/* TODO -- the following two lines shouldn't be necessary, but if
they're removed, a bug is exposed later in the code path.
This workaround was thus introduced, but will have to be
removed; please see PR 35150 for details about the issue. */
se->expr = convert (pvoid_type_node, se->expr);
se->expr = gfc_evaluate_now (se->expr, &se->pre);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
arg->expr->ts.type = sym->ts.u.derived->ts.type;
arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
/* Convert c_f_pointer and c_f_procpointer. */
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
gfc_add_block_to_block (&se->pre, &cptrse.pre);
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (arg->next->expr->rank == 0)
{
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| gfc_is_proc_ptr_comp (arg->next->expr))
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se->pre, &fptrse.pre);
gfc_add_block_to_block (&se->post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
return 1;
}
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
fptrse.descriptor_only = 1;
gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc,
fold_convert (tmp, cptrse.expr));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (TREE_TYPE (desc)));
/* Start scalarization of the bounds, using the shape argument. */
shape_ss = gfc_walk_expr (arg->next->next->expr);
gcc_assert (shape_ss != gfc_ss_terminator);
gfc_init_se (&shapese, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &arg->next->expr->where);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
shapese.ss = shape_ss;
stride = gfc_create_var (gfc_array_index_type, "stride");
offset = gfc_create_var (gfc_array_index_type, "offset");
gfc_add_modify (&block, stride, gfc_index_one_node);
gfc_add_modify (&block, offset, gfc_index_zero_node);
/* Loop body. */
gfc_start_scalarized_body (&loop, &body);
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
/* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_expr (&shapese, arg->next->next->expr);
gfc_add_block_to_block (&body, &shapese.pre);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
/* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
/* Update stride. */
gfc_add_modify (&body, stride,
fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
/* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
se->expr = gfc_finish_block (&block);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
gfc_se arg1se;
gfc_se arg2se;
/* Build the addr_expr for the first argument. The argument is
already an *address* so we don't need to set want_pointer in
the gfc_se. */
gfc_init_se (&arg1se, NULL);
gfc_conv_expr (&arg1se, arg->expr);
gfc_add_block_to_block (&se->pre, &arg1se.pre);
gfc_add_block_to_block (&se->post, &arg1se.post);
/* See if we were given two arguments. */
if (arg->next == NULL)
/* Only given one arg so generate a null and do a
not-equal comparison against the first arg. */
se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
arg1se.expr,
fold_convert (TREE_TYPE (arg1se.expr),
null_pointer_node));
else
{
tree eq_expr;
tree not_null_expr;
/* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
/* Generate test to compare that the two args are equal. */
eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
arg1se.expr, arg2se.expr);
/* Generate test to ensure that the first arg is not null. */
not_null_expr = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
arg1se.expr, null_pointer_node);
/* Finally, the generated test must check that both arg1 is not
NULL and that it is equal to the second arg. */
se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
boolean_type_node,
not_null_expr, eq_expr);
}
return 1;
}
/* Nothing was done. */
return 0;
}
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
......@@ -3964,10 +3741,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = NULL_TREE;
gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING
&& conv_isocbinding_procedure (se, sym, args))
return 0;
comp = gfc_get_proc_ptr_comp (expr);
if (se->ss != NULL)
......@@ -6013,7 +5786,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_add_expr_to_block (&block, tmp);
}
}
else if (expr->ts.type == BT_DERIVED)
else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
{
if (expr->expr_type != EXPR_STRUCTURE)
{
......@@ -6224,8 +5997,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
typespec for the C_PTR and C_FUNPTR symbols, which has already been
updated to be an integer with a kind equal to the size of a (void *). */
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
&& expr->ts.u.derived->attr.is_iso_c)
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID)
{
if (expr->expr_type == EXPR_VARIABLE
&& (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
......@@ -6240,9 +6012,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
/* Update the type/kind of the expression to be what the new
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
expr->ts.type = expr->ts.u.derived->ts.type;
expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
expr->ts.kind = expr->ts.u.derived->ts.kind;
expr->ts.type = BT_INTEGER;
expr->ts.f90_type = BT_VOID;
expr->ts.kind = gfc_index_integer_kind;
}
}
......
gcc/fortran/trans-intrinsic.c
......@@ -6301,6 +6301,208 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
se->expr = temp_var;
}
/* The following routine generates code for the intrinsic
functions from the ISO_C_BINDING module:
* C_LOC
* C_FUNLOC
* C_ASSOCIATED */
static void
conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *arg = expr->value.function.actual;
if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
{
if (arg->expr->rank == 0)
gfc_conv_expr_reference (se, arg->expr);
else
gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
/* TODO -- the following two lines shouldn't be necessary, but if
they're removed, a bug is exposed later in the code path.
This workaround was thus introduced, but will have to be
removed; please see PR 35150 for details about the issue. */
se->expr = convert (pvoid_type_node, se->expr);
se->expr = gfc_evaluate_now (se->expr, &se->pre);
}
else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
gfc_conv_expr_reference (se, arg->expr);
else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
{
gfc_se arg1se;
gfc_se arg2se;
/* Build the addr_expr for the first argument. The argument is
already an *address* so we don't need to set want_pointer in
the gfc_se. */
gfc_init_se (&arg1se, NULL);
gfc_conv_expr (&arg1se, arg->expr);
gfc_add_block_to_block (&se->pre, &arg1se.pre);
gfc_add_block_to_block (&se->post, &arg1se.post);
/* See if we were given two arguments. */
if (arg->next->expr == NULL)
/* Only given one arg so generate a null and do a
not-equal comparison against the first arg. */
se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
arg1se.expr,
fold_convert (TREE_TYPE (arg1se.expr),
null_pointer_node));
else
{
tree eq_expr;
tree not_null_expr;
/* Given two arguments so build the arg2se from second arg. */
gfc_init_se (&arg2se, NULL);
gfc_conv_expr (&arg2se, arg->next->expr);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
/* Generate test to compare that the two args are equal. */
eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
arg1se.expr, arg2se.expr);
/* Generate test to ensure that the first arg is not null. */
not_null_expr = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node,
arg1se.expr, null_pointer_node);
/* Finally, the generated test must check that both arg1 is not
NULL and that it is equal to the second arg. */
se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
boolean_type_node,
not_null_expr, eq_expr);
}
}
else
gcc_unreachable ();
}
/* The following routine generates code for the intrinsic
subroutines from the ISO_C_BINDING module:
* C_F_POINTER
* C_F_PROCPOINTER. */
static tree
conv_isocbinding_subroutine (gfc_code *code)
{
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
gfc_se shapese;
gfc_ss *shape_ss;
tree desc, dim, tmp, stride, offset;
stmtblock_t body, block;
gfc_loopinfo loop;
gfc_actual_arglist *arg = code->ext.actual;
gfc_init_se (&se, NULL);
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
gfc_add_block_to_block (&se.pre, &cptrse.pre);
gfc_add_block_to_block (&se.post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
if (arg->next->expr->rank == 0)
{
fptrse.want_pointer = 1;
gfc_conv_expr (&fptrse, arg->next->expr);
gfc_add_block_to_block (&se.pre, &fptrse.pre);
gfc_add_block_to_block (&se.post, &fptrse.post);
if (arg->next->expr->symtree->n.sym->attr.proc_pointer
&& arg->next->expr->symtree->n.sym->attr.dummy)
fptrse.expr = build_fold_indirect_ref_loc (input_location,
fptrse.expr);
se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (fptrse.expr),
fptrse.expr,
fold_convert (TREE_TYPE (fptrse.expr),
cptrse.expr));
gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
gfc_start_block (&block);
/* Get the descriptor of the Fortran pointer. */
fptrse.descriptor_only = 1;
gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
/* Set data value, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
gfc_get_dtype (TREE_TYPE (desc)));
/* Start scalarization of the bounds, using the shape argument. */
shape_ss = gfc_walk_expr (arg->next->next->expr);
gcc_assert (shape_ss != gfc_ss_terminator);
gfc_init_se (&shapese, NULL);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &arg->next->expr->where);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
shapese.ss = shape_ss;
stride = gfc_create_var (gfc_array_index_type, "stride");
offset = gfc_create_var (gfc_array_index_type, "offset");
gfc_add_modify (&block, stride, gfc_index_one_node);
gfc_add_modify (&block, offset, gfc_index_zero_node);
/* Loop body. */
gfc_start_scalarized_body (&loop, &body);
dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
loop.loopvar[0], loop.from[0]);
/* Set bounds and stride. */
gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
gfc_conv_expr (&shapese, arg->next->next->expr);
gfc_add_block_to_block (&body, &shapese.pre);
gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
gfc_add_block_to_block (&body, &shapese.post);
/* Calculate offset. */
gfc_add_modify (&body, offset,
fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, stride));
/* Update stride. */
gfc_add_modify (&body, stride,
fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride,
fold_convert (gfc_array_index_type,
shapese.expr)));
/* Finish scalarization loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
gfc_cleanup_loop (&loop);
gfc_add_modify (&block, offset,
fold_build1_loc (input_location, NEGATE_EXPR,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (&block, desc, offset);
gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
}
/* Generate code for an intrinsic function. Some map directly to library
calls, others get special handling. In some cases the name of the function
used depends on the type specifiers. */
......@@ -6476,6 +6678,12 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
break;
case GFC_ISYM_C_ASSOCIATED:
case GFC_ISYM_C_FUNLOC:
case GFC_ISYM_C_LOC:
conv_isocbinding_function (se, expr);
break;
case GFC_ISYM_ACHAR:
case GFC_ISYM_CHAR:
gfc_conv_intrinsic_char (se, expr);
......@@ -7585,6 +7793,12 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);
break;
default:
res = NULL_TREE;
break;
......
gcc/fortran/trans-io.c
......@@ -2026,20 +2026,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
&& ts->u.derived != NULL
&& (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
{
/* C_PTR and C_FUNPTR have private components which means they can not
be printed. However, if -std=gnu and not -pedantic, allow
the component to be printed to help debugging. */
if (gfc_notification_std (GFC_STD_GNU) != SILENT)
{
gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
ts->u.derived->name, code != NULL ? &(code->loc) :
&gfc_current_locus);
return;
}
ts->type = ts->u.derived->ts.type;
ts->kind = ts->u.derived->ts.kind;
ts->f90_type = ts->u.derived->ts.f90_type;
ts->type = BT_INTEGER;
ts->kind = gfc_index_integer_kind;
}
kind = ts->kind;
......
gcc/fortran/trans-types.c
......@@ -338,12 +338,11 @@ gfc_init_c_interop_kinds (void)
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_DERIVED; \
c_interop_kinds_table[a].value = c;
#define PROCEDURE(a,b) \
#define NAMED_FUNCTION(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = 0;
#include "iso-c-binding.def"
#define NAMED_FUNCTION(a,b,c,d) \
c_interop_kinds_table[a].value = c;
#define NAMED_SUBROUTINE(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = c;
......@@ -1111,11 +1110,11 @@ gfc_typenode_for_spec (gfc_typespec * spec)
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
symbol that was declared of type C_PTR or C_FUNPTR. */
if (spec->u.derived->attr.is_iso_c)
if (spec->u.derived->ts.f90_type == BT_VOID)
{
spec->type = spec->u.derived->ts.type;
spec->kind = spec->u.derived->ts.kind;
spec->f90_type = spec->u.derived->ts.f90_type;
spec->type = BT_INTEGER;
spec->kind = gfc_index_integer_kind;
spec->f90_type = BT_VOID;
}
break;
case BT_VOID:
......@@ -2349,7 +2348,7 @@ gfc_get_derived_type (gfc_symbol * derived)
derived = gfc_find_dt_in_generic (derived);
/* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1)
if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
{
if (derived->backend_decl)
return derived->backend_decl;
......
gcc/testsuite/ChangeLog
2013-03-25 Tobias Burnus <burnus@net-b.de>
PR fortran/38536
PR fortran/38813
PR fortran/38894
PR fortran/39288
PR fortran/40963
PR fortran/45824
PR fortran/47023
PR fortran/47034
PR fortran/49023
PR fortran/50269
PR fortran/50612
PR fortran/52426
PR fortran/54263
PR fortran/55343
PR fortran/55444
PR fortran/55574
PR fortran/56079
PR fortran/56378
* gfortran.dg/c_assoc_2.f03: Update dg-error wording.
* gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
* gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
* gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
* gfortran.dg/c_funloc_tests_2.f03: Ditto.
* gfortran.dg/c_funloc_tests_5.f03: Ditto.
* gfortran.dg/c_funloc_tests_6.f90: Ditto.
* gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
* gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
* gfortran.dg/c_loc_tests_16.f90: Ditto.
* gfortran.dg/c_loc_tests_4.f03: Ditto.
* gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
* gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
* gfortran.dg/c_loc_tests_8.f03: Ditto.
* gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
* gfortran.dg/c_ptr_tests_15.f90: Ditto.
* gfortran.dg/c_sizeof_1.f90: Fix invalid code.
* gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
* gfortran.dg/pr32601_1.f03: Ditto.
* gfortran.dg/storage_size_2.f08: Remove dg-error.
* gfortran.dg/blockdata_7.f90: New.
* gfortran.dg/c_assoc_4.f90: New.
* gfortran.dg/c_f_pointer_tests_6.f90: New.
* gfortran.dg/c_f_pointer_tests_7.f90: New.
* gfortran.dg/c_funloc_tests_8.f90: New.
* gfortran.dg/c_loc_test_17.f90: New.
* gfortran.dg/c_loc_test_18.f90: New.
* gfortran.dg/c_loc_test_19.f90: New.
* gfortran.dg/c_loc_test_20.f90: New.
* gfortran.dg/c_sizeof_5.f90: New.
* gfortran.dg/iso_c_binding_rename_3.f90: New.
* gfortran.dg/transfer_resolve_2.f90: New.
* gfortran.dg/transfer_resolve_3.f90: New.
* gfortran.dg/transfer_resolve_4.f90: New.
* gfortran.dg/pr32601.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
* gfortran.dg/c_ptr_tests_9.f03: Fix test case.
2013-03-25 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
* gcc.target/arm/vseleqdf.c: New test.
......
gcc/testsuite/gfortran.dg/blockdata_7.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/55444
!
! Contributed by Henrik Holst
!
BLOCKDATA
! USE ISO_C_BINDING, ONLY: C_INT, C_FLOAT ! WORKS
USE :: ISO_C_BINDING ! FAILS
INTEGER(C_INT) X
REAL(C_FLOAT) Y
COMMON /FOO/ X,Y
BIND(C,NAME='fortranStuff') /FOO/
DATA X /1/
DATA Y /2.0/
END BLOCKDATA
gcc/testsuite/gfortran.dg/c_assoc_2.f03
......@@ -16,19 +16,19 @@ contains
call abort()
end if
if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "More actual than formal arguments" }
if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "Too many arguments in call" }
call abort()
end if
if(.not. c_associated()) then ! { dg-error "Missing argument" }
if(.not. c_associated()) then ! { dg-error "Missing actual argument 'C_PTR_1' in call to 'c_associated'" }
call abort()
end if ! { dg-error "Expecting END SUBROUTINE" }
end if
if(.not. c_associated(my_c_ptr_2)) then
call abort()
end if
if(.not. c_associated(my_integer)) then ! { dg-error "Type mismatch" }
if(.not. c_associated(my_integer)) then ! { dg-error "shall have the type TYPE.C_PTR. or TYPE.C_FUNPTR." }
call abort()
end if
end subroutine sub0
......
gcc/testsuite/gfortran.dg/c_assoc_4.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/49023
!
PROGRAM test
USE, INTRINSIC :: iso_c_binding
IMPLICIT NONE
TYPE (C_PTR) :: x, y
PRINT *, C_ASSOCIATED([x,y]) ! { dg-error "'C_PTR_1' argument of 'c_associated' intrinsic at .1. must be a scalar" }
END PROGRAM test
gcc/testsuite/gfortran.dg/c_f_pointer_shape_test.f90
......@@ -13,7 +13,7 @@ contains
type(c_ptr), value :: cPtr
myArrayPtr => myArray
call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE argument" }
call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Expected SHAPE argument to C_F_POINTER with array FPTR" }
end subroutine test_0
end module c_f_pointer_shape_test
......
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03
......@@ -8,7 +8,7 @@ contains
type(c_ptr), value :: my_c_array
integer(c_int), dimension(:), pointer :: my_array_ptr
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be a rank 1 INTEGER array" }
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be INTEGER" }
end subroutine sub0
subroutine sub1(my_c_array) bind(c)
......@@ -17,6 +17,6 @@ contains
integer(c_int), dimension(1,1) :: shape
shape(1,1) = 10
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be a rank 1 INTEGER array" }
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be of rank 1" }
end subroutine sub1
end module c_f_pointer_shape_tests_3
gcc/testsuite/gfortran.dg/c_f_pointer_tests_5.f90
......@@ -9,5 +9,5 @@ type :: nc
end type
type(c_ptr) :: cSelf
class(nc), pointer :: self
call c_f_pointer(cSelf, self) ! { dg-error "must not be polymorphic" }
call c_f_pointer(cSelf, self) ! { dg-error "shall not be polymorphic" }
end
gcc/testsuite/gfortran.dg/c_f_pointer_tests_6.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/38894
!
!
subroutine test2
use iso_c_binding
type(c_funptr) :: fun
type(c_ptr) :: fptr
procedure(), pointer :: bar
integer, pointer :: bari
call c_f_procpointer(fptr,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
call c_f_pointer(fun,bari) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
fun = fptr ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
end
subroutine test()
use iso_c_binding, c_ptr2 => c_ptr
type(c_ptr2) :: fun
procedure(), pointer :: bar
integer, pointer :: foo
call c_f_procpointer(fun,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
call c_f_pointer(fun,foo) ! OK
end
module rename
use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr
end module rename
program p
use, intrinsic :: iso_c_binding, my_c_ptr => c_ptr
type(my_c_ptr) :: my_ptr
print *,c_associated(my_ptr)
contains
subroutine sub()
use rename ! (***)
type(my_c_ptr_0) :: my_ptr2
type(c_funptr) :: myfun
print *,c_associated(my_ptr,my_ptr2)
print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of TYPE.c_funptr." }
end subroutine
end
gcc/testsuite/gfortran.dg/c_f_pointer_tests_7.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/54263
!
use iso_c_binding
type(c_ptr) :: cp
integer, pointer :: p
call c_f_pointer (cp, p, shape=[2]) ! { dg-error "Unexpected SHAPE argument at .1. to C_F_POINTER with scalar FPTR" }
end
gcc/testsuite/gfortran.dg/c_funloc_tests_2.f03
......@@ -8,9 +8,9 @@ contains
type(c_funptr) :: my_c_funptr
integer :: my_local_variable
my_c_funptr = c_funloc() ! { dg-error "Missing argument" }
my_c_funptr = c_funloc() ! { dg-error "Missing actual argument 'x' in call to 'c_funloc'" }
my_c_funptr = c_funloc(sub0)
my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "More actual than formal" }
my_c_funptr = c_funloc(my_local_variable) ! { dg-error "must be a procedure" }
my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "Too many arguments in call to 'c_funloc'" }
my_c_funptr = c_funloc(my_local_variable) ! { dg-error "Argument X at .1. to C_FUNLOC shall be a procedure or a procedure pointer" }
end subroutine sub0
end module c_funloc_tests_2
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
......@@ -8,9 +8,9 @@ contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable argument" }
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable argument" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
end subroutine sub0
subroutine sub1()
......
gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
......@@ -23,9 +23,9 @@ procedure(integer), pointer :: fint
cp = c_funloc (sub) ! { dg-error "Can't convert TYPE.c_funptr. to TYPE.c_ptr." })
cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR to C_F_POINTER at .1. shall have the type C_PTR" }
call c_f_procpointer (cp, fsub) ! { dg-error "Argument at .1. to C_F_FUNPOINTER shall have the type C_FUNPTR" }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
call c_f_procpointer (cp, fsub) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable argument 'nocsub' to 'c_funloc'" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure-pointer at .1. to C_F_FUNPOINTER" }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure pointer at .1. to C_F_PROCPOINTER" }
end
gcc/testsuite/gfortran.dg/c_funloc_tests_8.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/50612
! PR fortran/47023
!
subroutine test
use iso_c_binding
implicit none
external foo
procedure(), pointer :: pp
print *, c_sizeof(pp) ! { dg-error "Procedure unexpected as argument" }
print *, c_sizeof(foo) ! { dg-error "Procedure unexpected as argument" }
print *, c_sizeof(bar) ! { dg-error "Procedure unexpected as argument" }
contains
subroutine bar()
end subroutine bar
end
integer function foo2()
procedure(), pointer :: ptr
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
foo2 = 7
block
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
end block
contains
subroutine foo()
ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" }
end subroutine foo
end function foo2
module m2
contains
integer function foo(i, fptr) bind(C)
use iso_c_binding
implicit none
integer :: i
type(c_funptr) :: fptr
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
block
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
end block
foo = 42*i
contains
subroutine bar()
fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" }
end subroutine bar
end function foo
end module m2
gcc/testsuite/gfortran.dg/c_loc_test_17.f90 0 → 100644
! { dg-do compile }
! { dg-options "" }
!
! PR fortran/56378
! PR fortran/52426
!
! Contributed by David Sagan & Joost VandeVondele
!
module t
use, intrinsic :: iso_c_binding
interface fvec2vec
module procedure int_fvec2vec
end interface
contains
function int_fvec2vec (f_vec, n) result (c_vec)
integer f_vec(:)
integer(c_int), target :: c_vec(n)
end function int_fvec2vec
subroutine lat_to_c (Fp, C) bind(c)
integer, allocatable :: ic(:)
call lat_to_c2 (c_loc(fvec2vec(ic, n1_ic))) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
end subroutine lat_to_c
end module
use iso_c_binding
print *, c_loc([1]) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" }
end
gcc/testsuite/gfortran.dg/c_loc_test_18.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/39288
!
! From IR F03/0129, cf.
! Fortran 2003, Technical Corrigendum 5
!
! Was invalid before.
SUBROUTINE S(A,I,K)
USE ISO_C_BINDING
CHARACTER(*),TARGET :: A
CHARACTER(:),ALLOCATABLE,TARGET :: B
TYPE(C_PTR) P1,P2,P3,P4,P5
P1 = C_LOC(A(1:1)) ! *1
P2 = C_LOC(A(I:I)) ! *2
P3 = C_LOC(A(1:)) ! *3
P4 = C_LOC(A(I:K)) ! *4
ALLOCATE(CHARACTER(1)::B)
P5 = C_LOC(B) ! *5
END SUBROUTINE
gcc/testsuite/gfortran.dg/c_loc_test_19.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/50269
!
Program gf
Use iso_c_binding
Real( c_double ), Dimension( 1:10 ), Target :: a
Call test( a )
Contains
Subroutine test( aa )
Real( c_double ), Dimension( : ), Target :: aa
Type( c_ptr ), Pointer :: b
b = c_loc( aa( 1 ) ) ! was rejected before.
b = c_loc( aa ) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
End Subroutine test
End Program gf
gcc/testsuite/gfortran.dg/c_loc_test_20.f90 0 → 100644
! { dg-do run }
!
! PR fortran/38829
! PR fortran/40963
! PR fortran/38813
!
!
program testcloc
use, intrinsic :: iso_c_binding
implicit none
type obj
real :: array(10,10)
real, allocatable :: array2(:,:)
end type
type(obj), target :: obj1
type(c_ptr) :: cptr
integer :: i
real, pointer :: array(:)
allocate (obj1%array2(10,10))
obj1%array = reshape ([(i, i=1,100)], shape (obj1%array))
obj1%array2 = reshape ([(i, i=1,100)], shape (obj1%array))
cptr = c_loc (obj1%array)
call c_f_pointer (cptr, array, shape=[100])
if (any (array /= [(i, i=1,100)])) call abort ()
cptr = c_loc (obj1%array2)
call c_f_pointer (cptr, array, shape=[100])
if (any (array /= [(i, i=1,100)])) call abort ()
end program testcloc
gcc/testsuite/gfortran.dg/c_loc_tests_10.f03
! { dg-do compile }
! { dg-options "-std=f2008" }
subroutine aaa(in)
use iso_c_binding
implicit none
integer(KIND=C_int), DIMENSION(:), TARGET :: in
type(c_ptr) :: cptr
cptr = c_loc(in) ! { dg-error "not C interoperable" }
cptr = c_loc(in) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC" }
end subroutine aaa
gcc/testsuite/gfortran.dg/c_loc_tests_11.f03
! { dg-do compile }
! { dg-options "-std=f2008" }
!
! Test argument checking for C_LOC with subcomponent parameters.
module c_vhandle_mod
use iso_c_binding
......@@ -29,9 +31,9 @@ contains
integer(c_int), intent(in) :: handle
if (.true.) then ! The ultimate component is an allocatable target
get_double_vector_address = c_loc(dbv_pool(handle)%v)
get_double_vector_address = c_loc(dbv_pool(handle)%v) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
else
get_double_vector_address = c_loc(vv)
get_double_vector_address = c_loc(vv) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
endif
end function get_double_vector_address
......@@ -39,9 +41,9 @@ contains
type(c_ptr) function get_foo_address(handle)
integer(c_int), intent(in) :: handle
get_foo_address = c_loc(foo_pool(handle)%v)
get_foo_address = c_loc(foo_pool(handle)%v)
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "must be a scalar" }
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Expression is a noninteroperable derived type" }
end function get_foo_address
......
gcc/testsuite/gfortran.dg/c_loc_tests_15.f90
......@@ -11,6 +11,6 @@
type(c_ptr) :: tt_cptr
class(t), pointer :: tt_fptr
if (associated(tt_fptr)) tt_cptr = c_loc(tt_fptr) ! { dg-error "must not be polymorphic" }
if (associated(tt_fptr)) tt_cptr = c_loc(tt_fptr) ! { dg-error "shall not be polymorphic" }
end
gcc/testsuite/gfortran.dg/c_loc_tests_16.f90
! { dg-do compile }
! { dg-options "-fcoarray=single" }
! { dg-options "-fcoarray=single -std=f2008" }
! PR 38536 - array sections as arguments to c_loc are illegal.
use iso_c_binding
type, bind(c) :: t1
......@@ -18,8 +18,8 @@
integer(c_int), target :: x[*]
type(C_PTR) :: p
p = c_loc(tt%t%i(1)) ! { dg-error "Array section not permitted" }
p = c_loc(n(1:2)) ! { dg-warning "Array section" }
p = c_loc(ttt%t(5,1:2)%i(1)) ! { dg-error "Array section not permitted" }
p = c_loc(x[1]) ! { dg-error "Coindexed argument not permitted" }
p = c_loc(tt%t%i(1))
p = c_loc(n(1:2)) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only whole-arrays are interoperable" }
p = c_loc(ttt%t(5,1:2)%i(1)) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Only whole-arrays are interoperable" }
p = c_loc(x[1]) ! { dg-error "shall not be coindexed" }
end
gcc/testsuite/gfortran.dg/c_loc_tests_17.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/55574
! The following code used to be accepted because C_LOC pulls in C_PTR
! implicitly.
!
! Contributed by Valery Weber <valeryweber@hotmail.com>
!
program aaaa
use iso_c_binding, only : c_loc
integer, target :: i
type(C_PTR) :: f_ptr ! { dg-error "being used before it is defined" }
f_ptr=c_loc(i) ! { dg-error "Can't convert" }
end program aaaa
gcc/testsuite/gfortran.dg/c_loc_tests_3.f03
......@@ -3,6 +3,6 @@ use iso_c_binding
implicit none
character(kind=c_char,len=256),target :: arg
type(c_ptr),pointer :: c
c = c_loc(arg) ! { dg-error "must have a length of 1" }
c = c_loc(arg) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129
end
gcc/testsuite/gfortran.dg/c_loc_tests_4.f03
! { dg-do compile }
! { dg-options "-std=f2008" }
!
module c_loc_tests_4
use, intrinsic :: iso_c_binding
implicit none
......@@ -10,6 +12,6 @@ contains
type(c_ptr) :: my_c_ptr
my_array_ptr => my_array
my_c_ptr = c_loc(my_array_ptr) ! { dg-error "must be an associated scalar POINTER" }
my_c_ptr = c_loc(my_array_ptr) ! { dg-error "Noninteroperable array at .1. as argument to C_LOC: Only explicit-size and assumed-size arrays are interoperable" }
end subroutine sub0
end module c_loc_tests_4
gcc/testsuite/gfortran.dg/c_loc_tests_8.f03
......@@ -7,7 +7,7 @@ contains
SUBROUTINE glutInit_f03()
TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
character(kind=c_char, len=5), target :: string="hello"
argv(1)=C_LOC(string) ! { dg-error "must have a length of 1" }
argv(1)=C_LOC(string) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129
END SUBROUTINE
end module x
gcc/testsuite/gfortran.dg/c_ptr_tests_13.f03
......@@ -10,6 +10,6 @@ program main
integer(C_INTPTR_T) p
type(C_PTR) cptr
p = 0
cptr = C_PTR(p+1) ! { dg-error "Components of structure constructor" }
cptr = C_PTR(1) ! { dg-error "Components of structure constructor" }
cptr = C_PTR(p+1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
cptr = C_PTR(1) ! { dg-error "is a PRIVATE component of 'c_ptr'" }
end program main
gcc/testsuite/gfortran.dg/c_ptr_tests_14.f90
......@@ -39,8 +39,10 @@ program test
if(c_associated(file%gsl_func)) call abort()
end program test
! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } }
! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }
......
gcc/testsuite/gfortran.dg/c_ptr_tests_15.f90
......@@ -41,8 +41,10 @@ program test
if(c_associated(file%gsl_func)) call abort()
end program test
! { dg-final { scan-tree-dump-times "gsl_file = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "gsl_func = 0B" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } }
! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } }
! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } }
......
gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
......@@ -16,9 +16,9 @@ contains
type(myF90Derived), pointer :: my_f90_type_ptr
my_f90_type%my_c_ptr = c_null_ptr
print *, 'my_f90_type is: ', my_f90_type
print *, 'my_f90_type is: ', my_f90_type%my_c_ptr
my_f90_type_ptr => my_f90_type
print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
print *, 'my_f90_type_ptr is: ', my_f90_type_ptr%my_c_ptr
end subroutine sub0
end module c_ptr_tests_9
......
gcc/testsuite/gfortran.dg/c_sizeof_1.f90
......@@ -4,7 +4,8 @@
use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr, c_sizeof
integer(kind=c_int) :: i, j(10)
character(kind=c_char,len=4),parameter :: str(1) = "abcd"
character(kind=c_char,len=4),parameter :: str(1 ) = "abcd"
character(kind=c_char,len=1),parameter :: str2(4) = ["a","b","c","d"]
type(c_ptr) :: cptr
integer(c_intptr_t) :: iptr
......@@ -15,13 +16,13 @@ if (i /= 4) call abort()
i = c_sizeof(j)
if (i /= 40) call abort()
i = c_sizeof(str)
i = c_sizeof(str2)
if (i /= 4) call abort()
i = c_sizeof(str(1))
if (i /= 4) call abort()
i = c_sizeof(str2(1))
if (i /= 1) call abort()
i = c_sizeof(str(1)(1:3))
i = c_sizeof(str2(1:3))
if (i /= 3) call abort()
write(*,*) c_sizeof(cptr), c_sizeof(iptr), c_sizeof(C_NULL_PTR)
......
gcc/testsuite/gfortran.dg/c_sizeof_5.f90 0 → 100644
! { dg-do run }
! { dg-options "-fcray-pointer" }
!
use iso_c_binding
real target(10)
real pointee(10)
pointer (ipt, pointee)
integer(c_intptr_t) :: int_cptr
real :: x
if (c_sizeof(ipt) /= c_sizeof(int_cptr)) call abort()
if (c_sizeof(pointee) /= c_sizeof(x)*10) call abort()
end
gcc/testsuite/gfortran.dg/iso_c_binding_init_expr.f03
......@@ -5,7 +5,7 @@ use iso_c_binding
implicit none
integer, target :: a
type t
type(c_ptr) :: ptr = c_loc(a) ! { dg-error "must be an intrinsic function" }
type(c_ptr) :: ptr = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" }
end type t
type(c_ptr) :: ptr2 = c_loc(a) ! { dg-error "must be an intrinsic function" }
type(c_ptr) :: ptr2 = c_loc(a) ! { dg-error "Intrinsic function 'c_loc' at .1. is not permitted in an initialization expression" }
end
gcc/testsuite/gfortran.dg/iso_c_binding_rename_3.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/55343
!
! Contributed by Janus Weil
!
module my_mod
implicit none
type int_type
integer :: i
end type int_type
end module my_mod
program main
use iso_c_binding, only: C_void_ptr=>C_ptr, C_string_ptr=>C_ptr
use my_mod, only: i1_type=>int_type, i2_type=>int_type
implicit none
type(C_string_ptr) :: p_string
type(C_void_ptr) :: p_void
type (i1_type) :: i1
type (i2_type) :: i2
p_void = p_string
i1 = i2
end program main
gcc/testsuite/gfortran.dg/pr32601.f03
......@@ -19,9 +19,9 @@ type(c_ptr) :: t
t = c_null_ptr
! Next two lines should be errors if -pedantic or -std=f2003
print *, c_null_ptr, t ! { dg-error "has PRIVATE components" }
print *, t ! { dg-error "has PRIVATE components" }
print *, c_null_ptr, t ! { dg-error "cannot have PRIVATE components" }
print *, t ! { dg-error "cannot have PRIVATE components" }
print *, c_loc(get_ptr()) ! { dg-error "has PRIVATE components" }
print *, c_loc(get_ptr()) ! { dg-error "cannot have PRIVATE components" }
end
gcc/testsuite/gfortran.dg/pr32601_1.f03
! { dg-do compile }
! { dg-options "" }
!
! PR fortran/32601
use, intrinsic :: iso_c_binding, only: c_loc, c_ptr
implicit none
! This was causing an ICE, but is an error because the argument to C_LOC
! needs to be a variable.
print *, c_loc(4) ! { dg-error "not a variable" }
print *, c_loc(4) ! { dg-error "shall have either the POINTER or the TARGET attribute" }
end
gcc/testsuite/gfortran.dg/storage_size_2.f08
......@@ -14,10 +14,10 @@ integer(4) :: i1
integer(c_int) :: i2
type(t) :: x
print *,c_sizeof(i1) ! { dg-error "must be an interoperable data entity" }
print *,c_sizeof(i1)
print *,c_sizeof(i2)
print *,c_sizeof(x)
print *, c_sizeof(ran()) ! { dg-error "must be an interoperable data entity" }
print *, c_sizeof(ran())
print *,storage_size(1.0,4)
print *,storage_size(1.0,3.2) ! { dg-error "must be INTEGER" }
......
gcc/testsuite/gfortran.dg/transfer_resolve_2.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/56079
!
! Contributed by Thomas Koenig
!
program gar_nichts
use ISO_C_BINDING
use ISO_C_BINDING, only: C_PTR
use ISO_C_BINDING, only: abc => C_PTR
use ISO_C_BINDING, only: xyz => C_PTR
type(xyz) nada
nada = transfer(C_NULL_PTR,nada)
end program gar_nichts
gcc/testsuite/gfortran.dg/transfer_resolve_3.f90 0 → 100644
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/56079
!
use iso_c_binding
implicit none
type t
type(c_ptr) :: ptr = c_null_ptr
end type t
type(t), parameter :: para = t()
integer(c_intptr_t) :: intg
intg = transfer (para, intg)
intg = transfer (para%ptr, intg)
end
! { dg-final { scan-tree-dump-times "intg = 0;" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
gcc/testsuite/gfortran.dg/transfer_resolve_4.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/47034
!
! Contributed by James Van Buskirk
!
subroutine james
use iso_c_binding
type(C_PTR), parameter :: p1 = &
transfer(32512_C_INTPTR_T,C_NULL_PTR)
integer(C_INTPTR_T), parameter :: n1 = transfer(p1,0_C_INTPTR_T)
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment