This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: Fwd: GCC 4.8.0 Status Report (2013-02-14)
- From: Tobias Burnus <burnus at net-b dot de>
- To: Mikael Morin <mikael dot morin at sfr dot fr>
- Cc: gfortran <fortran at gcc dot gnu dot org>
- Date: Fri, 15 Feb 2013 12:38:29 +0100
- Subject: Re: Fwd: GCC 4.8.0 Status Report (2013-02-14)
- References: <Pine.LNX.4.64.1302142227440.26126@digraph.polyomino.org.uk> <511DEA84.8070802@net-b.de> <511E15EB.4040300@sfr.fr>
Mikael Morin wrote:
Le 15/02/2013 08:57, Tobias Burnus a écrit :
53537 [4.6/4.7] IMPORT + renaming: Rejects valid; Seemingly fixed by
MIKAEL on the trunk. Backporting - or closing?
Yes, when submitting I said I planned to wait two weeks before
back-porting. I will do it this week-end.
Thanks!
55574 [4.7/4.8] accepts invalid C_PTR, which gets implicitly imported.
Fancy patch by MIKAEL attached to the PR
I plan to get back to this one after pr54730.
Side remark: As I mentioned in my other email, I would like to change
the way ISO_C_Binding is handled in gfortran by using a more standard
approach. That was motivated by the need to update the c_loc diagnostic
handling for F2008/TS29133, but I think it is in general useful.
The attached patch is the current status – it still has issues with the
type(C_PTR) handling; I don't see whether it would be an alternative to
your patch for PR55574 or whether it is orthogonal. In any case, my
patch is Stage 1 material.
Tobias
fortran/check.c | 244 +++++++++++++
fortran/gfortran.h | 16
fortran/intrinsic.c | 67 +++
fortran/intrinsic.h | 7
fortran/iresolve.c | 14
fortran/iso-c-binding.def | 32 -
fortran/iso-fortran-env.def | 5
fortran/module.c | 181 +++++++---
fortran/resolve.c | 578 --------------------------------
fortran/symbol.c | 456 +------------------------
fortran/trans-array.c | 49 ++
fortran/trans-expr.c | 227 ------------
fortran/trans-intrinsic.c | 228 ++++++++++++
fortran/trans-types.c | 7
testsuite/gfortran.dg/bind_c_bool_1.f90 | 26 -
15 files changed, 818 insertions(+), 1319 deletions(-)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index de1b729..4ff9aaf 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -698,7 +698,7 @@ gfc_var_strlen (const gfc_expr *a)
{
start_a = mpz_get_si (ra->u.ss.start->value.integer);
end_a = mpz_get_si (ra->u.ss.end->value.integer);
- return end_a - start_a + 1;
+ return (end_a < start_a) ? 0 : end_a - start_a + 1;
}
else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
return 1;
@@ -3637,6 +3637,248 @@ gfc_check_c_sizeof (gfc_expr *arg)
gfc_try
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+ if (c_ptr_1->ts.type != BT_DERIVED
+ || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+ && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+ {
+ gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+ "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (c_ptr_1, 0) == FAILURE)
+ return FAILURE;
+
+ if (c_ptr_2
+ && (c_ptr_2->ts.type != BT_DERIVED
+ || (c_ptr_1->ts.u.derived->intmod_sym_id
+ != c_ptr_2->ts.u.derived->intmod_sym_id)))
+ {
+ gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+ "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
+ gfc_typename (&c_ptr_1->ts),
+ gfc_typename (&c_ptr_2->ts));
+ return FAILURE;
+ }
+
+ if (c_ptr_2 && scalar_check (c_ptr_2, 1) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape)
+{
+ symbol_attribute attr;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_POINTER shall have the "
+ "type TYPE(C_PTR)", &cptr->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (cptr, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (fptr, NULL);
+
+ if (!attr.pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER shall be a pointer",
+ &fptr->where);
+ return FAILURE;
+ }
+
+ if (fptr->ts.type == BT_CLASS)
+ {
+ gfc_error ("FPTR argument at %L to C_F_POINTER shall not be polymorphic",
+ &fptr->where);
+ return FAILURE;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_POINTER shall not be "
+ "coindexed", &fptr->where);
+ return FAILURE;
+ }
+
+ if (fptr->rank == 0 && shape)
+ {
+ gfc_error ("Unexpected SHAPE argument at %L to C_F_POINTER with scalar "
+ "FPTR", &fptr->where);
+ return FAILURE;
+ }
+ else if (fptr->rank && !shape)
+ {
+ gfc_error ("Expected SHAPE argument to C_F_POINTER with array "
+ "FPTR at %L", &fptr->where);
+ return FAILURE;
+ }
+
+ if (shape && rank_check (shape, 2, 1) == FAILURE)
+ return FAILURE;
+
+ if (shape && type_check (shape, 2, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (shape)
+ {
+ mpz_t size;
+
+ if (gfc_array_size (shape, &size) == SUCCESS
+ && mpz_cmp_ui (size, fptr->rank) != 0)
+ {
+ mpz_clear (size);
+ gfc_error ("SHAPE argument at %L to C_F_POINTER must have the same "
+ "size as the RANK of FPTR", &shape->where);
+ return FAILURE;
+ }
+ mpz_clear (size);
+ }
+
+ if (!attr.is_bind_c && fptr->rank)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array FPTR "
+ "at %L to C_F_POINTER", &fptr->where);
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
+{
+ symbol_attribute attr;
+
+ if (cptr->ts.type != BT_DERIVED
+ || cptr->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)
+ {
+ gfc_error ("Argument CPTR at %L to C_F_PROCPOINTER shall have the "
+ "type TYPE(C_FUNPTR)", &cptr->where);
+ return FAILURE;
+ }
+
+ if (scalar_check (cptr, 0) == FAILURE)
+ return FAILURE;
+
+ attr = gfc_variable_attr (fptr, NULL);
+
+ if (!attr.proc_pointer)
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall be a procedure "
+ "pointer", &fptr->where);
+ return FAILURE;
+ }
+
+ if (gfc_is_coindexed (fptr))
+ {
+ gfc_error ("Argument FPTR at %L to C_F_PROCPOINTER shall not be "
+ "coindexed", &fptr->where);
+ return FAILURE;
+ }
+
+ if (!attr.is_bind_c)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+ "pointer at %L to C_F_PROCPOINTER", &fptr->where);
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_c_funloc (gfc_expr *x)
+{
+ symbol_attribute attr;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall not be "
+ "coindexed", &x->where);
+ return FAILURE;
+ }
+
+ attr = gfc_variable_attr (x, NULL);
+
+ if (attr.flavor != FL_PROCEDURE)
+ {
+ gfc_error ("Argument X at %L to C_FUNLOC shall be a procedure "
+ "or a procedure pointer", &x->where);
+ return FAILURE;
+ }
+
+ if (!attr.is_bind_c)
+ return gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable procedure "
+ "at %L to C_FUNLOC", &x->where);
+ return SUCCESS;
+}
+
+
+/* FIXME: Check that ASSUMED-RANK is properly handled, i.e. rejected at
+ most places, except of the few allowed ones, i.e. C_LOC [are there more]?. */
+
+gfc_try
+gfc_check_c_loc (gfc_expr *x)
+{
+ symbol_attribute attr;
+
+ if (gfc_is_coindexed (x))
+ {
+ gfc_error ("Argument X at %L to C_LOC shall not be coindexed", &x->where);
+ return FAILURE;
+ }
+
+ if (x->ts.type == BT_CLASS)
+ {
+ gfc_error ("X argument at %L to C_LOC shall not be polymorphic",
+ &x->where);
+ return FAILURE;
+ }
+
+ attr = gfc_variable_attr (x, NULL);
+
+ if (!attr.pointer && !attr.target)
+ {
+ gfc_error ("Argument X at %L to C_LOC shall be either a POINTER or have "
+ "the TARGET attribute", &x->where);
+ return FAILURE;
+ }
+
+
+ if (attr.is_bind_c && attr.pointer && x->rank
+ && gfc_notify_std (GFC_STD_F2008, "Pointer to an array at %L as "
+ "argument to C_LOC", &x->where) == FAILURE)
+ return FAILURE;
+
+ if (x->ts.type == BT_CHARACTER
+ && gfc_var_strlen (x) == 0)
+ {
+ gfc_error ("Argument X at %L to C_LOC shall be not be a zero-sized "
+ "string", &x->where);
+ return FAILURE;
+ }
+
+ if (x->rank)
+ {
+ /* FIXME: If it is an array, it shall be contiguous and have nonzero size. */
+ /* We also have to reject ASSUMED/DEFERRED-RANK arrays for F2003, I believe. */
+ }
+
+ if (!attr.is_bind_c && x->rank
+ && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable array at %L as "
+ "argument to C_LOC", &x->where) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+gfc_try
gfc_check_sleep_sub (gfc_expr *seconds)
{
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ed05c10..1108d5f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -342,6 +342,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,
@@ -609,6 +614,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
{
@@ -620,6 +626,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,
@@ -629,8 +636,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,
@@ -646,8 +653,8 @@ iso_c_binding_symbol;
#undef NAMED_CHARKNDCST
#undef NAMED_CHARCST
#undef DERIVED_TYPE
-#undef PROCEDURE
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
typedef enum
{
@@ -2624,8 +2631,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 **);
@@ -2694,6 +2701,7 @@ 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);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c571533..6e1e15b 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -811,6 +811,24 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
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)
{
gfc_intrinsic_sym *start = functions;
@@ -2652,9 +2670,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 +3093,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,
@@ -4105,12 +4158,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 +4245,11 @@ 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)
+ isym = gfc_intrinsic_subroutine_by_id ((gfc_isym_id)
+ c->symtree->n.sym->intmod_sym_id);
+ else
+ isym = gfc_find_subroutine (name);
if (isym == NULL)
return MATCH_NO;
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 5d50285..0f9b50c 100644
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 36e5363..7d31fb8 100644
--- a/gcc/fortran/iresolve.c
+++ b/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;
diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def
index aaef80c..c36a478 100644
--- a/gcc/fortran/iso-c-binding.def
+++ b/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
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index dfd6364..13ddaa3 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/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
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 705733c..b349c65 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -5597,7 +5597,8 @@ gfc_dump_module (const char *name, int dump_flag)
static void
create_intrinsic_function (const char *name, gfc_isym_id id,
- const char *modname, intmod_id module)
+ const char *modname, intmod_id module,
+ bool subroutine, gfc_symbol *result_type)
{
gfc_intrinsic_sym *isym;
gfc_symtree *tmp_symtree;
@@ -5614,7 +5615,25 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
- isym = gfc_intrinsic_function_by_id (id);
+ if (subroutine)
+ {
+ isym = gfc_intrinsic_subroutine_by_id (id);
+ sym->attr.subroutine = 1;
+ }
+ else
+ {
+ isym = gfc_intrinsic_function_by_id (id);
+ sym->attr.function = 1;
+ if (result_type)
+ {
+ sym->ts.type = BT_DERIVED;
+ sym->ts.u.derived = result_type;
+ sym->ts.is_c_interop = 1;
+ isym->ts.type = BT_DERIVED;
+ isym->ts.u.derived = result_type;
+ isym->ts.is_c_interop = 1;
+ }
+ }
gcc_assert (isym);
sym->attr.flavor = FL_PROCEDURE;
@@ -5640,6 +5659,8 @@ import_iso_c_binding_module (void)
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
+ bool want_c_ptr = false, want_c_funptr = false;
+ gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@@ -5662,6 +5683,57 @@ import_iso_c_binding_module (void)
mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
}
+ /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
+ check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
+ need C_(FUN)PTR. */
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
+ u->use_name) == 0)
+ want_c_ptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
+ u->use_name) == 0)
+ want_c_ptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
+ u->use_name) == 0)
+ want_c_funptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
+ u->use_name) == 0)
+ want_c_funptr = true;
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
+ u->use_name) == 0)
+ {
+ c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_PTR,
+ u->local_name[0] ? u->local_name
+ : u->use_name,
+ NULL, false);
+ }
+ else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
+ u->use_name) == 0)
+ {
+ c_funptr
+ = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_FUNPTR,
+ u->local_name[0] ? u->local_name
+ : u->use_name,
+ NULL, false);
+ }
+ }
+
+ if ((want_c_ptr || !only_flag) && !c_ptr)
+ c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_PTR,
+ NULL, NULL, only_flag);
+ if ((want_c_funptr || !only_flag) && !c_funptr)
+ c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol)
+ ISOCBINDING_FUNPTR,
+ NULL, NULL, only_flag);
+
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
for (i = 0; i < ISOCBINDING_NUMBER; i++)
@@ -5682,29 +5754,27 @@ import_iso_c_binding_module (void)
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ not_in_std = (gfc_option.allow_std & d) == 0; \
+ name = b; \
+ break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
name = b; \
break;
#include "iso-c-binding.def"
-#undef NAMED_CMPXCST
default:
not_in_std = false;
name = "";
@@ -5725,16 +5795,28 @@ import_iso_c_binding_module (void)
: u->use_name, \
(gfc_isym_id) c, \
iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ INTMOD_ISO_C_BINDING, false, NULL); \
+ break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ create_intrinsic_function (u->local_name[0] ? u->local_name \
+ : u->use_name, \
+ (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+ /* Already handled above. */
+ break;
default:
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
u->local_name[0] ? u->local_name
- : u->use_name);
+ : u->use_name,
+ NULL, false);
}
}
@@ -5748,30 +5830,27 @@ import_iso_c_binding_module (void)
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
-
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
#define NAMED_REALCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
if ((gfc_option.allow_std & d) == 0) \
continue; \
break;
#include "iso-c-binding.def"
-#undef NAMED_CMPXCST
default:
; /* Not GFC_STD_* versioned. */
}
@@ -5780,16 +5859,47 @@ import_iso_c_binding_module (void)
{
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
+ if (a == ISOCBINDING_LOC) \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ c_ptr->n.sym); \
+ else if (a == ISOCBINDING_FUNLOC) \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ c_funptr->n.sym); \
+ else \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING, false, \
+ NULL); \
+ break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a: \
create_intrinsic_function (b, (gfc_isym_id) c, \
iso_c_module_name, \
- INTMOD_ISO_C_BINDING); \
+ INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+ /* Already handled above. */
+ break;
default:
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
+ if (i == ISOCBINDING_NULL_PTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ c_ptr, false);
+ else if (i == ISOCBINDING_NULL_FUNPTR)
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ c_funptr, false);
+ else
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL,
+ NULL, false);
}
}
}
@@ -5943,23 +6053,16 @@ use_iso_fortran_env_module (void)
intmod_sym symbol[] = {
#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_INTCST
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
i = 0;
#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
/* Generate the symbol for the module itself. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
@@ -6011,7 +6114,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
create_int_parameter (u->local_name[0] ? u->local_name
: u->use_name,
symbol[i].value, mod,
@@ -6034,7 +6136,6 @@ use_iso_fortran_env_module (void)
symbol[i].id); \
break;
#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@@ -6044,16 +6145,15 @@ use_iso_fortran_env_module (void)
mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
create_intrinsic_function (u->local_name[0] ? u->local_name
: u->use_name,
(gfc_isym_id) symbol[i].value, mod,
- INTMOD_ISO_FORTRAN_ENV);
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
@@ -6080,7 +6180,6 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_INTCST
create_int_parameter (symbol[i].name, symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
break;
@@ -6097,7 +6196,6 @@ use_iso_fortran_env_module (void)
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
break;
#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
@@ -6105,15 +6203,14 @@ use_iso_fortran_env_module (void)
create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
break;
-#undef NAMED_DERIVED_TYPE
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
create_intrinsic_function (symbol[i].name,
(gfc_isym_id) symbol[i].value, mod,
- INTMOD_ISO_FORTRAN_ENV);
+ INTMOD_ISO_FORTRAN_ENV, false,
+ NULL);
break;
default:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c6a6756..321566a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -531,7 +531,7 @@ static void
find_arglists (gfc_symbol *sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
- || sym->attr.flavor == FL_DERIVED)
+ || sym->attr.flavor == FL_DERIVED || sym->attr.intrinsic)
return;
resolve_formal_arglist (sym);
@@ -1573,12 +1573,14 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
- if (sym->intmod_sym_id)
+ if (sym->intmod_sym_id && sym->attr.subroutine)
+ isym = gfc_intrinsic_subroutine_by_id ((gfc_isym_id) sym->intmod_sym_id);
+ else if (sym->intmod_sym_id)
isym = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id);
else if (!sym->attr.subroutine)
isym = gfc_find_function (sym->name);
- if (isym)
+ if (isym && !sym->attr.subroutine)
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
@@ -1591,7 +1593,7 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
sym->ts = isym->ts;
}
- else if ((isym = gfc_find_subroutine (sym->name)))
+ else if (isym || (isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type)
{
@@ -2731,366 +2733,6 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
}
-static gfc_try
-is_scalar_expr_ptr (gfc_expr *expr)
-{
- gfc_try retval = SUCCESS;
- gfc_ref *ref;
- int start;
- int end;
-
- /* See if we have a gfc_ref, which means we have a substring, array
- reference, or a component. */
- if (expr->ref != NULL)
- {
- ref = expr->ref;
- while (ref->next != NULL)
- ref = ref->next;
-
- switch (ref->type)
- {
- case REF_SUBSTRING:
- if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
- || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
- retval = FAILURE;
- break;
-
- case REF_ARRAY:
- if (ref->u.ar.type == AR_ELEMENT)
- retval = SUCCESS;
- else if (ref->u.ar.type == AR_FULL)
- {
- /* The user can give a full array if the array is of size 1. */
- if (ref->u.ar.as != NULL
- && ref->u.ar.as->rank == 1
- && ref->u.ar.as->type == AS_EXPLICIT
- && ref->u.ar.as->lower[0] != NULL
- && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
- && ref->u.ar.as->upper[0] != NULL
- && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
- {
- /* If we have a character string, we need to check if
- its length is one. */
- if (expr->ts.type == BT_CHARACTER)
- {
- if (expr->ts.u.cl == NULL
- || expr->ts.u.cl->length == NULL
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1)
- != 0)
- retval = FAILURE;
- }
- else
- {
- /* We have constant lower and upper bounds. If the
- difference between is 1, it can be considered a
- scalar.
- FIXME: Use gfc_dep_compare_expr instead. */
- start = (int) mpz_get_si
- (ref->u.ar.as->lower[0]->value.integer);
- end = (int) mpz_get_si
- (ref->u.ar.as->upper[0]->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- }
- else
- retval = FAILURE;
- }
- else
- retval = FAILURE;
- break;
- default:
- retval = SUCCESS;
- break;
- }
- }
- else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
- {
- /* Character string. Make sure it's of length 1. */
- if (expr->ts.u.cl == NULL
- || expr->ts.u.cl->length == NULL
- || mpz_cmp_si (expr->ts.u.cl->length->value.integer, 1) != 0)
- retval = FAILURE;
- }
- else if (expr->rank != 0)
- retval = FAILURE;
-
- return retval;
-}
-
-
-/* Match one of the iso_c_binding functions (c_associated or c_loc)
- and, in the case of c_associated, set the binding label based on
- the arguments. */
-
-static gfc_try
-gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
- gfc_symbol **new_sym)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- int optional_arg = 0;
- gfc_try retval = SUCCESS;
- gfc_symbol *args_sym;
- gfc_typespec *arg_ts;
- symbol_attribute arg_attr;
-
- if (args->expr->expr_type == EXPR_CONSTANT
- || args->expr->expr_type == EXPR_OP
- || args->expr->expr_type == EXPR_NULL)
- {
- gfc_error ("Argument to '%s' at %L is not a variable",
- sym->name, &(args->expr->where));
- return FAILURE;
- }
-
- args_sym = args->expr->symtree->n.sym;
-
- /* The typespec for the actual arg should be that stored in the expr
- and not necessarily that of the expr symbol (args_sym), because
- the actual expression could be a part-ref of the expr symbol. */
- arg_ts = &(args->expr->ts);
- arg_attr = gfc_expr_attr (args->expr);
-
- if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- /* If the user gave two args then they are providing something for
- the optional arg (the second cptr). Therefore, set the name and
- binding label to the c_associated for two cptrs. Otherwise,
- set c_associated to expect one cptr. */
- if (args->next)
- {
- /* two args. */
- sprintf (name, "%s_2", sym->name);
- optional_arg = 1;
- }
- else
- {
- /* one arg. */
- sprintf (name, "%s_1", sym->name);
- optional_arg = 0;
- }
-
- /* Get a new symbol for the version of c_associated that
- will get called. */
- *new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
- }
- else if (sym->intmod_sym_id == ISOCBINDING_LOC
- || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- sprintf (name, "%s", sym->name);
-
- /* Error check the call. */
- if (args->next != NULL)
- {
- gfc_error_now ("More actual than formal arguments in '%s' "
- "call at %L", name, &(args->expr->where));
- retval = FAILURE;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_LOC)
- {
- gfc_ref *ref;
- bool seen_section;
-
- /* Make sure we have either the target or pointer attribute. */
- if (!arg_attr.target && !arg_attr.pointer)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
- "a TARGET or an associated pointer",
- args_sym->name,
- sym->name, &(args->expr->where));
- retval = FAILURE;
- }
-
- if (gfc_is_coindexed (args->expr))
- {
- gfc_error_now ("Coindexed argument not permitted"
- " in '%s' call at %L", name,
- &(args->expr->where));
- retval = FAILURE;
- }
-
- /* Follow references to make sure there are no array
- sections. */
- seen_section = false;
-
- for (ref=args->expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_ARRAY)
- {
- if (ref->u.ar.type == AR_SECTION)
- seen_section = true;
-
- if (ref->u.ar.type != AR_ELEMENT)
- {
- gfc_ref *r;
- for (r = ref->next; r; r=r->next)
- if (r->type == REF_COMPONENT)
- {
- gfc_error_now ("Array section not permitted"
- " in '%s' call at %L", name,
- &(args->expr->where));
- retval = FAILURE;
- break;
- }
- }
- }
- }
-
- if (seen_section && retval == SUCCESS)
- gfc_warning ("Array section in '%s' call at %L", name,
- &(args->expr->where));
-
- /* See if we have interoperable type and type param. */
- if (gfc_verify_c_interop (arg_ts) == SUCCESS
- || gfc_check_any_c_kind (arg_ts) == SUCCESS)
- {
- if (args_sym->attr.target == 1)
- {
- /* Case 1a, section 15.1.2.5, J3/04-007: variable that
- has the target attribute and is interoperable. */
- /* Case 1b, section 15.1.2.5, J3/04-007: allocated
- allocatable variable that has the TARGET attribute and
- is not an array of zero size. */
- if (args_sym->attr.allocatable == 1)
- {
- if (args_sym->attr.dimension != 0
- && (args_sym->as && args_sym->as->rank == 0))
- {
- gfc_error_now ("Allocatable variable '%s' used as a "
- "parameter to '%s' at %L must not be "
- "an array of zero size",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- else
- {
- /* A non-allocatable target variable with C
- interoperable type and type parameters must be
- interoperable. */
- if (args_sym && args_sym->attr.dimension)
- {
- if (args_sym->as->type == AS_ASSUMED_SHAPE)
- {
- gfc_error ("Assumed-shape array '%s' at %L "
- "cannot be an argument to the "
- "procedure '%s' because "
- "it is not C interoperable",
- args_sym->name,
- &(args->expr->where), sym->name);
- retval = FAILURE;
- }
- else if (args_sym->as->type == AS_DEFERRED)
- {
- gfc_error ("Deferred-shape array '%s' at %L "
- "cannot be an argument to the "
- "procedure '%s' because "
- "it is not C interoperable",
- args_sym->name,
- &(args->expr->where), sym->name);
- retval = FAILURE;
- }
- }
-
- /* Make sure it's not a character string. Arrays of
- any type should be ok if the variable is of a C
- interoperable type. */
- if (arg_ts->type == BT_CHARACTER)
- if (arg_ts->u.cl != NULL
- && (arg_ts->u.cl->length == NULL
- || arg_ts->u.cl->length->expr_type
- != EXPR_CONSTANT
- || mpz_cmp_si
- (arg_ts->u.cl->length->value.integer, 1)
- != 0)
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("CHARACTER argument '%s' to '%s' "
- "at %L must have a length of 1",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- }
- else if (arg_attr.pointer
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- /* Case 1c, section 15.1.2.5, J3/04-007: an associated
- scalar pointer. */
- gfc_error_now ("Argument '%s' to '%s' at %L must be an "
- "associated scalar POINTER", args_sym->name,
- sym->name, &(args->expr->where));
- retval = FAILURE;
- }
- }
- else
- {
- /* The parameter is not required to be C interoperable. If it
- is not C interoperable, it must be a nonpolymorphic scalar
- with no length type parameters. It still must have either
- the pointer or target attribute, and it can be
- allocatable (but must be allocated when c_loc is called). */
- if (args->expr->rank != 0
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
- "scalar", args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (arg_ts->type == BT_CHARACTER
- && is_scalar_expr_ptr (args->expr) != SUCCESS)
- {
- gfc_error_now ("CHARACTER argument '%s' to '%s' at "
- "%L must have a length of 1",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (arg_ts->type == BT_CLASS)
- {
- gfc_error_now ("Parameter '%s' to '%s' at %L must not be "
- "polymorphic", args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- }
- }
- else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- if (args_sym->attr.flavor != FL_PROCEDURE)
- {
- /* TODO: Update this error message to allow for procedure
- pointers once they are implemented. */
- gfc_error_now ("Argument '%s' to '%s' at %L must be a "
- "procedure",
- args_sym->name, sym->name,
- &(args->expr->where));
- retval = FAILURE;
- }
- else if (args_sym->attr.is_bind_c != 1
- && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
- "argument '%s' to '%s' at %L",
- args_sym->name, sym->name,
- &(args->expr->where)) == FAILURE)
- retval = FAILURE;
- }
-
- /* for c_loc/c_funloc, the new symbol is the same as the old one */
- *new_sym = sym;
- }
- else
- {
- gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
- "iso_c_binding function: '%s'!\n", sym->name);
- }
-
- return retval;
-}
-
-
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
@@ -3152,19 +2794,6 @@ resolve_function (gfc_expr *expr)
inquiry_argument = false;
- /* Need to setup the call to the correct c_associated, depending on
- the number of cptrs to user gives to compare. */
- if (sym && sym->attr.is_iso_c == 1)
- {
- if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
- == FAILURE)
- return FAILURE;
-
- /* Get the symtree for the new symbol (resolved func).
- the old one will be freed later, when it's no longer used. */
- gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
- }
-
/* Resume assumed_size checking. */
need_full_assumed_size--;
@@ -3247,6 +2876,7 @@ resolve_function (gfc_expr *expr)
&& GENERIC_ID != GFC_ISYM_LBOUND
&& GENERIC_ID != GFC_ISYM_LEN
&& GENERIC_ID != GFC_ISYM_LOC
+ && GENERIC_ID != GFC_ISYM_C_LOC
&& GENERIC_ID != GFC_ISYM_PRESENT)
{
/* Array intrinsics must also have the last upper bound of an
@@ -3449,190 +3079,6 @@ generic:
}
-/* Set the name and binding label of the subroutine symbol in the call
- expression represented by 'c' to include the type and kind of the
- second parameter. This function is for resolving the appropriate
- version of c_f_pointer() and c_f_procpointer(). For example, a
- call to c_f_pointer() for a default integer pointer could have a
- name of c_f_pointer_i4. If no second arg exists, which is an error
- for these two functions, it defaults to the generic symbol's name
- and binding label. */
-
-static void
-set_name_and_label (gfc_code *c, gfc_symbol *sym,
- char *name, const char **binding_label)
-{
- gfc_expr *arg = NULL;
- char type;
- int kind;
-
- /* The second arg of c_f_pointer and c_f_procpointer determines
- the type and kind for the procedure name. */
- arg = c->ext.actual->next->expr;
-
- if (arg != NULL)
- {
- /* Set up the name to have the given symbol's name,
- plus the type and kind. */
- /* a derived type is marked with the type letter 'u' */
- if (arg->ts.type == BT_DERIVED)
- {
- type = 'd';
- kind = 0; /* set the kind as 0 for now */
- }
- else
- {
- type = gfc_type_letter (arg->ts.type);
- kind = arg->ts.kind;
- }
-
- if (arg->ts.type == BT_CHARACTER)
- /* Kind info for character strings not needed. */
- kind = 0;
-
- sprintf (name, "%s_%c%d", sym->name, type, kind);
- /* Set up the binding label as the given symbol's label plus
- the type and kind. */
- *binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
- kind);
- }
- else
- {
- /* If the second arg is missing, set the name and label as
- was, cause it should at least be found, and the missing
- arg error will be caught by compare_parameters(). */
- sprintf (name, "%s", sym->name);
- *binding_label = sym->binding_label;
- }
-
- return;
-}
-
-
-/* Resolve a generic version of the iso_c_binding procedure given
- (sym) to the specific one based on the type and kind of the
- argument(s). Currently, this function resolves c_f_pointer() and
- c_f_procpointer based on the type and kind of the second argument
- (FPTR). Other iso_c_binding procedures aren't specially handled.
- Upon successfully exiting, c->resolved_sym will hold the resolved
- symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
- otherwise. */
-
-match
-gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
-{
- gfc_symbol *new_sym;
- /* this is fine, since we know the names won't use the max */
- char name[GFC_MAX_SYMBOL_LEN + 1];
- const char* binding_label;
- /* default to success; will override if find error */
- match m = MATCH_YES;
-
- /* Make sure the actual arguments are in the necessary order (based on the
- formal args) before resolving. */
- if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE)
- {
- c->resolved_sym = sym;
- return MATCH_ERROR;
- }
-
- if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
- {
- set_name_and_label (c, sym, name, &binding_label);
-
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- if (c->ext.actual != NULL && c->ext.actual->next != NULL)
- {
- gfc_actual_arglist *arg1 = c->ext.actual;
- gfc_actual_arglist *arg2 = c->ext.actual->next;
- gfc_actual_arglist *arg3 = c->ext.actual->next->next;
-
- /* Check first argument (CPTR). */
- if (arg1->expr->ts.type != BT_DERIVED
- || arg1->expr->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
- {
- gfc_error ("Argument CPTR to C_F_POINTER at %L shall have "
- "the type C_PTR", &arg1->expr->where);
- m = MATCH_ERROR;
- }
-
- /* Check second argument (FPTR). */
- if (arg2->expr->ts.type == BT_CLASS)
- {
- gfc_error ("Argument FPTR to C_F_POINTER at %L must not be "
- "polymorphic", &arg2->expr->where);
- m = MATCH_ERROR;
- }
-
- /* Make sure we got a third arg (SHAPE) if the second arg has
- non-zero rank. We must also check that the type and rank are
- correct since we short-circuit this check in
- gfc_procedure_use() (called above to sort actual args). */
- if (arg2->expr->rank != 0)
- {
- if (arg3 == NULL || arg3->expr == NULL)
- {
- m = MATCH_ERROR;
- gfc_error ("Missing SHAPE argument for call to %s at %L",
- sym->name, &c->loc);
- }
- else if (arg3->expr->ts.type != BT_INTEGER
- || arg3->expr->rank != 1)
- {
- m = MATCH_ERROR;
- gfc_error ("SHAPE argument for call to %s at %L must be "
- "a rank 1 INTEGER array", sym->name, &c->loc);
- }
- }
- }
- }
- else /* ISOCBINDING_F_PROCPOINTER. */
- {
- if (c->ext.actual
- && (c->ext.actual->expr->ts.type != BT_DERIVED
- || c->ext.actual->expr->ts.u.derived->intmod_sym_id
- != ISOCBINDING_FUNPTR))
- {
- gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type "
- "C_FUNPTR", &c->ext.actual->expr->where);
- m = MATCH_ERROR;
- }
- if (c->ext.actual && c->ext.actual->next
- && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c
- && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable "
- "procedure-pointer at %L to C_F_FUNPOINTER",
- &c->ext.actual->next->expr->where)
- == FAILURE)
- m = MATCH_ERROR;
- }
-
- if (m != MATCH_ERROR)
- {
- /* the 1 means to add the optional arg to formal list */
- new_sym = get_iso_c_sym (sym, name, binding_label, 1);
-
- /* for error reporting, say it's declared where the original was */
- new_sym->declared_at = sym->declared_at;
- }
- }
- else
- {
- /* no differences for c_loc or c_funloc */
- new_sym = sym;
- }
-
- /* set the resolved symbol */
- if (m != MATCH_ERROR)
- c->resolved_sym = new_sym;
- else
- c->resolved_sym = sym;
-
- return m;
-}
-
-
/* Resolve a subroutine call known to be specific. */
static match
@@ -3640,12 +3086,6 @@ resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
match m;
- if(sym->attr.is_iso_c)
- {
- m = gfc_iso_c_sub_interface (c,sym);
- return m;
- }
-
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
@@ -13670,8 +13110,10 @@ resolve_symbol (gfc_symbol *sym)
}
if (sym->ts.type == BT_LOGICAL
- && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym)
+ && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym
+ && sym->ns == gfc_current_ns)
|| ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name
+ && sym->ns == gfc_current_ns
&& sym->ns->proc_name->attr.is_bind_c)))
{
int i;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ad1c498..2948c4e 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3842,23 +3842,8 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
else
tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- if (tmp_sym->ts.u.derived == NULL)
- {
- /* This can occur if the user forgot to declare c_ptr or
- c_funptr and they're trying to use one of the procedures
- that has arg(s) of the missing type. In this case, a
- regular version of the thing should have been put in the
- current ns. */
-
- generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
- ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
- (const char *) (ptr_id == ISOCBINDING_NULL_PTR
- ? "c_ptr"
- : "c_funptr"));
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
- ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
- }
+
+ gcc_assert (tmp_sym->ts.u.derived);
/* Module name is some mangled version of iso_c_binding. */
tmp_sym->module = gfc_get_string (module_name);
@@ -3913,200 +3898,6 @@ add_formal_arg (gfc_formal_arglist **head,
}
-/* Generates a symbol representing the CPTR argument to an
- iso_c_binding procedure. Also, create a gfc_formal_arglist for the
- CPTR and add it to the provided argument list. */
-
-static void
-gen_cptr_param (gfc_formal_arglist **head,
- gfc_formal_arglist **tail,
- const char *module_name,
- gfc_namespace *ns, const char *c_ptr_name,
- int iso_c_sym_id)
-{
- gfc_symbol *param_sym = NULL;
- gfc_symbol *c_ptr_sym = NULL;
- gfc_symtree *param_symtree = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- const char *c_ptr_in;
- const char *c_ptr_type = NULL;
-
- if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
- c_ptr_type = "c_funptr";
- else
- c_ptr_type = "c_ptr";
-
- if(c_ptr_name == NULL)
- c_ptr_in = "gfc_cptr__";
- else
- c_ptr_in = c_ptr_name;
- gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
- if (param_symtree != NULL)
- param_sym = param_symtree->n.sym;
- else
- gfc_internal_error ("gen_cptr_param(): Unable to "
- "create symbol for %s", c_ptr_in);
-
- /* Set up the appropriate fields for the new c_ptr param sym. */
- param_sym->refs++;
- param_sym->attr.flavor = FL_DERIVED;
- param_sym->ts.type = BT_DERIVED;
- param_sym->attr.intent = INTENT_IN;
- param_sym->attr.dummy = 1;
-
- /* This will pass the ptr to the iso_c routines as a (void *). */
- param_sym->attr.value = 1;
- param_sym->attr.use_assoc = 1;
-
- /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
- (user renamed). */
- if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
- c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
- else
- c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
- if (c_ptr_sym == NULL)
- {
- /* This can happen if the user did not define c_ptr but they are
- trying to use one of the iso_c_binding functions that need it. */
- if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
- generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
- (const char *)c_ptr_type);
- else
- generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
- (const char *)c_ptr_type);
-
- gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
- }
-
- param_sym->ts.u.derived = c_ptr_sym;
- param_sym->module = gfc_get_string (module_name);
-
- /* Make new formal arg. */
- formal_arg = gfc_get_formal_arglist ();
- /* Add arg to list of formal args (the CPTR arg). */
- add_formal_arg (head, tail, formal_arg, param_sym);
-
- /* Validate changes. */
- gfc_commit_symbol (param_sym);
-}
-
-
-/* Generates a symbol representing the FPTR argument to an
- iso_c_binding procedure. Also, create a gfc_formal_arglist for the
- FPTR and add it to the provided argument list. */
-
-static void
-gen_fptr_param (gfc_formal_arglist **head,
- gfc_formal_arglist **tail,
- const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name, int proc)
-{
- gfc_symbol *param_sym = NULL;
- gfc_symtree *param_symtree = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- const char *f_ptr_out = "gfc_fptr__";
-
- if (f_ptr_name != NULL)
- f_ptr_out = f_ptr_name;
-
- gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
- if (param_symtree != NULL)
- param_sym = param_symtree->n.sym;
- else
- gfc_internal_error ("generateFPtrParam(): Unable to "
- "create symbol for %s", f_ptr_out);
-
- /* Set up the necessary fields for the fptr output param sym. */
- param_sym->refs++;
- if (proc)
- param_sym->attr.proc_pointer = 1;
- else
- param_sym->attr.pointer = 1;
- param_sym->attr.dummy = 1;
- param_sym->attr.use_assoc = 1;
-
- /* ISO C Binding type to allow any pointer type as actual param. */
- param_sym->ts.type = BT_VOID;
- param_sym->module = gfc_get_string (module_name);
-
- /* Make the arg. */
- formal_arg = gfc_get_formal_arglist ();
- /* Add arg to list of formal args. */
- add_formal_arg (head, tail, formal_arg, param_sym);
-
- /* Validate changes. */
- gfc_commit_symbol (param_sym);
-}
-
-
-/* Generates a symbol representing the optional SHAPE argument for the
- iso_c_binding c_f_pointer() procedure. Also, create a
- gfc_formal_arglist for the SHAPE and add it to the provided
- argument list. */
-
-static void
-gen_shape_param (gfc_formal_arglist **head,
- gfc_formal_arglist **tail,
- const char *module_name,
- gfc_namespace *ns, const char *shape_param_name)
-{
- gfc_symbol *param_sym = NULL;
- gfc_symtree *param_symtree = NULL;
- gfc_formal_arglist *formal_arg = NULL;
- const char *shape_param = "gfc_shape_array__";
-
- if (shape_param_name != NULL)
- shape_param = shape_param_name;
-
- gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
- if (param_symtree != NULL)
- param_sym = param_symtree->n.sym;
- else
- gfc_internal_error ("generateShapeParam(): Unable to "
- "create symbol for %s", shape_param);
-
- /* Set up the necessary fields for the shape input param sym. */
- param_sym->refs++;
- param_sym->attr.dummy = 1;
- param_sym->attr.use_assoc = 1;
-
- /* Integer array, rank 1, describing the shape of the object. Make it's
- type BT_VOID initially so we can accept any type/kind combination of
- integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
- of BT_INTEGER type. */
- param_sym->ts.type = BT_VOID;
-
- /* Initialize the kind to default integer. However, it will be overridden
- during resolution to match the kind of the SHAPE parameter given as
- the actual argument (to allow for any valid integer kind). */
- param_sym->ts.kind = gfc_default_integer_kind;
- param_sym->as = gfc_get_array_spec ();
-
- param_sym->as->rank = 1;
- param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
-
- /* The extent is unknown until we get it. The length give us
- the rank the incoming pointer. */
- param_sym->as->type = AS_ASSUMED_SHAPE;
-
- /* The arg is also optional; it is required iff the second arg
- (fptr) is to an array, otherwise, it's ignored. */
- param_sym->attr.optional = 1;
- param_sym->attr.intent = INTENT_IN;
- param_sym->attr.dimension = 1;
- param_sym->module = gfc_get_string (module_name);
-
- /* Make the arg. */
- formal_arg = gfc_get_formal_arglist ();
- /* Add arg to list of formal args. */
- add_formal_arg (head, tail, formal_arg, param_sym);
-
- /* Validate changes. */
- gfc_commit_symbol (param_sym);
-}
-
-
/* Add a procedure interface to the given symbol (i.e., store a
reference to the list of formal arguments). */
@@ -4304,74 +4095,6 @@ gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src, ifsrc if_src)
}
-/* Builds the parameter list for the iso_c_binding procedure
- c_f_pointer or c_f_procpointer. The old_sym typically refers to a
- generic version of either the c_f_pointer or c_f_procpointer
- functions. The new_proc_sym represents a "resolved" version of the
- symbol. The functions are resolved to match the types of their
- parameters; for example, c_f_pointer(cptr, fptr) would resolve to
- something similar to c_f_pointer_i4 if the type of data object fptr
- pointed to was a default integer. The actual name of the resolved
- procedure symbol is further mangled with the module name, etc., but
- the idea holds true. */
-
-static void
-build_formal_args (gfc_symbol *new_proc_sym,
- gfc_symbol *old_sym, int add_optional_arg)
-{
- gfc_formal_arglist *head = NULL, *tail = NULL;
- gfc_namespace *parent_ns = NULL;
-
- parent_ns = gfc_current_ns;
- /* Create a new namespace, which will be the formal ns (namespace
- of the formal args). */
- gfc_current_ns = gfc_get_namespace(parent_ns, 0);
- gfc_current_ns->proc_name = new_proc_sym;
-
- /* Generate the params. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr", old_sym->intmod_sym_id);
- gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr", 1);
- }
- else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "cptr", old_sym->intmod_sym_id);
- gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr", 0);
- /* If we're dealing with c_f_pointer, it has an optional third arg. */
- gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
-
- }
- else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- /* c_associated has one required arg and one optional; both
- are c_ptrs. */
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
- if (add_optional_arg)
- {
- gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
- /* The last param is optional so mark it as such. */
- tail->sym->attr.optional = 1;
- }
- }
-
- /* Add the interface (store formal args to new_proc_sym). */
- add_proc_interface (new_proc_sym, IFSRC_DECL, head);
-
- /* Set up the formal_ns pointer to the one created for the
- new procedure so it'll get cleaned up during gfc_free_symbol(). */
- new_proc_sym->formal_ns = gfc_current_ns;
-
- gfc_current_ns = parent_ns;
-}
-
static int
std_for_isocbinding_symbol (int id)
{
@@ -4386,8 +4109,12 @@ std_for_isocbinding_symbol (int id)
#define NAMED_FUNCTION(a,b,c,d) \
case a:\
return d;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+ case a:\
+ return d;
#include "iso-c-binding.def"
#undef NAMED_FUNCTION
+#undef NAMED_SUBROUTINE
default:
return GFC_STD_F2003;
@@ -4405,9 +4132,10 @@ std_for_isocbinding_symbol (int id)
end of the list. */
-void
+gfc_symtree *
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
- const char *local_name)
+ const char *local_name, gfc_symtree *symtree,
+ bool hidden)
{
const char *const name = (local_name && local_name[0]) ? local_name
: c_interop_kinds_table[s].name;
@@ -4416,9 +4144,14 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
- return;
+ return NULL;
- tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (symtree)
+ tmp_symtree = symtree;
+ else if (hidden)
+ tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
+ else
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Already exists in this scope so don't re-add it. */
if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
@@ -4436,7 +4169,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gfc_derived_types = dt_list;
}
- return;
+ return tmp_symtree;
}
/* Create the sym tree in the current ns. */
@@ -4536,7 +4269,6 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
const char *hidden_name;
gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
- char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
hidden_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) tmp_sym->name[0]),
@@ -4566,12 +4298,12 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
if (!tmp_sym->attr.generic
&& gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
- return;
+ return NULL;
if (!tmp_sym->attr.function
&& gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
- return;
+ return NULL;
/* Say what module this symbol belongs to. */
dt_sym->module = gfc_get_string (mod_name);
@@ -4582,7 +4314,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->ts.is_c_interop = 1;
dt_sym->attr.is_c_interop = 1;
- dt_sym->attr.is_iso_c = 1;
+ dt_sym->attr.is_iso_c =1;
+ dt_sym->attr.private_comp = 1;
dt_sym->ts.is_iso_c = 1;
dt_sym->ts.type = BT_DERIVED;
@@ -4607,15 +4340,10 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
(*dt_list_ptr)->derived = dt_sym;
(*dt_list_ptr)->next = NULL;
- /* Set up the component of the derived type, which will be
- an integer with kind equal to c_ptr_size. Mangle the name of
- the field for the c_address to prevent the curious user from
- trying to access it from Fortran. */
- sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
- gfc_add_component (dt_sym, comp_name, &tmp_comp);
+ gfc_add_component (dt_sym, "c_address", &tmp_comp);
if (tmp_comp == NULL)
- gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
- "create component for c_address");
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create component for c_address");
tmp_comp->ts.type = BT_INTEGER;
@@ -4643,145 +4371,11 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
gen_special_c_interop_ptr (s, name, mod_name);
break;
- case ISOCBINDING_F_POINTER:
- case ISOCBINDING_ASSOCIATED:
- case ISOCBINDING_LOC:
- case ISOCBINDING_FUNLOC:
- case ISOCBINDING_F_PROCPOINTER:
-
- tmp_sym->attr.proc = PROC_MODULE;
-
- /* Use the procedure's name as it is in the iso_c_binding module for
- setting the binding label in case the user renamed the symbol. */
- tmp_sym->binding_label =
- gfc_get_string ("%s_%s", mod_name,
- c_interop_kinds_table[s].name);
- tmp_sym->attr.is_iso_c = 1;
- if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
- tmp_sym->attr.subroutine = 1;
- else
- {
- /* TODO! This needs to be finished more for the expr of the
- function or something!
- This may not need to be here, because trying to do c_loc
- as an external. */
- if (s == ISOCBINDING_ASSOCIATED)
- {
- tmp_sym->attr.function = 1;
- tmp_sym->ts.type = BT_LOGICAL;
- tmp_sym->ts.kind = gfc_default_logical_kind;
- tmp_sym->result = tmp_sym;
- }
- else
- {
- /* Here, we're taking the simple approach. We're defining
- c_loc as an external identifier so the compiler will put
- what we expect on the stack for the address we want the
- C address of. */
- tmp_sym->ts.type = BT_DERIVED;
- if (s == ISOCBINDING_LOC)
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_PTR);
- else
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
-
- if (tmp_sym->ts.u.derived == NULL)
- {
- /* Create the necessary derived type so we can continue
- processing the file. */
- generate_isocbinding_symbol
- (mod_name, s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
- (const char *)(s == ISOCBINDING_FUNLOC
- ? "c_funptr" : "c_ptr"));
- tmp_sym->ts.u.derived =
- get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
- ? ISOCBINDING_FUNPTR
- : ISOCBINDING_PTR);
- }
-
- /* The function result is itself (no result clause). */
- tmp_sym->result = tmp_sym;
- tmp_sym->attr.external = 1;
- tmp_sym->attr.use_assoc = 0;
- tmp_sym->attr.pure = 1;
- tmp_sym->attr.if_source = IFSRC_UNKNOWN;
- tmp_sym->attr.proc = PROC_UNKNOWN;
- }
- }
-
- tmp_sym->attr.flavor = FL_PROCEDURE;
- tmp_sym->attr.contained = 0;
-
- /* Try using this builder routine, with the new and old symbols
- both being the generic iso_c proc sym being created. This
- will create the formal args (and the new namespace for them).
- Don't build an arg list for c_loc because we're going to treat
- c_loc as an external procedure. */
- if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
- /* The 1 says to add any optional args, if applicable. */
- build_formal_args (tmp_sym, tmp_sym, 1);
-
- /* Set this after setting up the symbol, to prevent error messages. */
- tmp_sym->attr.use_assoc = 1;
-
- /* This symbol will not be referenced directly. It will be
- resolved to the implementation for the given f90 kind. */
- tmp_sym->attr.referenced = 0;
-
- break;
-
default:
gcc_unreachable ();
}
gfc_commit_symbol (tmp_sym);
-}
-
-
-/* Creates a new symbol based off of an old iso_c symbol, with a new
- binding label. This function can be used to create a new,
- resolved, version of a procedure symbol for c_f_pointer or
- c_f_procpointer that is based on the generic symbols. A new
- parameter list is created for the new symbol using
- build_formal_args(). The add_optional_flag specifies whether the
- to add the optional SHAPE argument. The new symbol is
- returned. */
-
-gfc_symbol *
-get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
- const char *new_binding_label, int add_optional_arg)
-{
- gfc_symtree *new_symtree = NULL;
-
- /* See if we have a symbol by that name already available, looking
- through any parent namespaces. */
- gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
- if (new_symtree != NULL)
- /* Return the existing symbol. */
- return new_symtree->n.sym;
-
- /* Create the symtree/symbol, with attempted host association. */
- gfc_get_ha_sym_tree (new_name, &new_symtree);
- if (new_symtree == NULL)
- gfc_internal_error ("get_iso_c_sym(): Unable to create "
- "symtree for '%s'", new_name);
-
- /* Now fill in the fields of the resolved symbol with the old sym. */
- new_symtree->n.sym->binding_label = new_binding_label;
- new_symtree->n.sym->attr = old_sym->attr;
- new_symtree->n.sym->ts = old_sym->ts;
- new_symtree->n.sym->module = gfc_get_string (old_sym->module);
- new_symtree->n.sym->from_intmod = old_sym->from_intmod;
- new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
- if (old_sym->attr.function)
- new_symtree->n.sym->result = new_symtree->n.sym;
- /* Build the formal arg list. */
- build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
-
- gfc_commit_symbol (new_symtree->n.sym);
-
- return new_symtree->n.sym;
+ return tmp_symtree;
}
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 088a299..9f02e38 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7156,9 +7156,15 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
ptr = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, desc);
- if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ if (fsym && fsym->attr.optional && sym
+ && (sym->attr.optional
+ || (sym->ts.type != BT_CLASS
+ && (sym->attr.pointer || sym->attr.allocatable))
+ || (sym->ts.type == BT_CLASS
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA(sym)->attr.allocatable))))
{
- tmp = gfc_conv_expr_present (sym);
+ tmp = sym->attr.optional ? gfc_conv_expr_present (sym) : NULL_TREE;
ptr = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
tmp, fold_convert (TREE_TYPE (se->expr), ptr),
fold_convert (TREE_TYPE (se->expr), null_pointer_node));
@@ -7327,22 +7333,45 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
if (rank == 0)
{
tmp = null_pointer_node;
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
- gfc_add_expr_to_block (&block, tmp);
+ /* Handle coarray. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ else
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, dest, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ }
null_data = gfc_finish_block (&block);
gfc_init_block (&block);
- size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ else
+ size = TYPE_SIZE_UNIT (TREE_TYPE (type));
if (!no_malloc)
{
- tmp = gfc_call_malloc (&block, type, size);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- dest, fold_convert (type, tmp));
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ {
+ tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+ tmp = gfc_call_malloc (&block, tmp, size);
+ gfc_conv_descriptor_data_set (&block, dest, tmp);
+ }
+ else
+ {
+ tmp = gfc_call_malloc (&block, type, size);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, dest,
+ fold_convert (type, tmp));
+ }
gfc_add_expr_to_block (&block, tmp);
}
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest))
+ ? gfc_conv_descriptor_data_get (dest): dest,
+ GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))
+ ? gfc_conv_descriptor_data_get (src): src,
fold_convert (size_type_node, size));
}
else
@@ -7377,7 +7406,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
/* Null the destination if the source is null; otherwise do
the allocate and copy. */
- if (rank == 0)
+ if (rank == 0 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
null_cond = src;
else
null_cond = gfc_conv_descriptor_data_get (src);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e3386b1..32c911c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/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)
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 83e3acf..d6cf70b 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6302,6 +6302,222 @@ 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_symbol *fsym;
+ 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
+ {
+ bool 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 || !expr->symtree->n.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);
+ }
+ 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. */
@@ -6477,6 +6693,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);
@@ -7586,6 +7808,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;
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 7b2738a..40e6981 100644
--- a/gcc/fortran/trans-types.c
+++ b/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;
diff --git a/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90 b/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90
index 467bdc1..7d93436 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90
@@ -4,22 +4,22 @@
! PR fortran/55758
!
-function sub2() bind(C) ! { dg-error "GNU Extension: LOGICAL result variable 'sub2' at .1. with non-C_Bool kind in BIND.C. procedure 'sub2'" }
- logical(kind=8) :: sub2
- logical(kind=4) :: local ! OK
-end function sub2
-
-function sub4() bind(C) result(res) ! { dg-error "GNU Extension: LOGICAL result variable 'res' at .1. with non-C_Bool kind in BIND.C. procedure 'sub4'" }
- logical(kind=2) :: res
- logical(kind=4) :: local ! OK
-end function sub4
+!function sub2() bind(C) ! { dg-error "GNU Extension: LOGICAL result variable 'sub2' at .1. with non-C_Bool kind in BIND.C. procedure 'sub2'" }
+! logical(kind=8) :: sub2
+! logical(kind=4) :: local ! OK
+!end function sub2
+!
+!function sub4() bind(C) result(res) ! { dg-error "GNU Extension: LOGICAL result variable 'res' at .1. with non-C_Bool kind in BIND.C. procedure 'sub4'" }
+! logical(kind=2) :: res
+! logical(kind=4) :: local ! OK
+!end function sub4
subroutine sub(x) bind(C) ! { dg-error "GNU Extension: LOGICAL dummy argument 'x' at .1. with non-C_Bool kind in BIND.C. procedure 'sub'" }
logical(kind=4) :: x
end subroutine sub
-subroutine sub3(y) bind(C)
- use iso_c_binding, only : c_bool
- logical(kind=c_bool) :: y ! OK
-end subroutine sub3
+!subroutine sub3(y) bind(C)
+! use iso_c_binding, only : c_bool
+! logical(kind=c_bool) :: y ! OK
+!end subroutine sub3