From 36b0a1b039d86aea9b9684db3b8edaf09a150285 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 28 Jun 2009 17:56:41 +0000 Subject: [PATCH] 2009-06-28 Tobias Burnus Francois-Xavier Coudert 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 Tobias Burnus PR fortran/34112 * gfortran.dg/compiler-directive_1.f90: New test. * gfortran.dg/compiler-directive_2.f: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149036 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 39 +++++++ gcc/fortran/decl.c | 118 +++++++++++++++++++-- gcc/fortran/expr.c | 26 +++++ gcc/fortran/gfortran.h | 28 ++++- gcc/fortran/gfortran.texi | 55 ++++++++++ gcc/fortran/match.c | 4 +- gcc/fortran/match.h | 1 + gcc/fortran/module.c | 7 +- gcc/fortran/parse.c | 74 +++++++++++-- gcc/fortran/primary.c | 10 +- gcc/fortran/resolve.c | 2 +- gcc/fortran/scanner.c | 50 ++++++++- gcc/fortran/symbol.c | 33 +++--- gcc/fortran/trans-decl.c | 38 ++++++- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/compiler-directive_1.f90 | 48 +++++++++ gcc/testsuite/gfortran.dg/compiler-directive_2.f | 11 ++ 17 files changed, 507 insertions(+), 43 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/compiler-directive_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/compiler-directive_2.f diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 61196df9ba8..3357fde6790 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,42 @@ +2009-06-28 Tobias Burnus + Francois-Xavier Coudert + + 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 * gfortran.h: Define HAVE_mpc_pow. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 179d1e2e61a..c3760a81c0b 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -696,14 +696,18 @@ syntax: (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) @@ -1204,7 +1208,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) gfc_expr *init; init = *initp; - if (find_special (name, &sym)) + if (find_special (name, &sym, false)) return FAILURE; attr = sym->attr; @@ -4103,11 +4107,11 @@ add_hidden_procptr_result (gfc_symbol *sym) { 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; } @@ -5539,7 +5543,7 @@ attr_decl1 (void) 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; @@ -7375,7 +7379,7 @@ match_procedure_in_type (void) } 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); @@ -7618,3 +7622,101 @@ gfc_match_final_decl (void) 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; +} diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 2049fa400b1..b1d572ec231 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3186,6 +3186,32 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) 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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 80991689770..67127419b00 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -619,6 +619,28 @@ CInteropKind_t; 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 { @@ -704,6 +726,9 @@ 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; } @@ -2299,6 +2324,7 @@ gfc_try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); 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 *); @@ -2379,7 +2405,7 @@ gfc_try verify_bind_c_derived_type (gfc_symbol *); 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 **); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index ab69c0aa3a6..f0b1c675922 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1851,6 +1851,7 @@ c @menu * Interoperability with C:: +* GNU Fortran Compiler Directives:: * Non-Fortran Main Program:: @end menu @@ -2097,6 +2098,60 @@ C-interoperable @code{OPTIONAL} and for assumed-rank and assumed-type 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 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index cf558b54e1b..1cc6e5fdfa2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -674,7 +674,7 @@ gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) 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; @@ -2711,7 +2711,7 @@ gfc_match_call (void) { /* ...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) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 81bf4213289..b6c09241693 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -160,6 +160,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int); 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); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 15b1b5da6c8..7e6e8ff93c4 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -5006,7 +5006,8 @@ import_iso_c_binding_module (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; @@ -5094,7 +5095,7 @@ create_int_parameter (const char *name, int value, const char *modname, 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); @@ -5135,7 +5136,7 @@ use_iso_fortran_env_module (void) 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; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 0b2cbf3cb0e..da16c2b570f 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -566,6 +566,34 @@ decode_omp_directive (void) 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 @@ -637,21 +665,39 @@ next_free (void) 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"); @@ -709,12 +755,22 @@ next_fixed (void) 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') { diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 1a03165fcbe..cc6cada545c 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1388,7 +1388,7 @@ match_actual_arg (gfc_expr **result) 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 @@ -2365,7 +2365,7 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) && !(*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; @@ -2423,7 +2423,7 @@ gfc_match_rvalue (gfc_expr **result) 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); @@ -2782,7 +2782,7 @@ gfc_match_rvalue (gfc_expr **result) /* 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; @@ -2815,7 +2815,7 @@ gfc_match_rvalue (gfc_expr **result) 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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9ea2a2d24d3..697c1ab5070 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4400,7 +4400,7 @@ check_host_association (gfc_expr *e) } /* 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) diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index cff988367cd..58422907d36 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -63,9 +63,10 @@ static gfc_directorylist *include_dirs, *intrinsic_modules_dirs; 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; @@ -663,6 +664,34 @@ gfc_define_undef_line (void) } +/* 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 @@ -694,6 +723,10 @@ skip_free_comments (void) 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 @@ -752,6 +785,8 @@ skip_free_comments (void) if (openmp_flag && at_bol) openmp_flag = 0; + + gcc_attribute_flag = 0; gfc_current_locus = start; return false; } @@ -806,6 +841,13 @@ skip_fixed_comments (void) 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 @@ -917,6 +959,7 @@ skip_fixed_comments (void) } openmp_flag = 0; + gcc_attribute_flag = 0; gfc_current_locus = start; } @@ -963,6 +1006,11 @@ restart: 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) diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 89cff6567bd..0c1a2fdaad0 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -809,19 +809,28 @@ duplicate_attr (const char *attr, locus *where) } +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) { @@ -2539,7 +2548,8 @@ save_symbol_data (gfc_symbol *sym) 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; @@ -2580,11 +2590,10 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result) } 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", @@ -2609,7 +2618,7 @@ gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) 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; @@ -2651,7 +2660,7 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) } } - return gfc_get_sym_tree (name, gfc_current_ns, result); + return gfc_get_sym_tree (name, gfc_current_ns, result, false); } @@ -3653,7 +3662,7 @@ gen_cptr_param (gfc_formal_arglist **head, 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 @@ -3719,7 +3728,7 @@ gen_fptr_param (gfc_formal_arglist **head, 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 @@ -3766,7 +3775,7 @@ gen_shape_param (gfc_formal_arglist **head, 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 @@ -4115,7 +4124,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, 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 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 091d3946852..d64c3fae3c9 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -980,6 +980,26 @@ gfc_add_assign_aux_vars (gfc_symbol * sym) 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. */ @@ -988,6 +1008,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) { tree decl; tree length = NULL_TREE; + tree attributes; int byref; gcc_assert (sym->attr.referenced @@ -1187,6 +1208,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !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; } @@ -1223,6 +1248,7 @@ static tree get_proc_pointer_decl (gfc_symbol *sym) { tree decl; + tree attributes; decl = sym->backend_decl; if (decl) @@ -1266,6 +1292,9 @@ get_proc_pointer_decl (gfc_symbol *sym) 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; } @@ -1277,6 +1306,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) { tree type; tree fndecl; + tree attributes; gfc_expr e; gfc_intrinsic_sym *isym; gfc_expr argexpr; @@ -1439,6 +1469,9 @@ gfc_get_extern_function_decl (gfc_symbol * sym) 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; } @@ -1450,7 +1483,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) 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; @@ -1557,6 +1590,9 @@ build_function_decl (gfc_symbol * sym) 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index aa693ce4c34..ce26ed95043 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2009-06-28 Tobias Burnus + + 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 * gfortran.dg/integer_exponentiation_4.f90: Temporarily diff --git a/gcc/testsuite/gfortran.dg/compiler-directive_1.f90 b/gcc/testsuite/gfortran.dg/compiler-directive_1.f90 new file mode 100644 index 00000000000..75f28dcc928 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/compiler-directive_1.f90 @@ -0,0 +1,48 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/compiler-directive_2.f b/gcc/testsuite/gfortran.dg/compiler-directive_2.f new file mode 100644 index 00000000000..fcb1657b4ea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/compiler-directive_2.f @@ -0,0 +1,11 @@ +! { 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 -- 2.11.0