if (!proc->attr.contained || proc->result->attr.implicit_type)
return;
- if (proc->result->ts.type == BT_UNKNOWN)
+ if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
{
if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
== SUCCESS)
}
+gfc_try
+gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
+ locus *where ATTRIBUTE_UNUSED)
+{
+ attr->ext_attr |= 1 << ext_attr;
+ return SUCCESS;
+}
+
+
/* Called from decl.c (attr_decl1) to check attributes, when declared
separately. */
gfc_try
gfc_add_attribute (symbol_attribute *attr, locus *where)
{
-
if (check_used (attr, NULL, where))
return FAILURE;
return check_conflict (attr, NULL, where);
}
+
gfc_try
gfc_add_allocatable (symbol_attribute *attr, locus *where)
{
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
{
sym_flavor flavor;
+ bt type;
if (where == NULL)
where = &gfc_current_locus;
- if (sym->ts.type != BT_UNKNOWN)
+ if (sym->result)
+ type = sym->result->ts.type;
+ else
+ type = sym->ts.type;
+
+ if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
+ type = sym->ns->proc_name->ts.type;
+
+ if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
{
- const char *msg = "Symbol '%s' at %L already has basic type of %s";
- if (!(sym->ts.type == ts->type && sym->attr.result)
- || gfc_notification_std (GFC_STD_GNU) == ERROR
- || pedantic)
- {
- gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
- return FAILURE;
- }
- if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
- gfc_basic_typename (sym->ts.type)) == FAILURE)
- return FAILURE;
- if (gfc_option.warn_surprising)
- gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
+ gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
+ where, gfc_basic_typename (type));
+ return FAILURE;
}
if (sym->attr.procedure && sym->ts.interface)
{
- gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where,
- gfc_basic_typename (ts->type));
+ gfc_error ("Procedure '%s' at %L may not have basic type of %s",
+ sym->name, where, gfc_basic_typename (ts->type));
return FAILURE;
}
{
int is_proc_lang_bind_spec;
+ dest->ext_attr = src->ext_attr;
+
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
{
gfc_namespace *ns;
gfc_typespec *ts;
- gfc_intrinsic_op in;
+ int in;
int i;
ns = XCNEW (gfc_namespace);
ns->parent = parent;
for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
- ns->operator_access[in] = ACCESS_UNKNOWN;
+ {
+ ns->operator_access[in] = ACCESS_UNKNOWN;
+ ns->tb_op[in] = NULL;
+ }
/* Initialize default implicit types. */
for (i = 'a'; i <= 'z'; i++)
So if the return value is nonzero, then an error was issued. */
int
-gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
+gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
+ bool allow_subroutine)
{
gfc_symtree *st;
gfc_symbol *p;
}
p = st->n.sym;
-
if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
- && !(ns->proc_name
- && ns->proc_name->attr.if_source == IFSRC_IFBODY
- && (ns->has_import_set || p->attr.imported)))
+ && !(allow_subroutine && p->attr.subroutine)
+ && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && (ns->has_import_set || p->attr.imported)))
{
/* Symbol is from another namespace. */
gfc_error ("Symbol '%s' at %C has already been host associated",
gfc_symtree *st;
int i;
- i = gfc_get_sym_tree (name, ns, &st);
+ i = gfc_get_sym_tree (name, ns, &st, false);
if (i != 0)
return i;
}
}
- return gfc_get_sym_tree (name, gfc_current_ns, result);
+ return gfc_get_sym_tree (name, gfc_current_ns, result, false);
}
static void
free_uop_tree (gfc_symtree *uop_tree)
{
-
if (uop_tree == NULL)
return;
free_uop_tree (uop_tree->right);
gfc_free_interface (uop_tree->n.uop->op);
-
gfc_free (uop_tree->n.uop);
gfc_free (uop_tree);
}
}
+/* Create a new gfc_charlen structure and add it to a namespace. */
+
+gfc_charlen*
+gfc_new_charlen (gfc_namespace *ns)
+{
+ gfc_charlen *cl;
+ cl = gfc_get_charlen ();
+ cl->next = ns->cl_list;
+ ns->cl_list = cl;
+ return cl;
+}
+
+
/* Free the charlen list from cl to end (end is not freed).
Free the whole list if end is NULL. */
gfc_free_namespace (gfc_namespace *ns)
{
gfc_namespace *p, *q;
- gfc_intrinsic_op i;
+ int i;
if (ns == NULL)
return;
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_tb_tree (ns->tb_sym_root);
+ free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
retval = FAILURE;
}
+ if (curr_comp->attr.proc_pointer != 0)
+ {
+ gfc_error ("Procedure pointer component '%s' at %L cannot be 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->attr.allocatable != 0)
c_ptr_in = "gfc_cptr__";
else
c_ptr_in = c_ptr_name;
- gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
+ gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
if (f_ptr_name != NULL)
f_ptr_out = f_ptr_name;
- gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
+ gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
if (shape_param_name != NULL)
shape_param = shape_param_name;
- gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
+ gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
if (param_symtree != NULL)
param_sym = param_symtree->n.sym;
else
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.intent = curr_arg->intent;
formal_arg->sym->attr.flavor = FL_VARIABLE;
formal_arg->sym->attr.dummy = 1;
+ if (formal_arg->sym->ts.type == BT_CHARACTER)
+ formal_arg->sym->ts.cl = gfc_new_charlen (gfc_current_ns);
+
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
anything other than NULL. */
}
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *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);
+ /* TODO: gfc_current_ns->proc_name = dest;*/
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ dest->formal = head;
+ dest->attr.if_source = IFSRC_DECL;
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
/* 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
return;
/* Create the sym tree in the current ns. */
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
if (tmp_symtree)
tmp_sym = tmp_symtree->n.sym;
else
}
-/* Find a type-bound procedure by name for a derived-type (looking recursively
- through the super-types). */
+/* General worker function to find either a type-bound procedure or a
+ type-bound user operator. */
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess)
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, bool uop)
{
gfc_symtree* res;
+ gfc_symtree* root;
+
+ /* Set correct symbol-root. */
+ gcc_assert (derived->f2k_derived);
+ root = (uop ? derived->f2k_derived->tb_uop_root
+ : derived->f2k_derived->tb_sym_root);
/* Set default to failure. */
if (t)
*t = FAILURE;
/* Try to find it in the current type's namespace. */
- gcc_assert (derived->f2k_derived);
- res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
+ res = gfc_find_symtree (root, name);
if (res && res->n.tb)
{
/* We found one. */
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, t, name, noaccess);
+
+ return find_typebound_proc_uop (super_type, t, name, noaccess, uop);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+ (looking recursively through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, false);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, true);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+ super-type hierarchy. */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+ gfc_intrinsic_op op, bool noaccess)
+{
+ gfc_typebound_proc* res;
+
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
+ /* Try to find it in the current type's namespace. */
+ if (derived->f2k_derived)
+ res = derived->f2k_derived->tb_op[op];
+ else
+ res = NULL;
+
+ /* Check access. */
+ if (res)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' of '%s' is PRIVATE at %C",
+ gfc_op2string (op), derived->name);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+
+ return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess);
}
/* Nothing found. */
return result;
}
-
OSDN Git Service
