int length;
match m;
- *deferred = false;
+ *deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
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. */
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
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)
{
"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->ns->proc_name->name,
sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS)
gfc_error ("Variable '%s' at %L is a dummy argument to the "
until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
- && !sym->attr.proc_pointer
+ && !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
return FAILURE;
int k;
gfc_expr* lower;
gfc_expr* e;
-
+
lower = sym->as->lower[dim];
if (lower->expr_type != EXPR_CONSTANT)
{
? init
: gfc_copy_expr (init),
&init->where);
-
+
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
if (!procptr)
gfc_resolve_expr (*init);
-
+
if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
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. */
if (cp_as != NULL)
{
goto cleanup;
}
}
-
+
if (check_function_name (name) == FAILURE)
{
m = MATCH_ERROR;
if (gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C") == FAILURE)
return MATCH_ERROR;
-
+
return match_old_style_init (name);
}
{
if (gfc_matching_function)
{
- /* The function kind expression might include use associated or
+ /* The function kind expression might include use associated or
imported parameters and try again after the specification
expressions..... */
if (gfc_match_char (')') != MATCH_YES)
ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type;
}
-
+
gfc_free_expr (e);
e = NULL;
if (n != MATCH_YES && gfc_matching_function)
{
/* The expression might include use-associated or imported
- parameters and try again after the specification
+ parameters and try again after the specification
expressions. */
gfc_free_expr (e);
gfc_undo_symbols ();
if (m == MATCH_ERROR)
gfc_current_locus = where;
-
+
/* Return what we know from the test(s). */
return m;
if (gfc_match (" kind =") == MATCH_YES)
{
m = match_char_kind (&kind, &is_iso_c);
-
+
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
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.
+ 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_symbol *upe;
gfc_symtree *st;
ts->type = BT_CLASS;
- gfc_find_symbol ("$tar", gfc_current_ns, 1, &upe);
+ gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
if (upe == NULL)
{
- upe = gfc_new_symbol ("$tar", gfc_current_ns);
- st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar");
+ upe = gfc_new_symbol ("STAR", gfc_current_ns);
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe;
gfc_set_sym_referenced (upe);
upe->refs++;
}
else
{
- st = gfc_find_symtree (gfc_current_ns->sym_root, "$tar");
+ st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR");
if (st == NULL)
- st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar");
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe;
upe->refs++;
}
/* Defer association of the derived type until the end of the
specification block. However, if the derived type can be
- found, add it to the typespec. */
+ found, add it to the typespec. */
if (gfc_matching_function)
{
ts->u.derived = NULL;
|| gfc_current_ns->has_import_set;
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
- {
+ {
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
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, "VALUE attribute "
"at %C")
there is more than one argument (num_idents), it is an error. */
static gfc_try
-set_binding_label (const char **dest_label, const char *sym_name,
+set_binding_label (const char **dest_label, const char *sym_name,
int num_idents)
{
if (num_idents > 1 && has_name_equals)
if (sym_name != NULL && has_name_equals == 0)
*dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
}
-
+
return SUCCESS;
}
gfc_try retval = SUCCESS;
curr_sym = com_block->head;
-
+
/* Make sure we have at least one symbol. */
if (curr_sym == NULL)
return retval;
/* 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);
+ } while (curr_sym != NULL);
return retval;
}
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 (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
{
if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
{
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. */
&(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)
set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
{
gfc_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. */
set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
{
gfc_try retval = SUCCESS;
-
+
/* destLabel, common name, typespec (which may have binding label). */
- if (set_binding_label (&com_block->binding_label, com_block->name,
+ if (set_binding_label (&com_block->binding_label, com_block->name,
num_idents)
!= SUCCESS)
return FAILURE;
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;
"attribute specification statement at %C");
return FAILURE;
}
-
+
/* Save the current identifier and look for more. */
do
{
/* 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 || com_block != NULL)
{
if (tmp_sym != NULL)
{
!= SUCCESS)
return FAILURE;
}
-
+
/* Look to see if we have another identifier. */
tmp_sym = NULL;
if (gfc_match_eos () == MATCH_YES)
/* Try and match a BIND(C) attribute specification statement. */
-
+
match
gfc_match_bind_c_stmt (void)
{
gfc_typespec *ts;
ts = ¤t_ts;
-
+
/* This may not be necessary. */
gfc_clear_ts (ts);
/* Clear the temporary binding label holder. */
int elem;
num_idents_on_line = 0;
-
+
m = gfc_match_decl_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
/* Initialize to having found nothing. */
found_match = MATCH_NO;
- is_bind_c = MATCH_NO;
+ is_bind_c = MATCH_NO;
is_result = MATCH_NO;
/* Get the next char to narrow between result and bind(c). */
}
else
/* This should only be MATCH_ERROR. */
- found_match = is_result;
+ found_match = is_result;
break;
case 'b':
/* Look for bind(c) first. */
== FAILURE)
return MATCH_ERROR;
}
-
+
return found_match;
}
return MATCH_ERROR;
}
/* Set binding label for BIND(C). */
- if (set_binding_label (&sym->binding_label, sym->name, num)
+ if (set_binding_label (&sym->binding_label, sym->name, num)
!= SUCCESS)
return MATCH_ERROR;
}
locus old_loc;
match m;
match suffix_match;
- match found_match; /* Status returned by match func. */
+ match found_match; /* Status returned by match func. */
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
{
/* 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;
gfc_error_now ("BIND(C) attribute at %L can only be used for "
"variables or common blocks", &gfc_current_locus);
}
-
+
/* Check what next non-whitespace character is so we can tell if there
is the required parens if we have a BIND(C). */
gfc_gobble_whitespace ();
is the required parens if we have a BIND(C). */
gfc_gobble_whitespace ();
peek_char = gfc_peek_ascii_char ();
-
+
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
== FAILURE)
return MATCH_ERROR;
}
-
+
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_SUBROUTINE);
match
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{
- /* binding label, if exists */
+ /* binding label, if exists */
const char* binding_label = NULL;
match double_quote;
match single_quote;
- /* Initialize the flag that specifies whether we encountered a NAME=
+ /* Initialize the flag that specifies whether we encountered a NAME=
specifier or not. */
has_name_equals = 0;
"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)
{
m = MATCH_ERROR;
goto cleanup;
}
-
+
var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */
goto cleanup;
}
}
-
+
if (sym->ts.type == BT_CLASS
&& gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE)
{
if (sym->attr.cray_pointee && sym->as != NULL)
{
/* Fix the array spec. */
- m = gfc_mod_pointee_as (sym->as);
+ m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR)
goto cleanup;
}
{
gfc_free_array_spec (as);
as = NULL;
- }
+ }
if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
return MATCH_ERROR;
gfc_free_array_spec (as);
return MATCH_ERROR;
}
-
+
as = NULL;
-
+
if (cpte->as != NULL)
{
/* Fix array spec. */
m = gfc_mod_pointee_as (cpte->as);
if (m == MATCH_ERROR)
return m;
- }
-
+ }
+
/* Point the Pointee at the Pointer. */
cpte->cp_pointer = cptr;
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Expected \")\" at %C");
- return MATCH_ERROR;
+ return MATCH_ERROR;
}
m = gfc_match_char (',');
if (m != MATCH_YES)
done = true; /* Stop searching for more declarations. */
}
-
+
if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
|| gfc_match_eos () != MATCH_YES)
{
{
gfc_clear_attr (¤t_attr);
current_attr.pointer = 1;
-
+
return attr_decl ();
}
}
for(;;)
{
- /* VOLATILE is special because it can be added to host-associated
+ /* VOLATILE is special because it can be added to host-associated
symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1);
switch (m)
for(;;)
{
- /* ASYNCHRONOUS is special because it can be added to host-associated
+ /* ASYNCHRONOUS is special because it can be added to host-associated
symbols locally. */
m = gfc_match_symbol (&sym, 1);
switch (m)
}
else
gfc_current_locus = old_locus;
-
+
for (;;)
{
bool last = false;
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
-
+
if (extended && !sym->components)
{
gfc_component *p;
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
-
+
/* Set extension level. */
if (extended->attr.extension == 255)
{
}
-/* Cray Pointees can be declared as:
+/* Cray Pointees can be declared as:
pointer (ipt, a (n,m,...,*)) */
match
}
-/* Match the enum definition statement, here we are trying to match
- the first line of enum definition statement.
+/* Match the enum definition statement, here we are trying to match
+ the first line of enum definition statement.
Returns MATCH_YES if match is found. */
match
gfc_match_enum (void)
{
match m;
-
+
m = gfc_match_eos ();
if (m != MATCH_YES)
return m;
return MATCH_ERROR;
}
- /* Match the binding names. */
+ /* Match the binding names. */
for(num=1;;num++)
{
m = gfc_match_name (name);
false))
return MATCH_ERROR;
gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
-
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
/* Match the binding name; depending on type (operator / generic) format
it for future error messages into bind_name. */
-
+
m = gfc_match_generic_spec (&op_type, name, &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
case INTERFACE_GENERIC:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
-
+
case INTERFACE_USER_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
break;
-
+
case INTERFACE_INTRINSIC_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
gfc_op2string (op));
gfc_error ("Expected '=>' at %C");
goto error;
}
-
+
/* Try to find existing GENERIC binding with this name / for this operator;
if there is something, check that it is another GENERIC and then extend
it rather than building a new node. Otherwise, create it and put it
break;
}
-
+
case INTERFACE_INTRINSIC_OP:
ns->tb_op[op] = tb;
break;
if (!gfc_is_whitespace (c) && c != ':')
return MATCH_NO;
}
-
+
if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
if (gfc_current_form == FORM_FIXED)
MATCH_NO. */
match
gfc_match_gcc_attributes (void)
-{
+{
symbol_attribute attr;
char name[GFC_MAX_SYMBOL_LEN + 1];
unsigned id;
if (find_special (name, &sym, true))
return MATCH_ERROR;
-
+
sym->attr.ext_attr |= attr.ext_attr;
if (gfc_match_eos () == MATCH_YES)
projects / platform / upstream / gcc.git / commitdiff