This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Fortran] RFC: Patch to support STDCALL etc. (PR 34112)


Attached is the first version of a patch which allows to use

!GCC$ ATTRIBUTES attribute :: symbol-list

where attribute is one of:
- CDECL
- STDCALL
- FASTCALL
- DLLEXPORT
- DLLIMPORT

The effect of the attribute is target dependent. For instance,
using STDCALL on x86-64-linux will only produce a warning that
STDCALL is ignored. On x86-32-linux, the effect is that the
called procedure and not the calling procedure pops the stack.
And on x86-32-windows the stack effect is the same, but the
symbol also gets a @<n> attached (n = number of bytes to pop
from the stack).

CDECL, STDCALL and FASTCALL can be used for procedures and
procedure pointers, DLLIMPORT/DLLEXPORT for procedures and
global variables (common blocks, module variables). There is
no attempt made to ensure the attributes are used sensible,
in some cases the middle end gives a warning, but not always.

However, for procedure-pointer assignment, a rather strict
check has been implemented. In principle, CDECL is (usually)
compatible with "no attribute" -- except -mrtd is used;
in that case STDCALL is equivalent to "no attribute".
Thus, one could consider to change the error into a warning.
The proper check would operate on TREE and has therefore to
be placed into trans-expr.c.

As a near-term TODO, one should allow an attribute list
rather than a single attribute, e.g. "DLLEXPORT, STDCALL"
is a reasonable combination; currently, one has to use
two "!GNU$ ATTRIBUTES" statements.

A longer term TODO could be to support all GCC attributes,
including ALIAS, ALIGN, WEAK, ...

The attributes are only sensible together with BIND(C) as
otherwise the normal gfortran symbol names are used
(dressed according to target and calling convention). One
could also support !DEC$ but that will be a significant
work as some of attributes are handled slightly different,
the attributes are partially incompatible with BIND(C) and
the attributes are not well defined. Maybe a subset could
be useful together with a "-fdec-attributes" option?

The patch is based on FX's patch, but it has been significantly
extended, fixed and modified.

I have tested it lightly on x86-64-linux with -m64 (gives some
nice warnings) and -m32 (supports stdcall but has no mangling).
However, I would be happy if someone could test it on
Cygwin/Mingwin (with 32bit Windows). Or on every other system.
I am also looking forward to your comments.

Tobias
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 148690)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -809,19 +809,28 @@ duplicate_attr (const char *attr, locus
 }
 
 
+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_
 	}
 
       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_na
   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, g
 	}
     }
 
-  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 **hea
     c_ptr_in = "gfc_cptr__";
   else
     c_ptr_in = c_ptr_name;
-  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree);
+  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -3719,7 +3728,7 @@ gen_fptr_param (gfc_formal_arglist **hea
   if (f_ptr_name != NULL)
     f_ptr_out = f_ptr_name;
 
-  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree);
+  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -3766,7 +3775,7 @@ gen_shape_param (gfc_formal_arglist **he
   if (shape_param_name != NULL)
     shape_param = shape_param_name;
 
-  gfc_get_sym_tree (shape_param, ns, &param_symtree);
+  gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
   if (param_symtree != NULL)
     param_sym = param_symtree->n.sym;
   else
@@ -4061,7 +4070,7 @@ generate_isocbinding_symbol (const char
     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
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(Revision 148690)
+++ gcc/fortran/decl.c	(Arbeitskopie)
@@ -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 *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 *s
     {
       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;
 	}
@@ -5538,7 +5542,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;
@@ -7374,7 +7378,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);
 
@@ -7617,3 +7621,82 @@ 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)
+{ 
+  char attr[GFC_MAX_SYMBOL_LEN + 1];
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  unsigned id;
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_match_name (attr) != MATCH_YES)
+    return MATCH_ERROR;
+
+  for (id = 0; id < EXT_ATTR_LAST; id++)
+    if (strcmp (attr, ext_attr_list[id].name) == 0)
+      break;
+
+  if (id == EXT_ATTR_LAST)
+    {
+      gfc_error ("Unknow attribute in !GCC$ ATTRIBUTES statement at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match (" ::") != MATCH_YES)
+    return MATCH_ERROR;
+
+  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;
+      
+      if (gfc_add_ext_attribute (&sym->attr, id, &gfc_current_locus)
+	  == FAILURE)
+	return MATCH_ERROR;
+
+      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;
+}
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi	(Revision 148690)
+++ gcc/fortran/gfortran.texi	(Arbeitskopie)
@@ -1851,6 +1851,7 @@ c
 
 @menu
 * Interoperability with C::
+* Attributes such as STDCALL::
 * Non-Fortran Main Program::
 @end menu
 
@@ -2097,6 +2098,56 @@ C-interoperable @code{OPTIONAL} and for
 dummy arguments. However, the TR has neither been approved nor implemented
 in GNU Fortran; therefore, these features are not yet available.
 
+
+@node Attributes such as STDCALL
+@section Attributes such as STDCALL
+
+The Fortran standard -- as the C standard -- describe how a conforming
+program shall behave; however, the exact implementation is not
+standarized. In order to allow the user to choose the implementation
+choices, attributes were invented which can be used for functions
+and variables. However, not only the suported attributes but also the
+syntax is compiler-dependent. GNU Fortran currently supports for
+procedures and procedure pointers the following calling-conventions
+attributes
+
+@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 ensure that
+the symbols are properly decorated, e.g. by a leading underscore or by
+a trailing at-sign followed by the number of bytes on the stack. It is
+recommended to use the default calling convention of the system. When
+assigning a procedure to a procedure pointer, both should have the same
+calling convention. Note: The effect of the option is target dependent
+(processor and operating system). For details,
+@ref{Top,,gcc,C Extensions,Function Attributes}).
+
+Additionally, for procedures and for global variables (module variables
+and @code{COMMON} blocks), the following attributes are supported
+
+@itemize
+@item @code{DLLEXPORT}
+@item @code{DLLIMPORT}
+@end itemize
+
+For details, @ref{Top,,gcc,C Extensions,Variable Attributes}.
+
+The attributes are specified using the syntax
+
+@code{!GNU$ ATTRIBUTES} @var{attribute} @code{::} @var{variable-list}
+
+where in free-form Fortran only whitespace is allowed before @code{!GNU$}
+and in fixed-form Fortran @code{!GNU$}, @code{cGNU$} or @code{*GNU$} shall
+start in the first column. The procedure attributes have to be specified
+in the associated procedure body, the variable attributes in the same
+declaration part
+
+
 @node Non-Fortran Main Program
 @section Non-Fortran Main Program
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(Revision 148690)
+++ gcc/fortran/gfortran.h	(Arbeitskopie)
@@ -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;
 }
@@ -2285,6 +2310,7 @@ gfc_try gfc_set_default_type (gfc_symbol
 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 *);
@@ -2365,7 +2391,7 @@ gfc_try verify_bind_c_derived_type (gfc_
 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 **);
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 148690)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -3177,6 +3177,32 @@ gfc_check_pointer_assign (gfc_expr *lval
 			      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: missmatch in the calling convention",
+			 &rvalue->where);
+	  return FAILURE;
+	    }
+	}
+
       /* TODO: Enable interface check for PPCs.  */
       if (is_proc_ptr_comp (rvalue, NULL))
 	return SUCCESS;
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(Revision 148690)
+++ gcc/fortran/module.c	(Arbeitskopie)
@@ -4977,7 +4977,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;
@@ -5065,7 +5066,7 @@ create_int_parameter (const char *name,
 	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);
@@ -5106,7 +5107,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;
 
Index: gcc/fortran/scanner.c
===================================================================
--- gcc/fortran/scanner.c	(Revision 148690)
+++ gcc/fortran/scanner.c	(Arbeitskopie)
@@ -63,9 +63,10 @@ static gfc_directorylist *include_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)
 }
 
 
+/* Skip a  */
+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)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 148690)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -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)
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 148690)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -674,7 +674,7 @@ gfc_match_sym_tree (gfc_symtree **matche
     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)
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(Revision 148690)
+++ gcc/fortran/trans-decl.c	(Arbeitskopie)
@@ -980,6 +980,21 @@ gfc_add_assign_aux_vars (gfc_symbol * sy
   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 }
 
+
+static tree
+add_attributes_to_decl (symbol_attribute attr, tree list)
+{
+  unsigned id;
+
+  for (id = 0; id < EXT_ATTR_NUM; id++)
+    if (attr.ext_attr & (1 << id))
+      list = tree_cons (get_identifier (ext_attr_list[id].middle_end_name),
+			list, NULL_TREE);
+
+  return list;
+}
+
+
 /* Return the decl for a gfc_symbol, create it if it doesn't already
    exist.  */
 
@@ -988,6 +1003,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 +1203,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 +1243,7 @@ static tree
 get_proc_pointer_decl (gfc_symbol *sym)
 {
   tree decl;
+  tree attributes;
 
   decl = sym->backend_decl;
   if (decl)
@@ -1266,6 +1287,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 +1301,7 @@ gfc_get_extern_function_decl (gfc_symbol
 {
   tree type;
   tree fndecl;
+  tree attributes;
   gfc_expr e;
   gfc_intrinsic_sym *isym;
   gfc_expr argexpr;
@@ -1439,6 +1464,9 @@ gfc_get_extern_function_decl (gfc_symbol
   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 +1478,7 @@ gfc_get_extern_function_decl (gfc_symbol
 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 +1585,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);
@@ -3835,7 +3866,11 @@ add_argument_checking (stmtblock_t *bloc
 
 	/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
 	   string lengths must match exactly.  Otherwise, it is only required
-	   that the actual string length is *at least* the expected one.  */
+	   that the actual string length is *at least* the expected one.
+	   Sequence association allows for a mismatch of the string length
+	   if the actual argument is (part of) an array, but only if the
+	   dummy argument is an array. (See "Sequence association" in
+	   Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
 	if (fsym->attr.pointer || fsym->attr.allocatable
 	    || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
 	  {
@@ -3843,6 +3878,8 @@ add_argument_checking (stmtblock_t *bloc
 	    message = _("Actual string length does not match the declared one"
 			" for dummy argument '%s' (%ld/%ld)");
 	  }
+	else if (fsym->as && fsym->as->rank != 0)
+	  continue;
 	else
 	  {
 	    comparison = LT_EXPR;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(Revision 148690)
+++ gcc/fortran/match.h	(Arbeitskopie)
@@ -160,6 +160,7 @@ void gfc_set_constant_character_len (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);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(Revision 148690)
+++ gcc/fortran/parse.c	(Arbeitskopie)
@@ -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')
 		{
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 148690)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -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 **
       && !(*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;

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]