+2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
+
+ * interface.c (gfc_compare_derived_types): Special case for comparing
+ derived types across namespaces.
+ (gfc_compare_types): Deal with BT_VOID.
+ (compare_parameter): Use BT_VOID to accept ISO C Binding pointers.
+ * trans-expr.c (gfc_conv_function_call): Remove setting parm_kind
+ to SCALAR
+ (gfc_conv_initializer): Deal with ISO C Binding NULL_PTR and
+ NULL_FUNPTR.
+ (gfc_conv_expr): Convert expressions for ISO C Binding derived types.
+ * symbol.c (gfc_set_default_type): BIND(C) variables should not be
+ implicitly declared.
+ (check_conflict): Add BIND(C) and check for conflicts.
+ (gfc_add_explicit_interface): Whitespace.
+ (gfc_add_is_bind_c): New function.
+ (gfc_copy_attr): Use it.
+ (gfc_new_symbol): Initialize ISO C Binding objects.
+ (get_iso_c_binding_dt): New function.
+ (verify_bind_c_derived_type): Ditto.
+ (gen_special_c_interop_ptr): Ditto.
+ (add_formal_arg): Ditto.
+ (gen_cptr_param): Ditto.
+ (gen_fptr_param): Ditto.
+ (gen_shape_param): Ditto.
+ (add_proc_interface): Ditto.
+ (build_formal_args): Ditto.
+ (generate_isocbinding_symbol): Ditto.
+ (get_iso_c_sym): Ditto.
+ * decl.c (num_idents_on_line, has_name_equals): New variables.
+ (verify_c_interop_param): New function.
+ (build_sym): Finish binding labels and deal with COMMON blocks.
+ (add_init_expr_to_sym): Check if the initialized expression is
+ an iso_c_binding named constants
+ (variable_decl): Set ISO C Binding type_spec components.
+ (gfc_match_kind_spec): Check match for C interoperable kind.
+ (match_char_spec): Fix comment. Chnage gfc_match_small_int
+ to gfc_match_small_int_expr. Check for C interoperable kind.
+ (match_type_spec): Clear the current binding label.
+ (match_attr_spec): Add DECL_IS_BIND_C. If BIND(C) is found, use it
+ to set attributes.
+ (set_binding_label): New function.
+ (set_com_block_bind_c): Ditto.
+ (verify_c_interop): Ditto.
+ (verify_com_block_vars_c_interop): Ditto.
+ (verify_bind_c_sym): Ditto.
+ (set_verify_bind_c_sym): Ditto.
+ (set_verify_bind_c_com_block): Ditto.
+ (get_bind_c_idents): Ditto.
+ (gfc_match_bind_c_stmt): Ditto.
+ (gfc_match_data_decl): Use num_idents_on_line.
+ (match_result): Deal with right paren in BIND(C).
+ (gfc_match_suffix): New function.
+ (gfc_match_function_decl): Use it. Code is re-arranged to deal with
+ ISO C Binding result clauses.
+ (gfc_match_subroutine): Deal with BIND(C).
+ (gfc_match_bind_c): New function.
+ (gfc_get_type_attr_spec): New function. Code is re-arranged in and
+ taken from gfc_match_derived_decl.
+ (gfc_match_derived_decl): Add check for BIND(C).
+ * trans-common.c: Forward declare gfc_get_common.
+ (gfc_sym_mangled_common_id): Change arg from 'const char *name' to
+ 'gfc_common_head *com'. Check for ISO C Binding of the common block.
+ (build_common_decl): 'com->name' to 'com in SET_DECL_ASSEMBLER_NAME.
+ * gfortran.h: Add GFC_MAX_BINDING_LABEL_LEN
+ (bt): Add BT_VOID
+ (sym_flavor): Add FL_VOID.
+ (iso_fortran_env_symbol, iso_c_binding_symbol, intmod_id): New enum
+ (CInteropKind_t): New struct.
+ (c_interop_kinds_table): Use it. Declare an array of structs.
+ (symbol_attribute): Add is_bind_c, is_c_interop, and is_iso_c
+ bitfields.
+ (gfc_typespec): Add is_c_interop; is_iso_c, and f90_type members.
+ (gfc_symbol): Add from_intmod, intmod_sym_id, binding_label, and
+ common_block members.
+ (gfc_common_head): Add binding_label and is_bind_c members.
+ (gfc_gsymbol): Add sym_name, mod_name, and binding_label members.
+ Add prototypes for get_c_kind, gfc_validate_c_kind,
+ gfc_check_any_c_kind, gfc_add_is_bind_c, gfc_add_value,
+ verify_c_interop, verify_c_interop_param, verify_bind_c_sym,
+ verify_bind_c_derived_type, verify_com_block_vars_c_interop,
+ generate_isocbinding_symbol, get_iso_c_sym, gfc_iso_c_sub_interface
+ * iso-c-binding.def: New file. This file contains the definitions
+ of the types provided by the Fortran 2003 ISO_C_BINDING intrinsic
+ module.
+ * trans-const.c (gfc_conv_constant_to_tree): Deal with C_NULL_PTR
+ or C_NULL_FUNPTR expressions.
+ * expr.c (gfc_copy_expr): Add BT_VOID case. For BT_CHARACTER, the
+ ISO C Binding requires a minimum string length of 1 for '\0'.
+ * module.c (intmod_sym): New struct.
+ (pointer_info): Add binding_label member.
+ (write_atom): Set len to 0 for NULL pointers. Check for NULL p and *p.
+ (ab_attribute): Add AB_IS_BIND_C, AB_IS_C_INTEROP and AB_IS_ISO_C.
+ (attr_bits): Add "IS_BIND_C", "IS_C_INTEROP", and "IS_ISO_C".
+ (mio_symbol_attribute): Deal with ISO C Binding attributes.
+ (bt_types): Add "VOID".
+ (mio_typespec): Deal with ISO C Binding components.
+ (mio_namespace_ref): Add intmod variable.
+ (mio_symbol): Check for symbols from an intrinsic module.
+ (load_commons): Check for BIND(C) common block.
+ (read_module): Read binding_label and use it.
+ (write_common): Add label. Write BIND(C) info.
+ (write_blank_common): Blank commons are not BIND(C). Explicitly
+ set is_bind_c=0.
+ (write_symbol): Deal with binding_label.
+ (sort_iso_c_rename_list): New function.
+ (import_iso_c_binding_module): Ditto.
+ (create_int_parameter): Add to args.
+ (use_iso_fortran_env_module): Adjust to deal with iso_c_binding
+ intrinsic module.
+ * trans-types.c (c_interop_kinds_table): new array of structs.
+ (gfc_validate_c_kind): New function.
+ (gfc_check_any_c_kind): Ditto.
+ (get_real_kind_from_node): Ditto.
+ (get_int_kind_from_node): Ditto.
+ (get_int_kind_from_width): Ditto.
+ (get_int_kind_from_minimal_width): Ditto.
+ (init_c_interop_kinds): Ditto.
+ (gfc_init_kinds): call init_c_interop_kinds.
+ (gfc_typenode_for_spec): Adjust for BT_VOID and ISO C Binding pointers.
+ Adjust handling of BT_DERIVED.
+ (gfc_sym_type): Whitespace.
+ (gfc_get_derived_type): Account for iso_c_binding derived types
+ * resolve.c (is_scalar_expr_ptr): New function.
+ (gfc_iso_c_func_interface): Ditto.
+ (resolve_function): Use gfc_iso_c_func_interface.
+ (set_name_and_label): New function.
+ (gfc_iso_c_sub_interface): Ditto.
+ (resolve_specific_s0): Use gfc_iso_c_sub_interface.
+ (resolve_bind_c_comms): New function.
+ (resolve_bind_c_derived_types): Ditto.
+ (gfc_verify_binding_labels): Ditto.
+ (resolve_fl_procedure): Check for ISO C interoperability.
+ (resolve_symbol): Check C interoperability.
+ (resolve_types): Walk the namespace. Check COMMON blocks.
+ * trans-decl.c (gfc_sym_mangled_identifier): Prevent the mangling
+ of identifiers that have an assigned binding label.
+ (gfc_sym_mangled_function_id): Use the binding label rather than
+ the mangled name.
+ (gfc_finish_var_decl): Put variables that are BIND(C) into a common
+ segment of the object file, because this is what C would do.
+ (gfc_create_module_variable): Conver to proper types
+ (set_tree_decl_type_code): New function.
+ (generate_local_decl): Check dummy variables and derived types for
+ ISO C Binding attributes.
+ * match.c (gfc_match_small_int_expr): New function.
+ (gfc_match_name_C): Ditto.
+ (match_common_name): Deal with ISO C Binding in COMMON blocks
+ * trans-io.c (transfer_expr): Deal with C_NULL_PTR or C_NULL_FUNPTR
+ expressions
+ * match.h: Add prototypes for gfc_match_small_int_expr,
+ gfc_match_name_C, match_common_name, set_com_block_bind_c,
+ set_binding_label, set_verify_bind_c_sym,
+ set_verify_bind_c_com_block, get_bind_c_idents,
+ gfc_match_bind_c_stmt, gfc_match_suffix, gfc_match_bind_c,
+ gfc_get_type_attr_spec
+ * parse.c (decode_statement): Use gfc_match_bind_c_stmt
+ (parse_derived): Init *derived_sym = NULL, and gfc_current_block
+ later for valiadation.
+ * primary.c (got_delim): Set ISO C Binding components of ts.
+ (match_logical_constant): Ditto.
+ (match_complex_constant): Ditto.
+ (match_complex_constant): Ditto.
+ (gfc_match_rvalue): Check for existence of at least one arg for
+ C_LOC, C_FUNLOC, and C_ASSOCIATED.
+ * misc.c (gfc_clear_ts): Clear ISO C Bindoing components in ts.
+ (get_c_kind): New function.
+
2007-07-01 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/32239
static gfc_array_spec *current_as;
static int colon_seen;
+/* The current binding label (if any). */
+static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+/* Need to know how many identifiers are on the current data declaration
+ line in case we're given the BIND(C) attribute with a NAME= specifier. */
+static int num_idents_on_line;
+/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
+ can supply a name if the curr_binding_label is nil and NAME= was not. */
+static int has_name_equals = 0;
+
/* Initializer of the previous enumerator. */
static gfc_expr *last_initializer;
}
-/* Function called by variable_decl() that adds a name to the symbol
- table. */
+/* Verify that the given symbol representing a parameter is C
+ interoperable, by checking to see if it was marked as such after
+ its declaration. If the given symbol is not interoperable, a
+ warning is reported, thus removing the need to return the status to
+ the calling function. The standard does not require the user use
+ one of the iso_c_binding named constants to declare an
+ interoperable parameter, but we can't be sure if the param is C
+ interop or not if the user doesn't. For example, integer(4) may be
+ legal Fortran, but doesn't have meaning in C. It may interop with
+ a number of the C types, which causes a problem because the
+ compiler can't know which one. This code is almost certainly not
+ portable, and the user will get what they deserve if the C type
+ across platforms isn't always interoperable with integer(4). If
+ the user had used something like integer(c_int) or integer(c_long),
+ the compiler could have automatically handled the varying sizes
+ across platforms. */
+
+try
+verify_c_interop_param (gfc_symbol *sym)
+{
+ int is_c_interop = 0;
+ try retval = SUCCESS;
+
+ /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
+ Don't repeat the checks here. */
+ if (sym->attr.implicit_type)
+ return SUCCESS;
+
+ /* For subroutines or functions that are passed to a BIND(C) procedure,
+ they're interoperable if they're BIND(C) and their params are all
+ interoperable. */
+ if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ if (sym->attr.is_bind_c == 0)
+ {
+ gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
+ "attribute to be C interoperable", sym->name,
+ &(sym->declared_at));
+
+ return FAILURE;
+ }
+ else
+ {
+ if (sym->attr.is_c_interop == 1)
+ /* We've already checked this procedure; don't check it again. */
+ return SUCCESS;
+ else
+ return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block);
+ }
+ }
+
+ /* See if we've stored a reference to a procedure that owns sym. */
+ if (sym->ns != NULL && sym->ns->proc_name != NULL)
+ {
+ if (sym->ns->proc_name->attr.is_bind_c == 1)
+ {
+ is_c_interop =
+ (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
+ == SUCCESS ? 1 : 0);
+
+ if (is_c_interop != 1)
+ {
+ /* Make personalized messages to give better feedback. */
+ if (sym->ts.type == BT_DERIVED)
+ gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
+ " procedure '%s' but is not C interoperable "
+ "because derived type '%s' is not C interoperable",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name,
+ sym->ts.derived->name);
+ else
+ gfc_warning ("Variable '%s' at %L is a parameter to the "
+ "BIND(C) procedure '%s' but may not be C "
+ "interoperable",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name);
+ }
+
+ /* We have to make sure that any param to a bind(c) routine does
+ not have the allocatable, pointer, or optional attributes,
+ according to J3/04-007, section 5.1. */
+ if (sym->attr.allocatable == 1)
+ {
+ gfc_error ("Variable '%s' at %L cannot have the "
+ "ALLOCATABLE attribute because procedure '%s'"
+ " is BIND(C)", sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name);
+ retval = FAILURE;
+ }
+
+ if (sym->attr.pointer == 1)
+ {
+ gfc_error ("Variable '%s' at %L cannot have the "
+ "POINTER attribute because procedure '%s'"
+ " is BIND(C)", sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name);
+ retval = FAILURE;
+ }
+
+ if (sym->attr.optional == 1)
+ {
+ gfc_error ("Variable '%s' at %L cannot have the "
+ "OPTIONAL attribute because procedure '%s'"
+ " is BIND(C)", sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name);
+ retval = FAILURE;
+ }
+
+ /* Make sure that if it has the dimension attribute, that it is
+ either assumed size or explicit shape. */
+ if (sym->as != NULL)
+ {
+ if (sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Assumed-shape array '%s' at %L cannot be an "
+ "argument to the procedure '%s' at %L because "
+ "the procedure is BIND(C)", sym->name,
+ &(sym->declared_at), sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at));
+ retval = FAILURE;
+ }
+
+ if (sym->as->type == AS_DEFERRED)
+ {
+ gfc_error ("Deferred-shape array '%s' at %L cannot be an "
+ "argument to the procedure '%s' at %L because "
+ "the procedure is BIND(C)", sym->name,
+ &(sym->declared_at), sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at));
+ retval = FAILURE;
+ }
+ }
+ }
+ }
+
+ return retval;
+}
+
+
+/* Function called by variable_decl() that adds a name to the symbol table. */
static try
build_sym (const char *name, gfc_charlen *cl,
if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
return FAILURE;
+ /* Finish any work that may need to be done for the binding label,
+ if it's a bind(c). The bind(c) attr is found before the symbol
+ is made, and before the symbol name (for data decls), so the
+ current_ts is holding the binding label, or nothing if the
+ name= attr wasn't given. Therefore, test here if we're dealing
+ with a bind(c) and make sure the binding label is set correctly. */
+ if (sym->attr.is_bind_c == 1)
+ {
+ if (sym->binding_label[0] == '\0')
+ {
+ /* Here, we're not checking the numIdents (the last param).
+ This could be an error we're letting slip through! */
+ if (set_binding_label (sym->binding_label, sym->name, 1) == FAILURE)
+ return FAILURE;
+ }
+ }
+
+ /* See if we know we're in a common block, and if it's a bind(c)
+ common then we need to make sure we're an interoperable type. */
+ if (sym->attr.in_common == 1)
+ {
+ /* Test the common block object. */
+ if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
+ && sym->ts.is_c_interop != 1)
+ {
+ gfc_error_now ("Variable '%s' in common block '%s' at %C "
+ "must be declared with a C interoperable "
+ "kind since common block '%s' is BIND(C)",
+ sym->name, sym->common_block->name,
+ sym->common_block->name);
+ gfc_clear_error ();
+ }
+ }
+
sym->attr.implied_index = 0;
return SUCCESS;
}
}
+ /* Need to check if the expression we initialized this
+ to was one of the iso_c_binding named constants. If so,
+ and we're a parameter (constant), let it be iso_c.
+ For example:
+ integer(c_int), parameter :: my_int = c_int
+ integer(my_int) :: my_int_2
+ If we mark my_int as iso_c (since we can see it's value
+ is equal to one of the named constants), then my_int_2
+ will be considered C interoperable. */
+ if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
+ {
+ sym->ts.is_iso_c |= init->ts.is_iso_c;
+ sym->ts.is_c_interop |= init->ts.is_c_interop;
+ /* attr bits needed for module files. */
+ sym->attr.is_iso_c |= init->ts.is_iso_c;
+ sym->attr.is_c_interop |= init->ts.is_c_interop;
+ if (init->ts.is_iso_c)
+ sym->ts.f90_type = init->ts.f90_type;
+ }
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
sym->ts.kind = current_ts.kind;
sym->ts.cl = cl;
sym->ts.derived = current_ts.derived;
+ sym->ts.is_c_interop = current_ts.is_c_interop;
+ sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES;
/* Check to see if we have an array specification. */
goto no_match;
}
+ /* Before throwing away the expression, let's see if we had a
+ C interoperable kind (and store the fact). */
+ if (e->ts.is_c_interop == 1)
+ {
+ /* Mark this as c interoperable if being declared with one
+ of the named constants from iso_c_binding. */
+ ts->is_c_interop = e->ts.is_iso_c;
+ ts->f90_type = e->ts.f90_type;
+ }
+
gfc_free_expr (e);
e = NULL;
+ /* Ignore errors to this point, if we've gotten here. This means
+ we ignore the m=MATCH_ERROR from above. */
if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
{
gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
gfc_basic_typename (ts->type));
-
m = MATCH_ERROR;
- goto no_match;
}
-
- if (gfc_match_char (')') != MATCH_YES)
+ else if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
- goto no_match;
+ m = MATCH_ERROR;
}
+ else
+ /* All tests passed. */
+ m = MATCH_YES;
- return MATCH_YES;
+ if(m == MATCH_ERROR)
+ gfc_current_locus = where;
+
+ /* Return what we know from the test(s). */
+ return m;
no_match:
gfc_free_expr (e);
gfc_charlen *cl;
gfc_expr *len;
match m;
-
+ gfc_expr *kind_expr = NULL;
kind = gfc_default_character_kind;
len = NULL;
seen_length = 0;
m = gfc_match_char ('(');
if (m != MATCH_YES)
{
- m = MATCH_YES; /* character without length is a single char */
+ m = MATCH_YES; /* Character without length is a single char. */
goto done;
}
- /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
+ /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
if (gfc_match (" kind =") == MATCH_YES)
{
- m = gfc_match_small_int (&kind);
+ m = gfc_match_small_int_expr(&kind, &kind_expr);
+
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
if (gfc_match (" , kind =") != MATCH_YES)
goto syntax;
- gfc_match_small_int (&kind);
+ gfc_match_small_int_expr(&kind, &kind_expr);
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
{
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
- gfc_match (" kind ="); /* Gobble optional text */
+ gfc_match (" kind ="); /* Gobble optional text. */
- m = gfc_match_small_int (&kind);
+ m = gfc_match_small_int_expr(&kind, &kind_expr);
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
if (m != MATCH_YES)
{
gfc_free_expr (len);
+ gfc_free_expr (kind_expr);
return m;
}
ts->cl = cl;
ts->kind = kind;
+ /* We have to know if it was a c interoperable kind so we can
+ do accurate type checking of bind(c) procs, etc. */
+ if (kind_expr != NULL)
+ {
+ /* Mark this as c interoperable if being declared with one
+ of the named constants from iso_c_binding. */
+ ts->is_c_interop = kind_expr->ts.is_iso_c;
+ gfc_free_expr (kind_expr);
+ }
+ else if (len != NULL)
+ {
+ /* Here, we might have parsed something such as:
+ character(c_char)
+ In this case, the parsing code above grabs the c_char when
+ looking for the length (line 1690, roughly). it's the last
+ testcase for parsing the kind params of a character variable.
+ However, it's not actually the length. this seems like it
+ could be an error.
+ To see if the user used a C interop kind, test the expr
+ of the so called length, and see if it's C interoperable. */
+ ts->is_c_interop = len->ts.is_iso_c;
+ }
+
return MATCH_YES;
}
gfc_clear_ts (ts);
+ /* Clear the current binding label, in case one is given. */
+ curr_binding_label[0] = '\0';
+
if (gfc_match (" byte") == MATCH_YES)
{
if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
- DECL_COLON, DECL_NONE,
+ DECL_IS_BIND_C, DECL_COLON, DECL_NONE,
GFC_DECL_END /* Sentinel */
}
decl_types;
const char *attr;
match m;
try t;
+ char peek_char;
gfc_clear_attr (¤t_attr);
start = gfc_current_locus;
for (;;)
{
d = (decl_types) gfc_match_strings (decls);
+
+ if (d == DECL_NONE)
+ {
+ /* See if we can find the bind(c) since all else failed.
+ We need to skip over any whitespace and stop on the ','. */
+ gfc_gobble_whitespace ();
+ peek_char = gfc_peek_char ();
+ if (peek_char == ',')
+ {
+ /* Chomp the comma. */
+ peek_char = gfc_next_char ();
+ /* Try and match the bind(c). */
+ if (gfc_match_bind_c (NULL) == MATCH_YES)
+ d = DECL_IS_BIND_C;
+ else
+ {
+ return MATCH_ERROR;
+ }
+ }
+ }
+
if (d == DECL_NONE || d == DECL_COLON)
break;
case DECL_TARGET:
attr = "TARGET";
break;
- case DECL_VALUE:
- attr = "VALUE";
- break;
+ case DECL_IS_BIND_C:
+ attr = "IS_BIND_C";
+ break;
+ case DECL_VALUE:
+ attr = "VALUE";
+ break;
case DECL_VOLATILE:
attr = "VOLATILE";
break;
t = gfc_add_target (¤t_attr, &seen_at[d]);
break;
+ case DECL_IS_BIND_C:
+ t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
+ break;
+
case DECL_VALUE:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
"at %C")
}
+/* Set the binding label, dest_label, either with the binding label
+ stored in the given gfc_typespec, ts, or if none was provided, it
+ will be the symbol name in all lower case, as required by the draft
+ (J3/04-007, section 15.4.1). If a binding label was given and
+ there is more than one argument (num_idents), it is an error. */
+
+try
+set_binding_label (char *dest_label, const char *sym_name, int num_idents)
+{
+ if (curr_binding_label[0] != '\0')
+ {
+ if (num_idents > 1 || num_idents_on_line > 1)
+ {
+ gfc_error ("Multiple identifiers provided with "
+ "single NAME= specifier at %C");
+ return FAILURE;
+ }
+
+ /* Binding label given; store in temp holder til have sym. */
+ strncpy (dest_label, curr_binding_label,
+ strlen (curr_binding_label) + 1);
+ }
+ else
+ {
+ /* No binding label given, and the NAME= specifier did not exist,
+ which means there was no NAME="". */
+ if (sym_name != NULL && has_name_equals == 0)
+ strncpy (dest_label, sym_name, strlen (sym_name) + 1);
+ }
+
+ return SUCCESS;
+}
+
+
+/* Set the status of the given common block as being BIND(C) or not,
+ depending on the given parameter, is_bind_c. */
+
+void
+set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
+{
+ com_block->is_bind_c = is_bind_c;
+ return;
+}
+
+
+/* Verify that the given gfc_typespec is for a C interoperable type. */
+
+try
+verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
+{
+ try t;
+
+ /* Make sure the kind used is appropriate for the type.
+ The f90_type is unknown if an integer constant was
+ used (e.g., real(4), bind(c) :: myFloat). */
+ if (ts->f90_type != BT_UNKNOWN)
+ {
+ t = gfc_validate_c_kind (ts);
+ if (t != SUCCESS)
+ {
+ /* Print an error, but continue parsing line. */
+ gfc_error_now ("C kind parameter is for type %s but "
+ "symbol '%s' at %L is of type %s",
+ gfc_basic_typename (ts->f90_type),
+ name, where,
+ gfc_basic_typename (ts->type));
+ }
+ }
+
+ /* Make sure the kind is C interoperable. This does not care about the
+ possible error above. */
+ if (ts->type == BT_DERIVED && ts->derived != NULL)
+ return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ else if (ts->is_c_interop != 1)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* Verify that the variables of a given common block, which has been
+ defined with the attribute specifier bind(c), to be of a C
+ interoperable type. Errors will be reported here, if
+ encountered. */
+
+try
+verify_com_block_vars_c_interop (gfc_common_head *com_block)
+{
+ gfc_symbol *curr_sym = NULL;
+ try retval = SUCCESS;
+
+ curr_sym = com_block->head;
+
+ /* Make sure we have at least one symbol. */
+ if (curr_sym == NULL)
+ return retval;
+
+ /* Here we know we have a symbol, so we'll execute this loop
+ at least once. */
+ do
+ {
+ /* The second to last param, 1, says this is in a common block. */
+ retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
+ curr_sym = curr_sym->common_next;
+ } while (curr_sym != NULL);
+
+ return retval;
+}
+
+
+/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
+ an appropriate error message is reported. */
+
+try
+verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
+ int is_in_common, gfc_common_head *com_block)
+{
+ try retval = SUCCESS;
+
+ /* Here, we know we have the bind(c) attribute, so if we have
+ enough type info, then verify that it's a C interop kind.
+ The info could be in the symbol already, or possibly still in
+ the given ts (current_ts), so look in both. */
+ if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
+ {
+ if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
+ &(tmp_sym->declared_at)) != SUCCESS)
+ {
+ /* See if we're dealing with a sym in a common block or not. */
+ if (is_in_common == 1)
+ {
+ gfc_warning ("Variable '%s' in common block '%s' at %L "
+ "may not be a C interoperable "
+ "kind though common block '%s' is BIND(C)",
+ tmp_sym->name, com_block->name,
+ &(tmp_sym->declared_at), com_block->name);
+ }
+ else
+ {
+ if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
+ gfc_error ("Type declaration '%s' at %L is not C "
+ "interoperable but it is BIND(C)",
+ tmp_sym->name, &(tmp_sym->declared_at));
+ else
+ gfc_warning ("Variable '%s' at %L "
+ "may not be a C interoperable "
+ "kind but it is bind(c)",
+ tmp_sym->name, &(tmp_sym->declared_at));
+ }
+ }
+
+ /* Variables declared w/in a common block can't be bind(c)
+ since there's no way for C to see these variables, so there's
+ semantically no reason for the attribute. */
+ if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
+ {
+ gfc_error ("Variable '%s' in common block '%s' at "
+ "%L cannot be declared with BIND(C) "
+ "since it is not a global",
+ tmp_sym->name, com_block->name,
+ &(tmp_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* Scalar variables that are bind(c) can not have the pointer
+ or allocatable attributes. */
+ if (tmp_sym->attr.is_bind_c == 1)
+ {
+ if (tmp_sym->attr.pointer == 1)
+ {
+ gfc_error ("Variable '%s' at %L cannot have both the "
+ "POINTER and BIND(C) attributes",
+ tmp_sym->name, &(tmp_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ if (tmp_sym->attr.allocatable == 1)
+ {
+ gfc_error ("Variable '%s' at %L cannot have both the "
+ "ALLOCATABLE and BIND(C) attributes",
+ tmp_sym->name, &(tmp_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* If it is a BIND(C) function, make sure the return value is a
+ scalar value. The previous tests in this function made sure
+ the type is interoperable. */
+ if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
+ gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ "be an array", tmp_sym->name, &(tmp_sym->declared_at));
+
+ /* BIND(C) functions can not return a character string. */
+ if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
+ if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
+ || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
+ gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ "be a character string", tmp_sym->name,
+ &(tmp_sym->declared_at));
+ }
+ }
+
+ /* See if the symbol has been marked as private. If it has, make sure
+ there is no binding label and warn the user if there is one. */
+ if (tmp_sym->attr.access == ACCESS_PRIVATE
+ && tmp_sym->binding_label[0] != '\0')
+ /* Use gfc_warning_now because we won't say that the symbol fails
+ just because of this. */
+ gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
+ "given the binding label '%s'", tmp_sym->name,
+ &(tmp_sym->declared_at), tmp_sym->binding_label);
+
+ return retval;
+}
+
+
+/* Set the appropriate fields for a symbol that's been declared as
+ BIND(C) (the is_bind_c flag and the binding label), and verify that
+ the type is C interoperable. Errors are reported by the functions
+ used to set/test these fields. */
+
+try
+set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
+{
+ try retval = SUCCESS;
+
+ /* TODO: Do we need to make sure the vars aren't marked private? */
+
+ /* Set the is_bind_c bit in symbol_attribute. */
+ gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
+
+ if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
+ num_idents) != SUCCESS)
+ return FAILURE;
+
+ return retval;
+}
+
+
+/* Set the fields marking the given common block as BIND(C), including
+ a binding label, and report any errors encountered. */
+
+try
+set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
+{
+ try retval = SUCCESS;
+
+ /* destLabel, common name, typespec (which may have binding label). */
+ if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
+ != SUCCESS)
+ return FAILURE;
+
+ /* Set the given common block (com_block) to being bind(c) (1). */
+ set_com_block_bind_c (com_block, 1);
+
+ return retval;
+}
+
+
+/* Retrieve the list of one or more identifiers that the given bind(c)
+ attribute applies to. */
+
+try
+get_bind_c_idents (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ int num_idents = 0;
+ gfc_symbol *tmp_sym = NULL;
+ match found_id;
+ gfc_common_head *com_block = NULL;
+
+ if (gfc_match_name (name) == MATCH_YES)
+ {
+ found_id = MATCH_YES;
+ gfc_get_ha_symbol (name, &tmp_sym);
+ }
+ else if (match_common_name (name) == MATCH_YES)
+ {
+ found_id = MATCH_YES;
+ com_block = gfc_get_common (name, 0);
+ }
+ else
+ {
+ gfc_error ("Need either entity or common block name for "
+ "attribute specification statement at %C");
+ return FAILURE;
+ }
+
+ /* Save the current identifier and look for more. */
+ do
+ {
+ /* Increment the number of identifiers found for this spec stmt. */
+ num_idents++;
+
+ /* Make sure we have a sym or com block, and verify that it can
+ be bind(c). Set the appropriate field(s) and look for more
+ identifiers. */
+ if (tmp_sym != NULL || com_block != NULL)
+ {
+ if (tmp_sym != NULL)
+ {
+ if (set_verify_bind_c_sym (tmp_sym, num_idents)
+ != SUCCESS)
+ return FAILURE;
+ }
+ else
+ {
+ if (set_verify_bind_c_com_block(com_block, num_idents)
+ != SUCCESS)
+ return FAILURE;
+ }
+
+ /* Look to see if we have another identifier. */
+ tmp_sym = NULL;
+ if (gfc_match_eos () == MATCH_YES)
+ found_id = MATCH_NO;
+ else if (gfc_match_char (',') != MATCH_YES)
+ found_id = MATCH_NO;
+ else if (gfc_match_name (name) == MATCH_YES)
+ {
+ found_id = MATCH_YES;
+ gfc_get_ha_symbol (name, &tmp_sym);
+ }
+ else if (match_common_name (name) == MATCH_YES)
+ {
+ found_id = MATCH_YES;
+ com_block = gfc_get_common (name, 0);
+ }
+ else
+ {
+ gfc_error ("Missing entity or common block name for "
+ "attribute specification statement at %C");
+ return FAILURE;
+ }
+ }
+ else
+ {
+ gfc_internal_error ("Missing symbol");
+ }
+ } while (found_id == MATCH_YES);
+
+ /* if we get here we were successful */
+ return SUCCESS;
+}
+
+
+/* Try and match a BIND(C) attribute specification statement. */
+
+match
+gfc_match_bind_c_stmt (void)
+{
+ match found_match = MATCH_NO;
+ gfc_typespec *ts;
+
+ ts = ¤t_ts;
+
+ /* This may not be necessary. */
+ gfc_clear_ts (ts);
+ /* Clear the temporary binding label holder. */
+ curr_binding_label[0] = '\0';
+
+ /* Look for the bind(c). */
+ found_match = gfc_match_bind_c (NULL);
+
+ if (found_match == MATCH_YES)
+ {
+ /* Look for the :: now, but it is not required. */
+ gfc_match (" :: ");
+
+ /* Get the identifier(s) that needs to be updated. This may need to
+ change to hand the flag(s) for the attr specified so all identifiers
+ found can have all appropriate parts updated (assuming that the same
+ spec stmt can have multiple attrs, such as both bind(c) and
+ allocatable...). */
+ if (get_bind_c_idents () != SUCCESS)
+ /* Error message should have printed already. */
+ return MATCH_ERROR;
+ }
+
+ return found_match;
+}
+
+
/* Match a data declaration statement. */
match
match m;
int elem;
+ num_idents_on_line = 0;
+
m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
elem = 1;
for (;;)
{
+ num_idents_on_line++;
m = variable_decl (elem++);
if (m == MATCH_ERROR)
goto cleanup;
if (m != MATCH_YES)
return m;
- if (gfc_match (" )%t") != MATCH_YES)
+ /* Get the right paren, and that's it because there could be the
+ bind(c) attribute after the result clause. */
+ if (gfc_match_char(')') != MATCH_YES)
{
- gfc_error ("Unexpected junk following RESULT variable at %C");
+ /* TODO: should report the missing right paren here. */
return MATCH_ERROR;
}
}
+/* Match a function suffix, which could be a combination of a result
+ clause and BIND(C), either one, or neither. The draft does not
+ require them to come in a specific order. */
+
+match
+gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
+{
+ match is_bind_c; /* Found bind(c). */
+ match is_result; /* Found result clause. */
+ match found_match; /* Status of whether we've found a good match. */
+ int peek_char; /* Character we're going to peek at. */
+
+ /* Initialize to having found nothing. */
+ found_match = MATCH_NO;
+ is_bind_c = MATCH_NO;
+ is_result = MATCH_NO;
+
+ /* Get the next char to narrow between result and bind(c). */
+ gfc_gobble_whitespace ();
+ peek_char = gfc_peek_char ();
+
+ switch (peek_char)
+ {
+ case 'r':
+ /* Look for result clause. */
+ is_result = match_result (sym, result);
+ if (is_result == MATCH_YES)
+ {
+ /* Now see if there is a bind(c) after it. */
+ is_bind_c = gfc_match_bind_c (sym);
+ /* We've found the result clause and possibly bind(c). */
+ found_match = MATCH_YES;
+ }
+ else
+ /* This should only be MATCH_ERROR. */
+ found_match = is_result;
+ break;
+ case 'b':
+ /* Look for bind(c) first. */
+ is_bind_c = gfc_match_bind_c (sym);
+ if (is_bind_c == MATCH_YES)
+ {
+ /* Now see if a result clause followed it. */
+ is_result = match_result (sym, result);
+ found_match = MATCH_YES;
+ }
+ else
+ {
+ /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
+ found_match = MATCH_ERROR;
+ }
+ break;
+ default:
+ gfc_error ("Unexpected junk after function declaration at %C");
+ found_match = MATCH_ERROR;
+ break;
+ }
+
+ if (is_result == MATCH_ERROR || is_bind_c == MATCH_ERROR)
+ {
+ gfc_error ("Error in function suffix at %C");
+ return MATCH_ERROR;
+ }
+
+ if (is_bind_c == MATCH_YES)
+ if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ return found_match;
+}
+
+
/* Match a function declaration. */
match
gfc_symbol *sym, *result;
locus old_loc;
match m;
+ match suffix_match;
+ match found_match; /* Status returned by match func. */
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
result = NULL;
- if (gfc_match_eos () != MATCH_YES)
- {
- /* See if a result variable is present. */
- m = match_result (sym, &result);
- if (m == MATCH_NO)
- gfc_error ("Unexpected junk after function declaration at %C");
-
- if (m != MATCH_YES)
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
+ /* According to the draft, the bind(c) and result clause can
+ come in either order after the formal_arg_list (i.e., either
+ can be first, both can exist together or by themselves or neither
+ one). Therefore, the match_result can't match the end of the
+ string, and check for the bind(c) or result clause in either order. */
+ found_match = gfc_match_eos ();
+
+ /* Make sure that it isn't already declared as BIND(C). If it is, it
+ must have been marked BIND(C) with a BIND(C) attribute and that is
+ not allowed for procedures. */
+ if (sym->attr.is_bind_c == 1)
+ {
+ sym->attr.is_bind_c = 0;
+ if (sym->old_symbol != NULL)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks",
+ &(sym->old_symbol->declared_at));
+ else
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", &gfc_current_locus);
}
- /* Make changes to the symbol. */
- m = MATCH_ERROR;
-
- if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
- goto cleanup;
-
- if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
- || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
- goto cleanup;
-
- if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
- && !sym->attr.implicit_type)
+ if (found_match != MATCH_YES)
{
- gfc_error ("Function '%s' at %C already has a type of %s", name,
- gfc_basic_typename (sym->ts.type));
- goto cleanup;
+ /* If we haven't found the end-of-statement, look for a suffix. */
+ suffix_match = gfc_match_suffix (sym, &result);
+ if (suffix_match == MATCH_YES)
+ /* Need to get the eos now. */
+ found_match = gfc_match_eos ();
+ else
+ found_match = suffix_match;
}
- if (result == NULL)
- {
- sym->ts = current_ts;
- sym->result = sym;
- }
+ if(found_match != MATCH_YES)
+ m = MATCH_ERROR;
else
{
- result->ts = current_ts;
- sym->result = result;
- }
+ /* Make changes to the symbol. */
+ m = MATCH_ERROR;
+
+ if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ goto cleanup;
+
+ if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
+ || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
+ goto cleanup;
- return MATCH_YES;
+ if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
+ && !sym->attr.implicit_type)
+ {
+ gfc_error ("Function '%s' at %C already has a type of %s", name,
+ gfc_basic_typename (sym->ts.type));
+ goto cleanup;
+ }
+
+ if (result == NULL)
+ {
+ sym->ts = current_ts;
+ sym->result = sym;
+ }
+ else
+ {
+ result->ts = current_ts;
+ sym->result = result;
+ }
+
+ return MATCH_YES;
+ }
cleanup:
gfc_current_locus = old_loc;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
+ match is_bind_c;
+ char peek_char;
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
return MATCH_ERROR;
gfc_new_block = sym;
+ /* Check what next non-whitespace character is so we can tell if there
+ where the required parens if we have a BIND(C). */
+ gfc_gobble_whitespace ();
+ peek_char = gfc_peek_char ();
+
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
return MATCH_ERROR;
+ /* Make sure that it isn't already declared as BIND(C). If it is, it
+ must have been marked BIND(C) with a BIND(C) attribute and that is
+ not allowed for procedures. */
+ if (sym->attr.is_bind_c == 1)
+ {
+ sym->attr.is_bind_c = 0;
+ if (sym->old_symbol != NULL)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks",
+ &(sym->old_symbol->declared_at));
+ else
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", &gfc_current_locus);
+ }
+
+ /* Here, we are just checking if it has the bind(c) attribute, and if
+ so, then we need to make sure it's all correct. If it doesn't,
+ we still need to continue matching the rest of the subroutine line. */
+ is_bind_c = gfc_match_bind_c (sym);
+ if (is_bind_c == MATCH_ERROR)
+ {
+ /* There was an attempt at the bind(c), but it was wrong. An
+ error message should have been printed w/in the gfc_match_bind_c
+ so here we'll just return the MATCH_ERROR. */
+ return MATCH_ERROR;
+ }
+
+ if (is_bind_c == MATCH_YES)
+ {
+ if (peek_char != '(')
+ {
+ gfc_error ("Missing required parentheses before BIND(C) at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_SUBROUTINE);
}
+/* Match a BIND(C) specifier, with the optional 'name=' specifier if
+ given, and set the binding label in either the given symbol (if not
+ NULL), or in the current_ts. The symbol may be NULL becuase we may
+ encounter the BIND(C) before the declaration itself. Return
+ MATCH_NO if what we're looking at isn't a BIND(C) specifier,
+ MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
+ or MATCH_YES if the specifier was correct and the binding label and
+ bind(c) fields were set correctly for the given symbol or the
+ current_ts. */
+
+match
+gfc_match_bind_c (gfc_symbol *sym)
+{
+ /* binding label, if exists */
+ char binding_label[GFC_MAX_SYMBOL_LEN + 1];
+ match double_quote;
+ match single_quote;
+ int has_name_equals = 0;
+
+ /* Initialize the flag that specifies whether we encountered a NAME=
+ specifier or not. */
+ has_name_equals = 0;
+
+ /* Init the first char to nil so we can catch if we don't have
+ the label (name attr) or the symbol name yet. */
+ binding_label[0] = '\0';
+
+ /* This much we have to be able to match, in this order, if
+ there is a bind(c) label. */
+ if (gfc_match (" bind ( c ") != MATCH_YES)
+ return MATCH_NO;
+
+ /* Now see if there is a binding label, or if we've reached the
+ end of the bind(c) attribute without one. */
+ if (gfc_match_char (',') == MATCH_YES)
+ {
+ if (gfc_match (" name = ") != MATCH_YES)
+ {
+ gfc_error ("Syntax error in NAME= specifier for binding label "
+ "at %C");
+ /* should give an error message here */
+ return MATCH_ERROR;
+ }
+
+ has_name_equals = 1;
+
+ /* Get the opening quote. */
+ double_quote = MATCH_YES;
+ single_quote = MATCH_YES;
+ double_quote = gfc_match_char ('"');
+ if (double_quote != MATCH_YES)
+ single_quote = gfc_match_char ('\'');
+ if (double_quote != MATCH_YES && single_quote != MATCH_YES)
+ {
+ gfc_error ("Syntax error in NAME= specifier for binding label "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Grab the binding label, using functions that will not lower
+ case the names automatically. */
+ if (gfc_match_name_C (binding_label) != MATCH_YES)
+ return MATCH_ERROR;
+
+ /* Get the closing quotation. */
+ if (double_quote == MATCH_YES)
+ {
+ if (gfc_match_char ('"') != MATCH_YES)
+ {
+ gfc_error ("Missing closing quote '\"' for binding label at %C");
+ /* User started string with '"' so looked to match it. */
+ return MATCH_ERROR;
+ }
+ }
+ else
+ {
+ if (gfc_match_char ('\'') != MATCH_YES)
+ {
+ gfc_error ("Missing closing quote '\'' for binding label at %C");
+ /* User started string with "'" char. */
+ return MATCH_ERROR;
+ }
+ }
+ }
+
+ /* Get the required right paren. */
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Missing closing paren for binding label at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Save the binding label to the symbol. If sym is null, we're
+ probably matching the typespec attributes of a declaration and
+ haven't gotten the name yet, and therefore, no symbol yet. */
+ if (binding_label[0] != '\0')
+ {
+ if (sym != NULL)
+ {
+ strncpy (sym->binding_label, binding_label,
+ strlen (binding_label)+1);
+ }
+ else
+ strncpy (curr_binding_label, binding_label,
+ strlen (binding_label) + 1);
+ }
+ else
+ {
+ /* No binding label, but if symbol isn't null, we
+ can set the label for it here. */
+ /* TODO: If the name= was given and no binding label (name=""), we simply
+ will let fortran mangle the symbol name as it usually would.
+ However, this could still let C call it if the user looked up the
+ symbol in the object file. Should the name set during mangling in
+ trans-decl.c be marked with characters that are invalid for C to
+ prevent this? */
+ if (sym != NULL && sym->name != NULL && has_name_equals == 0)
+ strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
+ }
+
+ return MATCH_YES;
+}
+
+
/* Return nonzero if we're currently compiling a contained procedure. */
static int
}
-/* Match the beginning of a derived type declaration. If a type name
- was the result of a function, then it is possible to have a symbol
- already to be known as a derived type yet have no components. */
+/* Match the optional attribute specifiers for a type declaration.
+ Return MATCH_ERROR if an error is encountered in one of the handled
+ attributes (public, private, bind(c)), MATCH_NO if what's found is
+ not a handled attribute, and MATCH_YES otherwise. TODO: More error
+ checking on attribute conflicts needs to be done. */
match
-gfc_match_derived_decl (void)
+gfc_get_type_attr_spec (symbol_attribute *attr)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- symbol_attribute attr;
- gfc_symbol *sym;
- match m;
-
- if (gfc_current_state () == COMP_DERIVED)
- return MATCH_NO;
-
- gfc_clear_attr (&attr);
-
-loop:
+ /* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
{
if (gfc_current_state () != COMP_MODULE)
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
+ if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
return MATCH_ERROR;
- goto loop;
}
-
- if (gfc_match (" , public") == MATCH_YES)
+ else if (gfc_match (" , public") == MATCH_YES)
{
if (gfc_current_state () != COMP_MODULE)
{
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
+ if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
- goto loop;
}
+ else if(gfc_match(" , bind ( c )") == MATCH_YES)
+ {
+ /* If the type is defined to be bind(c) it then needs to make
+ sure that all fields are interoperable. This will
+ need to be a semantic check on the finished derived type.
+ See 15.2.3 (lines 9-12) of F2003 draft. */
+ if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
+ return MATCH_ERROR;
+
+ /* TODO: attr conflicts need to be checked, probably in symbol.c. */
+ }
+ else
+ return MATCH_NO;
+
+ /* If we get here, something matched. */
+ return MATCH_YES;
+}
+
+
+/* Match the beginning of a derived type declaration. If a type name
+ was the result of a function, then it is possible to have a symbol
+ already to be known as a derived type yet have no components. */
+
+match
+gfc_match_derived_decl (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ symbol_attribute attr;
+ gfc_symbol *sym;
+ match m;
+ match is_type_attr_spec = MATCH_NO;
+
+ if (gfc_current_state () == COMP_DERIVED)
+ return MATCH_NO;
+
+ gfc_clear_attr (&attr);
+
+ do
+ {
+ is_type_attr_spec = gfc_get_type_attr_spec (&attr);
+ if (is_type_attr_spec == MATCH_ERROR)
+ return MATCH_ERROR;
+ } while (is_type_attr_spec == MATCH_YES);
if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
{
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
+ /* See if the derived type was labeled as bind(c). */
+ if (attr.is_bind_c != 0)
+ sym->attr.is_bind_c = attr.is_bind_c;
+
gfc_new_block = sym;
return MATCH_YES;
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
- memcpy (s, p->value.character.string, p->value.character.length + 1);
+ /* This is the case for the C_NULL_CHAR named constant. */
+ if (p->value.character.length == 0
+ && (p->ts.is_c_interop || p->ts.is_iso_c))
+ {
+ *s = '\0';
+ /* Need to set the length to 1 to make sure the NUL
+ terminator is copied. */
+ q->value.character.length = 1;
+ }
+ else
+ memcpy (s, p->value.character.string,
+ p->value.character.length + 1);
}
break;
case BT_HOLLERITH:
case BT_LOGICAL:
case BT_DERIVED:
- break; /* Already done */
+ break; /* Already done. */
case BT_PROCEDURE:
+ case BT_VOID:
+ /* Should never be reached. */
case BT_UNKNOWN:
gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached */
+ /* Not reached. */
}
break;
/* Major control parameters. */
#define GFC_MAX_SYMBOL_LEN 63 /* Must be at least 63 for F2003. */
+#define GFC_MAX_BINDING_LABEL_LEN 126 /* (2 * GFC_MAX_SYMBOL_LEN) */
+#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */
#define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */
{ FORM_FREE, FORM_FIXED, FORM_UNKNOWN }
gfc_source_form;
+/* Basic types. BT_VOID is used by ISO C BInding so funcs like c_f_pointer
+ can take any arg with the pointer attribute as a param. */
typedef enum
{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
- BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH
+ BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH,
+ BT_VOID
}
bt;
typedef enum sym_flavor
{
FL_UNKNOWN = 0, FL_PROGRAM, FL_BLOCK_DATA, FL_MODULE, FL_VARIABLE,
- FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST
+ FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST,
+ FL_VOID
}
sym_flavor;
/* Used for keeping things in balanced binary trees. */
#define BBT_HEADER(self) int priority; struct self *left, *right
+#define NAMED_INTCST(a,b,c) a,
+typedef enum
+{
+ ISOFORTRANENV_INVALID = -1,
+#include "iso-fortran-env.def"
+ ISOFORTRANENV_LAST, ISOFORTRANENV_NUMBER = ISOFORTRANENV_LAST
+}
+iso_fortran_env_symbol;
+#undef NAMED_INTCST
+
+#define NAMED_INTCST(a,b,c) a,
+#define NAMED_REALCST(a,b,c) a,
+#define NAMED_CMPXCST(a,b,c) a,
+#define NAMED_LOGCST(a,b,c) a,
+#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,
+typedef enum
+{
+ ISOCBINDING_INVALID = -1,
+#include "iso-c-binding.def"
+ ISOCBINDING_LAST,
+ ISOCBINDING_NUMBER = ISOCBINDING_LAST
+}
+iso_c_binding_symbol;
+#undef NAMED_INTCST
+#undef NAMED_REALCST
+#undef NAMED_CMPXCST
+#undef NAMED_LOGCST
+#undef NAMED_CHARKNDCST
+#undef NAMED_CHARCST
+#undef DERIVED_TYPE
+#undef PROCEDURE
+
+typedef enum
+{
+ INTMOD_NONE = 0, INTMOD_ISO_FORTRAN_ENV, INTMOD_ISO_C_BINDING
+}
+intmod_id;
+
+typedef struct
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ int value; /* Used for both integer and character values. */
+ bt f90_type;
+}
+CInteropKind_t;
+
+/* Array of structs, where the structs represent the C interop kinds.
+ The list will be implemented based on a hash of the kind name since
+ these could be accessed multiple times.
+ Declared in trans-types.c as a global, since it's in that file
+ that the list is initialized. */
+extern CInteropKind_t c_interop_kinds_table[];
+
/* Symbol attribute structure. */
typedef struct
{
unsigned implicit_type:1; /* Type defined via implicit rules. */
unsigned untyped:1; /* No implicit type could be found. */
+ unsigned is_bind_c:1; /* say if is bound to C */
+
+ /* These flags are both in the typespec and attribute. The attribute
+ list is what gets read from/written to a module file. The typespec
+ is created from a decl being processed. */
+ unsigned is_c_interop:1; /* It's c interoperable. */
+ unsigned is_iso_c:1; /* Symbol is from iso_c_binding. */
+
/* Function/subroutine attributes */
unsigned sequence:1, elemental:1, pure:1, recursive:1;
unsigned unmaskable:1, masked:1, contained:1, mod_proc:1;
int kind;
struct gfc_symbol *derived;
gfc_charlen *cl; /* For character types only. */
+ int is_c_interop;
+ int is_iso_c;
+ bt f90_type;
}
gfc_typespec;
struct gfc_namespace *ns; /* namespace containing this symbol */
tree backend_decl;
+
+ /* Identity of the intrinsic module the symbol comes from, or
+ INTMOD_NONE if it's not imported from a intrinsic module. */
+ intmod_id from_intmod;
+ /* Identity of the symbol from intrinsic modules, from enums maintained
+ separately by each intrinsic module. Used together with from_intmod,
+ it uniquely identifies a symbol from an intrinsic module. */
+ int intmod_sym_id;
+
+ /* This may be repetitive, since the typespec now has a binding
+ label field. */
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ /* Store a reference to the common_block, if this symbol is in one. */
+ struct gfc_common_head *common_block;
}
gfc_symbol;
/* This structure is used to keep track of symbols in common blocks. */
-
typedef struct gfc_common_head
{
locus where;
char use_assoc, saved, threadprivate;
char name[GFC_MAX_SYMBOL_LEN + 1];
struct gfc_symbol *head;
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ int is_bind_c;
}
gfc_common_head;
BBT_HEADER(gfc_gsymbol);
const char *name;
+ const char *sym_name;
+ const char *mod_name;
+ const char *binding_label;
enum { GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE,
GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA } type;
void gfc_done_1 (void);
void gfc_done_2 (void);
+int get_c_kind (const char *, CInteropKind_t *);
+
/* options.c */
unsigned int gfc_init_options (unsigned int, const char **);
int gfc_handle_option (size_t, const char *, int);
arith gfc_check_integer_range (mpz_t p, int kind);
/* trans-types.c */
+try gfc_validate_c_kind (gfc_typespec *);
+try gfc_check_any_c_kind (gfc_typespec *);
int gfc_validate_kind (bt, int, bool);
extern int gfc_index_integer_kind;
extern int gfc_default_integer_kind;
try gfc_add_recursive (symbol_attribute *, locus *);
try gfc_add_function (symbol_attribute *, const char *, locus *);
try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
-try gfc_add_value (symbol_attribute *, const char *, locus *);
try gfc_add_volatile (symbol_attribute *, const char *, locus *);
try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
+try gfc_add_is_bind_c(symbol_attribute *, const char *, locus *, int);
+try gfc_add_value (symbol_attribute *, const char *, locus *);
try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *);
try gfc_add_entry (symbol_attribute *, const char *, locus *);
try gfc_add_procedure (symbol_attribute *, procedure_type,
int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **);
int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **);
+try verify_c_interop (gfc_typespec *, const char *name, locus *where);
+try verify_c_interop_param (gfc_symbol *);
+try verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
+try verify_bind_c_derived_type (gfc_symbol *);
+try verify_com_block_vars_c_interop (gfc_common_head *);
+void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, char *);
+gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int);
int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **);
int gfc_get_ha_symbol (const char *, gfc_symbol **);
int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
try gfc_resolve_index (gfc_expr *, int);
try gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);
+match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+
/* array.c */
void gfc_free_array_spec (gfc_array_spec *);
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
nonnull, then they are equal. */
- if (strcmp (derived1->name, derived2->name) == 0
- && derived1 != NULL && derived2 != NULL
+ if (derived1 != NULL && derived2 != NULL
+ && strcmp (derived1->name, derived2->name) == 0
&& derived1->module != NULL && derived2->module != NULL
&& strcmp (derived1->module, derived2->module) == 0)
return 1;
int
gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
+ /* See if one of the typespecs is a BT_VOID, which is what is being used
+ to allow the funcs like c_f_pointer to accept any pointer type.
+ TODO: Possibly should narrow this to just the one typespec coming in
+ that is for the formal arg, but oh well. */
+ if (ts1->type == BT_VOID || ts2->type == BT_VOID)
+ return 1;
+
if (ts1->type != ts2->type)
return 0;
if (ts1->type != BT_DERIVED)
{
gfc_ref *ref;
+ /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
+ procs c_f_pointer or c_f_procpointer, and we need to accept most
+ pointers the user could give us. This should allow that. */
+ if (formal->ts.type == BT_VOID)
+ return 1;
+
+ if (formal->ts.type == BT_DERIVED
+ && formal->ts.derived && formal->ts.derived->ts.is_iso_c
+ && actual->ts.type == BT_DERIVED
+ && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
+ return 1;
+
if (actual->ts.type == BT_PROCEDURE)
{
if (formal->attr.flavor != FL_PROCEDURE)
--- /dev/null
+/* Copyright (C) 2006 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
+
+/* This file contains the definition of the types provided by the
+ Fortran 2003 ISO_C_BINDING intrinsic module. */
+
+#ifndef NAMED_INTCST
+# define NAMED_INTCST(a,b,c)
+#endif
+
+#ifndef NAMED_REALCST
+# define NAMED_REALCST(a,b,c)
+#endif
+
+#ifndef NAMED_CMPXCST
+# define NAMED_CMPXCST(a,b,c)
+#endif
+
+#ifndef NAMED_LOGCST
+# define NAMED_LOGCST(a,b,c)
+#endif
+
+#ifndef NAMED_CHARKNDCST
+# define NAMED_CHARKNDCST(a,b,c)
+#endif
+
+/* The arguments to NAMED_*CST are:
+ -- an internal name
+ -- the symbol name in the module, as seen by Fortran code
+ -- the value it has, for use in trans-types.c */
+
+NAMED_INTCST (ISOCBINDING_INT, "c_int", gfc_c_int_kind)
+NAMED_INTCST (ISOCBINDING_SHORT, "c_short", \
+ get_int_kind_from_node (short_integer_type_node))
+NAMED_INTCST (ISOCBINDING_LONG, "c_long", \
+ get_int_kind_from_node (long_integer_type_node))
+NAMED_INTCST (ISOCBINDING_LONG_LONG, "c_long_long", \
+ get_int_kind_from_node (long_long_integer_type_node))
+
+NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \
+ get_int_kind_from_node (intmax_type_node))
+NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \
+ get_int_kind_from_node (ptr_type_node))
+NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \
+ gfc_index_integer_kind)
+NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \
+ get_int_kind_from_node (signed_char_type_node))
+
+NAMED_INTCST (ISOCBINDING_INT8_T, "c_int8_t", get_int_kind_from_width (8))
+NAMED_INTCST (ISOCBINDING_INT16_T, "c_int16_t", get_int_kind_from_width (16))
+NAMED_INTCST (ISOCBINDING_INT32_T, "c_int32_t", get_int_kind_from_width (32))
+NAMED_INTCST (ISOCBINDING_INT64_T, "c_int64_t", get_int_kind_from_width (64))
+
+NAMED_INTCST (ISOCBINDING_INT_LEAST8_T, "c_int_least8_t", \
+ get_int_kind_from_minimal_width (8))
+NAMED_INTCST (ISOCBINDING_INT_LEAST16_T, "c_int_least16_t", \
+ get_int_kind_from_minimal_width (16))
+NAMED_INTCST (ISOCBINDING_INT_LEAST32_T, "c_int_least32_t", \
+ get_int_kind_from_minimal_width (32))
+NAMED_INTCST (ISOCBINDING_INT_LEAST64_T, "c_int_least64_t", \
+ get_int_kind_from_minimal_width (64))
+
+/* TODO: Implement c_int_fast*_t. Depends on PR 448. */
+NAMED_INTCST (ISOCBINDING_INT_FAST8_T, "c_int_fast8_t", -2)
+NAMED_INTCST (ISOCBINDING_INT_FAST16_T, "c_int_fast16_t", -2)
+NAMED_INTCST (ISOCBINDING_INT_FAST32_T, "c_int_fast32_t", -2)
+NAMED_INTCST (ISOCBINDING_INT_FAST64_T, "c_int_fast64_t", -2)
+
+NAMED_REALCST (ISOCBINDING_FLOAT, "c_float", \
+ get_real_kind_from_node (float_type_node))
+NAMED_REALCST (ISOCBINDING_DOUBLE, "c_double", \
+ get_real_kind_from_node (double_type_node))
+NAMED_REALCST (ISOCBINDING_LONG_DOUBLE, "c_long_double", \
+ get_real_kind_from_node (long_double_type_node))
+NAMED_CMPXCST (ISOCBINDING_FLOAT_COMPLEX, "c_float_complex", \
+ get_real_kind_from_node (float_type_node))
+NAMED_CMPXCST (ISOCBINDING_DOUBLE_COMPLEX, "c_double_complex", \
+ get_real_kind_from_node (double_type_node))
+NAMED_CMPXCST (ISOCBINDING_LONG_DOUBLE_COMPLEX, "c_long_double_complex", \
+ get_real_kind_from_node (long_double_type_node))
+
+NAMED_LOGCST (ISOCBINDING_BOOL, "c_bool", \
+ get_int_kind_from_width (BOOL_TYPE_SIZE))
+
+NAMED_CHARKNDCST (ISOCBINDING_CHAR, "c_char", gfc_default_character_kind)
+
+#ifndef NAMED_CHARCST
+# define NAMED_CHARCST(a,b,c)
+#endif
+
+/* Use langhooks to deal with host to target translations. */
+NAMED_CHARCST (ISOCBINDING_NULL_CHAR, "c_null_char", \
+ lang_hooks.to_target_charset ('\0'))
+NAMED_CHARCST (ISOCBINDING_ALERT, "c_alert", \
+ lang_hooks.to_target_charset ('\a'))
+NAMED_CHARCST (ISOCBINDING_BACKSPACE, "c_backspace", \
+ lang_hooks.to_target_charset ('\b'))
+NAMED_CHARCST (ISOCBINDING_FORM_FEED, "c_form_feed", \
+ lang_hooks.to_target_charset ('\f'))
+NAMED_CHARCST (ISOCBINDING_NEW_LINE, "c_new_line", \
+ lang_hooks.to_target_charset ('\n'))
+NAMED_CHARCST (ISOCBINDING_CARRIAGE_RETURN, "c_carriage_return", \
+ lang_hooks.to_target_charset ('\r'))
+NAMED_CHARCST (ISOCBINDING_HORIZONTAL_TAB, "c_horizontal_tab", \
+ lang_hooks.to_target_charset ('\t'))
+NAMED_CHARCST (ISOCBINDING_VERTICAL_TAB, "c_vertical_tab", \
+ lang_hooks.to_target_charset ('\v'))
+
+#ifndef DERIVED_TYPE
+# define DERIVED_TYPE(a,b,c)
+#endif
+
+DERIVED_TYPE (ISOCBINDING_PTR, "c_ptr", \
+ get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_NULL_PTR, "c_null_ptr", \
+ get_int_kind_from_node (ptr_type_node))
+DERIVED_TYPE (ISOCBINDING_FUNPTR, "c_funptr", \
+ get_int_kind_from_node (ptr_type_node))
+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")
+
+/* Insert c_f_procpointer, though unsupported for now. */
+PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
+
+#undef NAMED_INTCST
+#undef NAMED_REALCST
+#undef NAMED_CMPXCST
+#undef NAMED_LOGCST
+#undef NAMED_CHARCST
+#undef NAMED_CHARKNDCST
+#undef DERIVED_TYPE
+#undef PROCEDURE
}
+/* This function is the same as the gfc_match_small_int, except that
+ we're keeping the pointer to the expr. This function could just be
+ removed and the previously mentioned one modified, though all calls
+ to it would have to be modified then (and there were a number of
+ them). Return MATCH_ERROR if fail to extract the int; otherwise,
+ return the result of gfc_match_expr(). The expr (if any) that was
+ matched is returned in the parameter expr. */
+
+match
+gfc_match_small_int_expr (int *value, gfc_expr **expr)
+{
+ const char *p;
+ match m;
+ int i;
+
+ m = gfc_match_expr (expr);
+ if (m != MATCH_YES)
+ return m;
+
+ p = gfc_extract_int (*expr, &i);
+
+ if (p != NULL)
+ {
+ gfc_error (p);
+ m = MATCH_ERROR;
+ }
+
+ *value = i;
+ return m;
+}
+
+
/* Matches a statement label. Uses gfc_match_small_literal_int() to
do most of the work. */
}
+/* Match a valid name for C, which is almost the same as for Fortran,
+ except that you can start with an underscore, etc.. It could have
+ been done by modifying the gfc_match_name, but this way other
+ things C allows can be added, such as no limits on the length.
+ Right now, the length is limited to the same thing as Fortran..
+ Also, by rewriting it, we use the gfc_next_char_C() to prevent the
+ input characters from being automatically lower cased, since C is
+ case sensitive. The parameter, buffer, is used to return the name
+ that is matched. Return MATCH_ERROR if the name is too long
+ (though this is a self-imposed limit), MATCH_NO if what we're
+ seeing isn't a name, and MATCH_YES if we successfully match a C
+ name. */
+
+match
+gfc_match_name_C (char *buffer)
+{
+ locus old_loc;
+ int i = 0;
+ int c;
+
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
+
+ /* Get the next char (first possible char of name) and see if
+ it's valid for C (either a letter or an underscore). */
+ c = gfc_next_char_literal (1);
+
+ /* If the user put nothing expect spaces between the quotes, it is valid
+ and simply means there is no name= specifier and the name is the fortran
+ symbol name, all lowercase. */
+ if (c == '"' || c == '\'')
+ {
+ buffer[0] = '\0';
+ gfc_current_locus = old_loc;
+ return MATCH_YES;
+ }
+
+ if (!ISALPHA (c) && c != '_')
+ {
+ gfc_error ("Invalid C name in NAME= specifier at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Continue to read valid variable name characters. */
+ do
+ {
+ buffer[i++] = c;
+
+ /* C does not define a maximum length of variable names, to my
+ knowledge, but the compiler typically places a limit on them.
+ For now, i'll use the same as the fortran limit for simplicity,
+ but this may need to be changed to a dynamic buffer that can
+ be realloc'ed here if necessary, or more likely, a larger
+ upper-bound set. */
+ if (i > gfc_option.max_identifier_length)
+ {
+ gfc_error ("Name at %C is too long");
+ return MATCH_ERROR;
+ }
+
+ old_loc = gfc_current_locus;
+
+ /* Get next char; param means we're in a string. */
+ c = gfc_next_char_literal (1);
+ } while (ISALNUM (c) || c == '_');
+
+ buffer[i] = '\0';
+ gfc_current_locus = old_loc;
+
+ /* See if we stopped because of whitespace. */
+ if (c == ' ')
+ {
+ gfc_gobble_whitespace ();
+ c = gfc_peek_char ();
+ if (c != '"' && c != '\'')
+ {
+ gfc_error ("Embedded space in NAME= specifier at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ /* If we stopped because we had an invalid character for a C name, report
+ that to the user by returning MATCH_NO. */
+ if (c != '"' && c != '\'')
+ {
+ gfc_error ("Invalid C name in NAME= specifier at %C");
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+}
+
+
/* Match a symbol on the input. Modifies the pointer to the symbol
pointer if successful. */
/* Match a common block name. */
-static match
-match_common_name (char *name)
+match match_common_name (char *name)
{
match m;
if (m == MATCH_NO)
goto syntax;
+ /* Store a ref to the common block for error checking. */
+ sym->common_block = t;
+
+ /* See if we know the current common block is bind(c), and if
+ so, then see if we can check if the symbol is (which it'll
+ need to be). This can happen if the bind(c) attr stmt was
+ applied to the common block, and the variable(s) already
+ defined, before declaring the common block. */
+ if (t->is_bind_c == 1)
+ {
+ if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
+ {
+ /* If we find an error, just print it and continue,
+ cause it's just semantic, and we can see if there
+ are more errors. */
+ gfc_error_now ("Variable '%s' at %L in common block '%s' "
+ "at %C must be declared with a C "
+ "interoperable kind since common block "
+ "'%s' is bind(c)",
+ sym->name, &(sym->declared_at), t->name,
+ t->name);
+ }
+
+ if (sym->attr.is_bind_c == 1)
+ gfc_error_now ("Variable '%s' in common block "
+ "'%s' at %C can not be bind(c) since "
+ "it is not global", sym->name, t->name);
+ }
+
if (sym->attr.in_common)
{
gfc_error ("Symbol '%s' at %C is already in a COMMON block",
match gfc_match_st_label (gfc_st_label **);
match gfc_match_label (void);
match gfc_match_small_int (int *);
+match gfc_match_small_int_expr (int *, gfc_expr **);
int gfc_match_strings (mstring *);
match gfc_match_name (char *);
+match gfc_match_name_C (char *buffer);
match gfc_match_symbol (gfc_symbol **, int);
match gfc_match_sym_tree (gfc_symtree **, int);
match gfc_match_intrinsic_op (gfc_intrinsic_op *);
match gfc_match_deallocate (void);
match gfc_match_return (void);
match gfc_match_call (void);
+
+/* We want to use this function to check for a common-block-name
+ that can exist in a bind statement, so removed the "static"
+ declaration of the function in match.c.
+
+ TODO: should probably rename this now that it'll be globally seen to
+ gfc_match_common_name. */
+match match_common_name (char *name);
+
match gfc_match_common (void);
match gfc_match_block_data (void);
match gfc_match_namelist (void);
match gfc_match_value (void);
match gfc_match_volatile (void);
-/* primary.c */
+/* decl.c. */
+
+/* Fortran 2003 c interop.
+ TODO: some of these should be moved to another file rather than decl.c */
+void set_com_block_bind_c (gfc_common_head *, int);
+try set_binding_label (char *, const char *, int);
+try set_verify_bind_c_sym (gfc_symbol *, int);
+try set_verify_bind_c_com_block (gfc_common_head *, int);
+try get_bind_c_idents (void);
+match gfc_match_bind_c_stmt (void);
+match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
+match gfc_match_bind_c (gfc_symbol *);
+match gfc_get_type_attr_spec (symbol_attribute *);
+
+/* primary.c. */
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
ts->kind = 0;
ts->derived = NULL;
ts->cl = NULL;
+ /* flag that says if the type is C interoperable */
+ ts->is_c_interop = 0;
+ /* says what f90 type the C kind interops with */
+ ts->f90_type = BT_UNKNOWN;
+ /* flag that says whether it's from iso_c_binding or not */
+ ts->is_iso_c = 0;
}
gfc_module_done_2 ();
}
+
+/* Returns the index into the table of C interoperable kinds where the
+ kind with the given name (c_kind_name) was found. */
+
+int
+get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
+{
+ int index = 0;
+
+ for (index = 0; index < ISOCBINDING_LAST; index++)
+ if (strcmp (kinds_table[index].name, c_kind_name) == 0)
+ return index;
+
+ return ISOCBINDING_INVALID;
+}
}
module_locus;
+/* Structure for list of symbols of intrinsic modules. */
+typedef struct
+{
+ int id;
+ const char *name;
+ int value;
+}
+intmod_sym;
+
typedef enum
{
module_locus where;
fixup_t *stfixup;
gfc_symtree *symtree;
+ char binding_label[GFC_MAX_SYMBOL_LEN + 1];
}
rsym;
}
+ if(p == NULL || *p == '\0')
+ len = 0;
+ else
len = strlen (p);
if (atom != ATOM_RPAREN)
if (atom == ATOM_STRING)
write_char ('\'');
- while (*p)
+ while (p != NULL && *p)
{
if (atom == ATOM_STRING && *p == '\'')
write_char ('\'');
AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
- AB_VALUE, AB_VOLATILE, AB_PROTECTED
+ AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP,
+ AB_IS_ISO_C
}
ab_attribute;
minit ("OPTIONAL", AB_OPTIONAL),
minit ("POINTER", AB_POINTER),
minit ("SAVE", AB_SAVE),
- minit ("VALUE", AB_VALUE),
minit ("VOLATILE", AB_VOLATILE),
minit ("TARGET", AB_TARGET),
minit ("THREADPRIVATE", AB_THREADPRIVATE),
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
minit ("CRAY_POINTER", AB_CRAY_POINTER),
minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("IS_BIND_C", AB_IS_BIND_C),
+ minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
+ minit ("IS_ISO_C", AB_IS_ISO_C),
+ minit ("VALUE", AB_VALUE),
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit (NULL, -1)
};
+
/* Specialization of mio_name. */
DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME (ar_type)
MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
if (attr->cray_pointee)
MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ if (attr->is_bind_c)
+ MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
+ if (attr->is_c_interop)
+ MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
+ if (attr->is_iso_c)
+ MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
if (attr->alloc_comp)
MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
case AB_CRAY_POINTEE:
attr->cray_pointee = 1;
break;
+ case AB_IS_BIND_C:
+ attr->is_bind_c = 1;
+ break;
+ case AB_IS_C_INTEROP:
+ attr->is_c_interop = 1;
+ break;
+ case AB_IS_ISO_C:
+ attr->is_iso_c = 1;
+ break;
case AB_ALLOC_COMP:
attr->alloc_comp = 1;
break;
minit ("DERIVED", BT_DERIVED),
minit ("PROCEDURE", BT_PROCEDURE),
minit ("UNKNOWN", BT_UNKNOWN),
+ minit ("VOID", BT_VOID),
minit (NULL, -1)
};
else
mio_symbol_ref (&ts->derived);
+ /* Add info for C interop and is_iso_c. */
+ mio_integer (&ts->is_c_interop);
+ mio_integer (&ts->is_iso_c);
+
+ /* If the typespec is for an identifier either from iso_c_binding, or
+ a constant that was initialized to an identifier from it, use the
+ f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
+ if (ts->is_iso_c)
+ ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
+ else
+ ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
+
if (ts->type != BT_CHARACTER)
{
/* ts->cl is only valid for BT_CHARACTER. */
static void
mio_symbol (gfc_symbol *sym)
{
+ int intmod = INTMOD_NONE;
+
gfc_formal_arglist *formal;
mio_lparen ();
= MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym);
+
+ /* Add the fields that say whether this is from an intrinsic module,
+ and if so, what symbol it is within the module. */
+/* mio_integer (&(sym->from_intmod)); */
+ if (iomode == IO_OUTPUT)
+ {
+ intmod = sym->from_intmod;
+ mio_integer (&intmod);
+ }
+ else
+ {
+ mio_integer (&intmod);
+ sym->from_intmod = intmod;
+ }
+
+ mio_integer (&(sym->intmod_sym_id));
+
mio_rparen ();
}
p->threadprivate = 1;
p->use_assoc = 1;
+ /* Get whether this was a bind(c) common or not. */
+ mio_integer (&p->is_bind_c);
+ /* Get the binding label. */
+ mio_internal_string (p->binding_label);
+
mio_rparen ();
}
mio_internal_string (info->u.rsym.true_name);
mio_internal_string (info->u.rsym.module);
+ mio_internal_string (info->u.rsym.binding_label);
+
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
gfc_current_ns);
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
+
+ /* TODO: hmm, can we test this? Do we know it will be
+ initialized to zeros? */
+ if (info->u.rsym.binding_label[0] != '\0')
+ strcpy (sym->binding_label, info->u.rsym.binding_label);
}
st->n.sym = sym;
gfc_common_head *p;
const char * name;
int flags;
-
+ const char *label;
+
if (st == NULL)
return;
if (p->threadprivate) flags |= 2;
mio_integer (&flags);
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&(p->is_bind_c));
+
+ /* Write out the binding label, or the com name if no label given. */
+ if (p->is_bind_c)
+ {
+ label = p->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ {
+ label = p->name;
+ mio_pool_string (&label);
+ }
+
mio_rparen ();
}
-/* Write the blank common block to the module */
+
+/* Write the blank common block to the module. */
static void
write_blank_common (void)
{
const char * name = BLANK_COMMON_NAME;
int saved;
+ /* TODO: Blank commons are not bind(c). The F2003 standard probably says
+ this, but it hasn't been checked. Just making it so for now. */
+ int is_bind_c = 0;
if (gfc_current_ns->blank_common.head == NULL)
return;
saved = gfc_current_ns->blank_common.saved;
mio_integer (&saved);
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&is_bind_c);
+
+ /* Write out the binding label, which is BLANK_COMMON_NAME, though
+ it doesn't matter because the label isn't used. */
+ mio_pool_string (&name);
+
mio_rparen ();
}
static void
write_symbol (int n, gfc_symbol *sym)
{
+ const char *label;
if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
+ if (sym->attr.is_bind_c || sym->attr.is_iso_c)
+ {
+ label = sym->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ mio_pool_string (&sym->name);
+
mio_pointer_ref (&sym->ns);
mio_symbol (sym);
write_symbol (p->integer, sym);
p->u.wsym.state = WRITTEN;
-
- return;
}
}
+static void
+sort_iso_c_rename_list (void)
+{
+ gfc_use_rename *tmp_list = NULL;
+ gfc_use_rename *curr;
+ gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
+ int c_kind;
+ int i;
+
+ for (curr = gfc_rename_list; curr; curr = curr->next)
+ {
+ c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
+ if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", curr->use_name,
+ &curr->where);
+ }
+ else
+ /* Put it in the list. */
+ kinds_used[c_kind] = curr;
+ }
+
+ /* Make a new (sorted) rename list. */
+ i = 0;
+ while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
+ i++;
+
+ if (i < ISOCBINDING_NUMBER)
+ {
+ tmp_list = kinds_used[i];
+
+ i++;
+ curr = tmp_list;
+ for (; i < ISOCBINDING_NUMBER; i++)
+ if (kinds_used[i] != NULL)
+ {
+ curr->next = kinds_used[i];
+ curr = curr->next;
+ curr->next = NULL;
+ }
+ }
+
+ gfc_rename_list = tmp_list;
+}
+
+
+/* Import the instrinsic ISO_C_BINDING module, generating symbols in
+ the current namespace for all named constants, pointer types, and
+ procedures in the module unless the only clause was used or a rename
+ list was provided. */
+
+static void
+import_iso_c_binding_module (void)
+{
+ gfc_symbol *mod_sym = NULL;
+ gfc_symtree *mod_symtree = NULL;
+ const char *iso_c_module_name = "__iso_c_binding";
+ gfc_use_rename *u;
+ int i;
+ char *local_name;
+
+ /* Look only in the current namespace. */
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
+
+ if (mod_symtree == NULL)
+ {
+ /* symtree doesn't already exist in current namespace. */
+ gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
+
+ if (mod_symtree != NULL)
+ mod_sym = mod_symtree->n.sym;
+ else
+ gfc_internal_error ("import_iso_c_binding_module(): Unable to "
+ "create symbol for %s", iso_c_module_name);
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (iso_c_module_name);
+ mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ }
+
+ /* Generate the symbols for the named constants representing
+ the kinds for intrinsic data types. */
+ if (only_flag)
+ {
+ /* Sort the rename list because there are dependencies between types
+ and procedures (e.g., c_loc needs c_ptr). */
+ sort_iso_c_rename_list ();
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ i = get_c_kind (u->use_name, c_interop_kinds_table);
+
+ if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
+ {
+ gfc_error ("Symbol '%s' referenced at %L does not exist in "
+ "intrinsic module ISO_C_BINDING.", u->use_name,
+ &u->where);
+ continue;
+ }
+
+ generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
+ }
+ }
+ else
+ {
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+ generate_isocbinding_symbol (iso_c_module_name, i, local_name);
+ }
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (u->found)
+ continue;
+
+ gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
+ "module ISO_C_BINDING", u->use_name, &u->where);
+ }
+ }
+}
+
+
/* Add an integer named constant from a given module. */
+
static void
-create_int_parameter (const char *name, int value, const char *modname)
+create_int_parameter (const char *name, int value, const char *modname,
+ intmod_id module, int id)
{
gfc_symtree *tmp_symtree;
gfc_symbol *sym;
sym->ts.kind = gfc_default_integer_kind;
sym->value = gfc_int_expr (value);
sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
}
gfc_symtree *mod_symtree;
int i;
- mstring symbol[] = {
-#define NAMED_INTCST(a,b,c) minit(b,0),
+ intmod_sym symbol[] = {
+#define NAMED_INTCST(a,b,c) { a, b, 0 },
#include "iso-fortran-env.def"
#undef NAMED_INTCST
- minit (NULL, -1234) };
+ { ISOFORTRANENV_INVALID, NULL, -1234 } };
i = 0;
-#define NAMED_INTCST(a,b,c) symbol[i++].tag = c;
+#define NAMED_INTCST(a,b,c) symbol[i++].value = c;
#include "iso-fortran-env.def"
#undef NAMED_INTCST
mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
mod_sym->module = gfc_get_string (mod);
+ mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
}
else
if (!mod_symtree->n.sym->attr.intrinsic)
if (only_flag)
for (u = gfc_rename_list; u; u = u->next)
{
- for (i = 0; symbol[i].string; i++)
- if (strcmp (symbol[i].string, u->use_name) == 0)
+ for (i = 0; symbol[i].name; i++)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
break;
- if (symbol[i].string == NULL)
+ if (symbol[i].name == NULL)
{
gfc_error ("Symbol '%s' referenced at %L does not exist in "
"intrinsic module ISO_FORTRAN_ENV", u->use_name,
}
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
- && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
"from intrinsic module ISO_FORTRAN_ENV at %L is "
"incompatible with option %s", &u->where,
? "-fdefault-integer-8" : "-fdefault-real-8");
create_int_parameter (u->local_name[0] ? u->local_name
- : symbol[i].string,
- symbol[i].tag, mod);
+ : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
}
else
{
- for (i = 0; symbol[i].string; i++)
+ for (i = 0; symbol[i].name; i++)
{
local_name = NULL;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (symbol[i].string, u->use_name) == 0)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
{
local_name = u->local_name;
u->found = 1;
}
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
- && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
"from intrinsic module ISO_FORTRAN_ENV at %C is "
"incompatible with option %s",
gfc_option.flag_default_integer
? "-fdefault-integer-8" : "-fdefault-real-8");
- create_int_parameter (local_name ? local_name : symbol[i].string,
- symbol[i].tag, mod);
+ create_int_parameter (local_name ? local_name : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
}
for (u = gfc_rename_list; u; u = u->next)
return;
}
+ if (strcmp (module_name, "iso_c_binding") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "ISO_C_BINDING module at %C") != FAILURE)
+ {
+ import_iso_c_binding_module();
+ return;
+ }
+
module_fp = gfc_open_intrinsic_module (filename);
if (module_fp == NULL && specified_int)
- gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
- module_name);
+ gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+ module_name);
}
if (module_fp == NULL)
case 'b':
match ("backspace", gfc_match_backspace, ST_BACKSPACE);
match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
+ match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
break;
case 'c':
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
gfc_state_data s;
+ gfc_symbol *derived_sym = NULL;
gfc_symbol *sym;
gfc_component *c;
}
}
+ /* need to verify that all fields of the derived type are
+ * interoperable with C if the type is declared to be bind(c)
+ */
+ derived_sym = gfc_current_block();
+
/* Look for allocatable components. */
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
e->ref = NULL;
e->ts.type = BT_CHARACTER;
e->ts.kind = kind;
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
e->where = start_locus;
e->value.character.string = p = gfc_getmem (length + 1);
e->value.logical = i;
e->ts.type = BT_LOGICAL;
e->ts.kind = kind;
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
e->where = gfc_current_locus;
*result = e;
}
target.type = BT_REAL;
target.kind = kind;
+ target.is_c_interop = 0;
+ target.is_iso_c = 0;
if (real->ts.type != BT_REAL || kind != real->ts.kind)
gfc_convert_type (real, &target, 2);
break;
}
+ /* Check here for the existence of at least one argument for the
+ iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
+ argument(s) given will be checked in gfc_iso_c_func_interface,
+ during resolution of the function call. */
+ if (sym->attr.is_iso_c == 1
+ && (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && (sym->intmod_sym_id == ISOCBINDING_LOC
+ || sym->intmod_sym_id == ISOCBINDING_FUNLOC
+ || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
+ {
+ /* make sure we were given a param */
+ if (actual_arglist == NULL)
+ {
+ gfc_error ("Missing argument to '%s' at %C", sym->name);
+ m = MATCH_ERROR;
+ break;
+ }
+ }
+
if (sym->result == NULL)
sym->result = sym;
}
+static try
+is_scalar_expr_ptr (gfc_expr *expr)
+{
+ 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.length != NULL
+ && ref->u.ss.length->length != NULL
+ && ref->u.ss.start
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref->u.ss.end
+ && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ start = (int) mpz_get_si (ref->u.ss.start->value.integer);
+ end = (int) mpz_get_si (ref->u.ss.end->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
+ else
+ 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.cl == NULL
+ || expr->ts.cl->length == NULL
+ || mpz_cmp_si (expr->ts.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. */
+ 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.cl == NULL
+ || expr->ts.cl->length == NULL
+ || mpz_cmp_si (expr->ts.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 try
+gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
+ gfc_symbol **new_sym)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ int optional_arg = 0;
+ try retval = SUCCESS;
+ gfc_symbol *args_sym;
+
+ args_sym = args->expr->symtree->n.sym;
+
+ 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);
+ sprintf (binding_label, "%s_2", sym->binding_label);
+ optional_arg = 1;
+ }
+ else
+ {
+ /* one arg. */
+ sprintf (name, "%s_1", sym->name);
+ sprintf (binding_label, "%s_1", sym->binding_label);
+ 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, binding_label, optional_arg);
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_LOC
+ || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ sprintf (name, "%s", sym->name);
+ sprintf (binding_label, "%s", sym->binding_label);
+
+ /* 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)
+ {
+ /* Make sure we have either the target or pointer attribute. */
+ if (!(args->expr->symtree->n.sym->attr.target)
+ && !(args->expr->symtree->n.sym->attr.pointer))
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
+ "a TARGET or an associated pointer",
+ args->expr->symtree->n.sym->name,
+ sym->name, &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* See if we have interoperable type and type param. */
+ if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
+ args->expr->symtree->n.sym->name,
+ &(args->expr->where)) == SUCCESS
+ || gfc_check_any_c_kind (&(args_sym->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
+ {
+ /* 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 (args_sym->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 (args_sym->attr.pointer == 1
+ && 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_sym->attr.dimension != 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 (args_sym->ts.type == BT_CHARACTER
+ && args_sym->ts.cl != NULL)
+ {
+ gfc_error_now ("CHARACTER parameter '%s' to '%s' at %L "
+ "cannot have a length type parameter",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
+ {
+ /* TODO: Update this error message to allow for procedure
+ pointers once they are implemented. */
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ "procedure",
+ args->expr->symtree->n.sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
+ "interoperable",
+ args->expr->symtree->n.sym->name, sym->name,
+ &(args->expr->where));
+ 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. */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
return FAILURE;
- /* Resume assumed_size checking. */
+ /* 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--;
if (sym && sym->ts.type == BT_CHARACTER
}
+/* 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, 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;
+ }
+ 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. */
+ sprintf (binding_label, "%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);
+ sprintf (binding_label, "%s", 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];
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ /* default to success; will override if find error */
+ match m = MATCH_YES;
+ gfc_symbol *tmp_sym;
+
+ 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)
+ {
+ /* Make sure we got a third arg. The type/rank of it will
+ be checked later if it's there (gfc_procedure_use()). */
+ if (c->ext.actual->next->expr->rank != 0 &&
+ c->ext.actual->next->next == NULL)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Missing SHAPE parameter for call to %s "
+ "at %L", sym->name, &(c->loc));
+ }
+ /* Make sure the param is a POINTER. No need to make sure
+ it does not have INTENT(IN) since it is a POINTER. */
+ tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
+ if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
+ {
+ gfc_error ("Argument '%s' to '%s' at %L "
+ "must have the POINTER attribute",
+ tmp_sym->name, sym->name, &(c->loc));
+ 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 if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ /* TODO: Figure out if this is even reacable; this part of the
+ conditional may not be necessary. */
+ int num_args = 0;
+ if (c->ext.actual->next == NULL)
+ {
+ /* The user did not give two args, so resolve to the version
+ of c_associated expecting one arg. */
+ num_args = 1;
+ /* get rid of the second arg */
+ /* TODO!! Should free up the memory here! */
+ sym->formal->next = NULL;
+ }
+ else
+ {
+ num_args = 2;
+ }
+
+ new_sym = sym;
+ sprintf (name, "%s_%d", sym->name, num_args);
+ sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
+ sym->name = gfc_get_string (name);
+ strcpy (sym->binding_label, binding_label);
+ }
+ else
+ {
+ /* no differences for c_loc or c_funloc */
+ new_sym = sym;
+ }
+
+ /* set the resolved symbol */
+ if (m != MATCH_ERROR)
+ {
+ gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
+ c->resolved_sym = new_sym;
+ }
+ else
+ c->resolved_sym = sym;
+
+ return m;
+}
+
+
/* Resolve a subroutine call known to be specific. */
static match
{
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)
}
+/* Verify the binding labels for common blocks that are BIND(C). The label
+ for a BIND(C) common block must be identical in all scoping units in which
+ the common block is declared. Further, the binding label can not collide
+ with any other global entity in the program. */
+
+static void
+resolve_bind_c_comms (gfc_symtree *comm_block_tree)
+{
+ if (comm_block_tree->n.common->is_bind_c == 1)
+ {
+ gfc_gsymbol *binding_label_gsym;
+ gfc_gsymbol *comm_name_gsym;
+
+ /* See if a global symbol exists by the common block's name. It may
+ be NULL if the common block is use-associated. */
+ comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->name);
+ if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L collides "
+ "with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ else if (comm_name_gsym != NULL
+ && strcmp (comm_name_gsym->name,
+ comm_block_tree->n.common->name) == 0)
+ {
+ /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
+ as expected. */
+ if (comm_name_gsym->binding_label == NULL)
+ /* No binding label for common block stored yet; save this one. */
+ comm_name_gsym->binding_label =
+ comm_block_tree->n.common->binding_label;
+ else
+ if (strcmp (comm_name_gsym->binding_label,
+ comm_block_tree->n.common->binding_label) != 0)
+ {
+ /* Common block names match but binding labels do not. */
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "does not match the binding label '%s' for common "
+ "block '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->binding_label,
+ comm_name_gsym->name,
+ &(comm_name_gsym->where));
+ return;
+ }
+ }
+
+ /* There is no binding label (NAME="") so we have nothing further to
+ check and nothing to add as a global symbol for the label. */
+ if (comm_block_tree->n.common->binding_label[0] == '\0' )
+ return;
+
+ binding_label_gsym =
+ gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->binding_label);
+ if (binding_label_gsym == NULL)
+ {
+ /* Need to make a global symbol for the binding label to prevent
+ it from colliding with another. */
+ binding_label_gsym =
+ gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
+ binding_label_gsym->sym_name = comm_block_tree->n.common->name;
+ binding_label_gsym->type = GSYM_COMMON;
+ }
+ else
+ {
+ /* If comm_name_gsym is NULL, the name common block is use
+ associated and the name could be colliding. */
+ if (binding_label_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ binding_label_gsym->name,
+ &(binding_label_gsym->where));
+ else if (comm_name_gsym != NULL
+ && (strcmp (binding_label_gsym->name,
+ comm_name_gsym->binding_label) != 0)
+ && (strcmp (binding_label_gsym->sym_name,
+ comm_name_gsym->name) != 0))
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with global entity '%s' at %L",
+ binding_label_gsym->name, binding_label_gsym->sym_name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ }
+ }
+
+ return;
+}
+
+
+/* Verify any BIND(C) derived types in the namespace so we can report errors
+ for them once, rather than for each variable declared of that type. */
+
+static void
+resolve_bind_c_derived_types (gfc_symbol *derived_sym)
+{
+ if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
+ && derived_sym->attr.is_bind_c == 1)
+ verify_bind_c_derived_type (derived_sym);
+
+ return;
+}
+
+
+/* Verify that any binding labels used in a given namespace do not collide
+ with the names or binding labels of any global symbols. */
+
+static void
+gfc_verify_binding_labels (gfc_symbol *sym)
+{
+ int has_error = 0;
+
+ if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+ {
+ gfc_gsymbol *bind_c_sym;
+
+ bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+ if (bind_c_sym != NULL
+ && strcmp (bind_c_sym->name, sym->binding_label) == 0)
+ {
+ if (sym->attr.if_source == IFSRC_DECL
+ && (bind_c_sym->type != GSYM_SUBROUTINE
+ && bind_c_sym->type != GSYM_FUNCTION)
+ && ((sym->attr.contained == 1
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ || (sym->attr.use_assoc == 1
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
+ {
+ /* Make sure global procedures don't collide with anything. */
+ gfc_error ("Binding label '%s' at %L collides with the global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_IFBODY
+ && sym->attr.flavor == FL_PROCEDURE)
+ && (bind_c_sym->sym_name != NULL
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0))
+ {
+ /* Make sure procedures in interface bodies don't collide. */
+ gfc_error ("Binding label '%s' in interface body at %L collides "
+ "with the global entity '%s' at %L",
+ sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_UNKNOWN))
+ if ((sym->attr.use_assoc
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
+ || sym->attr.use_assoc == 0)
+ {
+ gfc_error ("Binding label '%s' at %L collides with global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+
+ if (has_error != 0)
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label[0] = '\0';
+ }
+ else if (bind_c_sym == NULL)
+ {
+ bind_c_sym = gfc_get_gsymbol (sym->binding_label);
+ bind_c_sym->where = sym->declared_at;
+ bind_c_sym->sym_name = sym->name;
+
+ if (sym->attr.use_assoc == 1)
+ bind_c_sym->mod_name = sym->module;
+ else
+ if (sym->ns->proc_name != NULL)
+ bind_c_sym->mod_name = sym->ns->proc_name->name;
+
+ if (sym->attr.contained == 0)
+ {
+ if (sym->attr.subroutine)
+ bind_c_sym->type = GSYM_SUBROUTINE;
+ else if (sym->attr.function)
+ bind_c_sym->type = GSYM_FUNCTION;
+ }
+ }
+ }
+ return;
+}
+
+
/* Resolve an index expression. */
static try
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
+
+ if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
+ {
+ gfc_formal_arglist *curr_arg;
+
+ if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block) == FAILURE)
+ {
+ /* Clear these to prevent looking at them again if there was an
+ error. */
+ sym->attr.is_bind_c = 0;
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ }
+ else
+ {
+ /* So far, no errors have been found. */
+ sym->attr.is_c_interop = 1;
+ sym->ts.is_c_interop = 1;
+ }
+
+ curr_arg = sym->formal;
+ while (curr_arg != NULL)
+ {
+ /* Skip implicitly typed dummy args here. */
+ if (curr_arg->sym->attr.implicit_type == 0
+ && verify_c_interop_param (curr_arg->sym) == FAILURE)
+ {
+ /* If something is found to fail, mark the symbol for the
+ procedure as not being BIND(C) to try and prevent multiple
+ errors being reported. */
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ sym->attr.is_bind_c = 0;
+ }
+ curr_arg = curr_arg->next;
+ }
+ }
+
return SUCCESS;
}
sym->name, &sym->declared_at);
return;
}
+
+ if (sym->ts.is_c_interop
+ && mpz_cmp_si (cl->length->value.integer, 1) != 0)
+ {
+ gfc_error ("C interoperable character dummy variable '%s' at %L "
+ "with VALUE attribute must have length one",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
+ /* If the symbol is marked as bind(c), verify it's type and kind. Do not
+ do this for something that was implicitly typed because that is handled
+ in gfc_set_default_type. Handle dummy arguments and procedure
+ definitions separately. Also, anything that is use associated is not
+ handled here but instead is handled in the module it is declared in.
+ Finally, derived type definitions are allowed to be BIND(C) since that
+ only implies that they're interoperable, and they are checked fully for
+ interoperability when a variable is declared of that type. */
+ if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
+ sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
+ sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
+ {
+ try t = SUCCESS;
+
+ /* First, make sure the variable is declared at the
+ module-level scope (J3/04-007, Section 15.3). */
+ if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
+ sym->attr.in_common == 0)
+ {
+ gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
+ "is neither a COMMON block nor declared at the "
+ "module level scope", sym->name, &(sym->declared_at));
+ t = FAILURE;
+ }
+ else if (sym->common_head != NULL)
+ {
+ t = verify_com_block_vars_c_interop (sym->common_head);
+ }
+ else
+ {
+ /* If type() declaration, we need to verify that the components
+ of the given type are all C interoperable, etc. */
+ if (sym->ts.type == BT_DERIVED &&
+ sym->ts.derived->attr.is_c_interop != 1)
+ {
+ /* Make sure the user marked the derived type as BIND(C). If
+ not, call the verify routine. This could print an error
+ for the derived type more than once if multiple variables
+ of that type are declared. */
+ if (sym->ts.derived->attr.is_bind_c != 1)
+ verify_bind_c_derived_type (sym->ts.derived);
+ t = FAILURE;
+ }
+
+ /* Verify the variable itself as C interoperable if it
+ is BIND(C). It is not possible for this to succeed if
+ the verify_bind_c_derived_type failed, so don't have to handle
+ any error returned by verify_bind_c_derived_type. */
+ t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block);
+ }
+
+ if (t == FAILURE)
+ {
+ /* clear the is_bind_c flag to prevent reporting errors more than
+ once if something failed. */
+ sym->attr.is_bind_c = 0;
+ return;
+ }
}
/* If a derived type symbol has reached this point, without its
resolve_contained_functions (ns);
+ gfc_traverse_ns (ns, resolve_bind_c_derived_types);
+
for (cl = ns->cl_list; cl; cl = cl->next)
resolve_charlen (cl);
iter_stack = NULL;
gfc_traverse_ns (ns, gfc_formalize_init_value);
+ gfc_traverse_ns (ns, gfc_verify_binding_labels);
+
+ if (ns->common_root != NULL)
+ gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
+
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
#include "gfortran.h"
#include "parse.h"
+
/* Strings for all symbol attributes. We use these for dumping the
parse tree, in error messages, and also when reading and writing
modules. */
sym->ts = *ts;
sym->attr.implicit_type = 1;
+ if (sym->attr.is_bind_c == 1)
+ {
+ /* BIND(C) variables should not be implicitly declared. */
+ gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
+ "not be C interoperable", sym->name, &sym->declared_at);
+ sym->ts.f90_type = sym->ts.type;
+ }
+
+ if (sym->attr.dummy != 0)
+ {
+ if (sym->ns->proc_name != NULL
+ && (sym->ns->proc_name->attr.subroutine != 0
+ || sym->ns->proc_name->attr.function != 0)
+ && sym->ns->proc_name->attr.is_bind_c != 0)
+ {
+ /* Dummy args to a BIND(C) routine may not be interoperable if
+ they are implicitly typed. */
+ gfc_warning_now ("Implicity declared variable '%s' at %L may not "
+ "be C interoperable but it is a dummy argument to "
+ "the BIND(C) procedure '%s' at %L", sym->name,
+ &(sym->declared_at), sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at));
+ sym->ts.f90_type = sym->ts.type;
+ }
+ }
+
return SUCCESS;
}
*dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
*use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
*cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
- *volatile_ = "VOLATILE", *protected = "PROTECTED";
+ *volatile_ = "VOLATILE", *protected = "PROTECTED",
+ *is_bind_c = "BIND(C)";
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
conf (dummy, save);
conf (dummy, threadprivate);
conf (pointer, target);
- conf (pointer, external);
conf (pointer, intrinsic);
conf (pointer, elemental);
conf (allocatable, elemental);
conf (function, subroutine);
+ if (!function && !subroutine)
+ conf (is_bind_c, dummy);
+
+ conf (is_bind_c, cray_pointer);
+ conf (is_bind_c, cray_pointee);
+ conf (is_bind_c, allocatable);
+
+ /* Need to also get volatile attr, according to 5.1 of F2003 draft.
+ Parameter conflict caught below. Also, value cannot be specified
+ for a dummy procedure. */
+
/* Cray pointer/pointee conflicts. */
conf (cray_pointer, cray_pointee);
conf (cray_pointer, dimension);
conf (data, allocatable);
conf (data, use_assoc);
- conf (protected, intrinsic)
- conf (protected, external)
- conf (protected, in_common)
-
conf (value, pointer)
conf (value, allocatable)
conf (value, subroutine)
goto conflict;
}
+ conf (protected, intrinsic)
+ conf (protected, external)
+ conf (protected, in_common)
+
conf (volatile_, intrinsic)
conf (volatile_, external)
conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
+ /* TODO: hmm, double check this. */
+ conf2 (value);
break;
default:
}
+/* Set the is_bind_c field for the given symbol_attribute. */
+
+try
+gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
+ int is_proc_lang_bind_spec)
+{
+
+ if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", where);
+ else if (attr->is_bind_c)
+ gfc_error_now ("Duplicate BIND attribute specified at %L", where);
+ else
+ attr->is_bind_c = 1;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
+ == FAILURE)
+ return FAILURE;
+
+ return check_conflict (attr, name, where);
+}
+
+
try
-gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
- gfc_formal_arglist * formal, locus * where)
+gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist * formal, locus *where)
{
if (check_used (&sym->attr, sym->name, where))
where we are called from, so we ignore some bits. */
try
-gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
+gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
{
-
+ int is_proc_lang_bind_spec;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
goto fail;
+ is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
+ if (src->is_bind_c
+ && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
+ != SUCCESS)
+ return FAILURE;
+
+ if (src->is_c_interop)
+ dest->is_c_interop = 1;
+ if (src->is_iso_c)
+ dest->is_iso_c = 1;
+
if (src->external && gfc_add_external (dest, where) == FAILURE)
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
gfc_internal_error ("new_symbol(): Symbol name too long");
p->name = gfc_get_string (name);
+
+ /* Make sure flags for symbol being C bound are clear initially. */
+ p->attr.is_bind_c = 0;
+ p->attr.is_iso_c = 0;
+ /* Make sure the binding label field has a Nul char to start. */
+ p->binding_label[0] = '\0';
+
+ /* Clear the ptrs we may need. */
+ p->common_block = NULL;
+
return p;
}
return s;
}
+
+
+static gfc_symbol *
+get_iso_c_binding_dt (int sym_id)
+{
+ gfc_dt_list *dt_list;
+
+ dt_list = gfc_derived_types;
+
+ /* Loop through the derived types in the name list, searching for
+ the desired symbol from iso_c_binding. Search the parent namespaces
+ if necessary and requested to (parent_flag). */
+ while (dt_list != NULL)
+ {
+ if (dt_list->derived->from_intmod != INTMOD_NONE
+ && dt_list->derived->intmod_sym_id == sym_id)
+ return dt_list->derived;
+
+ dt_list = dt_list->next;
+ }
+
+ return NULL;
+}
+
+
+/* Verifies that the given derived type symbol, derived_sym, is interoperable
+ with C. This is necessary for any derived type that is BIND(C) and for
+ derived types that are parameters to functions that are BIND(C). All
+ fields of the derived type are required to be interoperable, and are tested
+ for such. If an error occurs, the errors are reported here, allowing for
+ multiple errors to be handled for a single derived type. */
+
+try
+verify_bind_c_derived_type (gfc_symbol *derived_sym)
+{
+ gfc_component *curr_comp = NULL;
+ try is_c_interop = FAILURE;
+ try retval = SUCCESS;
+
+ if (derived_sym == NULL)
+ gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
+ "unexpectedly NULL");
+
+ /* If we've already looked at this derived symbol, do not look at it again
+ so we don't repeat warnings/errors. */
+ if (derived_sym->ts.is_c_interop)
+ return SUCCESS;
+
+ /* The derived type must have the BIND attribute to be interoperable
+ J3/04-007, Section 15.2.3. */
+ if (derived_sym->attr.is_bind_c != 1)
+ {
+ derived_sym->ts.is_c_interop = 0;
+ gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
+ "attribute to be C interoperable", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ curr_comp = derived_sym->components;
+
+ /* TODO: is this really an error? */
+ if (curr_comp == NULL)
+ {
+ gfc_error ("Derived type '%s' at %L is empty",
+ derived_sym->name, &(derived_sym->declared_at));
+ return FAILURE;
+ }
+
+ /* Initialize the derived type as being C interoperable.
+ If we find an error in the components, this will be set false. */
+ derived_sym->ts.is_c_interop = 1;
+
+ /* Loop through the list of components to verify that the kind of
+ each is a C interoperable type. */
+ do
+ {
+ /* The components cannot be pointers (fortran sense).
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->pointer != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "POINTER attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* The components cannot be allocatable.
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->allocatable != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "ALLOCATABLE attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* BIND(C) derived types must have interoperable components. */
+ if (curr_comp->ts.type == BT_DERIVED
+ && curr_comp->ts.derived->ts.is_iso_c != 1
+ && curr_comp->ts.derived != derived_sym)
+ {
+ /* This should be allowed; the draft says a derived-type can not
+ have type parameters if it is has the BIND attribute. Type
+ parameters seem to be for making parameterized derived types.
+ There's no need to verify the type if it is c_ptr/c_funptr. */
+ retval = verify_bind_c_derived_type (curr_comp->ts.derived);
+ }
+ else
+ {
+ /* Grab the typespec for the given component and test the kind. */
+ is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
+ &(curr_comp->loc));
+
+ if (is_c_interop != SUCCESS)
+ {
+ /* Report warning and continue since not fatal. The
+ draft does specify a constraint that requires all fields
+ to interoperate, but if the user says real(4), etc., it
+ may interoperate with *something* in C, but the compiler
+ most likely won't know exactly what. Further, it may not
+ interoperate with the same data type(s) in C if the user
+ recompiles with different flags (e.g., -m32 and -m64 on
+ x86_64 and using integer(4) to claim interop with a
+ C_LONG). */
+ if (derived_sym->attr.is_bind_c == 1)
+ /* If the derived type is bind(c), all fields must be
+ interop. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable, even though "
+ "derived type '%s' is BIND(C)",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc), derived_sym->name);
+ else
+ /* If derived type is param to bind(c) routine, or to one
+ of the iso_c_binding procs, it must be interoperable, so
+ all fields must interop too. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc));
+ }
+ }
+
+ curr_comp = curr_comp->next;
+ } while (curr_comp != NULL);
+
+
+ /* Make sure we don't have conflicts with the attributes. */
+ if (derived_sym->attr.access == ACCESS_PRIVATE)
+ {
+ gfc_error ("Derived type '%s' at %L cannot be declared with both "
+ "PRIVATE and BIND(C) attributes", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ if (derived_sym->attr.sequence != 0)
+ {
+ gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
+ "attribute because it is BIND(C)", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* Mark the derived type as not being C interoperable if we found an
+ error. If there were only warnings, proceed with the assumption
+ it's interoperable. */
+ if (retval == FAILURE)
+ derived_sym->ts.is_c_interop = 0;
+
+ return retval;
+}
+
+
+/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
+
+static try
+gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
+ const char *module_name)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *tmp_sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
+
+ if (tmp_symtree != NULL)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ {
+ tmp_sym = NULL;
+ gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
+ "create symbol for %s", ptr_name);
+ }
+
+ /* Set up the symbol's important fields. Save attr required so we can
+ initialize the ptr to NULL. */
+ tmp_sym->attr.save = 1;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* The c_ptr and c_funptr derived types will provide the
+ definition for c_null_ptr and c_null_funptr, respectively. */
+ if (ptr_id == ISOCBINDING_NULL_PTR)
+ tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.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,
+ (char *) (ptr_id == ISOCBINDING_NULL_PTR
+ ? "_gfortran_iso_c_binding_c_ptr"
+ : "_gfortran_iso_c_binding_c_funptr"));
+
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+ }
+
+ /* Module name is some mangled version of iso_c_binding. */
+ tmp_sym->module = gfc_get_string (module_name);
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ tmp_sym->attr.use_assoc = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ /* Set the binding_label. */
+ sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+
+ /* Set the c_address field of c_null_ptr and c_null_funptr to
+ the value of NULL. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_STRUCTURE;
+ tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.derived = tmp_sym->ts.derived;
+ tmp_sym->value->value.constructor = gfc_get_constructor ();
+ /* This line will initialize the c_null_ptr/c_null_funptr
+ c_address field to NULL. */
+ tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
+ /* Must declare c_null_ptr and c_null_funptr as having the
+ PARAMETER attribute so they can be used in init expressions. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+
+ return SUCCESS;
+}
+
+
+/* Add a formal argument, gfc_formal_arglist, to the
+ end of the given list of arguments. Set the reference to the
+ provided symbol, param_sym, in the argument. */
+
+static void
+add_formal_arg (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ gfc_formal_arglist *formal_arg,
+ gfc_symbol *param_sym)
+{
+ /* Put in list, either as first arg or at the tail (curr arg). */
+ if (*head == NULL)
+ *head = *tail = formal_arg;
+ else
+ {
+ (*tail)->next = formal_arg;
+ (*tail) = formal_arg;
+ }
+
+ (*tail)->sym = param_sym;
+ (*tail)->next = NULL;
+
+ return;
+}
+
+
+/* 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)
+{
+ 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 = "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);
+ 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, no matter what it's name is (user renamed). */
+ 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. */
+ gfc_error_now ("Type 'C_PTR' required for ISO_C_BINDING function at %C");
+ generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
+ (char *) "_gfortran_iso_c_binding_c_ptr");
+
+ gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
+ }
+
+ param_sym->ts.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);
+}
+
+
+/* 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)
+{
+ 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);
+ 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++;
+ 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);
+}
+
+
+/* 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__";
+ int i;
+
+ if (shape_param_name != NULL)
+ shape_param = shape_param_name;
+
+ gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
+ 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. */
+ param_sym->ts.type = BT_INTEGER;
+ param_sym->ts.kind = gfc_default_integer_kind;
+ param_sym->as = gfc_get_array_spec ();
+
+ /* Clear out the dimension info for the array. */
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ param_sym->as->lower[i] = NULL;
+ param_sym->as->upper[i] = NULL;
+ }
+ param_sym->as->rank = 1;
+ param_sym->as->lower[0] = gfc_int_expr (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);
+}
+
+/* Add a procedure interface to the given symbol (i.e., store a
+ reference to the list of formal arguments). */
+
+static void
+add_proc_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist *formal)
+{
+
+ sym->formal = formal;
+ sym->attr.if_source = source;
+}
+
+
+/* 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_POINTER) ||
+ (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr");
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr");
+
+ /* If we're dealing with c_f_pointer, it has an optional third arg. */
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_shape_param (&head, &tail,
+ (const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+ }
+ }
+ 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");
+ if (add_optional_arg)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "c_ptr_2");
+ /* 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;
+}
+
+
+/* Generate the given set of C interoperable kind objects, or all
+ interoperable kinds. This function will only be given kind objects
+ for valid iso_c_binding defined types because this is verified when
+ the 'use' statement is parsed. If the user gives an 'only' clause,
+ the specific kinds are looked up; if they don't exist, an error is
+ reported. If the user does not give an 'only' clause, all
+ iso_c_binding symbols are generated. If a list of specific kinds
+ is given, it must have a NULL in the first empty spot to mark the
+ end of the list. */
+
+
+void
+generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
+ char *local_name)
+{
+ char *name = (local_name && local_name[0]) ? local_name
+ : c_interop_kinds_table[s].name;
+ gfc_symtree *tmp_symtree = NULL;
+ gfc_symbol *tmp_sym = NULL;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
+ char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
+ int index;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+ /* Already exists in this scope so don't re-add it.
+ TODO: we should probably check that it's really the same symbol. */
+ if (tmp_symtree != NULL)
+ return;
+
+ /* Create the sym tree in the current ns. */
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ if (tmp_symtree)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create symbol");
+
+ /* Say what module this symbol belongs to. */
+ tmp_sym->module = gfc_get_string (mod_name);
+ tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ tmp_sym->intmod_sym_id = s;
+
+ switch (s)
+ {
+
+#define NAMED_INTCST(a,b,c) case a :
+#define NAMED_REALCST(a,b,c) case a :
+#define NAMED_CMPXCST(a,b,c) case a :
+#define NAMED_LOGCST(a,b,c) case a :
+#define NAMED_CHARKNDCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_INTEGER;
+ tmp_sym->ts.kind = gfc_default_integer_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->attr.is_c_interop = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+
+#define NAMED_CHARCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ /* Initialize an integer constant expression node for the
+ length of the character. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_CONSTANT;
+ tmp_sym->value->ts.type = BT_CHARACTER;
+ tmp_sym->value->ts.kind = gfc_default_character_kind;
+ tmp_sym->value->where = gfc_current_locus;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->value->value.character.length = 1;
+ tmp_sym->value->value.character.string = gfc_getmem (2);
+ tmp_sym->value->value.character.string[0]
+ = (char) c_interop_kinds_table[s].value;
+ tmp_sym->value->value.character.string[1] = '\0';
+
+ /* May not need this in both attr and ts, but do need in
+ attr for writing module file. */
+ tmp_sym->attr.is_c_interop = 1;
+
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_CHARACTER;
+
+ /* Need to set it to the C_CHAR kind. */
+ tmp_sym->ts.kind = gfc_default_character_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = BT_CHARACTER;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_DERIVED;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ tmp_sym->attr.is_bind_c = 1;
+
+ tmp_sym->attr.referenced = 1;
+
+ tmp_sym->ts.derived = tmp_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ dt_list_ptr = &(gfc_derived_types);
+ while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+
+ /* There is already at least one derived type in the list, so append
+ the one we're currently building for c_ptr or c_funptr. */
+ if (*dt_list_ptr != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+ (*dt_list_ptr) = gfc_get_dt_list ();
+ (*dt_list_ptr)->derived = tmp_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", tmp_sym->name, "c_address");
+ gfc_add_component (tmp_sym, comp_name, &tmp_comp);
+ if (tmp_comp == NULL)
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create component for c_address");
+
+ tmp_comp->ts.type = BT_INTEGER;
+
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
+
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+
+ tmp_comp->pointer = 0;
+ tmp_comp->dimension = 0;
+
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+
+ /* Make it use associated (iso_c_binding module). */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_NULL_PTR:
+ case ISOCBINDING_NULL_FUNPTR:
+ 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. */
+ sprintf (tmp_sym->binding_label, "%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.derived =
+ get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.derived =
+ get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+
+ if (tmp_sym->ts.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_FUNPTR,
+ (char *)(s == ISOCBINDING_FUNLOC
+ ? "_gfortran_iso_c_binding_c_funptr"
+ : "_gfortran_iso_c_binding_c_ptr"));
+ tmp_sym->ts.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.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 ();
+ }
+}
+
+
+/* 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,
+ 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. */
+ strcpy (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);
+ /* 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;
+}
+
#include "target-memory.h"
+/* TODO: This is defined in match.h, and probably shouldn't be here also,
+ but we need it for now at least and don't want to include the whole
+ match.h. */
+gfc_common_head *gfc_get_common (const char *, int);
+
+
/* Holds a single variable in an equivalence set. */
typedef struct segment_info
{
return list;
}
+
/* Construct mangled common block name from symbol name. */
+/* We need the bind(c) flag to tell us how/if we should mangle the symbol
+ name. There are few calls to this function, so few places that this
+ would need to be added. At the moment, there is only one call, in
+ build_common_decl(). We can't attempt to look up the common block
+ because we may be building it for the first time and therefore, it won't
+ be in the common_root. We also need the binding label, if it's bind(c).
+ Therefore, send in the pointer to the common block, so whatever info we
+ have so far can be used. All of the necessary info should be available
+ in the gfc_common_head by now, so it should be accurate to test the
+ isBindC flag and use the binding label given if it is bind(c).
+
+ We may NOT know yet if it's bind(c) or not, but we can try at least.
+ Will have to figure out what to do later if it's labeled bind(c)
+ after this is called. */
+
static tree
-gfc_sym_mangled_common_id (const char *name)
+gfc_sym_mangled_common_id (gfc_common_head *com)
{
int has_underscore;
char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+
+ /* Get the name out of the common block pointer. */
+ strcpy (name, com->name);
+
+ /* If we're suppose to do a bind(c). */
+ if (com->is_bind_c == 1 && com->binding_label[0] != '\0')
+ return get_identifier (com->binding_label);
if (strcmp (name, BLANK_COMMON_NAME) == 0)
return get_identifier (name);
if (decl == NULL_TREE)
{
decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
+ SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
void
gfc_conv_constant (gfc_se * se, gfc_expr * expr)
{
+ /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
+ so, they expr_type will not yet be an EXPR_CONSTANT. We need to make
+ it so here. */
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived
+ && expr->ts.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Create a new EXPR_CONSTANT expression for our local uses. */
+ expr = gfc_int_expr (0);
+ }
+ }
+
gcc_assert (expr->expr_type == EXPR_CONSTANT);
if (se->ss != NULL)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ /* Prevent the mangling of identifiers that have an assigned
+ binding label (mainly those that are bind(c)). */
+ if (sym->attr.is_bind_c == 1
+ && sym->binding_label[0] != '\0')
+ return get_identifier(sym->binding_label);
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ /* It may be possible to simply use the binding label if it's
+ provided, and remove the other checks. Then we could use it
+ for other things if we wished. */
+ if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
+ sym->binding_label[0] != '\0')
+ /* use the binding label rather than the mangled name */
+ return get_identifier (sym->binding_label);
+
if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
if (sym->attr.cray_pointee)
return;
+ if(sym->attr.is_bind_c == 1)
+ {
+ /* We need to put variables that are bind(c) into the common
+ segment of the object file, because this is what C would do.
+ gfortran would typically put them in either the BSS or
+ initialized data segments, and only mark them as common if
+ they were part of common blocks. However, if they are not put
+ into common space, then C cannot initialize global fortran
+ variables that it interoperates with and the draft says that
+ either Fortran or C should be able to initialize it (but not
+ both, of course.) (J3/04-007, section 15.3). */
+ TREE_PUBLIC(decl) = 1;
+ DECL_COMMON(decl) = 1;
+ }
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
if (sym->attr.entry)
return;
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
}
+/* Set up the tree type for the given symbol to allow the dummy
+ variable (parameter) to be passed by-value. To do this, the main
+ idea is to simply remove the extra layer added by Fortran
+ automatically (the POINTER_TYPE node). This pointer type node
+ would normally just contain the real type underneath, but we remove
+ it here and later we change the way the argument is converted for a
+ function call (trans-expr.c:gfc_conv_function_call). This is the
+ approach the C compiler takes (or it appears to be this way). When
+ the middle-end is given the typed node rather than the POINTER_TYPE
+ node, it knows to pass the value. */
+
+static void
+set_tree_decl_type_code (gfc_symbol *sym)
+{
+ /* This should not happen. during the gfc_sym_type function,
+ when the backend_decl is being built for a dummy arg, if the arg
+ is pass-by-value then no reference type is wrapped around the
+ true type (e.g., REAL_TYPE). */
+ if (TREE_CODE (TREE_TYPE (sym->backend_decl)) == POINTER_TYPE ||
+ TREE_CODE (TREE_TYPE (sym->backend_decl)) == REFERENCE_TYPE)
+ TREE_TYPE (sym->backend_decl) = gfc_typenode_for_spec (&sym->ts);
+ DECL_BY_REFERENCE (sym->backend_decl) = 0;
+
+ /* the tree can't be addressable if it's pass-by-value..? x*/
+/* TREE_TYPE(sym->backend_decl)->common.addressable_flag = 0; */
+
+ DECL_ARG_TYPE (sym->backend_decl) = TREE_TYPE (sym->backend_decl);
+
+ DECL_MODE (sym->backend_decl) =
+ TYPE_MODE (TREE_TYPE (sym->backend_decl));
+
+ return;
+}
+
+
/* Drill down through expressions for the array specification bounds and
character length calling generate_local_decl for all those variables
that have not already been declared. */
gfc_get_symbol_decl (sym);
}
}
+
+ if (sym->attr.dummy == 1)
+ {
+ /* The sym->backend_decl can be NULL if this is one of the
+ intrinsic types, such as the symbol of type c_ptr for the
+ c_f_pointer function, so don't set up the tree code for it. */
+ if (sym->attr.value == 1 && sym->backend_decl != NULL)
+ set_tree_decl_type_code (sym);
+ }
+
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
}
static void
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
- {
- parm_kind = SCALAR;
+ {
if (fsym && fsym->attr.value)
{
gfc_conv_expr (&parmse, e);
if (!(expr || pointer))
return NULL_TREE;
+ if (expr != NULL && expr->ts.type == BT_DERIVED
+ && expr->ts.is_iso_c && expr->ts.derived
+ && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
+ expr = gfc_int_expr (0);
+
if (array)
{
/* Arrays need special handling. */
return;
}
+ /* We need to convert the expressions for the iso_c_binding derived types.
+ C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
+ 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.derived
+ && expr->ts.derived->attr.is_iso_c)
+ {
+ if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
+ {
+ /* Set expr_type to EXPR_NULL, which will result in
+ null_pointer_node being used below. */
+ expr->expr_type = EXPR_NULL;
+ }
+ else
+ {
+ /* 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.derived->ts.type;
+ expr->ts.f90_type = expr->ts.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.derived->ts.kind;
+ }
+ }
+
switch (expr->expr_type)
{
case EXPR_OP:
gfc_component *c;
int kind;
+ /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
+ the user says something like: print *, 'c_null_ptr: ', c_null_ptr
+ We need to translate the expression to a constant if it's either
+ C_NULL_PTR or C_NULL_FUNPTR. */
+ if (ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+ {
+ ts->type = ts->derived->ts.type;
+ ts->kind = ts->derived->ts.kind;
+ ts->f90_type = ts->derived->ts.f90_type;
+ }
+
kind = ts->kind;
function = NULL;
arg2 = NULL;
#include "system.h"
#include "coretypes.h"
#include "tree.h"
+#include "langhooks.h"
#include "tm.h"
#include "target.h"
#include "ggc.h"
#error If you really need >99 dimensions, continue the sequence above...
#endif
+/* array of structs so we don't have to worry about xmalloc or free */
+CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
+
static tree gfc_get_derived_type (gfc_symbol * derived);
tree gfc_array_index_type;
int gfc_numeric_storage_size;
int gfc_character_storage_size;
+
+/* Validate that the f90_type of the given gfc_typespec is valid for
+ the type it represents. The f90_type represents the Fortran types
+ this C kind can be used with. For example, c_int has a f90_type of
+ BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
+ if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
+ they match. */
+
+try
+gfc_validate_c_kind (gfc_typespec *ts)
+{
+ return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
+}
+
+
+try
+gfc_check_any_c_kind (gfc_typespec *ts)
+{
+ int i;
+
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ /* Check for any C interoperable kind for the given type/kind in ts.
+ This can be used after verify_c_interop to make sure that the
+ Fortran kind being used exists in at least some form for C. */
+ if (c_interop_kinds_table[i].f90_type == ts->type &&
+ c_interop_kinds_table[i].value == ts->kind)
+ return SUCCESS;
+ }
+
+ return FAILURE;
+}
+
+
+static int
+get_real_kind_from_node (tree type)
+{
+ int i;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
+ return gfc_real_kinds[i].kind;
+
+ return -4;
+}
+
+static int
+get_int_kind_from_node (tree type)
+{
+ int i;
+
+ if (!type)
+ return -2;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
+ return gfc_integer_kinds[i].kind;
+
+ return -1;
+}
+
+static int
+get_int_kind_from_width (int size)
+{
+ int i;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ return -2;
+}
+
+static int
+get_int_kind_from_minimal_width (int size)
+{
+ int i;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size >= size)
+ return gfc_integer_kinds[i].kind;
+
+ return -2;
+}
+
+
+/* Generate the CInteropKind_t objects for the C interoperable
+ kinds. */
+
+static
+void init_c_interop_kinds (void)
+{
+ int i;
+ tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
+ integer_type_node :
+ (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
+ long_integer_type_node :
+ long_long_integer_type_node);
+
+ /* init all pointers in the list to NULL */
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ /* Initialize the name and value fields. */
+ c_interop_kinds_table[i].name[0] = '\0';
+ c_interop_kinds_table[i].value = -100;
+ c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
+ }
+
+#define NAMED_INTCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_INTEGER; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_REALCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_REAL; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_CMPXCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_LOGCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_CHARKNDCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_CHARCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+ c_interop_kinds_table[a].value = c;
+#define DERIVED_TYPE(a,b,c) \
+ 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) \
+ 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"
+}
+
+
/* Query the target to determine which machine modes are available for
computation. Choose KIND numbers for them. */
gfc_index_integer_kind = POINTER_SIZE / 8;
/* Pick a kind the same size as the C "int" type. */
gfc_c_int_kind = INT_TYPE_SIZE / 8;
+
+ /* initialize the C interoperable kinds */
+ init_c_interop_kinds();
}
/* Make sure that a valid kind is present. Returns an index into the
gcc_unreachable ();
case BT_INTEGER:
- basetype = gfc_get_int_type (spec->kind);
+ /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
+ has been resolved. This is done so we can convert C_PTR and
+ C_FUNPTR to simple variables that get translated to (void *). */
+ if (spec->f90_type == BT_VOID)
+ basetype = ptr_type_node;
+ else
+ basetype = gfc_get_int_type (spec->kind);
break;
case BT_REAL:
case BT_DERIVED:
basetype = gfc_get_derived_type (spec->derived);
- break;
+ /* If we're dealing with either C_PTR or C_FUNPTR, we modified the
+ 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->derived->attr.is_iso_c)
+ {
+ spec->type = spec->derived->ts.type;
+ spec->kind = spec->derived->ts.kind;
+ spec->f90_type = spec->derived->ts.f90_type;
+ }
+ break;
+ case BT_VOID:
+ /* This is for the second arg to c_f_pointer and c_f_procpointer
+ of the iso_c_binding module, to accept any ptr type. */
+ basetype = ptr_type_node;
+ break;
default:
gcc_unreachable ();
}
}
}
else
+ {
type = gfc_build_array_type (type, sym->as);
}
+ }
else
{
if (sym->attr.allocatable || sym->attr.pointer)
static tree
gfc_get_derived_type (gfc_symbol * derived)
{
- tree typenode, field, field_type, fieldlist;
+ tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
gfc_component *c;
gfc_dt_list *dt;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
+ /* See if it's one of the iso_c_binding derived types. */
+ if (derived->attr.is_iso_c == 1)
+ {
+ derived->backend_decl = ptr_type_node;
+ derived->ts.kind = gfc_index_integer_kind;
+ derived->ts.type = BT_INTEGER;
+ /* Set the f90_type to BT_VOID as a way to recognize something of type
+ BT_INTEGER that needs to fit a void * for the purpose of the
+ iso_c_binding derived types. */
+ derived->ts.f90_type = BT_VOID;
+ return derived->backend_decl;
+ }
+
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
if (!c->pointer || c->ts.derived->backend_decl == NULL)
c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+
+ if (c->ts.derived && c->ts.derived->attr.is_iso_c)
+ {
+ /* Need to copy the modified ts from the derived type. The
+ typespec was modified because C_PTR/C_FUNPTR are translated
+ into (void *) from derived types. */
+ c->ts.type = c->ts.derived->ts.type;
+ c->ts.kind = c->ts.derived->ts.kind;
+ c->ts.f90_type = c->ts.derived->ts.f90_type;
+ }
}
if (TYPE_FIELDS (derived->backend_decl))
+2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
+
+ * bind_c_array_params.f03: New files for Fortran 2003 ISO C Binding.
+ * bind_c_coms.f90: Ditto.
+ * bind_c_coms_driver.c: Ditto.
+ * bind_c_dts.f90: Ditto.
+ * bind_c_dts_2.f03: Ditto.
+ * bind_c_dts_2_driver.c: Ditto.
+ * bind_c_dts_3.f03: Ditto.
+ * bind_c_dts_4.f03: Ditto.
+ * bind_c_dts_driver.c: Ditto.
+ * bind_c_implicit_vars.f03: Ditto.
+ * bind_c_procs.f03: Ditto.
+ * bind_c_usage_2.f03: Ditto.
+ * bind_c_usage_3.f03: Ditto.
+ * bind_c_usage_5.f03: Ditto.
+ * bind_c_usage_6.f03: Ditto.
+ * bind_c_usage_7.f03: Ditto.
+ * bind_c_vars.f90: Ditto.
+ * bind_c_vars_driver.c: Ditto.
+ * binding_c_table_15_1.f03: Ditto.
+ * binding_label_tests.f03: Ditto.
+ * binding_label_tests_10.f03: Ditto.
+ * binding_label_tests_10_main.f03: Ditto.
+ * binding_label_tests_11.f03: Ditto.
+ * binding_label_tests_11_main.f03: Ditto.
+ * binding_label_tests_12.f03: Ditto.
+ * binding_label_tests_13.f03: Ditto.
+ * binding_label_tests_13_main.f03: Ditto.
+ * binding_label_tests_14.f03: Ditto.
+ * binding_label_tests_2.f03: Ditto.
+ * binding_label_tests_3.f03: Ditto.
+ * binding_label_tests_4.f03: Ditto.
+ * binding_label_tests_5.f03: Ditto.
+ * binding_label_tests_6.f03: Ditto.
+ * binding_label_tests_7.f03: Ditto.
+ * binding_label_tests_8.f03: Ditto.
+ * binding_label_tests_9.f03: Ditto.
+ * c_assoc.f90: Ditto.
+ * c_assoc_2.f03: Ditto.
+ * c_f_pointer_shape_test.f90: Ditto.
+ * c_f_pointer_tests.f90: Ditto.
+ * c_f_tests_driver.c: Ditto.
+ * c_funloc_tests.f03: Ditto.
+ * c_funloc_tests_2.f03: Ditto.
+ * c_funloc_tests_3.f03: Ditto.
+ * c_funloc_tests_3_funcs.c: Ditto.
+ * c_kind_params.f90: Ditto.
+ * c_kind_tests_2.f03: Ditto.
+ * c_kinds.c: Ditto.
+ * c_loc_driver.c: Ditto.
+ * c_loc_test.f90: Ditto.
+ * c_loc_tests_2.f03: Ditto.
+ * c_loc_tests_2_funcs.c: Ditto.
+ * c_loc_tests_3.f03: Ditto.
+ * c_loc_tests_4.f03: Ditto.
+ * c_loc_tests_5.f03: Ditto.
+ * c_loc_tests_6.f03: Ditto.
+ * c_loc_tests_7.f03: Ditto.
+ * c_loc_tests_8.f03: Ditto.
+ * c_ptr_tests.f03: Ditto.
+ * c_ptr_tests_10.f03: Ditto.
+ * c_ptr_tests_5.f03: Ditto.
+ * c_ptr_tests_7.f03: Ditto.
+ * c_ptr_tests_7_driver.c: Ditto.
+ * c_ptr_tests_8.f03: Ditto.
+ * c_ptr_tests_8_funcs.c: Ditto.
+ * c_ptr_tests_9.f03: Ditto.
+ * c_ptr_tests_driver.c: Ditto.
+ * c_size_t_driver.c: Ditto.
+ * c_size_t_test.f03: Ditto.
+ * com_block_driver.f90: Ditto.
+ * global_vars_c_init.f90: Ditto.
+ * global_vars_c_init_driver.c: Ditto.
+ * global_vars_f90_init.f90: Ditto.
+ * global_vars_f90_init_driver.c: Ditto.
+ * interop_params.f03: Ditto.
+ * iso_c_binding_only.f03: Ditto.
+ * iso_c_binding_rename_1.f03: Ditto.
+ * iso_c_binding_rename_1_driver.c: Ditto.
+ * iso_c_binding_rename_2.f03: Ditto.
+ * iso_c_binding_rename_2_driver.c: Ditto.
+ * kind_tests_2.f03: Ditto.
+ * kind_tests_3.f03: Ditto.
+ * module_md5_1.f90: Ditto.
+ * only_clause_main.c: Ditto.
+ * print_c_kinds.f90: Ditto.
+ * test_bind_c_parens.f03: Ditto.
+ * test_c_assoc.c: Ditto.
+ * test_com_block.f90: Ditto.
+ * test_common_binding_labels.f03: Ditto.
+ * test_common_binding_labels_2.f03: Ditto.
+ * test_common_binding_labels_2_main.f03: Ditto.
+ * test_common_binding_labels_3.f03: Ditto.
+ * test_common_binding_labels_3_main.f03: Ditto.
+ * test_only_clause.f90: Ditto.
+ * use_iso_c_binding.f90: Ditto.
+ * value_5.f90: Ditto.
+ * value_test.f90: Ditto.
+ * value_tests_f03.f90: Ditto.
+
2007-07-01 Daniel Jacobowitz <dan@codesourcery.com>
* gcc.dg/tls/opt-14.c: New.
--- /dev/null
+! { dg-do compile }
+module bind_c_array_params
+use, intrinsic :: iso_c_binding
+implicit none
+
+contains
+ subroutine sub0(assumed_array) bind(c) ! { dg-error "cannot be an argument" }
+ integer(c_int), dimension(:) :: assumed_array
+ end subroutine sub0
+
+ subroutine sub1(deferred_array) bind(c) ! { dg-error "cannot" }
+ integer(c_int), pointer :: deferred_array(:)
+ end subroutine sub1
+end module bind_c_array_params
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources bind_c_coms_driver.c }
+! { dg-options "-w" }
+! the -w option is to prevent the warning about long long ints
+module bind_c_coms
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ common /COM/ R, S
+ real(c_double) :: r
+ real(c_double) :: t
+ real(c_double) :: s
+ bind(c) :: /COM/, /SINGLE/, /MYCOM/
+ common /SINGLE/ T
+ common /MYCOM/ LONG_INTS
+ integer(c_long) :: LONG_INTS
+ common /MYCOM2/ LONG_LONG_INTS
+ integer(c_long_long) :: long_long_ints
+ bind(c) :: /mycom2/
+
+ common /com2/ i, j
+ integer(c_int) :: i, j
+ bind(c, name="f03_com2") /com2/
+
+ common /com3/ m, n
+ integer(c_int) :: m, n
+ bind(c, name="") /com3/
+
+contains
+ subroutine test_coms() bind(c)
+ r = r + .1d0;
+ s = s + .1d0;
+ t = t + .1d0;
+ long_ints = long_ints + 1
+ long_long_ints = long_long_ints + 1
+ i = i + 1
+ j = j + 1
+
+ m = 1
+ n = 1
+ end subroutine test_coms
+end module bind_c_coms
+
+module bind_c_coms_2
+ use, intrinsic :: iso_c_binding, only: c_int
+ common /com3/ m, n
+ integer(c_int) :: m, n
+ bind(c, name="") /com3/
+end module bind_c_coms_2
+
+! { dg-final { cleanup-modules "bind_c_coms bind_c_coms_2" } }
--- /dev/null
+double fabs(double);
+
+void test_coms(void);
+
+extern void abort(void);
+
+struct {double r, s; } com; /* refers to the common block "com" */
+double single; /* refers to the common block "single" */
+long int mycom; /* refers to the common block "MYCOM" */
+long long int mycom2; /* refers to the common block "MYCOM2" */
+struct {int i, j; } f03_com2; /* refers to the common block "com2" */
+
+int main(int argc, char **argv)
+{
+ com.r = 1.0;
+ com.s = 2.0;
+ single = 1.0;
+ mycom = 1;
+ mycom2 = 2;
+ f03_com2.i = 1;
+ f03_com2.j = 2;
+
+ /* change the common block variables in F90 */
+ test_coms();
+
+ if(fabs(com.r - 1.1) > 0.00000000)
+ abort();
+ if(fabs(com.s - 2.1) > 0.00000000)
+ abort();
+ if(fabs(single - 1.1) > 0.00000000)
+ abort();
+ if(mycom != 2)
+ abort();
+ if(mycom2 != 3)
+ abort();
+ if(f03_com2.i != 2)
+ abort();
+ if(f03_com2.j != 3)
+ abort();
+
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources bind_c_dts_driver.c }
+module bind_c_dts
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ type, bind(c) :: MYFTYPE_1
+ integer(c_int) :: i, j
+ real(c_float) :: s
+ end type MYFTYPE_1
+
+ TYPE, BIND(C) :: particle
+ REAL(C_DOUBLE) :: x,vx
+ REAL(C_DOUBLE) :: y,vy
+ REAL(C_DOUBLE) :: z,vz
+ REAL(C_DOUBLE) :: m
+ END TYPE particle
+
+ type(myftype_1), bind(c, name="myDerived") :: myDerived
+
+contains
+ subroutine types_test(my_particles, num_particles) bind(c)
+ integer(c_int), value :: num_particles
+ type(particle), dimension(num_particles) :: my_particles
+ integer :: i
+
+ ! going to set the particle in the middle of the list
+ i = num_particles / 2;
+ my_particles(i)%x = my_particles(i)%x + .2d0
+ my_particles(i)%vx = my_particles(i)%vx + .2d0
+ my_particles(i)%y = my_particles(i)%y + .2d0
+ my_particles(i)%vy = my_particles(i)%vy + .2d0
+ my_particles(i)%z = my_particles(i)%z + .2d0
+ my_particles(i)%vz = my_particles(i)%vz + .2d0
+ my_particles(i)%m = my_particles(i)%m + .2d0
+
+ myDerived%i = myDerived%i + 1
+ myDerived%j = myDerived%j + 1
+ myDerived%s = myDerived%s + 1.0;
+ end subroutine types_test
+end module bind_c_dts
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources bind_c_dts_2_driver.c }
+module bind_c_dts_2
+use, intrinsic :: iso_c_binding
+implicit none
+
+type, bind(c) :: my_c_type_0
+ integer(c_int) :: i
+ type(c_ptr) :: nested_c_address
+ integer(c_int) :: array(3)
+end type my_c_type_0
+
+type, bind(c) :: my_c_type_1
+ type(my_c_type_0) :: my_nested_type
+ type(c_ptr) :: c_address
+ integer(c_int) :: j
+end type my_c_type_1
+
+contains
+ subroutine sub0(my_type, expected_i, expected_nested_c_address, &
+ expected_array_1, expected_array_2, expected_array_3, &
+ expected_c_address, expected_j) bind(c)
+ type(my_c_type_1) :: my_type
+ integer(c_int), value :: expected_i
+ type(c_ptr), value :: expected_nested_c_address
+ integer(c_int), value :: expected_array_1
+ integer(c_int), value :: expected_array_2
+ integer(c_int), value :: expected_array_3
+ type(c_ptr), value :: expected_c_address
+ integer(c_int), value :: expected_j
+
+ if (my_type%my_nested_type%i .ne. expected_i) then
+ call abort ()
+ end if
+
+ if (.not. c_associated(my_type%my_nested_type%nested_c_address, &
+ expected_nested_c_address)) then
+ call abort ()
+ end if
+
+ if (my_type%my_nested_type%array(1) .ne. expected_array_1) then
+ call abort ()
+ end if
+
+ if (my_type%my_nested_type%array(2) .ne. expected_array_2) then
+ call abort ()
+ end if
+
+ if (my_type%my_nested_type%array(3) .ne. expected_array_3) then
+ call abort ()
+ end if
+
+ if (.not. c_associated(my_type%c_address, expected_c_address)) then
+ call abort ()
+ end if
+
+ if (my_type%j .ne. expected_j) then
+ call abort ()
+ end if
+ end subroutine sub0
+end module bind_c_dts_2
--- /dev/null
+typedef struct c_type_0
+{
+ int i;
+ int *ptr;
+ int array[3];
+}c_type_0_t;
+
+typedef struct c_type_1
+{
+ c_type_0_t nested_type;
+ int *ptr;
+ int j;
+}c_type_1_t;
+
+void sub0(c_type_1_t *c_type, int expected_i, int *expected_nested_ptr,
+ int array_0, int array_1, int array_2,
+ int *expected_ptr, int expected_j);
+
+int main(int argc, char **argv)
+{
+ c_type_1_t c_type;
+
+ c_type.nested_type.i = 10;
+ c_type.nested_type.ptr = &(c_type.nested_type.i);
+ c_type.nested_type.array[0] = 1;
+ c_type.nested_type.array[1] = 2;
+ c_type.nested_type.array[2] = 3;
+ c_type.ptr = &(c_type.j);
+ c_type.j = 11;
+
+ sub0(&c_type, c_type.nested_type.i, c_type.nested_type.ptr,
+ c_type.nested_type.array[0],
+ c_type.nested_type.array[1], c_type.nested_type.array[2],
+ c_type.ptr, c_type.j);
+
+ return 0;
+}
--- /dev/null
+! { dg-do compile }
+module bind_c_dts_3
+use, intrinsic :: iso_c_binding
+implicit none
+
+TYPE, bind(c) :: t
+ integer(c_int) :: i
+end type t
+
+type :: my_c_type_0 ! { dg-error "must have the BIND attribute" }
+ integer(c_int) :: i
+end type my_c_type_0
+
+type, bind(c) :: my_c_type_1 ! { dg-error "BIND.C. derived type" }
+ type(my_c_type_0) :: my_nested_type
+ type(c_ptr) :: c_address
+ integer(c_int), pointer :: j ! { dg-error "cannot have the POINTER" }
+end type my_c_type_1
+
+type, bind(c) :: t2 ! { dg-error "BIND.C. derived type" }
+ type (t2), pointer :: next ! { dg-error "cannot have the POINTER" }
+end type t2
+
+type, bind(c):: t3 ! { dg-error "BIND.C. derived type" }
+ type(t), allocatable :: c(:) ! { dg-error "cannot have the ALLOCATABLE" }
+end type t3
+
+contains
+ subroutine sub0(my_type, expected_value) bind(c) ! { dg-error "is not C interoperable" }
+ type(my_c_type_1) :: my_type
+ integer(c_int), value :: expected_value
+
+ if (my_type%my_nested_type%i .ne. expected_value) then
+ call abort ()
+ end if
+ end subroutine sub0
+end module bind_c_dts_3
+
+! { dg-final { cleanup-modules "bind_c_dts_3" } }
--- /dev/null
+! { dg-do compile }
+module test
+use iso_c_binding, only: c_int
+ type, bind(c) :: foo
+ integer :: p ! { dg-warning "may not be C interoperable" }
+ end type
+ type(foo), bind(c) :: cp
+end module test
+
+! { dg-final { cleanup-modules "test" } }
--- /dev/null
+double fabs (double);
+
+/* interops with myftype_1 */
+typedef struct {
+ int m, n;
+ float r;
+} myctype_t;
+
+/* interops with particle in f90 */
+typedef struct particle
+{
+ double x; /* x position */
+ double vx; /* velocity in x direction */
+ double y; /* y position */
+ double vy; /* velocity in y direction */
+ double z; /* z position */
+ double vz; /* velocity in z direction */
+ double m; /* mass */
+}particle_t;
+
+extern void abort(void);
+void types_test(particle_t *my_particles, int num_particles);
+/* declared in the fortran module bind_c_dts */
+extern myctype_t myDerived;
+
+int main(int argc, char **argv)
+{
+ particle_t my_particles[100];
+
+ /* the fortran code will modify the middle particle */
+ my_particles[49].x = 1.0;
+ my_particles[49].vx = 1.0;
+ my_particles[49].y = 1.0;
+ my_particles[49].vy = 1.0;
+ my_particles[49].z = 1.0;
+ my_particles[49].vz = 1.0;
+ my_particles[49].m = 1.0;
+
+ myDerived.m = 1;
+ myDerived.n = 2;
+ myDerived.r = 3.0;
+
+ types_test(&(my_particles[0]), 100);
+
+ if(fabs(my_particles[49].x - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].vx - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].y - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].vy - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].z - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].vz - 1.2) > 0.00000000)
+ abort();
+ if(fabs(my_particles[49].m - 1.2) > 0.00000000)
+ abort();
+ if(myDerived.m != 2)
+ abort();
+ if(myDerived.n != 3)
+ abort();
+ if(fabs(myDerived.r - 4.0) > 0.00000000)
+ abort();
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do compile }
+module bind_c_implicit_vars
+
+bind(c) :: j ! { dg-warning "may not be C interoperable" }
+
+contains
+ subroutine sub0(i) bind(c) ! { dg-warning "may not be C interoperable" }
+ i = 0
+ end subroutine sub0
+end module bind_c_implicit_vars
--- /dev/null
+! { dg-do compile }
+module bind_c_procs
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ interface
+ ! warning for my_param possibly not being C interoperable
+ subroutine my_c_sub(my_param) bind(c) ! { dg-warning "may not be C interoperable" }
+ integer, value :: my_param
+ end subroutine my_c_sub
+
+ ! warning for my_c_func possibly not being a C interoperable kind
+ ! warning for my_param possibly not being C interoperable
+ ! error message truncated to provide an expression that both warnings
+ ! should match.
+ function my_c_func(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ integer :: my_c_func
+ end function my_c_func
+ end interface
+
+contains
+ ! warning for my_param possibly not being C interoperable
+ subroutine my_f03_sub(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ end subroutine my_f03_sub
+
+ ! warning for my_f03_func possibly not being a C interoperable kind
+ ! warning for my_param possibly not being C interoperable
+ ! error message truncated to provide an expression that both warnings
+ ! should match.
+ function my_f03_func(my_param) bind(c) ! { dg-warning "may not be" }
+ integer, value :: my_param
+ integer :: my_f03_func
+ my_f03_func = 1
+ end function my_f03_func
+
+end module bind_c_procs
+
+! { dg-final { cleanup-modules "bind_c_procs" } }
--- /dev/null
+! { dg-do compile }
+use, intrinsic :: iso_c_binding
+type, bind(c) :: mytype
+ integer(c_int) :: j
+end type mytype
+
+type(mytype), bind(c) :: mytype_var ! { dg-error "cannot be BIND.C." }
+
+integer(c_int), bind(c) :: i ! { dg-error "cannot be declared with BIND.C." }
+integer(c_int), bind(c), dimension(10) :: my_array ! { dg-error "cannot be BIND.C." }
+
+common /COM/ i
+bind(c) :: /com/
+
+end
--- /dev/null
+! { dg-do compile }
+module test
+ use, intrinsic :: iso_c_binding
+
+ type, bind(c) :: my_c_type ! { dg-error "BIND.C. derived type" }
+ integer(c_int), pointer :: ptr ! { dg-error "cannot have the POINTER attribute" }
+ end type my_c_type
+
+ type, bind(c) :: my_type ! { dg-error "BIND.C. derived type" }
+ integer(c_int), allocatable :: ptr(:) ! { dg-error "cannot have the ALLOCATABLE attribute" }
+ end type my_type
+
+ type foo ! { dg-error "must have the BIND attribute" }
+ integer(c_int) :: p
+ end type foo
+
+ type(foo), bind(c) :: cp ! { dg-error "is not C interoperable" }
+ real(c_double), pointer,bind(c) :: p ! { dg-error "cannot have both the POINTER and BIND.C." }
+end module test
--- /dev/null
+! { dg-do compile }
+module bind_c_usage_5
+use, intrinsic :: iso_c_binding
+
+bind(c) c3, c4
+integer(c_int), bind(c) :: c3 ! { dg-error "Duplicate BIND attribute" }
+integer(c_int) :: c4
+end module bind_c_usage_5
--- /dev/null
+! { dg-do compile }
+module x
+ use iso_c_binding
+ bind(c) :: test, sub1 ! { dg-error "only be used for variables or common blocks" }
+ bind(c) :: sub2 ! { dg-error "only be used for variables or common blocks" }
+contains
+ function foo() bind(c,name="xx")
+ integer(c_int),bind(c,name="xy") :: foo ! { dg-error "only be used for variables or common blocks" }
+ ! NAG f95: "BIND(C) for non-variable FOO"
+ ! g95: "Duplicate BIND attribute specified"
+ ! gfortran: Accepted
+ foo = 5_c_int
+ end function foo
+
+ function test()
+ integer(c_int) :: test
+ bind(c,name="kk") :: test ! { dg-error "only be used for variables or common blocks" }
+ ! NAG f95: "BIND(C) for non-variable TEST"
+ ! gfortran, g95: Accepted
+ test = 5_c_int
+ end function test
+
+ function bar() bind(c)
+ integer(c_int) :: bar
+ bind(c,name="zx") :: bar ! { dg-error "only be used for variables or common blocks" }
+ bar = 5_c_int
+ end function bar
+
+ subroutine sub0() bind(c)
+ bind(c) :: sub0 ! { dg-error "only be used for variables or common blocks" }
+ end subroutine sub0
+
+ subroutine sub1(i) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), value :: i
+ end subroutine sub1
+
+ subroutine sub2(i)
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), value :: i
+ end subroutine sub2
+
+ subroutine sub3(i)
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), value :: i
+ bind(c) :: sub3 ! { dg-error "only be used for variables or common blocks" }
+ end subroutine sub3
+end module x
--- /dev/null
+! { dg-do compile }
+module x
+ use iso_c_binding
+ implicit none
+contains
+ function bar() bind(c) ! { dg-error "cannot be an array" }
+ integer(c_int) :: bar(5)
+ end function bar
+
+ function my_string_func() bind(c) ! { dg-error "cannot be a character string" }
+ character(kind=c_char, len=10) :: my_string_func
+ my_string_func = 'my_string' // C_NULL_CHAR
+ end function my_string_func
+end module x
+
+! { dg-final { cleanup-modules "x" } }
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources bind_c_vars_driver.c }
+module bind_c_vars
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ integer(c_int), bind(c) :: myF90Int
+ real(c_float), bind(c, name="myF90Real") :: f90_real
+ integer(c_int) :: c2
+ integer(c_int) :: c3
+ integer(c_int) :: c4
+ bind(c, name="myVariable") :: c2
+ bind(c) c3, c4
+
+ integer(c_int), bind(c, name="myF90Array3D") :: A(18, 3:7, 10)
+ integer(c_int), bind(c, name="myF90Array2D") :: B(3, 2)
+
+contains
+
+ subroutine changeF90Globals() bind(c, name='changeF90Globals')
+ implicit none
+ ! should make it 2
+ myF90Int = myF90Int + 1
+ ! should make it 3.0
+ f90_real = f90_real * 3.0;
+ ! should make it 4
+ c2 = c2 * 2;
+ ! should make it 6
+ c3 = c3 + 3;
+ ! should make it 2
+ c4 = c4 / 2;
+ ! should make it 2
+ A(5, 6, 3) = A(5, 6, 3) + 1
+ ! should make it 3
+ B(3, 2) = B(3, 2) + 1
+ end subroutine changeF90Globals
+
+end module bind_c_vars
--- /dev/null
+double fabs (double);
+
+/* defined in fortran module bind_c_vars */
+void changeF90Globals(void);
+
+extern void abort(void);
+
+/* module level scope in bind_c_vars */
+extern int myf90int; /* myf90int in bind_c_vars */
+float myF90Real; /* f90_real in bind_c_vars */
+int myF90Array3D[10][5][18]; /* A in bind_c_vars */
+int myF90Array2D[2][3]; /* B in bind_c_vars */
+int myVariable; /* c2 in bind_c_vars */
+int c3; /* c3 in bind_c_vars */
+int c4; /* c4 in bind_c_vars */
+
+int main(int argc, char **argv)
+{
+ myf90int = 1;
+ myF90Real = 1.0;
+ myVariable = 2;
+ c3 = 3;
+ c4 = 4;
+ myF90Array3D[2][3][4] = 1;
+ myF90Array2D[1][2] = 2;
+
+ /* will change the global vars initialized above */
+ changeF90Globals();
+
+ if(myf90int != 2)
+ abort();
+ if(fabs(myF90Real-3.0) > 0.00000000)
+ abort();
+ if(myVariable != 4)
+ abort();
+ if(c3 != 6)
+ abort();
+ if(c4 != 2)
+ abort();
+ if(myF90Array3D[2][3][4] != 2)
+ abort();
+ if(myF90Array2D[1][2] != 3)
+ abort();
+
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do run }
+! Test the named constants in Table 15.1.
+program a
+ use, intrinsic :: iso_c_binding
+ implicit none
+ if (C_NULL_CHAR /= CHAR(0) ) call abort
+ if (C_ALERT /= ACHAR(7) ) call abort
+ if (C_BACKSPACE /= ACHAR(8) ) call abort
+ if (C_FORM_FEED /= ACHAR(12)) call abort
+ if (C_NEW_LINE /= ACHAR(10)) call abort
+ if (C_CARRIAGE_RETURN /= ACHAR(13)) call abort
+ if (C_HORIZONTAL_TAB /= ACHAR(9) ) call abort
+ if (C_VERTICAL_TAB /= ACHAR(11)) call abort
+end program a
--- /dev/null
+! { dg-do compile }
+module binding_label_tests
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ contains
+
+ subroutine c_sub() BIND(c, name = "C_Sub")
+ print *, 'hello from c_sub'
+ end subroutine c_sub
+
+ integer(c_int) function c_func() bind(C, name="__C_funC")
+ print *, 'hello from c_func'
+ c_func = 1
+ end function c_func
+
+ real(c_float) function f90_func()
+ print *, 'hello from f90_func'
+ f90_func = 1.0
+ end function f90_func
+
+ real(c_float) function c_real_func() bind(c)
+ print *, 'hello from c_real_func'
+ c_real_func = 1.5
+ end function c_real_func
+
+ integer function f90_func_0() result ( f90_func_0_result )
+ print *, 'hello from f90_func_0'
+ f90_func_0_result = 0
+ end function f90_func_0
+
+ integer(c_int) function f90_func_1() result ( f90_func_1_result ) bind(c, name="__F90_Func_1__")
+ print *, 'hello from f90_func_1'
+ f90_func_1_result = 1
+ end function f90_func_1
+
+ integer(c_int) function f90_func_3() result ( f90_func_3_result ) bind(c)
+ print *, 'hello from f90_func_3'
+ f90_func_3_result = 3
+ end function f90_func_3
+
+ integer(c_int) function F90_func_2() bind(c) result ( f90_func_2_result )
+ print *, 'hello from f90_func_2'
+ f90_func_2_result = 2
+ end function f90_func_2
+
+ integer(c_int) function F90_func_4() bind(c, name="F90_func_4") result ( f90_func_4_result )
+ print *, 'hello from f90_func_4'
+ f90_func_4_result = 4
+ end function f90_func_4
+
+ integer(c_int) function F90_func_5() bind(c, name="F90_func_5") result ( f90_func_5_result )
+ print *, 'hello from f90_func_5'
+ f90_func_5_result = 5
+ end function f90_func_5
+
+ subroutine c_sub_2() bind(c, name='c_sub_2')
+ print *, 'hello from c_sub_2'
+ end subroutine c_sub_2
+
+ subroutine c_sub_3() BIND(c, name = " C_Sub_3 ")
+ print *, 'hello from c_sub_3'
+ end subroutine c_sub_3
+
+ subroutine c_sub_5() BIND(c, name = "C_Sub_5 ")
+ print *, 'hello from c_sub_5'
+ end subroutine c_sub_5
+
+ ! nothing between the quotes except spaces, so name="".
+ ! the name will get set to the regularly mangled version of the name.
+ ! perhaps it should be marked with some characters that are invalid for
+ ! C names so C can not call it?
+ subroutine sub4() BIND(c, name = " ")
+ end subroutine sub4
+end module binding_label_tests
+
+! { dg-final { cleanup-modules "binding_label_tests" } }
--- /dev/null
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_10_main.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_10
+ use iso_c_binding
+ implicit none
+ integer(c_int), bind(c,name="c_one") :: one
+end module binding_label_tests_10
+
+! Do not use dg-final to cleanup-modules
--- /dev/null
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_10.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_10_main
+ use iso_c_binding
+ implicit none
+ integer(c_int), bind(c,name="c_one") :: one ! { dg-error "collides" }
+end module binding_label_tests_10_main
+
+program main
+ use binding_label_tests_10 ! { dg-error "collides" }
+ use binding_label_tests_10_main
+end program main
+
+! { dg-final { cleanup-modules "binding_label_tests_10_main binding_label_tests_10" } }
--- /dev/null
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_11_main.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_11
+ use iso_c_binding, only: c_int
+ implicit none
+contains
+ function one() bind(c, name="c_one")
+ integer(c_int) one
+ one = 1
+ end function one
+end module binding_label_tests_11
+
+! Do not use dg-final to cleanup-modules
--- /dev/null
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_11.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_11_main
+ use iso_c_binding, only: c_int
+ implicit none
+contains
+ function one() bind(c, name="c_one") ! { dg-error "collides" }
+ integer(c_int) one
+ one = 1
+ end function one
+end module binding_label_tests_11_main
+
+program main
+ use binding_label_tests_11 ! { dg-error "collides" }
+ use binding_label_tests_11_main
+end program main
+
+! { dg-final { cleanup-modules "binding_label_tests_11_main binding_label_tests_11" } }
--- /dev/null
+! { dg-do run }
+! This verifies that the compiler will correctly accpet the name="", write out
+! an empty string for the binding label to the module file, and then read it
+! back in. Also, during gfc_verify_binding_labels, the name="" will prevent
+! any verification (since there is no label to verify).
+module one
+contains
+ subroutine foo() bind(c)
+ end subroutine foo
+end module one
+
+module two
+contains
+ ! This procedure is only used accessed in C
+ ! as procedural pointer
+ subroutine foo() bind(c, name="")
+ end subroutine foo
+end module two
+
+use one, only: foo_one => foo
+use two, only: foo_two => foo
+end
+
+! { dg-final { cleanup-modules "one two" } }
--- /dev/null
+! { dg-do compile }
+! This file must be compiled BEFORE binding_label_tests_13_main.f03, which it
+! should be because dejagnu will sort the files.
+module binding_label_tests_13
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int) :: c3
+ bind(c) c3
+end module binding_label_tests_13
--- /dev/null
+! { dg-do compile }
+! This file must be compiled AFTER binding_label_tests_13.f03, which it
+! should be because dejagnu will sort the files. The module file
+! binding_label_tests_13.mod can not be removed until after this test is done.
+module binding_label_tests_13_main
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int) :: c3 ! { dg-error "collides" }
+ bind(c) c3
+
+contains
+ subroutine c_sub() BIND(c, name = "C_Sub")
+ use binding_label_tests_13 ! { dg-error "collides" }
+ end subroutine c_sub
+end module binding_label_tests_13_main
+! { dg-final { cleanup-modules "binding_label_tests_13 binding_label_tests_13_main" } }
+
--- /dev/null
+! { dg-do run }
+subroutine display() bind(c)
+ implicit none
+end subroutine display
+
+program main
+ implicit none
+ interface
+ subroutine display() bind(c)
+ end subroutine display
+ end interface
+end program main
--- /dev/null
+! { dg-do compile }
+module binding_label_tests_2
+
+contains
+ ! this is just here so at least one of the subroutines will be accepted so
+ ! gfortran doesn't give an Extension warning when using -pedantic-errors
+ subroutine ok()
+ end subroutine ok
+
+ subroutine sub0() bind(c, name=" 1") ! { dg-error "Invalid C name" }
+ end subroutine sub0 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub1() bind(c, name="$") ! { dg-error "Invalid C name" }
+ end subroutine sub1 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub2() bind(c, name="abc$") ! { dg-error "Invalid C name" }
+ end subroutine sub2 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub3() bind(c, name="abc d") ! { dg-error "Embedded space" }
+ end subroutine sub3 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Embedded space" }
+ end subroutine sub5 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub6() bind(c, name=" ) ! { dg-error "Invalid C name" }
+ end subroutine sub6 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub7() bind(c, name=) ! { dg-error "Syntax error" }
+ end subroutine sub7 ! { dg-error "Expecting END MODULE" }
+
+ subroutine sub8() bind(c, name) ! { dg-error "Syntax error" }
+ end subroutine sub8 ! { dg-error "Expecting END MODULE" }
+end module binding_label_tests_2
+
+! { dg-final { cleanup-modules "binding_label_tests_2" } }
--- /dev/null
+! { dg-do compile }
+program main
+use iso_c_binding
+ interface
+ subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
+ import :: c_ptr, c_int, c_double
+ type(c_ptr), value :: f
+ integer(c_int), value :: a1, a3
+ real(c_double), value :: a2, a4
+ end subroutine p1
+
+ subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! { dg-error "collides" }
+ import :: c_ptr, c_int, c_double
+ type(c_ptr), value :: f
+ real(c_double), value :: a1, a3
+ integer(c_int), value :: a2, a4
+ end subroutine p2
+ end interface
+
+ type(c_ptr) :: f_ptr
+ character(len=20), target :: format
+
+ f_ptr = c_loc(format(1:1))
+
+ format = 'Hello %d %f %d %f\n' // char(0)
+ call p1(f_ptr, 10, 1.23d0, 20, 2.46d0)
+
+ format = 'World %f %d %f %d\n' // char(0)
+ call p2(f_ptr, 1.23d0, 10, 2.46d0, 20)
+end program main
--- /dev/null
+! { dg-do compile }
+module A
+ use, intrinsic :: iso_c_binding
+contains
+ subroutine pA() bind(c, name='printf') ! { dg-error "collides" }
+ print *, 'hello from pA'
+ end subroutine pA
+end module A
+
+module B
+ use, intrinsic :: iso_c_binding
+
+contains
+ subroutine pB() bind(c, name='printf') ! { dg-error "collides" }
+ print *, 'hello from pB'
+ end subroutine pB
+end module B
+
+module C
+use A
+use B ! { dg-error "Can't open module file" }
+end module C
+
+
--- /dev/null
+! { dg-do compile }
+module binding_label_tests_5
+ use, intrinsic :: iso_c_binding
+
+ interface
+ subroutine sub0() bind(c, name='c_sub') ! { dg-error "collides" }
+ end subroutine sub0
+
+ subroutine sub1() bind(c, name='c_sub') ! { dg-error "collides" }
+ end subroutine sub1
+ end interface
+end module binding_label_tests_5
--- /dev/null
+! { dg-do compile }
+module binding_label_tests_6
+ use, intrinsic :: iso_c_binding
+ integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "collides" }
+ integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "collides" }
+end module binding_label_tests_6
--- /dev/null
+! { dg-do compile }
+module A
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "collides" }
+end module A
+
+program main
+use A
+interface
+ subroutine my_c_print() bind(c) ! { dg-error "collides" }
+ end subroutine my_c_print
+end interface
+
+call my_c_print()
+end program main
--- /dev/null
+! { dg-do compile }
+module binding_label_tests_8
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "collides" }
+
+contains
+ subroutine my_f90_sub() bind(c) ! { dg-error "collides" }
+ end subroutine my_f90_sub
+end module binding_label_tests_8
--- /dev/null
+! { dg-do compile }
+module x
+ use iso_c_binding
+ implicit none
+ private :: bar ! { dg-warning "PRIVATE but has been given the binding label" }
+ private :: my_private_sub
+ private :: my_private_sub_2 ! { dg-warning "PRIVATE but has been given the binding label" }
+ public :: my_public_sub
+contains
+ subroutine bar() bind(c,name="foo")
+ end subroutine bar
+
+ subroutine my_private_sub() bind(c, name="")
+ end subroutine my_private_sub
+
+ subroutine my_private_sub_2() bind(c)
+ end subroutine my_private_sub_2
+
+ subroutine my_public_sub() bind(c, name="my_sub")
+ end subroutine my_public_sub
+end module x
+
+! { dg-final { cleanup-modules "x" } }
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources test_c_assoc.c }
+module c_assoc
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+contains
+
+ function test_c_assoc_0(my_c_ptr) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
+ integer(c_int) :: test_c_assoc_0
+ type(c_ptr), value :: my_c_ptr
+
+ if(c_associated(my_c_ptr)) then
+ test_c_assoc_0 = 1
+ else
+ test_c_assoc_0 = 0
+ endif
+ end function test_c_assoc_0
+
+ function test_c_assoc_1(my_c_ptr_1, my_c_ptr_2) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
+ integer(c_int) :: test_c_assoc_1
+ type(c_ptr), value :: my_c_ptr_1
+ type(c_ptr), value :: my_c_ptr_2
+
+ if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
+ test_c_assoc_1 = 1
+ else
+ test_c_assoc_1 = 0
+ endif
+ end function test_c_assoc_1
+
+ function test_c_assoc_2(my_c_ptr_1, my_c_ptr_2, num_ptrs) bind(c)
+ integer(c_int) :: test_c_assoc_2
+ type(c_ptr), value :: my_c_ptr_1
+ type(c_ptr), value :: my_c_ptr_2
+ integer(c_int), value :: num_ptrs
+
+ if(num_ptrs .eq. 1) then
+ if(c_associated(my_c_ptr_1)) then
+ test_c_assoc_2 = 1
+ else
+ test_c_assoc_2 = 0
+ endif
+ else
+ if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
+ test_c_assoc_2 = 1
+ else
+ test_c_assoc_2 = 0
+ endif
+ endif
+ end function test_c_assoc_2
+
+ subroutine verify_assoc(my_c_ptr_1, my_c_ptr_2) bind(c)
+ type(c_ptr), value :: my_c_ptr_1
+ type(c_ptr), value :: my_c_ptr_2
+
+ if(.not. c_associated(my_c_ptr_1)) then
+ call abort()
+ else if(.not. c_associated(my_c_ptr_2)) then
+ call abort()
+ else if(.not. c_associated(my_c_ptr_1, my_c_ptr_2)) then
+ call abort()
+ endif
+ end subroutine verify_assoc
+
+end module c_assoc
--- /dev/null
+! { dg-do compile }
+module c_assoc_2
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_associated
+
+contains
+ subroutine sub0(my_c_ptr) bind(c)
+ type(c_ptr), value :: my_c_ptr
+ type(c_ptr), pointer :: my_c_ptr_2
+ integer :: my_integer
+
+ if(.not. c_associated(my_c_ptr)) then
+ call abort()
+ end if
+
+ if(.not. c_associated(my_c_ptr, my_c_ptr)) then
+ 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" }
+ call abort()
+ end if
+
+ if(.not. c_associated()) then ! { dg-error "Missing argument" }
+ call abort()
+ end if ! { dg-error "Expecting END SUBROUTINE" }
+
+ if(.not. c_associated(my_c_ptr_2)) then
+ call abort()
+ end if
+
+ if(.not. c_associated(my_integer)) then ! { dg-error "Type/rank mismatch" }
+ call abort()
+ end if
+ end subroutine sub0
+
+end module c_assoc_2
--- /dev/null
+! { dg-do compile }
+! verify that the compiler catches the error in the call to c_f_pointer
+! because it is missing the required SHAPE parameter. the SHAPE parameter
+! is optional, in general, but must exist if given a fortran pointer
+! to a non-zero rank object. --Rickett, 09.26.06
+module c_f_pointer_shape_test
+contains
+ subroutine test_0(myAssumedArray, cPtr)
+ use, intrinsic :: iso_c_binding
+ integer, dimension(*) :: myAssumedArray
+ integer, dimension(:), pointer :: myArrayPtr
+ integer, dimension(1:2), target :: myArray
+ type(c_ptr), value :: cPtr
+
+ myArrayPtr => myArray
+ call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Missing SHAPE parameter" }
+ end subroutine test_0
+end module c_f_pointer_shape_test
+
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_f_tests_driver.c }
+module c_f_pointer_tests
+ use, intrinsic :: iso_c_binding
+
+ type myF90Derived
+ integer(c_int) :: cInt
+ real(c_double) :: cDouble
+ real(c_float) :: cFloat
+ integer(c_short) :: cShort
+ type(c_funptr) :: myFunPtr
+ end type myF90Derived
+
+ type dummyDerived
+ integer(c_int) :: myInt
+ end type dummyDerived
+
+ contains
+
+ subroutine testDerivedPtrs(myCDerived, derivedArray, arrayLen, &
+ derived2DArray, dim1, dim2) &
+ bind(c, name="testDerivedPtrs")
+ implicit none
+ type(c_ptr), value :: myCDerived
+ type(c_ptr), value :: derivedArray
+ integer(c_int), value :: arrayLen
+ type(c_ptr), value :: derived2DArray
+ integer(c_int), value :: dim1
+ integer(c_int), value :: dim2
+ type(myF90Derived), pointer :: myF90Type
+ type(myF90Derived), dimension(:), pointer :: myF90DerivedArray
+ type(myF90Derived), dimension(:,:), pointer :: derivedArray2D
+ ! one dimensional array coming in (derivedArray)
+ integer(c_int), dimension(1:1) :: shapeArray
+ integer(c_int), dimension(1:2) :: shapeArray2
+ type(myF90Derived), dimension(1:10), target :: tmpArray
+
+ call c_f_pointer(myCDerived, myF90Type)
+ ! make sure numbers are ok. initialized in c_f_tests_driver.c
+ if(myF90Type%cInt .ne. 1) then
+ call abort()
+ endif
+ if(myF90Type%cDouble .ne. 2.0d0) then
+ call abort()
+ endif
+ if(myF90Type%cFloat .ne. 3.0) then
+ call abort()
+ endif
+ if(myF90Type%cShort .ne. 4) then
+ call abort()
+ endif
+
+ shapeArray(1) = arrayLen
+ call c_f_pointer(derivedArray, myF90DerivedArray, shapeArray)
+
+ ! upper bound of each dim is arrayLen2
+ shapeArray2(1) = dim1
+ shapeArray2(2) = dim2
+ call c_f_pointer(derived2DArray, derivedArray2D, shapeArray2)
+ ! make sure the last element is ok
+ if((derivedArray2D(dim1, dim2)%cInt .ne. 4) .or. &
+ (derivedArray2D(dim1, dim2)%cDouble .ne. 4.0d0) .or. &
+ (derivedArray2D(dim1, dim2)%cFloat .ne. 4.0) .or. &
+ (derivedArray2D(dim1, dim2)%cShort .ne. 4)) then
+ call abort()
+ endif
+ end subroutine testDerivedPtrs
+end module c_f_pointer_tests
--- /dev/null
+extern void abort(void);
+
+typedef struct myCDerived
+{
+ int cInt;
+ double cDouble;
+ float cFloat;
+ short cShort;
+ void *ptr;
+}myCDerived_t;
+
+#define DERIVED_ARRAY_LEN 10
+#define ARRAY_LEN_2 3
+#define DIM1 2
+#define DIM2 3
+
+void testDerivedPtrs(myCDerived_t *cDerivedPtr,
+ myCDerived_t *derivedArray, int arrayLen,
+ myCDerived_t *derived2d, int dim1, int dim2);
+
+int main(int argc, char **argv)
+{
+ myCDerived_t cDerived;
+ myCDerived_t derivedArray[DERIVED_ARRAY_LEN];
+ myCDerived_t derived2DArray[DIM1][DIM2];
+ int i = 0;
+ int j = 0;
+
+ cDerived.cInt = 1;
+ cDerived.cDouble = 2.0;
+ cDerived.cFloat = 3.0;
+ cDerived.cShort = 4;
+/* cDerived.ptr = NULL; */
+ /* nullify the ptr */
+ cDerived.ptr = 0;
+
+ for(i = 0; i < DERIVED_ARRAY_LEN; i++)
+ {
+ derivedArray[i].cInt = (i+1) * 1;
+ derivedArray[i].cDouble = (i+1) * 1.0; /* 2.0; */
+ derivedArray[i].cFloat = (i+1) * 1.0; /* 3.0; */
+ derivedArray[i].cShort = (i+1) * 1; /* 4; */
+/* derivedArray[i].ptr = NULL; */
+ derivedArray[i].ptr = 0;
+ }
+
+ for(i = 0; i < DIM1; i++)
+ {
+ for(j = 0; j < DIM2; j++)
+ {
+ derived2DArray[i][j].cInt = ((i*DIM1) * 1) + j;
+ derived2DArray[i][j].cDouble = ((i*DIM1) * 1.0) + j;
+ derived2DArray[i][j].cFloat = ((i*DIM1) * 1.0) + j;
+ derived2DArray[i][j].cShort = ((i*DIM1) * 1) + j;
+/* derived2DArray[i][j].ptr = NULL; */
+ derived2DArray[i][j].ptr = 0;
+ }
+ }
+
+ /* send in the transpose size (dim2 is dim1, dim1 is dim2) */
+ testDerivedPtrs(&cDerived, derivedArray, DERIVED_ARRAY_LEN,
+ derived2DArray[0], DIM2, DIM1);
+
+ return 0;
+}/* end main() */
+
--- /dev/null
+! { dg-do run }
+! This test case simply checks that c_funloc exists, accepts arguments of
+! flavor FL_PROCEDURE, and returns the type c_funptr
+module c_funloc_tests
+ use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+
+contains
+ subroutine sub0() bind(c)
+ type(c_funptr) :: my_c_funptr
+
+ my_c_funptr = c_funloc(sub0)
+ end subroutine sub0
+end module c_funloc_tests
+
+program driver
+ use c_funloc_tests
+
+ call sub0()
+end program driver
+
+! { dg-final { cleanup-modules "c_funloc_tests" } }
--- /dev/null
+! { dg-do compile }
+module c_funloc_tests_2
+ use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc
+ implicit none
+
+contains
+ subroutine sub0() bind(c)
+ type(c_funptr) :: my_c_funptr
+ integer :: my_local_variable
+
+ my_c_funptr = c_funloc() ! { dg-error "Missing argument" }
+ 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" }
+ end subroutine sub0
+end module c_funloc_tests_2
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_funloc_tests_3_funcs.c }
+! This testcase tests c_funloc and c_funptr from iso_c_binding. It uses
+! functions defined in c_funloc_tests_3_funcs.c.
+module c_funloc_tests_3
+ implicit none
+contains
+ function ffunc(j) bind(c)
+ use iso_c_binding, only: c_funptr, c_int
+ integer(c_int) :: ffunc
+ integer(c_int), value :: j
+ ffunc = -17*j
+ end function ffunc
+end module c_funloc_tests_3
+program main
+ use iso_c_binding, only: c_funptr, c_funloc
+ use c_funloc_tests_3, only: ffunc
+ implicit none
+ interface
+ function returnFunc() bind(c,name="returnFunc")
+ use iso_c_binding, only: c_funptr
+ type(c_funptr) :: returnFunc
+ end function returnFunc
+ subroutine callFunc(func,pass,compare) bind(c,name="callFunc")
+ use iso_c_binding, only: c_funptr, c_int
+ type(c_funptr), value :: func
+ integer(c_int), value :: pass,compare
+ end subroutine callFunc
+ end interface
+ type(c_funptr) :: p
+ p = returnFunc()
+ call callFunc(p, 13,3*13)
+ p = c_funloc(ffunc)
+ call callFunc(p, 21,-17*21)
+end program main
+! { dg-final { cleanup-modules "c_funloc_tests_3" } }
--- /dev/null
+/* These functions support the test case c_funloc_tests_3. */
+#include <stdlib.h>
+#include <stdio.h>
+
+int printIntC(int i)
+{
+ return 3*i;
+}
+
+int (*returnFunc(void))(int)
+{
+ return &printIntC;
+}
+
+void callFunc(int(*func)(int), int pass, int compare)
+{
+ int result = (*func)(pass);
+ if(result != compare)
+ {
+ printf("FAILED: Got %d, expected %d\n", result, compare);
+ abort();
+ }
+ else
+ printf("SUCCESS: Got %d, expected %d\n", result, compare);
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_kinds.c }
+! { dg-options "-w -std=c99" }
+! the -w option is needed to make f951 not report a warning for
+! the -std=c99 option that the C file needs.
+!
+! Note: int_fast*_t currently not supported, cf. PR 448.
+module c_kind_params
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+contains
+ subroutine param_test(my_short, my_int, my_long, my_long_long, &
+ my_int8_t, my_int_least8_t, my_int16_t, &
+ my_int_least16_t, my_int32_t, my_int_least32_t, &
+ my_int64_t, my_int_least64_t, &
+ my_intmax_t, my_intptr_t, my_float, my_double, my_long_double, &
+ my_char, my_bool) bind(c)
+ integer(c_short), value :: my_short
+ integer(c_int), value :: my_int
+ integer(c_long), value :: my_long
+ integer(c_long_long), value :: my_long_long
+ integer(c_int8_t), value :: my_int8_t
+ integer(c_int_least8_t), value :: my_int_least8_t
+! integer(c_int_fast8_t), value :: my_int_fast8_t
+ integer(c_int16_t), value :: my_int16_t
+ integer(c_int_least16_t), value :: my_int_least16_t
+! integer(c_int_fast16_t), value :: my_int_fast16_t
+ integer(c_int32_t), value :: my_int32_t
+ integer(c_int_least32_t), value :: my_int_least32_t
+! integer(c_int_fast32_t), value :: my_int_fast32_t
+ integer(c_int64_t), value :: my_int64_t
+ integer(c_int_least64_t), value :: my_int_least64_t
+! integer(c_int_fast64_t), value :: my_int_fast64_t
+ integer(c_intmax_t), value :: my_intmax_t
+ integer(c_intptr_t), value :: my_intptr_t
+ real(c_float), value :: my_float
+ real(c_double), value :: my_double
+ real(c_long_double), value :: my_long_double
+ character(c_char), value :: my_char
+ logical(c_bool), value :: my_bool
+
+ if(my_short /= 1_c_short) call abort()
+ if(my_int /= 2_c_int) call abort()
+ if(my_long /= 3_c_long) call abort()
+ if(my_long_long /= 4_c_long_long) call abort()
+
+ if(my_int8_t /= 1_c_int8_t) call abort()
+ if(my_int_least8_t /= 2_c_int_least8_t ) call abort()
+ print *, 'c_int_fast8_t is: ', c_int_fast8_t
+
+ if(my_int16_t /= 1_c_int16_t) call abort()
+ if(my_int_least16_t /= 2_c_int_least16_t) call abort()
+ print *, 'c_int_fast16_t is: ', c_int_fast16_t
+
+ if(my_int32_t /= 1_c_int32_t) call abort()
+ if(my_int_least32_t /= 2_c_int_least32_t) call abort()
+ print *, 'c_int_fast32_t is: ', c_int_fast32_t
+
+ if(my_int64_t /= 1_c_int64_t) call abort()
+ if(my_int_least64_t /= 2_c_int_least64_t) call abort()
+ print *, 'c_int_fast64_t is: ', c_int_fast64_t
+
+ if(my_intmax_t /= 1_c_intmax_t) call abort()
+ if(my_intptr_t /= 0_c_intptr_t) call abort()
+
+ if(my_float /= 1.0_c_float) call abort()
+ if(my_double /= 2.0_c_double) call abort()
+ if(my_long_double /= 3.0_c_long_double) call abort()
+
+ if(my_char /= c_char_'y') call abort()
+ if(my_bool .neqv. .true._c_bool) call abort()
+ end subroutine param_test
+
+end module c_kind_params
+! { dg-final { cleanup-modules "c_kind_params" } }
--- /dev/null
+! { dg-do compile }
+module c_kind_tests_2
+ use, intrinsic :: iso_c_binding
+
+ integer, parameter :: myF = c_float
+ real(myF), bind(c) :: myCFloat
+ integer(myF), bind(c) :: myCInt ! { dg-error "is for type REAL" }
+ integer(c_double), bind(c) :: myCInt2 ! { dg-error "is for type REAL" }
+
+ integer, parameter :: myI = c_int
+ real(myI) :: myReal
+ real(myI), bind(c) :: myCFloat2 ! { dg-error "is for type INTEGER" }
+ real(4), bind(c) :: myFloat ! { dg-warning "may not be a C interoperable" }
+end module c_kind_tests_2
--- /dev/null
+/* { dg-do compile } */
+/* { dg-options "-std=c99" } */
+
+#include <stdint.h>
+
+/* Note: int_fast*_t is currently not supported, cf. PR 448 */
+void param_test(short int my_short, int my_int, long int my_long,
+ long long int my_long_long, int8_t my_int8_t,
+ int_least8_t my_int_least8_t, /*int_fast8_t my_int_fast8_t,*/
+ int16_t my_int16_t, int_least16_t my_int_least16_t,
+ /*int_fast16_t my_int_fast16_t,*/ int32_t my_int32_t,
+ int_least32_t my_int_least32_t, /*int_fast32_t my_int_fast32_t,*/
+ int64_t my_int64_t, int_least64_t my_int_least64_t,
+ /*int_fast64_t my_int_fast64_t,*/ intmax_t my_intmax_t,
+ intptr_t my_intptr_t, float my_float, double my_double,
+ long double my_long_double, char my_char, _Bool my_bool);
+
+
+int main(int argc, char **argv)
+{
+ short int my_short = 1;
+ int my_int = 2;
+ long int my_long = 3;
+ long long int my_long_long = 4;
+ int8_t my_int8_t = 1;
+ int_least8_t my_int_least8_t = 2;
+ int_fast8_t my_int_fast8_t = 3;
+ int16_t my_int16_t = 1;
+ int_least16_t my_int_least16_t = 2;
+ int_fast16_t my_int_fast16_t = 3;
+ int32_t my_int32_t = 1;
+ int_least32_t my_int_least32_t = 2;
+ int_fast32_t my_int_fast32_t = 3;
+ int64_t my_int64_t = 1;
+ int_least64_t my_int_least64_t = 2;
+ int_fast64_t my_int_fast64_t = 3;
+ intmax_t my_intmax_t = 1;
+ intptr_t my_intptr_t = 0;
+ float my_float = 1.0;
+ double my_double = 2.0;
+ long double my_long_double = 3.0;
+ char my_char = 'y';
+ _Bool my_bool = 1;
+
+ param_test(my_short, my_int, my_long, my_long_long, my_int8_t,
+ my_int_least8_t, /*my_int_fast8_t, */ my_int16_t,
+ my_int_least16_t,/* my_int_fast16_t,*/ my_int32_t,
+ my_int_least32_t,/* my_int_fast32_t,*/ my_int64_t,
+ my_int_least64_t,/* my_int_fast64_t,*/ my_intmax_t,
+ my_intptr_t, my_float, my_double, my_long_double, my_char,
+ my_bool);
+
+ return 0;
+}/* end main() */
--- /dev/null
+/* in fortran module */
+void test0(void);
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+ test0();
+ return 0;
+}/* end main() */
+
+void test_address(void *c_ptr, int expected_value)
+{
+ if((*(int *)(c_ptr)) != expected_value)
+ abort();
+ return;
+}/* end test_address() */
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_loc_driver.c }
+module c_loc_test
+implicit none
+
+contains
+ subroutine test0() bind(c)
+ use, intrinsic :: iso_c_binding
+ implicit none
+ integer, target :: x
+ type(c_ptr) :: my_c_ptr
+ interface
+ subroutine test_address(x, expected_value) bind(c)
+ use, intrinsic :: iso_c_binding
+ type(c_ptr), value :: x
+ integer(c_int), value :: expected_value
+ end subroutine test_address
+ end interface
+ x = 100
+ my_c_ptr = c_loc(x)
+ call test_address(my_c_ptr, 100)
+ end subroutine test0
+end module c_loc_test
+! { dg-final { cleanup-modules "c_loc_test.mod" } }
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_loc_tests_2_funcs.c }
+module c_loc_tests_2
+use, intrinsic :: iso_c_binding
+implicit none
+
+interface
+ function test_scalar_address(cptr) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+ type(c_ptr), value :: cptr
+ integer(c_int) :: test_scalar_address
+ end function test_scalar_address
+
+ function test_array_address(cptr, num_elements) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+ type(c_ptr), value :: cptr
+ integer(c_int), value :: num_elements
+ integer(c_int) :: test_array_address
+ end function test_array_address
+
+ function test_type_address(cptr) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int
+ type(c_ptr), value :: cptr
+ integer(c_int) :: test_type_address
+ end function test_type_address
+end interface
+
+contains
+ subroutine test0() bind(c)
+ integer, target :: xtar
+ integer, pointer :: xptr
+ type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+ type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+ xtar = 100
+ xptr => xtar
+ my_c_ptr_1 = c_loc(xtar)
+ my_c_ptr_2 = c_loc(xptr)
+ if(test_scalar_address(my_c_ptr_1) .ne. 1) then
+ call abort()
+ end if
+ if(test_scalar_address(my_c_ptr_2) .ne. 1) then
+ call abort()
+ end if
+ end subroutine test0
+
+ subroutine test1() bind(c)
+ integer, target, dimension(100) :: int_array_tar
+ type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+ type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+
+ int_array_tar = 100
+ my_c_ptr_1 = c_loc(int_array_tar)
+ if(test_array_address(my_c_ptr_1, 100) .ne. 1) then
+ call abort()
+ end if
+ end subroutine test1
+
+ subroutine test2() bind(c)
+ type, bind(c) f90type
+ integer(c_int) :: i
+ real(c_double) :: x
+ end type f90type
+ type(f90type), target :: type_tar
+ type(f90type), pointer :: type_ptr
+ type(c_ptr) :: my_c_ptr_1 = c_null_ptr
+ type(c_ptr) :: my_c_ptr_2 = c_null_ptr
+
+ type_ptr => type_tar
+ type_tar%i = 100
+ type_tar%x = 1.0d0
+ my_c_ptr_1 = c_loc(type_tar)
+ my_c_ptr_2 = c_loc(type_ptr)
+ if(test_type_address(my_c_ptr_1) .ne. 1) then
+ call abort()
+ end if
+ if(test_type_address(my_c_ptr_2) .ne. 1) then
+ call abort()
+ end if
+ end subroutine test2
+end module c_loc_tests_2
+
+program driver
+ use c_loc_tests_2
+ call test0()
+ call test1()
+ call test2()
+end program driver
+! { dg-final { cleanup-modules "c_loc_tests_2" } }
--- /dev/null
+double fabs (double);
+
+typedef struct ctype
+{
+ int i;
+ double x;
+}ctype_t;
+
+int test_scalar_address(int *ptr)
+{
+ /* The value in Fortran should be initialized to 100. */
+ if(*ptr != 100)
+ return 0;
+ else
+ return 1;
+}
+
+int test_array_address(int *int_array, int num_elements)
+{
+ int i = 0;
+
+ for(i = 0; i < num_elements; i++)
+ /* Fortran will init all of the elements to 100; verify that here. */
+ if(int_array[i] != 100)
+ return 0;
+
+ /* all elements were equal to 100 */
+ return 1;
+}
+
+int test_type_address(ctype_t *type_ptr)
+{
+ /* i was set to 100 by Fortran */
+ if(type_ptr->i != 100)
+ return 0;
+
+ /* x was set to 1.0d0 by Fortran */
+ if(fabs(type_ptr->x - 1.0) > 0.00000000)
+ return 0;
+
+ return 1;
+}
--- /dev/null
+! { dg-do compile }
+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" }
+
+end
--- /dev/null
+! { dg-do compile }
+module c_loc_tests_4
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+contains
+ subroutine sub0() bind(c)
+ integer(c_int), target, dimension(10) :: my_array
+ integer(c_int), pointer, dimension(:) :: my_array_ptr
+ 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" }
+ end subroutine sub0
+end module c_loc_tests_4
--- /dev/null
+! { dg-do compile }
+module c_loc_tests_5
+ use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_loc, c_int
+
+contains
+ subroutine sub0() bind(c)
+ type(c_ptr) :: f_ptr, my_c_ptr
+ character(kind=c_char, len=20), target :: format
+ integer(c_int), dimension(:), pointer :: int_ptr
+ integer(c_int), dimension(10), target :: int_array
+
+ f_ptr = c_loc(format(1:1))
+
+ int_ptr => int_array
+ my_c_ptr = c_loc(int_ptr(0))
+
+ end subroutine sub0
+end module c_loc_tests_5
+! { dg-final { cleanup-modules "c_loc_tests_5" } }
--- /dev/null
+! { dg-do compile }
+! Verifies that the c_loc scalar pointer tests recognize the string of length
+! one as being allowable for the parameter to c_loc.
+module x
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+ TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+ CHARACTER(C_CHAR), DIMENSION(10), TARGET :: empty_string=C_NULL_CHAR
+ argv(1)=C_LOC(empty_string)
+END SUBROUTINE
+end module x
+! { dg-final { cleanup-modules "x" } }
--- /dev/null
+! { dg-do compile }
+module c_loc_tests_7
+use iso_c_binding
+contains
+SUBROUTINE glutInit_f03()
+ TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR
+ CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR
+ argv(1)=C_LOC(empty_string)
+END SUBROUTINE
+end module c_loc_tests_7
+! { dg-final { cleanup-modules "c_loc_tests_7" } }
--- /dev/null
+! { dg-do compile }
+! Verifies that the c_loc scalar pointer tests recognize the string of length
+! greater than one as not being allowable for the parameter to c_loc.
+module x
+use iso_c_binding
+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" }
+END SUBROUTINE
+end module x
+
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_driver.c }
+module c_ptr_tests
+ use, intrinsic :: iso_c_binding
+
+ ! TODO::
+ ! in order to be associated with a C address,
+ ! the derived type needs to be C interoperable,
+ ! which requires bind(c) and all fields interoperable.
+ type, bind(c) :: myType
+ type(c_ptr) :: myServices
+ type(c_funptr) :: mySetServices
+ type(c_ptr) :: myPort
+ end type myType
+
+ type, bind(c) :: f90Services
+ integer(c_int) :: compId
+ type(c_ptr) :: globalServices = c_null_ptr
+ end type f90Services
+
+ contains
+
+ subroutine sub0(c_self, services) bind(c)
+ use, intrinsic :: iso_c_binding
+ implicit none
+ type(c_ptr), value :: c_self, services
+ type(myType), pointer :: self
+ type(f90Services), pointer :: localServices
+! type(c_ptr) :: my_cptr
+ type(c_ptr), save :: my_cptr = c_null_ptr
+
+ call c_f_pointer(c_self, self)
+ if(.not. associated(self)) then
+ print *, 'self is not associated'
+ end if
+ self%myServices = services
+
+ ! c_null_ptr is defined in iso_c_binding
+ my_cptr = c_null_ptr
+
+ ! get access to the local services obj from C
+ call c_f_pointer(self%myServices, localServices)
+ end subroutine sub0
+end module c_ptr_tests
--- /dev/null
+! { dg-run }
+! This test case exists because gfortran had an error in converting the
+! expressions for the derived types from iso_c_binding in some cases.
+module c_ptr_tests_10
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+contains
+ subroutine sub0() bind(c)
+ print *, 'c_null_ptr is: ', c_null_ptr
+ end subroutine sub0
+end module c_ptr_tests_10
+
+program main
+ use c_ptr_tests_10
+ call sub0()
+end program main
+
+! { dg-final { cleanup-modules "c_ptr_tests_10" } }
--- /dev/null
+! { dg-do compile }
+module c_ptr_tests_5
+use, intrinsic :: iso_c_binding
+
+type, bind(c) :: my_f90_type
+ integer(c_int) :: i
+end type my_f90_type
+
+contains
+ subroutine sub0(c_struct) bind(c)
+ type(c_ptr), value :: c_struct
+ type(my_f90_type) :: f90_type
+
+ call c_f_pointer(c_struct, f90_type) ! { dg-error "must have the POINTER" }
+ end subroutine sub0
+end module c_ptr_tests_5
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_7_driver.c }
+module c_ptr_tests_7
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+contains
+ function func0() bind(c)
+ type(c_ptr) :: func0
+ func0 = c_null_ptr
+ end function func0
+end module c_ptr_tests_7
+! { dg-final { cleanup-modules "c_ptr_tests_7" } }
--- /dev/null
+/* This is the driver for c_ptr_test_7. */
+extern void abort(void);
+
+void *func0();
+
+int main(int argc, char **argv)
+{
+ /* The Fortran module c_ptr_tests_7 contains function func0, which has
+ return type of c_ptr, and should set the return value to c_null_ptr. */
+ if (func0() != 0)
+ abort();
+
+ return 0;
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_ptr_tests_8_funcs.c }
+program main
+use iso_c_binding, only: c_ptr
+implicit none
+interface
+ function create() bind(c)
+ use iso_c_binding, only: c_ptr
+ type(c_ptr) :: create
+ end function create
+ subroutine show(a) bind(c)
+ import :: c_ptr
+ type(c_ptr), VALUE :: a
+ end subroutine show
+end interface
+
+type(c_ptr) :: ptr
+ptr = create()
+call show(ptr)
+end program main
--- /dev/null
+/* This file provides auxilliary functions for c_ptr_tests_8. */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+extern void abort (void);
+
+void *create (void)
+{
+ int *a;
+ a = malloc (sizeof (a));
+ *a = 444;
+ return a;
+
+}
+
+void show (int *a)
+{
+ if (*a == 444)
+ printf ("SUCCESS (%d)\n", *a);
+ else
+ {
+ printf ("FAILED: Expected 444, received %d\n", *a);
+ abort ();
+ }
+}
--- /dev/null
+! { dg-do run }
+! This test is pretty simple but is here just to make sure that the changes
+! done to c_ptr and c_funptr (translating them to void *) works in the case
+! where a component of a type is of type c_ptr or c_funptr.
+module c_ptr_tests_9
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
+
+ type myF90Derived
+ type(c_ptr) :: my_c_ptr
+ end type myF90Derived
+
+contains
+ subroutine sub0() bind(c)
+ type(myF90Derived), target :: my_f90_type
+ type(myF90Derived), pointer :: my_f90_type_ptr
+
+ my_f90_type%my_c_ptr = c_null_ptr
+ print *, 'my_f90_type is: ', my_f90_type
+ my_f90_type_ptr => my_f90_type
+ print *, 'my_f90_type_ptr is: ', my_f90_type_ptr
+ end subroutine sub0
+end module c_ptr_tests_9
+
+
+program main
+ use c_ptr_tests_9
+
+ call sub0()
+end program main
+
+! { dg-final { cleanup-modules "c_ptr_tests_9" } }
--- /dev/null
+/* this is the driver for c_ptr_test.f03 */
+
+typedef struct services
+{
+ int compId;
+ void *globalServices;
+}services_t;
+
+typedef struct comp
+{
+ void *myServices;
+ void (*setServices)(struct comp *self, services_t *myServices);
+ void *myPort;
+}comp_t;
+
+/* prototypes for f90 functions */
+void sub0(comp_t *self, services_t *myServices);
+
+int main(int argc, char **argv)
+{
+ services_t servicesObj;
+ comp_t myComp;
+
+ servicesObj.compId = 17;
+ servicesObj.globalServices = 0; /* NULL; */
+ myComp.myServices = &servicesObj;
+ myComp.setServices = 0; /* NULL; */
+ myComp.myPort = 0; /* NULL; */
+
+ sub0(&myComp, &servicesObj);
+
+ return 0;
+}/* end main() */
+
--- /dev/null
+#include <stdlib.h>
+void sub0(int my_c_size);
+
+int main(int argc, char **argv)
+{
+ int my_c_size;
+
+ my_c_size = (int)sizeof(size_t);
+ sub0(my_c_size);
+
+ return 0;
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources c_size_t_driver.c }
+module c_size_t_test
+ use, intrinsic :: iso_c_binding
+
+contains
+ subroutine sub0(my_c_size) bind(c)
+ integer(c_int), value :: my_c_size ! value of C's sizeof(size_t)
+
+ ! if the value of c_size_t isn't equal to the value of C's sizeof(size_t)
+ ! we call abort.
+ if(c_size_t .ne. my_c_size) then
+ call abort ()
+ end if
+ end subroutine sub0
+end module c_size_t_test
--- /dev/null
+! { dg-do run }
+module myComModule
+ use, intrinsic :: iso_c_binding
+
+ common /COM2/ R2, S2
+ real(c_double) :: r2
+ real(c_double) :: s2
+ bind(c) :: /COM2/
+
+end module myComModule
+
+module comBlockTests
+ use, intrinsic :: iso_c_binding
+ use myComModule
+
+ implicit none
+
+ common /COM/ R, S
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c) :: /COM/
+
+ contains
+
+ subroutine testTypes()
+ implicit none
+ end subroutine testTypes
+end module comBlockTests
+
+program comBlockDriver
+ use comBlockTests
+
+ call testTypes()
+end program comBlockDriver
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources global_vars_c_init_driver.c }
+module global_vars_c_init
+ use, intrinsic :: iso_c_binding, only: c_int
+ implicit none
+
+ integer(c_int), bind(c, name='i') :: I
+
+contains
+ subroutine test_globals() bind(c)
+ ! the value of I is initialized above
+ if(I .ne. 2) then
+ call abort()
+ endif
+ end subroutine test_globals
+end module global_vars_c_init
+
+
--- /dev/null
+int i = 2;
+void test_globals(void);
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+ /* verify that i has been initialized by f90 */
+ if(i != 2)
+ abort();
+ test_globals();
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources global_vars_f90_init_driver.c }
+module global_vars_f90_init
+ use, intrinsic :: iso_c_binding, only: c_int
+ implicit none
+
+ integer(c_int), bind(c, name='i') :: I = 2
+
+contains
+ subroutine test_globals() bind(c)
+ ! the value of I is initialized above
+ if(I .ne. 2) then
+ call abort()
+ endif
+ end subroutine test_globals
+end module global_vars_f90_init
+
+
--- /dev/null
+/* initialized by fortran */
+int i;
+void test_globals(void);
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+ /* verify that i has been initialized by f90 */
+ if(i != 2)
+ abort();
+ test_globals();
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do compile }
+module interop_params
+use, intrinsic :: iso_c_binding
+
+type my_f90_type
+ integer :: i
+ real :: x
+end type my_f90_type
+
+contains
+ subroutine test_0(my_f90_int) bind(c) ! { dg-warning "may not be C interoperable" }
+ use, intrinsic :: iso_c_binding
+ integer, value :: my_f90_int
+ end subroutine test_0
+
+ subroutine test_1(my_f90_real) bind(c) ! { dg-error "is for type INTEGER" }
+ real(c_int), value :: my_f90_real
+ end subroutine test_1
+
+ subroutine test_2(my_type) bind(c) ! { dg-error "is not C interoperable" }
+ use, intrinsic :: iso_c_binding
+ type(my_f90_type) :: my_type
+ end subroutine test_2
+end module interop_params
--- /dev/null
+! { dg-do compile }
+module iso_c_binding_only
+ use, intrinsic :: iso_c_binding, only: c_null_ptr
+ ! This should be allowed since the C_PTR that the C_NULL_PTR needs will use
+ ! a mangled name to prevent collisions.
+ integer :: c_ptr
+end module iso_c_binding_only
+! { dg-final { cleanup-modules "iso_c_binding_only" } }
+
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources iso_c_binding_rename_1_driver.c }
+module iso_c_binding_rename_0
+ use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr, &
+ c_associated
+end module iso_c_binding_rename_0
+
+
+module iso_c_binding_rename_1
+ ! rename a couple of the symbols from iso_c_binding. the compiler
+ ! needs to be able to recognize the derived types with names different
+ ! from the one in iso_c_binding because it will look up the derived types
+ ! to define the args and return values of some of the procedures in
+ ! iso_c_binding. this should verify that this functionality works.
+ use, intrinsic :: iso_c_binding, my_c_int => c_int, my_c_ptr => c_ptr, &
+ my_c_associated => c_associated, my_c_f_pointer => c_f_pointer
+
+contains
+ subroutine sub0(my_int) bind(c)
+ integer(my_c_int), value :: my_int
+ if(my_int .ne. 1) then
+ call abort()
+ end if
+ end subroutine sub0
+
+ subroutine sub1(my_ptr) bind(c)
+ type(my_c_ptr), value :: my_ptr
+
+ if(.not. my_c_associated(my_ptr)) then
+ call abort()
+ end if
+ end subroutine sub1
+
+ subroutine sub2(my_int, my_long) bind(c)
+ use, intrinsic :: iso_c_binding, my_c_int_2 => c_int, &
+ my_c_long_2 => c_long
+ integer(my_c_int_2), value :: my_int
+ integer(my_c_long_2), value :: my_long
+
+ if(my_int .ne. 1) then
+ call abort()
+ end if
+ if(my_long .ne. 1) then
+ call abort()
+ end if
+ end subroutine sub2
+
+ subroutine sub3(cptr1, cptr2) bind(c)
+ type(my_c_ptr), value :: cptr1
+ type(my_c_ptr), value :: cptr2
+ integer(my_c_int), pointer :: my_f90_c_ptr
+
+ if(.not. my_c_associated(cptr1)) then
+ call abort()
+ end if
+
+ if(.not. my_c_associated(cptr1, cptr2)) then
+ call abort()
+ end if
+
+ call my_c_f_pointer(cptr1, my_f90_c_ptr)
+ end subroutine sub3
+
+ subroutine sub4(cptr1, cptr2) bind(c)
+ ! rename the my_c_ptr_0 from iso_c_binding_rename_0 just to further test
+ ! both are actually aliases to c_ptr
+ use iso_c_binding_rename_0, my_c_ptr_local => my_c_ptr_0, &
+ my_c_associated_2 => c_associated
+
+ implicit none
+ type(my_c_ptr_local), value :: cptr1
+ type(my_c_ptr_local), value :: cptr2
+
+ if(.not. my_c_associated_2(cptr1)) then
+ call abort()
+ end if
+
+ if(.not. my_c_associated_2(cptr2)) then
+ call abort()
+ end if
+ end subroutine sub4
+end module iso_c_binding_rename_1
+
--- /dev/null
+void sub0(int);
+void sub1(int *);
+void sub2(int, long);
+void sub3(int *, int *);
+void sub4(int *, int *);
+
+int main(int argc, char **argv)
+{
+ int i = 1;
+ long j = 1;
+
+ sub0(i);
+ sub1(&i);
+ sub2(i, j);
+ sub3(&i, &i);
+ sub4(&i, &i);
+
+ return 0;
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources iso_c_binding_rename_2_driver.c }
+module mod0
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_associated
+end module mod0
+
+module mod1
+ use mod0, my_c_ptr => c_ptr, my_c_associated => c_associated
+end module mod1
+
+module mod2
+contains
+ subroutine sub2(my_ptr1) bind(c)
+ use mod1, my_c_ptr_2 => my_c_ptr, my_c_associated_2 => my_c_associated
+ implicit none
+ type(my_c_ptr_2) :: my_ptr1
+ if( .not. my_c_associated_2(my_ptr1)) then
+ call abort()
+ end if
+ end subroutine sub2
+
+ subroutine sub3(my_ptr1) bind(c)
+ use mod1, my_c_ptr_2 => my_c_ptr
+ implicit none
+ type(my_c_ptr_2) :: my_ptr1
+ if( .not. my_c_associated(my_ptr1)) then
+ call abort()
+ end if
+ end subroutine sub3
+
+ subroutine sub4(my_ptr1) bind(c)
+ use mod1, my_c_associated_3 => my_c_associated
+ implicit none
+ type(my_c_ptr) :: my_ptr1
+ if( .not. my_c_associated_3(my_ptr1)) then
+ call abort()
+ end if
+ end subroutine sub4
+
+end module mod2
--- /dev/null
+void sub2(int **);
+void sub3(int **);
+void sub4(int **);
+
+int main(int argc, char **argv)
+{
+ int i = 1;
+ int *ptr;
+
+ ptr = &i;
+ sub2(&ptr);
+ sub3(&ptr);
+ sub4(&ptr);
+
+ return 0;
+}
--- /dev/null
+! { dg-do compile }
+module kind_tests_2
+ use, intrinsic :: iso_c_binding
+
+ integer, parameter :: myFKind = c_float
+ real(myFKind), bind(c) :: myF
+end module kind_tests_2
--- /dev/null
+! { dg-do compile }
+module my_kinds
+ use, intrinsic :: iso_c_binding
+ integer, parameter :: myFKind = c_float
+end module my_kinds
+
+module my_module
+ use my_kinds
+ real(myFKind), bind(c) :: myF
+end module my_module
use foo
print *, pi
end program test
-! { dg-final { scan-module "foo" "MD5:18a257e13c90e3872b7b9400c2fc6e4b" } }
+! { dg-final { scan-module "foo" "MD5:10e58dd12566bfc60412da6f8f8f7a07" } }
! { dg-final { cleanup-modules "foo" } }
--- /dev/null
+/* this is an f90 function */
+void testOnly(int *cIntPtr);
+
+int main(int argc, char **argv)
+{
+ int myCInt;
+
+ myCInt = -11;
+ testOnly(&myCInt);
+
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do run }
+program print_c_kinds
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ print *, 'c_short is: ', c_short
+ print *, 'c_int is: ', c_int
+ print *, 'c_long is: ', c_long
+ print *, 'c_long_long is: ', c_long_long
+ print *
+ print *, 'c_int8_t is: ', c_int8_t
+ print *, 'c_int_least8_t is: ', c_int_least8_t
+ print *, 'c_int_fast8_t is: ', c_int_fast8_t
+ print *
+ print *, 'c_int16_t is: ', c_int16_t
+ print *, 'c_int_least16_t is: ', c_int_least16_t
+ print *, 'c_int_fast16_t is: ', c_int_fast16_t
+ print *
+ print *, 'c_int32_t is: ', c_int32_t
+ print *, 'c_int_least32_t is: ', c_int_least32_t
+ print *, 'c_int_fast32_t is: ', c_int_fast32_t
+ print *
+ print *, 'c_int64_t is: ', c_int64_t
+ print *, 'c_int_least64_t is: ', c_int_least64_t
+ print *, 'c_int_fast64_t is: ', c_int_fast64_t
+ print *
+ print *, 'c_intmax_t is: ', c_intmax_t
+ print *, 'c_intptr_t is: ', c_intptr_t
+ print *
+ print *, 'c_float is: ', c_float
+ print *, 'c_double is: ', c_double
+ print *, 'c_long_double is: ', c_long_double
+ print *
+ print *, 'c_char is: ', c_char
+end program print_c_kinds
--- /dev/null
+! { dg-do compile }
+module test_bind_c_parens
+ interface
+ subroutine sub bind(c) ! { dg-error "Missing required parentheses" }
+ end subroutine sub ! { dg-error "Expecting END INTERFACE" }
+ end interface
+end module test_bind_c_parens
--- /dev/null
+/* use 0 for NULL so no need for system header */
+
+int test_c_assoc_0(void *my_c_ptr);
+int test_c_assoc_1(void *my_c_ptr_1, void *my_c_ptr_2);
+int test_c_assoc_2(void *my_c_ptr_1, void *my_c_ptr_2, int num_ptrs);
+void verify_assoc(void *my_c_ptr_1, void *my_c_ptr_2);
+
+extern void abort(void);
+
+int main(int argc, char **argv)
+{
+ int i;
+ int j;
+
+ if(test_c_assoc_0(0) != 0)
+ abort();
+
+ if(test_c_assoc_0(&i) != 1)
+ abort();
+
+ if(test_c_assoc_1(0, 0) != 0)
+ abort();
+
+ if(test_c_assoc_1(0, &i) != 0)
+ abort();
+
+ if(test_c_assoc_1(&i, &i) != 1)
+ abort();
+
+ if(test_c_assoc_1(&i, 0) != 0)
+ abort();
+
+ if(test_c_assoc_1(&i, &j) != 0)
+ abort();
+
+ /* this should be associated, cause only testing 1 ptr (i) */
+ if(test_c_assoc_2(&i, 0, 1) != 1)
+ abort();
+
+ /* this should be associated */
+ if(test_c_assoc_2(&i, &i, 2) != 1)
+ abort();
+
+ /* this should not be associated (i) */
+ if(test_c_assoc_2(&i, &j, 2) != 0)
+ abort();
+
+ /* this should be associated, cause only testing 1 ptr (i) */
+ if(test_c_assoc_2(&i, &j, 1) != 1)
+ abort();
+
+ verify_assoc(&i, &i);
+
+ return 0;
+}/* end main() */
--- /dev/null
+! { dg-do run }
+module nonF03ComBlock
+ common /NONF03COM/ r, s
+ real :: r
+ real :: s
+
+ contains
+
+ subroutine hello(myArray)
+ integer, dimension(:) :: myArray
+
+ r = 1.0
+ s = 2.0
+ end subroutine hello
+end module nonF03ComBlock
+
+program testComBlock
+ use nonF03ComBlock
+ integer, dimension(1:10) :: myArray
+
+ call hello(myArray)
+
+ ! these are set in the call to hello() above
+ ! r and s are reals (default size) in com block, set to
+ ! 1.0 and 2.0, respectively, in hello()
+ if(r .ne. 1.0) then
+ call abort()
+ endif
+ if(s .ne. 2.0) then
+ call abort()
+ endif
+end program testComBlock
--- /dev/null
+! { dg-do compile }
+module x
+ use, intrinsic :: iso_c_binding, only: c_double
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+end module x
+
+module y
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="") /com2/
+end module y
+
+module z
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ ! this next line is an error; if a common block is bind(c), the binding label
+ ! for it must match across all scoping units that declare it.
+ bind(c, name="my_common_block_2") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="mycom2") /com2/
+end module z
+
+! { dg-final { cleanup-modules "x y" } }
--- /dev/null
+! { dg-do compile }
+module test_common_binding_labels_2
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+
+ common /com2/ i
+ integer(c_int) :: i
+ bind(c, name="") /com2/
+end module test_common_binding_labels_2
+
--- /dev/null
+! { dg-do compile }
+! This file depends on the module test_common_binding_labels_2. That module
+! must be compiled first and not be removed until after this test.
+module test_common_binding_labels_2_main
+ use, intrinsic :: iso_c_binding, only: c_double, c_int
+ implicit none
+
+ common /mycom/ r, s ! { dg-error "does not match" }
+ real(c_double) :: r
+ real(c_double) :: s
+ ! this next line is an error; if a common block is bind(c), the binding label
+ ! for it must match across all scoping units that declare it.
+ bind(c, name="my_common_block_2") :: /mycom/
+
+ common /com2/ i ! { dg-error "does not match" }
+ integer(c_int) :: i
+ bind(c, name="mycom2") /com2/
+end module test_common_binding_labels_2_main
+
+program main
+ use test_common_binding_labels_2 ! { dg-error "does not match" }
+ use test_common_binding_labels_2_main
+end program main
+
+! { dg-final { cleanup-modules "test_common_binding_labels_2_main test_common_binding_labels_2" } }
--- /dev/null
+! { dg-do compile }
+module test_common_binding_labels_3
+ use, intrinsic :: iso_c_binding, only: c_double
+ implicit none
+
+ common /mycom/ r, s
+ real(c_double) :: r
+ real(c_double) :: s
+ bind(c, name="my_common_block") :: /mycom/
+end module test_common_binding_labels_3
--- /dev/null
+! { dg-do compile }
+! This file depends on the module test_common_binding_labels_3. That module
+! must be compiled first and not be removed until after this test.
+module test_common_binding_labels_3_main
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(c_int), bind(c, name="my_common_block") :: my_int ! { dg-error "collides" }
+end module test_common_binding_labels_3_main
+
+program main
+ use test_common_binding_labels_3_main
+ use test_common_binding_labels_3 ! { dg-error "collides" }
+end program main
+
+! { dg-final { cleanup-modules "test_common_binding_labels_3_main test_common_binding_labels_3" } }
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources only_clause_main.c }
+module testOnlyClause
+
+ contains
+ subroutine testOnly(cIntPtr) bind(c, name="testOnly")
+ use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_f_pointer
+ implicit none
+ type(c_ptr), value :: cIntPtr
+ integer(c_int), pointer :: f90IntPtr
+
+ call c_f_pointer(cIntPtr, f90IntPtr)
+
+ ! f90IntPtr coming in has value of -11; this will make it -12
+ f90IntPtr = f90IntPtr - 1
+ if(f90IntPtr .ne. -12) then
+ call abort()
+ endif
+ end subroutine testOnly
+end module testOnlyClause
--- /dev/null
+! { dg-do compile }
+! this is to simply test that the various ways the use statement can
+! appear are handled by the compiler, since i did a special treatment
+! of the intrinsic iso_c_binding module. note: if the user doesn't
+! provide the 'intrinsic' keyword, the compiler will check for a user
+! provided module by the name of iso_c_binding before using the
+! intrinsic one. --Rickett, 09.26.06
+module use_stmt_0
+ ! this is an error because c_ptr_2 does not exist
+ use, intrinsic :: iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" }
+end module use_stmt_0
+
+module use_stmt_1
+ ! this is an error because c_ptr_2 does not exist
+ use iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" }
+end module use_stmt_1
+
+module use_stmt_2
+ ! works fine
+ use, intrinsic :: iso_c_binding, only: c_ptr
+end module use_stmt_2
+
+module use_stmt_3
+ ! works fine
+ use iso_c_binding, only: c_ptr
+end module use_stmt_3
+
+module use_stmt_4
+ ! works fine
+ use, intrinsic :: iso_c_binding
+end module use_stmt_4
+
+module use_stmt_5
+ ! works fine
+ use iso_c_binding
+end module use_stmt_5
+
+module use_stmt_6
+ ! hmm, is this an error? if so, it's not being caught...
+ ! --Rickett, 09.13.06
+ use, intrinsic :: iso_c_binding, only: c_int, c_int
+end module use_stmt_6
+
+module use_stmt_7
+ ! hmm, is this an error? if so, it's not being caught...
+ ! --Rickett, 09.13.06
+ use iso_c_binding, only: c_int, c_int
+end module use_stmt_7
+
--- /dev/null
+! { dg-do compile }
+! Length of character dummy variable with VALUE attribute:
+! - must be initialization expression or omitted
+! - C interoperable: must be initialization expression of length one
+! or omitted
+!
+! Contributed by Tobias Burnus
+program x
+ implicit none
+ character(10) :: c1,c10
+ c1 = 'H'
+ c10 = 'Main'
+ call foo1(c1)
+ call foo2(c1)
+ call foo3(c10)
+ call foo4(c10)
+ call bar1(c1)
+ call bar2(c1)
+ call bar3(c10)
+ call bar4(c10)
+
+contains
+
+ subroutine foo1(a)
+ character :: a
+ value :: a
+ end subroutine foo1
+
+ subroutine foo2(a)
+ character(1) :: a
+ value :: a
+ end subroutine foo2
+
+ subroutine foo3(a)
+ character(10) :: a
+ value :: a
+ end subroutine foo3
+
+ subroutine foo4(a) ! { dg-error "VALUE attribute must have constant length" }
+ character(*) :: a
+ value :: a
+ end subroutine foo4
+
+ subroutine bar1(a)
+ use iso_c_binding, only: c_char
+ character(kind=c_char) :: a
+ value :: a
+ end subroutine bar1
+
+ subroutine bar2(a)
+ use iso_c_binding, only: c_char
+ !character(kind=c_char,len=1) :: a
+ character(1,kind=c_char) :: a
+ value :: a
+ end subroutine bar2
+
+ subroutine bar3(a) ! { dg-error "VALUE attribute must have length one" }
+ use iso_c_binding, only: c_char
+ character(kind=c_char,len=10) :: a
+ value :: a
+ end subroutine bar3
+
+ subroutine bar4(a) ! { dg-error "VALUE attribute must have constant length" }
+ use iso_c_binding, only: c_char
+ character(kind=c_char,len=*) :: a
+ value :: a
+ end subroutine bar4
+end program x
--- /dev/null
+! { dg-do run }
+program valueTests
+ integer :: myInt
+ interface
+ subroutine mySub(myInt)
+ integer, value :: myInt
+ end subroutine mySub
+ end interface
+
+ myInt = 10
+
+ call mySub(myInt)
+ ! myInt should be unchanged since pass-by-value
+ if(myInt .ne. 10) then
+ call abort ()
+ endif
+end program valueTests
+
+subroutine mySub(myInt)
+ integer, value :: myInt
+ myInt = 11
+end subroutine mySub
+
--- /dev/null
+! { dg-do run }
+program value_tests_f03
+ use, intrinsic :: iso_c_binding
+ real(c_double) :: myDouble
+ interface
+ subroutine value_test(myDouble) bind(c)
+ use, intrinsic :: iso_c_binding
+ real(c_double), value :: myDouble
+ end subroutine value_test
+ end interface
+
+ myDouble = 9.0d0
+ call value_test(myDouble)
+end program value_tests_f03
+
+subroutine value_test(myDouble) bind(c)
+ use, intrinsic :: iso_c_binding
+ real(c_double), value :: myDouble
+ interface
+ subroutine mySub(myDouble)
+ use, intrinsic :: iso_c_binding
+ real(c_double), value :: myDouble
+ end subroutine mySub
+ end interface
+
+ myDouble = 10.0d0
+
+ call mySub(myDouble)
+end subroutine value_test
+
+subroutine mySub(myDouble)
+ use, intrinsic :: iso_c_binding
+ real(c_double), value :: myDouble
+
+ myDouble = 11.0d0
+end subroutine mySub
+
+2007-07-01 Christopher D. Rickett <crickett@lanl.gov>
+
+ * Makefile.in: Add support for iso_c_generated_procs.c and
+ iso_c_binding.c.
+ * Makefile.am: Ditto.
+ * intrinsics/iso_c_generated_procs.c: New file containing helper
+ functions.
+ * intrinsics/iso_c_binding.c: Ditto.
+ * intrinsics/iso_c_binding.h: New file
+ * gfortran.map: Include the __iso_c_binding_c_* functions.
+ * libgfortran.h: define GFC_NUM_RANK_BITS.
+
2007-07-01 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/32239
intrinsics/getlog.c \
intrinsics/getXid.c \
intrinsics/hostnm.c \
-intrinsics/kill.c \
intrinsics/ierrno.c \
intrinsics/ishftc.c \
+intrinsics/iso_c_generated_procs.c \
+intrinsics/iso_c_binding.c \
+intrinsics/kill.c \
intrinsics/link.c \
intrinsics/malloc.c \
intrinsics/mvbits.c \
reshape_generic.lo reshape_packed.lo selected_int_kind.lo \
selected_real_kind.lo stat.lo symlnk.lo system_clock.lo \
time.lo transpose_generic.lo umask.lo unlink.lo \
- unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo
+ unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
+ iso_c_generated_procs.lo iso_c_binding.lo
am__objects_33 =
am__objects_34 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
intrinsics/getlog.c \
intrinsics/getXid.c \
intrinsics/hostnm.c \
-intrinsics/kill.c \
intrinsics/ierrno.c \
intrinsics/ishftc.c \
+intrinsics/iso_c_generated_procs.c \
+intrinsics/iso_c_binding.c \
+intrinsics/kill.c \
intrinsics/link.c \
intrinsics/malloc.c \
intrinsics/mvbits.c \
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ishftc.lo `test -f 'intrinsics/ishftc.c' || echo '$(srcdir)/'`intrinsics/ishftc.c
+iso_c_generated_procs.lo: intrinsics/iso_c_generated_procs.c
+ $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iso_c_generated_procs.lo `test -f 'intrinsics/iso_c_generated_procs.c' || echo '$(srcdir)/'`intrinsics/iso_c_generated_procs.c
+
+iso_c_binding.lo: intrinsics/iso_c_binding.c
+ $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o iso_c_binding.lo `test -f 'intrinsics/iso_c_binding.c' || echo '$(srcdir)/'`intrinsics/iso_c_binding.c
+
+kill.lo: intrinsics/kill.c
+ $(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o kill.lo `test -f 'intrinsics/kill.c' || echo '$(srcdir)/'`intrinsics/kill.c
+
link.lo: intrinsics/link.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT link.lo -MD -MP -MF "$(DEPDIR)/link.Tpo" -c -o link.lo `test -f 'intrinsics/link.c' || echo '$(srcdir)/'`intrinsics/link.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/link.Tpo" "$(DEPDIR)/link.Plo"; else rm -f "$(DEPDIR)/link.Tpo"; exit 1; fi
_gfortran_unpack0_char;
_gfortran_unpack1;
_gfortran_unpack1_char;
+ __iso_c_binding_c_associated_1;
+ __iso_c_binding_c_associated_2;
+ __iso_c_binding_c_f_pointer;
+ __iso_c_binding_c_f_pointer_d0;
+ __iso_c_binding_c_f_pointer_i1;
+ __iso_c_binding_c_f_pointer_i2;
+ __iso_c_binding_c_f_pointer_i4;
+ __iso_c_binding_c_f_pointer_i8;
+ __iso_c_binding_c_f_pointer_i16;
+ __iso_c_binding_c_f_pointer_r4;
+ __iso_c_binding_c_f_pointer_r8;
+ __iso_c_binding_c_f_pointer_r10;
+ __iso_c_binding_c_f_pointer_r16;
+ __iso_c_binding_c_f_pointer_u0;
+ __iso_c_binding_c_f_procpointer;
+ __iso_c_binding_c_funloc;
+ __iso_c_binding_c_loc;
local:
*;
};
--- /dev/null
+/* Implementation of the ISO_C_BINDING library helper functions.
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Contributed by Christopher Rickett.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public
+License along with libgfortran; see the file COPYING. If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+
+/* Implement the functions and subroutines provided by the intrinsic
+ iso_c_binding module. */
+
+#include <stdlib.h>
+
+#include "libgfortran.h"
+#include "iso_c_binding.h"
+
+
+/* Set the fields of a Fortran pointer descriptor to point to the
+ given C address. It uses c_f_pointer_u0 for the common
+ fields, and will set up the information necessary if this C address
+ is to an array (i.e., offset, type, element size). The parameter
+ c_ptr_in represents the C address to have Fortran point to. The
+ parameter f_ptr_out is the Fortran pointer to associate with the C
+ address. The parameter shape is a one-dimensional array of integers
+ specifying the upper bound(s) of the array pointed to by the given C
+ address, if applicable. The shape parameter is optional in Fortran,
+ which will cause it to come in here as NULL. The parameter type is
+ the type of the data being pointed to (i.e.,libgfortran.h). The
+ elem_size parameter is the size, in bytes, of the data element being
+ pointed to. If the address is for an array, then the size needs to
+ be the size of a single element (i.e., for an array of doubles, it
+ needs to be the number of bytes for the size of one double). */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape,
+ int type, int elemSize)
+{
+ if (shape != NULL)
+ {
+ f_ptr_out->offset = 0;
+
+ /* Set the necessary dtype field for all pointers. */
+ f_ptr_out->dtype = 0;
+
+ /* Put in the element size. */
+ f_ptr_out->dtype = f_ptr_out->dtype | (elemSize << GFC_DTYPE_SIZE_SHIFT);
+
+ /* Set the data type (e.g., GFC_DTYPE_INTEGER). */
+ f_ptr_out->dtype = f_ptr_out->dtype | (type << GFC_DTYPE_TYPE_SHIFT);
+ }
+
+ /* Use the generic version of c_f_pointer to set common fields. */
+ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
+}
+
+
+/* A generic function to set the common fields of all descriptors, no
+ matter whether it's to a scalar or an array. Fields set are: data,
+ and if appropriate, rank, offset, dim[*].lbound, dim[*].ubound, and
+ dim[*].stride. Parameter shape is a rank 1 array of integers
+ containing the upper bound of each dimension of what f_ptr_out
+ points to. The length of this array must be EXACTLY the rank of
+ what f_ptr_out points to, as required by the draft (J3/04-007). If
+ f_ptr_out points to a scalar, then this parameter will be NULL. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ int i = 0;
+ int shapeSize = 0;
+
+ GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;
+
+ if (shape != NULL)
+ {
+ f_ptr_out->offset = 0;
+ shapeSize = 0;
+
+ /* shape's length (rank of the output array) */
+ shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
+ for (i = 0; i < shapeSize; i++)
+ {
+ /* Lower bound is 1, as specified by the draft. */
+ f_ptr_out->dim[i].lbound = 1;
+ f_ptr_out->dim[i].ubound = ((int *) (shape->data))[i];
+ }
+
+ /* Set the offset and strides.
+ offset is (sum of (dim[i].lbound * dim[i].stride) for all
+ dims) the -1 means we'll back the data pointer up that much
+ perhaps we could just realign the data pointer and not change
+ the offset? */
+ f_ptr_out->dim[0].stride = 1;
+ f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
+ for (i = 1; i < shapeSize; i++)
+ {
+ f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
+ - f_ptr_out->dim[i-1].lbound;
+ f_ptr_out->offset += f_ptr_out->dim[i].lbound
+ * f_ptr_out->dim[i].stride;
+ }
+
+ f_ptr_out->offset *= -1;
+
+ /* All we know is the rank, so set it, leaving the rest alone.
+ Make NO assumptions about the state of dtype coming in! If we
+ shift right by TYPE_SHIFT bits we'll throw away the existing
+ rank. Then, shift left by the same number to shift in zeros
+ and or with the new rank. */
+ f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
+ << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
+ }
+}
+
+
+/* Sets the descriptor fields for a Fortran pointer to a derived type,
+ using c_f_pointer_u0 for the majority of the work. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Set the common fields. */
+ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
+
+ /* Preserve the size and rank bits, but reset the type. */
+ if (shape != NULL)
+ {
+ f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK);
+ f_ptr_out->dtype = f_ptr_out->dtype
+ | (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT);
+ }
+}
+
+
+/* This function will change, once there is an actual f90 type for the
+ procedure pointer. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_procpointer) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out)
+{
+ GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in;
+}
+
+
+/* Test if the given c_ptr is associated or not. This function is
+ called if the user only supplied one c_ptr parameter to the
+ c_associated function. The second argument is optional, and the
+ Fortran compiler will resolve the function to this version if only
+ one arg was given. Associated here simply means whether or not the
+ c_ptr is NULL or not. */
+
+GFC_LOGICAL_4
+ISO_C_BINDING_PREFIX (c_associated_1) (void *c_ptr_in_1)
+{
+ if (c_ptr_in_1 != NULL)
+ return 1;
+ else
+ return 0;
+}
+
+
+/* Test if the two c_ptr arguments are associated with one another.
+ This version of the c_associated function is called if the user
+ supplied two c_ptr args in the Fortran source. According to the
+ draft standard (J3/04-007), if c_ptr_in_1 is NULL, the two pointers
+ are NOT associated. If c_ptr_in_1 is non-NULL and it is not equal
+ to c_ptr_in_2, then either c_ptr_in_2 is NULL or is associated with
+ another address; either way, the two pointers are not associated
+ with each other then. */
+
+GFC_LOGICAL_4
+ISO_C_BINDING_PREFIX (c_associated_2) (void *c_ptr_in_1, void *c_ptr_in_2)
+{
+ /* Since we have the second arg, if it doesn't equal the first,
+ return false; true otherwise. However, if the first one is null,
+ then return false; otherwise compare the two ptrs for equality. */
+ if (c_ptr_in_1 == NULL)
+ return 0;
+ else if (c_ptr_in_1 != c_ptr_in_2)
+ return 0;
+ else
+ return 1;
+}
+
+
+/* Return the C address of the given Fortran allocatable object. */
+
+void *
+ISO_C_BINDING_PREFIX (c_loc) (void *f90_obj)
+{
+ if (f90_obj == NULL)
+ {
+ runtime_error ("C_LOC: Attempt to get C address for Fortran object"
+ " that has not been allocated or associated");
+ abort ();
+ }
+
+ /* The "C" address should be the address of the object in Fortran. */
+ return f90_obj;
+}
+
+
+/* Return the C address of the given Fortran procedure. This
+ routine is expected to return a derived type of type C_FUNPTR,
+ which represents the C address of the given Fortran object. */
+
+void *
+ISO_C_BINDING_PREFIX (c_funloc) (void *f90_obj)
+{
+ if (f90_obj == NULL)
+ {
+ runtime_error ("C_LOC: Attempt to get C address for Fortran object"
+ " that has not been allocated or associated");
+ abort ();
+ }
+
+ /* The "C" address should be the address of the object in Fortran. */
+ return f90_obj;
+}
--- /dev/null
+/* Copyright (C) 2007 Free Software Foundation, Inc.
+ Contributed by Christopher Rickett.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING. If not, write to
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+
+/* Declarations for ISO_C_BINDING library helper functions. */
+
+#ifndef GFOR_ISO_C_BINDING_H
+#define GFOR_ISO_C_BINDING_H
+
+#include "libgfortran.h"
+
+typedef struct c_ptr
+{
+ void *c_address;
+}
+c_ptr_t;
+
+typedef struct c_funptr
+{
+ void *c_address;
+}
+c_funptr_t;
+
+#define ISO_C_BINDING_PREFIX(a) __iso_c_binding_##a
+
+void ISO_C_BINDING_PREFIX(c_f_pointer)(void *, gfc_array_void *,
+ const array_t *, int, int);
+
+/* The second param here may change, once procedure pointers are
+ implemented. */
+void ISO_C_BINDING_PREFIX(c_f_procpointer) (void *, gfc_array_void *);
+
+GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_1) (void *);
+GFC_LOGICAL_4 ISO_C_BINDING_PREFIX(c_associated_2) (void *, void *);
+
+void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *,
+ const array_t *);
+void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *,
+ const array_t *);
+
+void *ISO_C_BINDING_PREFIX(c_loc) (void *);
+void *ISO_C_BINDING_PREFIX(c_funloc) (void *);
+
+#endif
--- /dev/null
+/* Implementation of the ISO_C_BINDING library helper generated functions.
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Contributed by Christopher Rickett.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 2 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public
+License along with libgfortran; see the file COPYING. If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+
+#include "libgfortran.h"
+#include "iso_c_binding.h"
+
+
+/* TODO: This file needs to be finished so that a function is provided
+ for all possible type/kind combinations! */
+
+#ifdef HAVE_GFC_INTEGER_1
+void ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_INTEGER_2
+void ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_INTEGER_4
+void ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_INTEGER_8
+void ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_INTEGER_16
+void ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_REAL_4
+void ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_REAL_8
+void ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+#ifdef HAVE_GFC_REAL_10
+void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+#ifdef HAVE_GFC_REAL_16
+void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *, gfc_array_void *,
+ const array_t *);
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_1
+/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C
+ address, 'c_ptr_in'. The Fortran pointer is of type integer and
+ kind=1. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given C
+ address, if applicable. 'shape' is an optional parameter in
+ Fortran, so if the user does not provide it, it will come in here
+ as NULL. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an integer(kind=1). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_INTEGER,
+ (int) sizeof (GFC_INTEGER_1));
+}
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_2
+/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C
+ address, 'c_ptr_in'. The Fortran pointer is of type integer and
+ kind=2. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given C
+ address, if applicable. 'shape' is an optional parameter in
+ Fortran, so if the user does not provide it, it will come in here
+ as NULL. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an integer(kind=2). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_INTEGER,
+ (int) sizeof (GFC_INTEGER_2));
+}
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_4
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type integer and
+ kind=4. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an integer(kind=4). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_INTEGER,
+ (int) sizeof (GFC_INTEGER_4));
+}
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_8
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type integer and
+ kind=8. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an integer(kind=8). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_INTEGER,
+ (int) sizeof (GFC_INTEGER_8));
+}
+#endif
+
+
+#ifdef HAVE_GFC_INTEGER_16
+/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C
+ address, 'c_ptr_in'. The Fortran pointer is of type integer and
+ kind=16. The function c_f_pointer is used to set up the pointer
+ descriptor. shape is a one-dimensional array of integers
+ specifying the upper bounds of the array pointed to by the given C
+ address, if applicable. 'shape' is an optional parameter in
+ Fortran, so if the user does not provide it, it will come in here
+ as NULL. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an integer(kind=16). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_INTEGER,
+ (int) sizeof (GFC_INTEGER_16));
+}
+#endif
+
+
+#ifdef HAVE_GFC_REAL_4
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=4. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an real(kind=4). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_REAL,
+ (int) sizeof (GFC_REAL_4));
+}
+#endif
+
+
+#ifdef HAVE_GFC_REAL_8
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=8. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an real(kind=8). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_REAL,
+ (int) sizeof (GFC_REAL_8));
+}
+#endif
+
+
+#ifdef HAVE_GFC_REAL_10
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=10. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an real(kind=10). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_REAL,
+ (int) sizeof (GFC_REAL_10));
+}
+#endif
+
+
+#ifdef HAVE_GFC_REAL_16
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+ address, c_ptr_in. The Fortran pointer is of type real and
+ kind=16. The function c_f_pointer is used to set up the pointer
+ descriptor. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *c_ptr_in,
+ gfc_array_void *f_ptr_out,
+ const array_t *shape)
+{
+ /* Here we have an real(kind=16). */
+ ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+ (int) GFC_DTYPE_REAL,
+ (int) sizeof (GFC_REAL_16));
+}
+#endif
must free memory allocated for the filename string. */
char *
-filename_from_unit (int n)
+filename_from_unit (int unit_number)
{
char *filename;
- gfc_unit *u;
- int c;
-
- /* Find the unit. */
- u = unit_root;
- while (u != NULL)
- {
- c = compare (n, u->unit_number);
- if (c < 0)
- u = u->left;
- if (c > 0)
- u = u->right;
- if (c == 0)
- break;
- }
-
- /* Get the filename. */
+ gfc_unit *u = NULL;
+ u = find_unit (unit_number);
if (u != NULL)
{
filename = (char *) get_mem (u->file_len + 1);
}
else
return (char *) NULL;
-}
-
+}
\ No newline at end of file
#define GFC_DTYPE_TYPE_MASK 0x38
#define GFC_DTYPE_SIZE_SHIFT 6
+/* added for f03. --Rickett, 02.28.06 */
+#define GFC_NUM_RANK_BITS 3
+
enum
{
GFC_DTYPE_UNKNOWN = 0,
projects / platform / upstream / gcc.git / commitdiff