*intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
*intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
*allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
- *private = "PRIVATE", *recursive = "RECURSIVE",
+ *privat = "PRIVATE", *recursive = "RECURSIVE",
*in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
- *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
+ *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
*function = "FUNCTION", *subroutine = "SUBROUTINE",
*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", *is_protected = "PROTECTED",
*is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
static const char *threadprivate = "THREADPRIVATE";
if (attr->optional)
a1 = optional;
if (attr->access == ACCESS_PRIVATE)
- a1 = private;
+ a1 = privat;
if (attr->access == ACCESS_PUBLIC)
- a1 = public;
+ a1 = publik;
if (attr->intent != INTENT_UNKNOWN)
a1 = intent;
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
- case FL_PROCEDURE:
case FL_DERIVED:
case FL_PARAMETER:
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
+ case FL_PROCEDURE:
+ if (attr->proc_pointer)
+ break;
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+
case FL_VARIABLE:
case FL_NAMELIST:
default:
goto conflict;
}
- conf (protected, intrinsic)
- conf (protected, external)
- conf (protected, in_common)
+ conf (is_protected, intrinsic)
+ conf (is_protected, external)
+ conf (is_protected, in_common)
conf (volatile_, intrinsic)
conf (volatile_, external)
conf (procedure, allocatable)
conf (procedure, dimension)
conf (procedure, intrinsic)
- conf (procedure, protected)
+ conf (procedure, is_protected)
conf (procedure, target)
conf (procedure, value)
conf (procedure, volatile_)
conf (procedure, entry)
- /* TODO: Implement procedure pointers. */
- if (attr->procedure && attr->pointer)
- {
- gfc_error ("Fortran 2003: Procedure pointers at %L are "
- "not yet implemented in gfortran", where);
- return FAILURE;
- }
a1 = gfc_code2string (flavors, attr->flavor);
conf2 (dummy);
conf2 (volatile_);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (external);
conf2 (intrinsic);
if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
{
- a2 = attr->access == ACCESS_PUBLIC ? public : private;
+ a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
name, where);
return FAILURE;
break;
case FL_PROCEDURE:
- conf2 (intent);
+ if (!attr->proc_pointer)
+ conf2 (intent);
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
conf2 (subroutine);
conf2 (entry);
conf2 (pointer);
- conf2 (protected);
+ conf2 (is_protected);
conf2 (target);
conf2 (dummy);
conf2 (in_common);
return FAILURE;
}
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, where);
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, where);
}
if (check_used (attr, name, where))
return FAILURE;
- if (attr->protected)
+ if (attr->is_protected)
{
if (gfc_notify_std (GFC_STD_LEGACY,
"Duplicate PROTECTED attribute specified at %L",
return FAILURE;
}
- attr->protected = 1;
+ attr->is_protected = 1;
return check_conflict (attr, name, where);
}
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
- if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
+ if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
goto fail;
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
return SUCCESS;
lp = lp->right;
}
- lp = gfc_getmem (sizeof (gfc_st_label));
+ lp = XCNEW (gfc_st_label);
lp->value = labelno;
lp->defined = ST_LABEL_UNKNOWN;
gfc_intrinsic_op in;
int i;
- ns = gfc_getmem (sizeof (gfc_namespace));
+ ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
ns->finalizers = NULL;
{
gfc_symtree *st;
- st = gfc_getmem (sizeof (gfc_symtree));
+ st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
gfc_insert_bbt (root, st, compare_symtree);
st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
- uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
+ uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
uop->ns = gfc_current_ns;
{
gfc_symbol *p;
- p = gfc_getmem (sizeof (gfc_symbol));
+ p = XCNEW (gfc_symbol);
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
if (sym->new || sym->old_symbol != NULL)
return;
- sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
+ sym->old_symbol = XCNEW (gfc_symbol);
*(sym->old_symbol) = *sym;
sym->tlink = changed_syms;
if (s != NULL)
return s;
- s = gfc_getmem (sizeof (gfc_gsymbol));
+ s = XCNEW (gfc_gsymbol);
s->type = GSYM_UNKNOWN;
s->name = gfc_get_string (name);
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name)
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
- param_sym->attr.pointer = 1;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
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))
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr");
-
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_shape_param (&head, &tail,
- (const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
- }
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
projects / gcc.git / blobdiff