+2009-06-28 Tobias Burnus <burnus@net-b.de>
+ Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+ PR fortran/34112
+ * symbol.c (gfc_add_ext_attribute): New function.
+ (gfc_get_sym_tree): New argument allow_subroutine.
+ (gfc_get_symbol,gfc_get_ha_sym_tree,gen_cptr_param,gen_fptr_param
+ gen_shape_param,generate_isocbinding_symbol): Use it.
+ * decl.c (find_special): New argument allow_subroutine.
+ (add_init_expr_to_sym,add_hidden_procptr_result,attr_decl1,
+ match_procedure_in_type,gfc_match_final_decl): Use it.
+ (gfc_match_gcc_attributes): New function.
+ * gfortran.texi (Mixed-Language Programming): New section
+ "GNU Fortran Compiler Directives".
+ * gfortran.h (ext_attr_t): New struct.
+ (symbol_attributes): Use it.
+ (gfc_add_ext_attribute): New prototype.
+ (gfc_get_sym_tree): Update pototype.
+ * expr.c (gfc_check_pointer_assign): Check whether call
+ convention is the same.
+ * module.c (import_iso_c_binding_module, create_int_parameter,
+ use_iso_fortran_env_module): Update gfc_get_sym_tree call.
+ * scanner.c (skip_gcc_attribute): New function.
+ (skip_free_comments,skip_fixed_comments): Use it.
+ (gfc_next_char_literal): Support !GCC$ lines.
+ * resolve.c (check_host_association): Update
+ gfc_get_sym_tree call.
+ * match.c (gfc_match_sym_tree,gfc_match_call): Update
+ gfc_get_sym_tree call.
+ * trans-decl.c (add_attributes_to_decl): New function.
+ (gfc_get_symbol_decl,get_proc_pointer_decl,
+ gfc_get_extern_function_decl,build_function_decl: Use it.
+ * match.h (gfc_match_gcc_attributes): Add prototype.
+ * parse.c (decode_gcc_attribute): New function.
+ (next_free,next_fixed): Support !GCC$ lines.
+ * primary.c (match_actual_arg,check_for_implicit_index,
+ gfc_match_rvalue,gfc_match_rvalue): Update
+ gfc_get_sym_tree call.
+
2009-06-28 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gfortran.h: Define HAVE_mpc_pow.
(located in another namespace). */
static int
-find_special (const char *name, gfc_symbol **result)
+find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
{
gfc_state_data *s;
+ gfc_symtree *st;
int i;
- i = gfc_get_symbol (name, NULL, result);
+ i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
if (i == 0)
- goto end;
+ {
+ *result = st ? st->n.sym : NULL;
+ goto end;
+ }
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
gfc_expr *init;
init = *initp;
- if (find_special (name, &sym))
+ if (find_special (name, &sym, false))
return FAILURE;
attr = sym->attr;
{
gfc_symtree *stree;
if (case1)
- gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+ gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
else if (case2)
{
gfc_symtree *st2;
- gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+ gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
st2->n.sym = stree->n.sym;
}
if (m != MATCH_YES)
goto cleanup;
- if (find_special (name, &sym))
+ if (find_special (name, &sym, false))
return MATCH_ERROR;
var_locus = gfc_current_locus;
}
stree->n.tb = tb;
- if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
+ if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
return MATCH_ERROR;
gfc_set_sym_referenced (tb->u.specific->n.sym);
return MATCH_YES;
}
+
+
+const ext_attr_t ext_attr_list[] = {
+ { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
+ { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
+ { "cdecl", EXT_ATTR_CDECL, "cdecl" },
+ { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
+ { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
+ { NULL, EXT_ATTR_LAST, NULL }
+};
+
+/* Match a !GCC$ ATTRIBUTES statement of the form:
+ !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
+ When we come here, we have already matched the !GCC$ ATTRIBUTES string.
+
+ TODO: We should support all GCC attributes using the same syntax for
+ the attribute list, i.e. the list in C
+ __attributes(( attribute-list ))
+ matches then
+ !GCC$ ATTRIBUTES attribute-list ::
+ Cf. c-parser.c's c_parser_attributes; the data can then directly be
+ saved into a TREE.
+
+ As there is absolutely no risk of confusion, we should never return
+ MATCH_NO. */
+match
+gfc_match_gcc_attributes (void)
+{
+ symbol_attribute attr;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ unsigned id;
+ gfc_symbol *sym;
+ match m;
+
+ gfc_clear_attr (&attr);
+ for(;;)
+ {
+ char ch;
+
+ if (gfc_match_name (name) != MATCH_YES)
+ return MATCH_ERROR;
+
+ for (id = 0; id < EXT_ATTR_LAST; id++)
+ if (strcmp (name, ext_attr_list[id].name) == 0)
+ break;
+
+ if (id == EXT_ATTR_LAST)
+ {
+ gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_add_ext_attribute (&attr, id, &gfc_current_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ gfc_gobble_whitespace ();
+ ch = gfc_next_ascii_char ();
+ if (ch == ':')
+ {
+ /* This is the successful exit condition for the loop. */
+ if (gfc_next_ascii_char () == ':')
+ break;
+ }
+
+ if (ch == ',')
+ continue;
+
+ goto syntax;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ goto syntax;
+
+ for(;;)
+ {
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ return m;
+
+ if (find_special (name, &sym, true))
+ return MATCH_ERROR;
+
+ sym->attr.ext_attr |= attr.ext_attr;
+
+ if (gfc_match_eos () == MATCH_YES)
+ break;
+
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
+ return MATCH_ERROR;
+}
rvalue->symtree->name, &rvalue->where) == FAILURE)
return FAILURE;
}
+
+ /* Ensure that the calling convention is the same. As other attributes
+ such as DLLEXPORT may differ, one explicitly only tests for the
+ calling conventions. */
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && lvalue->symtree->n.sym->attr.ext_attr
+ != rvalue->symtree->n.sym->attr.ext_attr)
+ {
+ symbol_attribute cdecl, stdcall, fastcall;
+ unsigned calls;
+
+ gfc_add_ext_attribute (&cdecl, (unsigned) EXT_ATTR_CDECL, NULL);
+ gfc_add_ext_attribute (&stdcall, (unsigned) EXT_ATTR_STDCALL, NULL);
+ gfc_add_ext_attribute (&fastcall, (unsigned) EXT_ATTR_FASTCALL, NULL);
+ calls = cdecl.ext_attr | stdcall.ext_attr | fastcall.ext_attr;
+
+ if ((calls & lvalue->symtree->n.sym->attr.ext_attr)
+ != (calls & rvalue->symtree->n.sym->attr.ext_attr))
+ {
+ gfc_error ("Mismatch in the procedure pointer assignment "
+ "at %L: mismatch in the calling convention",
+ &rvalue->where);
+ return FAILURE;
+ }
+ }
+
/* TODO: Enable interface check for PPCs. */
if (is_proc_ptr_comp (rvalue, NULL))
return SUCCESS;
that the list is initialized. */
extern CInteropKind_t c_interop_kinds_table[];
+
+/* Structure and list of supported extension attributes. */
+enum
+{
+ EXT_ATTR_DLLIMPORT = 0,
+ EXT_ATTR_DLLEXPORT,
+ EXT_ATTR_STDCALL,
+ EXT_ATTR_CDECL,
+ EXT_ATTR_FASTCALL,
+ EXT_ATTR_LAST, EXT_ATTR_NUM = EXT_ATTR_LAST
+};
+
+typedef struct
+{
+ const char *name;
+ unsigned id;
+ const char *middle_end_name;
+}
+ext_attr_t;
+
+extern const ext_attr_t ext_attr_list[];
+
/* Symbol attribute structure. */
typedef struct
{
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1;
+ /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
+ unsigned ext_attr:EXT_ATTR_NUM;
+
/* The namespace where the VOLATILE attribute has been set. */
struct gfc_namespace *volatile_ns;
}
void gfc_set_sym_referenced (gfc_symbol *);
gfc_try gfc_add_attribute (symbol_attribute *, locus *);
+gfc_try gfc_add_ext_attribute (symbol_attribute *, unsigned, locus *);
gfc_try gfc_add_allocatable (symbol_attribute *, locus *);
gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *);
gfc_try gfc_add_external (symbol_attribute *, locus *);
gfc_try verify_com_block_vars_c_interop (gfc_common_head *);
void generate_isocbinding_symbol (const char *, iso_c_binding_symbol, const char *);
gfc_symbol *get_iso_c_sym (gfc_symbol *, char *, char *, int);
-int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **);
+int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
int gfc_get_ha_symbol (const char *, gfc_symbol **);
int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
@menu
* Interoperability with C::
+* GNU Fortran Compiler Directives::
* Non-Fortran Main Program::
@end menu
dummy arguments. However, the TR has neither been approved nor implemented
in GNU Fortran; therefore, these features are not yet available.
+
+
+@node GNU Fortran Compiler Directives
+@section GNU Fortran Compiler Directives
+
+The Fortran standard standard describes how a conforming program shall
+behave; however, the exact implementation is not standardized. In order
+to allow the user to choose specific implementation details, compiler
+directives can be used to set attributes of variables and procedures
+which are not part of the standard. Whether a given attribute is
+supported and its exact effects depend on both the operating system and
+on the processor; see
+@ref{Top,,C Extensions,gcc,Using the GNU Compiler Collection (GCC)}
+for details.
+
+For procedures and procedure pointers, the following attributes can
+be used to change the calling convention:
+
+@itemize
+@item @code{CDECL} -- standard C calling convention
+@item @code{STDCALL} -- convention where the called procedure pops the stack
+@item @code{FASTCALL} -- part of the arguments are passed via registers
+instead using the stack
+@end itemize
+
+Besides changing the calling convention, the attributes also influence
+the decoration of the symbol name, e.g., by a leading underscore or by
+a trailing at-sign followed by the number of bytes on the stack. When
+assigning a procedure to a procedure pointer, both should use the same
+calling convention.
+
+On some systems, procedures and global variables (module variables and
+@code{COMMON} blocks) need special handling to be accessible when they
+are in a shared library. The following attributes are available:
+
+@itemize
+@item @code{DLLEXPORT} -- provide a global pointer to a pointer in the DLL
+@item @code{DLLIMPORT} -- reference the function or variable using a global pointer
+@end itemize
+
+The attributes are specified using the syntax
+
+@code{!GCC$ ATTRIBUTES} @var{attribute-list} @code{::} @var{variable-list}
+
+where in free-form source code only whitespace is allowed before @code{!GCC$}
+and in fixed-form source code @code{!GCC$}, @code{cGCC$} or @code{*GCC$} shall
+start in the first column.
+
+For procedures, the compiler directives shall be placed into the body
+of the procedure; for variables and procedure pointers, they shall be in
+the same declaration part as the variable or procedure pointer.
+
+
+
@node Non-Fortran Main Program
@section Non-Fortran Main Program
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
? MATCH_ERROR : MATCH_YES;
- if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
+ if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
return MATCH_ERROR;
return MATCH_YES;
{
/* ...create a symbol in this scope... */
if (sym->ns != gfc_current_ns
- && gfc_get_sym_tree (name, NULL, &st) == 1)
+ && gfc_get_sym_tree (name, NULL, &st, false) == 1)
return MATCH_ERROR;
if (sym != st->n.sym)
match gfc_match_allocatable (void);
match gfc_match_dimension (void);
match gfc_match_external (void);
+match gfc_match_gcc_attributes (void);
match gfc_match_import (void);
match gfc_match_intent (void);
match gfc_match_intrinsic (void);
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);
+ gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
+ false);
if (mod_symtree != NULL)
mod_sym = mod_symtree->n.sym;
gfc_error ("Symbol '%s' already declared", name);
}
- gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
sym->module = gfc_get_string (modname);
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
if (mod_symtree == NULL)
{
- gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
+ gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
gcc_assert (mod_symtree);
mod_sym = mod_symtree->n.sym;
return ST_NONE;
}
+static gfc_statement
+decode_gcc_attribute (void)
+{
+ locus old_locus;
+
+#ifdef GFC_DEBUG
+ gfc_symbol_state ();
+#endif
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+ old_locus = gfc_current_locus;
+
+ match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
+
+ /* All else has failed, so give up. See if any of the matchers has
+ stored an error message of some sort. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable GCC directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
#undef match
else if (c == '!')
{
/* Comments have already been skipped by the time we get here,
- except for OpenMP directives. */
- if (gfc_option.flag_openmp)
+ except for GCC attributes and OpenMP directives. */
+
+ gfc_next_ascii_char (); /* Eat up the exclamation sign. */
+ c = gfc_peek_ascii_char ();
+
+ if (c == 'g')
{
int i;
c = gfc_next_ascii_char ();
- for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == "!$omp"[i]);
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "gcc$"[i]);
+
+ gfc_gobble_whitespace ();
+ return decode_gcc_attribute ();
+
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
+ {
+ int i;
+
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "$omp"[i]);
gcc_assert (c == ' ' || c == '\t');
gfc_gobble_whitespace ();
return decode_omp_directive ();
}
- }
+ gcc_unreachable ();
+ }
+
if (at_bol && c == ';')
{
gfc_error_now ("Semicolon at %C needs to be preceded by statement");
break;
/* Comments have already been skipped by the time we get
- here, except for OpenMP directives. */
+ here, except for GCC attributes and OpenMP directives. */
+
case '*':
- if (gfc_option.flag_openmp)
+ c = gfc_next_char_literal (0);
+
+ if (TOLOWER (c) == 'g')
+ {
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert (TOLOWER (c) == "gcc$"[i]);
+
+ return decode_gcc_attribute ();
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
{
- for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
- gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
{
have a function argument. */
if (symtree == NULL)
{
- gfc_get_sym_tree (name, NULL, &symtree);
+ gfc_get_sym_tree (name, NULL, &symtree, false);
gfc_set_sym_referenced (symtree->n.sym);
}
else
&& !(*sym)->attr.use_assoc)
{
int i;
- i = gfc_get_sym_tree ((*sym)->name, NULL, st);
+ i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
if (i)
return MATCH_ERROR;
*sym = (*st)->n.sym;
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
&& !gfc_current_ns->has_import_set)
- i = gfc_get_sym_tree (name, NULL, &symtree);
+ i = gfc_get_sym_tree (name, NULL, &symtree, false);
else
i = gfc_get_ha_sym_tree (name, &symtree);
/* Give up, assume we have a function. */
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
sym = symtree->n.sym;
e->expr_type = EXPR_FUNCTION;
break;
generic_function:
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
}
/* Give the symbol a symtree in the right place! */
- gfc_get_sym_tree (sym->name, gfc_current_ns, &st);
+ gfc_get_sym_tree (sym->name, gfc_current_ns, &st, false);
st->n.sym = sym;
if (old_sym->attr.flavor == FL_PROCEDURE)
static gfc_file *file_head, *current_file;
-static int continue_flag, end_flag, openmp_flag;
+static int continue_flag, end_flag, openmp_flag, gcc_attribute_flag;
static int continue_count, continue_line;
static locus openmp_locus;
+static locus gcc_attribute_locus;
gfc_source_form gfc_current_form;
static gfc_linebuf *line_head, *line_tail;
}
+/* Return true if GCC$ was matched. */
+static bool
+skip_gcc_attribute (locus start)
+{
+ bool r = false;
+ char c;
+ locus old_loc = gfc_current_locus;
+
+ if ((c = next_char ()) == 'g' || c == 'G')
+ if ((c = next_char ()) == 'c' || c == 'C')
+ if ((c = next_char ()) == 'c' || c == 'C')
+ if ((c = next_char ()) == '$')
+ r = true;
+
+ if (r == false)
+ gfc_current_locus = old_loc;
+ else
+ {
+ gcc_attribute_flag = 1;
+ gcc_attribute_locus = old_loc;
+ gfc_current_locus = start;
+ }
+
+ return r;
+}
+
+
+
/* Comment lines are null lines, lines containing only blanks or lines
on which the first nonblank line is a '!'.
Return true if !$ openmp conditional compilation sentinel was
if (c == '!')
{
+ /* Keep the !GCC$ line. */
+ if (at_bol && skip_gcc_attribute (start))
+ return false;
+
/* If -fopenmp, we need to handle here 2 things:
1) don't treat !$omp as comments, but directives
2) handle OpenMP conditional compilation, where
if (openmp_flag && at_bol)
openmp_flag = 0;
+
+ gcc_attribute_flag = 0;
gfc_current_locus = start;
return false;
}
if (c == '!' || c == 'c' || c == 'C' || c == '*')
{
+ if (skip_gcc_attribute (start))
+ {
+ /* Canonicalize to *$omp. */
+ *start.nextc = '*';
+ return;
+ }
+
/* If -fopenmp, we need to handle here 2 things:
1) don't treat !$omp|c$omp|*$omp as comments, but directives
2) handle OpenMP conditional compilation, where
}
openmp_flag = 0;
+ gcc_attribute_flag = 0;
gfc_current_locus = start;
}
if (!in_string && c == '!')
{
+ if (gcc_attribute_flag
+ && memcmp (&gfc_current_locus, &gcc_attribute_locus,
+ sizeof (gfc_current_locus)) == 0)
+ goto done;
+
if (openmp_flag
&& memcmp (&gfc_current_locus, &openmp_locus,
sizeof (gfc_current_locus)) == 0)
}
+gfc_try
+gfc_add_ext_attribute (symbol_attribute *attr, unsigned 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)
{
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);
}
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
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
GFC_DECL_ASSIGN_ADDR (decl) = addr;
}
+
+static tree
+add_attributes_to_decl (symbol_attribute sym_attr, tree list)
+{
+ unsigned id;
+ tree attr;
+
+ for (id = 0; id < EXT_ATTR_NUM; id++)
+ if (sym_attr.ext_attr & (1 << id))
+ {
+ attr = build_tree_list (
+ get_identifier (ext_attr_list[id].middle_end_name),
+ NULL_TREE);
+ list = chainon (list, attr);
+ }
+
+ return list;
+}
+
+
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
{
tree decl;
tree length = NULL_TREE;
+ tree attributes;
int byref;
gcc_assert (sym->attr.referenced
&& !sym->attr.proc_pointer)
DECL_BY_REFERENCE (decl) = 1;
+ /* Add attributes to variables. Functions are handled elsewhere. */
+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+ decl_attributes (&decl, attributes, 0);
+
return decl;
}
get_proc_pointer_decl (gfc_symbol *sym)
{
tree decl;
+ tree attributes;
decl = sym->backend_decl;
if (decl)
TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
}
+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+ decl_attributes (&decl, attributes, 0);
+
return decl;
}
{
tree type;
tree fndecl;
+ tree attributes;
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+ decl_attributes (&fndecl, attributes, 0);
+
return fndecl;
}
static void
build_function_decl (gfc_symbol * sym)
{
- tree fndecl, type;
+ tree fndecl, type, attributes;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
+ attributes = add_attributes_to_decl (attr, NULL_TREE);
+ decl_attributes (&fndecl, attributes, 0);
+
/* Layout the function declaration and put it in the binding level
of the current function. */
pushdecl (fndecl);
+2009-06-28 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/34112
+ * gfortran.dg/compiler-directive_1.f90: New test.
+ * gfortran.dg/compiler-directive_2.f: New test.
+
2009-06-28 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gfortran.dg/integer_exponentiation_4.f90: Temporarily
--- /dev/null
+! { dg-do compile }
+!
+! PR fortran/34112
+!
+! Check for calling convention consitency
+! in procedure-pointer assignments.
+
+program test
+ interface
+ subroutine sub1()
+ end subroutine sub1
+ subroutine sub2()
+ !GCC$ ATTRIBUTES CDECL :: sub2
+ end subroutine sub2
+ subroutine sub3()
+ !GCC$ ATTRIBUTES STDCALL :: sub3
+ end subroutine sub3
+ subroutine sub4()
+!GCC$ ATTRIBUTES FASTCALL :: sub4
+ end subroutine sub4
+ end interface
+
+ !gcc$ attributes cdecl :: cdecl
+ !gcc$ attributes stdcall :: stdcall
+ procedure(), pointer :: ptr
+ procedure(), pointer :: cdecl
+ procedure(), pointer :: stdcall
+ procedure(), pointer :: fastcall
+ !gcc$ attributes fastcall :: fastcall
+
+ ! Valid:
+ ptr => sub1
+ cdecl => sub2
+ stdcall => sub3
+ fastcall => sub4
+
+ ! Invalid:
+ ptr => sub3 ! { dg-error "mismatch in the calling convention" }
+ ptr => sub4 ! { dg-error "mismatch in the calling convention" }
+ cdecl => sub3 ! { dg-error "mismatch in the calling convention" }
+ cdecl => sub4 ! { dg-error "mismatch in the calling convention" }
+ stdcall => sub1 ! { dg-error "mismatch in the calling convention" }
+ stdcall => sub2 ! { dg-error "mismatch in the calling convention" }
+ stdcall => sub4 ! { dg-error "mismatch in the calling convention" }
+ fastcall => sub1 ! { dg-error "mismatch in the calling convention" }
+ fastcall => sub2 ! { dg-error "mismatch in the calling convention" }
+ fastcall => sub3 ! { dg-error "mismatch in the calling convention" }
+end program
--- /dev/null
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-require-effective-target ilp32 }
+!
+! PR fortran/34112
+!
+! Check for calling convention consitency
+! in procedure-pointer assignments.
+!
+ subroutine test() ! { dg-error "fastcall and stdcall attributes are not compatible" }
+cGCC$ attributes stdcall, fastcall::test
+ end subroutine test
projects / gcc.git / commitdiff