Skip to content

R
riscv-gcc-1
Commit f5acf0f2 by Paul Thomas
Options

re PR fortran/55868 (gfortran generates for CLASS(*) __m_MOD___vtab__$tar on… 

re PR fortran/55868 (gfortran generates for CLASS(*)   __m_MOD___vtab__$tar on NO_DOLLAR_IN_LABEL systems)

2013-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55868
	* class.c (get_unique_type_string): Change $tar to STAR and
	replace sprintf by strcpy where there is no formatting.
	* decl.c (gfc_match_decl_type_spec): Change $tar to STAR.

2013-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/55868
	* gfortran.dg/unlimited_polymorphic_8.f90: Update
	scan-tree-dump-times for foo.0.x._vptr to deal with change from
	$tar to STAR.

From-SVN: r195124
parent 90229b5d
Showing with 105 additions and 91 deletions
gcc/fortran/ChangeLog
2013-01-08 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55868
* class.c (get_unique_type_string): Change $tar to STAR and
replace sprintf by strcpy where there is no formatting.
* decl.c (gfc_match_decl_type_spec): Change $tar to STAR.
2013-01-09 Mikael Morin <mikael@gcc.gnu.org> 2013-01-09 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/47203 PR fortran/47203
......
gcc/fortran/class.c
...@@ -460,9 +460,9 @@ get_unique_type_string (char *string, gfc_symbol *derived) ...@@ -460,9 +460,9 @@ get_unique_type_string (char *string, gfc_symbol *derived)
{ {
char dt_name[GFC_MAX_SYMBOL_LEN+1]; char dt_name[GFC_MAX_SYMBOL_LEN+1];
if (derived->attr.unlimited_polymorphic) if (derived->attr.unlimited_polymorphic)
sprintf (dt_name, "%s", "$tar"); strcpy (dt_name, "STAR");
else else
sprintf (dt_name, "%s", derived->name); strcpy (dt_name, derived->name);
dt_name[0] = TOUPPER (dt_name[0]); dt_name[0] = TOUPPER (dt_name[0]);
if (derived->attr.unlimited_polymorphic) if (derived->attr.unlimited_polymorphic)
sprintf (string, "_%s", dt_name); sprintf (string, "_%s", dt_name);
......
gcc/fortran/decl.c
...@@ -737,7 +737,7 @@ match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) ...@@ -737,7 +737,7 @@ match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
int length; int length;
match m; match m;
*deferred = false; *deferred = false;
m = gfc_match_char ('*'); m = gfc_match_char ('*');
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
...@@ -988,7 +988,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) ...@@ -988,7 +988,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
Don't repeat the checks here. */ Don't repeat the checks here. */
if (sym->attr.implicit_type) if (sym->attr.implicit_type)
return SUCCESS; return SUCCESS;
/* For subroutines or functions that are passed to a BIND(C) procedure, /* For subroutines or functions that are passed to a BIND(C) procedure,
they're interoperable if they're BIND(C) and their params are all they're interoperable if they're BIND(C) and their params are all
interoperable. */ interoperable. */
...@@ -999,7 +999,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) ...@@ -999,7 +999,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
gfc_error_now ("Procedure '%s' at %L must have the BIND(C) " gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
"attribute to be C interoperable", sym->name, "attribute to be C interoperable", sym->name,
&(sym->declared_at)); &(sym->declared_at));
return FAILURE; return FAILURE;
} }
else else
...@@ -1012,7 +1012,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) ...@@ -1012,7 +1012,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
sym->common_block); sym->common_block);
} }
} }
/* See if we've stored a reference to a procedure that owns sym. */ /* See if we've stored a reference to a procedure that owns sym. */
if (sym->ns != NULL && sym->ns->proc_name != NULL) if (sym->ns != NULL && sym->ns->proc_name != NULL)
{ {
...@@ -1028,7 +1028,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) ...@@ -1028,7 +1028,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
"BIND(C) procedure '%s' but is not C interoperable " "BIND(C) procedure '%s' but is not C interoperable "
"because derived type '%s' is not C interoperable", "because derived type '%s' is not C interoperable",
sym->name, &(sym->declared_at), sym->name, &(sym->declared_at),
sym->ns->proc_name->name, sym->ns->proc_name->name,
sym->ts.u.derived->name); sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS) else if (sym->ts.type == BT_CLASS)
gfc_error ("Variable '%s' at %L is a dummy argument to the " gfc_error ("Variable '%s' at %L is a dummy argument to the "
...@@ -1350,7 +1350,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) ...@@ -1350,7 +1350,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
until later for derived type variables and procedure pointers. */ until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
&& !sym->attr.proc_pointer && !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, NULL, init) == FAILURE) && gfc_check_assign_symbol (sym, NULL, init) == FAILURE)
return FAILURE; return FAILURE;
...@@ -1436,7 +1436,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) ...@@ -1436,7 +1436,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
int k; int k;
gfc_expr* lower; gfc_expr* lower;
gfc_expr* e; gfc_expr* e;
lower = sym->as->lower[dim]; lower = sym->as->lower[dim];
if (lower->expr_type != EXPR_CONSTANT) if (lower->expr_type != EXPR_CONSTANT)
{ {
...@@ -1498,7 +1498,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) ...@@ -1498,7 +1498,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
? init ? init
: gfc_copy_expr (init), : gfc_copy_expr (init),
&init->where); &init->where);
array->shape = gfc_get_shape (sym->as->rank); array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++) for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]); spec_dimen_size (sym->as, n, &array->shape[n]);
...@@ -1759,7 +1759,7 @@ match_pointer_init (gfc_expr **init, int procptr) ...@@ -1759,7 +1759,7 @@ match_pointer_init (gfc_expr **init, int procptr)
if (!procptr) if (!procptr)
gfc_resolve_expr (*init); gfc_resolve_expr (*init);
if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
"initialization at %C") == FAILURE) "initialization at %C") == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -1919,7 +1919,7 @@ variable_decl (int elem) ...@@ -1919,7 +1919,7 @@ variable_decl (int elem)
sym->ts.is_c_interop = current_ts.is_c_interop; sym->ts.is_c_interop = current_ts.is_c_interop;
sym->ts.is_iso_c = current_ts.is_iso_c; sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES; m = MATCH_YES;
/* Check to see if we have an array specification. */ /* Check to see if we have an array specification. */
if (cp_as != NULL) if (cp_as != NULL)
{ {
...@@ -2002,7 +2002,7 @@ variable_decl (int elem) ...@@ -2002,7 +2002,7 @@ variable_decl (int elem)
goto cleanup; goto cleanup;
} }
} }
if (check_function_name (name) == FAILURE) if (check_function_name (name) == FAILURE)
{ {
m = MATCH_ERROR; m = MATCH_ERROR;
...@@ -2023,7 +2023,7 @@ variable_decl (int elem) ...@@ -2023,7 +2023,7 @@ variable_decl (int elem)
if (gfc_notify_std (GFC_STD_GNU, "Old-style " if (gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C") == FAILURE) "initialization at %C") == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
return match_old_style_init (name); return match_old_style_init (name);
} }
...@@ -2218,7 +2218,7 @@ kind_expr: ...@@ -2218,7 +2218,7 @@ kind_expr:
{ {
if (gfc_matching_function) if (gfc_matching_function)
{ {
/* The function kind expression might include use associated or /* The function kind expression might include use associated or
imported parameters and try again after the specification imported parameters and try again after the specification
expressions..... */ expressions..... */
if (gfc_match_char (')') != MATCH_YES) if (gfc_match_char (')') != MATCH_YES)
...@@ -2267,7 +2267,7 @@ kind_expr: ...@@ -2267,7 +2267,7 @@ kind_expr:
ts->is_c_interop = e->ts.is_iso_c; ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type; ts->f90_type = e->ts.f90_type;
} }
gfc_free_expr (e); gfc_free_expr (e);
e = NULL; e = NULL;
...@@ -2362,7 +2362,7 @@ match_char_kind (int * kind, int * is_iso_c) ...@@ -2362,7 +2362,7 @@ match_char_kind (int * kind, int * is_iso_c)
if (n != MATCH_YES && gfc_matching_function) if (n != MATCH_YES && gfc_matching_function)
{ {
/* The expression might include use-associated or imported /* The expression might include use-associated or imported
parameters and try again after the specification parameters and try again after the specification
expressions. */ expressions. */
gfc_free_expr (e); gfc_free_expr (e);
gfc_undo_symbols (); gfc_undo_symbols ();
...@@ -2405,7 +2405,7 @@ match_char_kind (int * kind, int * is_iso_c) ...@@ -2405,7 +2405,7 @@ match_char_kind (int * kind, int * is_iso_c)
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
gfc_current_locus = where; gfc_current_locus = where;
/* Return what we know from the test(s). */ /* Return what we know from the test(s). */
return m; return m;
...@@ -2457,7 +2457,7 @@ gfc_match_char_spec (gfc_typespec *ts) ...@@ -2457,7 +2457,7 @@ gfc_match_char_spec (gfc_typespec *ts)
if (gfc_match (" kind =") == MATCH_YES) if (gfc_match (" kind =") == MATCH_YES)
{ {
m = match_char_kind (&kind, &is_iso_c); m = match_char_kind (&kind, &is_iso_c);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
goto done; goto done;
if (m == MATCH_NO) if (m == MATCH_NO)
...@@ -2572,11 +2572,11 @@ done: ...@@ -2572,11 +2572,11 @@ done:
looking for the length (line 1690, roughly). it's the last looking for the length (line 1690, roughly). it's the last
testcase for parsing the kind params of a character variable. testcase for parsing the kind params of a character variable.
However, it's not actually the length. this seems like it However, it's not actually the length. this seems like it
could be an error. could be an error.
To see if the user used a C interop kind, test the expr To see if the user used a C interop kind, test the expr
of the so called length, and see if it's C interoperable. */ of the so called length, and see if it's C interoperable. */
ts->is_c_interop = len->ts.is_iso_c; ts->is_c_interop = len->ts.is_iso_c;
return MATCH_YES; return MATCH_YES;
} }
...@@ -2764,11 +2764,11 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ...@@ -2764,11 +2764,11 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
gfc_symbol *upe; gfc_symbol *upe;
gfc_symtree *st; gfc_symtree *st;
ts->type = BT_CLASS; ts->type = BT_CLASS;
gfc_find_symbol ("$tar", gfc_current_ns, 1, &upe); gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
if (upe == NULL) if (upe == NULL)
{ {
upe = gfc_new_symbol ("$tar", gfc_current_ns); upe = gfc_new_symbol ("STAR", gfc_current_ns);
st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar"); st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe; st->n.sym = upe;
gfc_set_sym_referenced (upe); gfc_set_sym_referenced (upe);
upe->refs++; upe->refs++;
...@@ -2783,9 +2783,9 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ...@@ -2783,9 +2783,9 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
} }
else else
{ {
st = gfc_find_symtree (gfc_current_ns->sym_root, "$tar"); st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR");
if (st == NULL) if (st == NULL)
st = gfc_new_symtree (&gfc_current_ns->sym_root, "$tar"); st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
st->n.sym = upe; st->n.sym = upe;
upe->refs++; upe->refs++;
} }
...@@ -2805,7 +2805,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ...@@ -2805,7 +2805,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
/* Defer association of the derived type until the end of the /* Defer association of the derived type until the end of the
specification block. However, if the derived type can be specification block. However, if the derived type can be
found, add it to the typespec. */ found, add it to the typespec. */
if (gfc_matching_function) if (gfc_matching_function)
{ {
ts->u.derived = NULL; ts->u.derived = NULL;
...@@ -2846,7 +2846,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ...@@ -2846,7 +2846,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
|| gfc_current_ns->has_import_set; || gfc_current_ns->has_import_set;
gfc_find_symbol (name, NULL, iface, &sym); gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{ {
gfc_error ("Type name '%s' at %C is ambiguous", name); gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR; return MATCH_ERROR;
} }
...@@ -3836,7 +3836,7 @@ match_attr_spec (void) ...@@ -3836,7 +3836,7 @@ match_attr_spec (void)
case DECL_IS_BIND_C: case DECL_IS_BIND_C:
t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0); t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
break; break;
case DECL_VALUE: case DECL_VALUE:
if (gfc_notify_std (GFC_STD_F2003, "VALUE attribute " if (gfc_notify_std (GFC_STD_F2003, "VALUE attribute "
"at %C") "at %C")
...@@ -3889,7 +3889,7 @@ cleanup: ...@@ -3889,7 +3889,7 @@ cleanup:
there is more than one argument (num_idents), it is an error. */ there is more than one argument (num_idents), it is an error. */
static gfc_try static gfc_try
set_binding_label (const char **dest_label, const char *sym_name, set_binding_label (const char **dest_label, const char *sym_name,
int num_idents) int num_idents)
{ {
if (num_idents > 1 && has_name_equals) if (num_idents > 1 && has_name_equals)
...@@ -3909,7 +3909,7 @@ set_binding_label (const char **dest_label, const char *sym_name, ...@@ -3909,7 +3909,7 @@ set_binding_label (const char **dest_label, const char *sym_name,
if (sym_name != NULL && has_name_equals == 0) if (sym_name != NULL && has_name_equals == 0)
*dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
} }
return SUCCESS; return SUCCESS;
} }
...@@ -3954,7 +3954,7 @@ verify_com_block_vars_c_interop (gfc_common_head *com_block) ...@@ -3954,7 +3954,7 @@ verify_com_block_vars_c_interop (gfc_common_head *com_block)
gfc_try retval = SUCCESS; gfc_try retval = SUCCESS;
curr_sym = com_block->head; curr_sym = com_block->head;
/* Make sure we have at least one symbol. */ /* Make sure we have at least one symbol. */
if (curr_sym == NULL) if (curr_sym == NULL)
return retval; return retval;
...@@ -3966,7 +3966,7 @@ verify_com_block_vars_c_interop (gfc_common_head *com_block) ...@@ -3966,7 +3966,7 @@ verify_com_block_vars_c_interop (gfc_common_head *com_block)
/* The second to last param, 1, says this is in a common block. */ /* The second to last param, 1, says this is in a common block. */
retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
curr_sym = curr_sym->common_next; curr_sym = curr_sym->common_next;
} while (curr_sym != NULL); } while (curr_sym != NULL);
return retval; return retval;
} }
...@@ -4005,7 +4005,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, ...@@ -4005,7 +4005,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
enough type info, then verify that it's a C interop kind. enough type info, then verify that it's a C interop kind.
The info could be in the symbol already, or possibly still in The info could be in the symbol already, or possibly still in
the given ts (current_ts), so look in both. */ the given ts (current_ts), so look in both. */
if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
{ {
if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS) if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
{ {
...@@ -4031,7 +4031,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, ...@@ -4031,7 +4031,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
tmp_sym->name, &(tmp_sym->declared_at)); tmp_sym->name, &(tmp_sym->declared_at));
} }
} }
/* Variables declared w/in a common block can't be bind(c) /* Variables declared w/in a common block can't be bind(c)
since there's no way for C to see these variables, so there's since there's no way for C to see these variables, so there's
semantically no reason for the attribute. */ semantically no reason for the attribute. */
...@@ -4044,7 +4044,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, ...@@ -4044,7 +4044,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
&(tmp_sym->declared_at)); &(tmp_sym->declared_at));
retval = FAILURE; retval = FAILURE;
} }
/* Scalar variables that are bind(c) can not have the pointer /* Scalar variables that are bind(c) can not have the pointer
or allocatable attributes. */ or allocatable attributes. */
if (tmp_sym->attr.is_bind_c == 1) if (tmp_sym->attr.is_bind_c == 1)
...@@ -4107,7 +4107,7 @@ gfc_try ...@@ -4107,7 +4107,7 @@ gfc_try
set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
{ {
gfc_try retval = SUCCESS; gfc_try retval = SUCCESS;
/* TODO: Do we need to make sure the vars aren't marked private? */ /* TODO: Do we need to make sure the vars aren't marked private? */
/* Set the is_bind_c bit in symbol_attribute. */ /* Set the is_bind_c bit in symbol_attribute. */
...@@ -4128,9 +4128,9 @@ gfc_try ...@@ -4128,9 +4128,9 @@ gfc_try
set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
{ {
gfc_try retval = SUCCESS; gfc_try retval = SUCCESS;
/* destLabel, common name, typespec (which may have binding label). */ /* destLabel, common name, typespec (which may have binding label). */
if (set_binding_label (&com_block->binding_label, com_block->name, if (set_binding_label (&com_block->binding_label, com_block->name,
num_idents) num_idents)
!= SUCCESS) != SUCCESS)
return FAILURE; return FAILURE;
...@@ -4153,7 +4153,7 @@ get_bind_c_idents (void) ...@@ -4153,7 +4153,7 @@ get_bind_c_idents (void)
gfc_symbol *tmp_sym = NULL; gfc_symbol *tmp_sym = NULL;
match found_id; match found_id;
gfc_common_head *com_block = NULL; gfc_common_head *com_block = NULL;
if (gfc_match_name (name) == MATCH_YES) if (gfc_match_name (name) == MATCH_YES)
{ {
found_id = MATCH_YES; found_id = MATCH_YES;
...@@ -4170,7 +4170,7 @@ get_bind_c_idents (void) ...@@ -4170,7 +4170,7 @@ get_bind_c_idents (void)
"attribute specification statement at %C"); "attribute specification statement at %C");
return FAILURE; return FAILURE;
} }
/* Save the current identifier and look for more. */ /* Save the current identifier and look for more. */
do do
{ {
...@@ -4180,7 +4180,7 @@ get_bind_c_idents (void) ...@@ -4180,7 +4180,7 @@ get_bind_c_idents (void)
/* Make sure we have a sym or com block, and verify that it can /* Make sure we have a sym or com block, and verify that it can
be bind(c). Set the appropriate field(s) and look for more be bind(c). Set the appropriate field(s) and look for more
identifiers. */ identifiers. */
if (tmp_sym != NULL || com_block != NULL) if (tmp_sym != NULL || com_block != NULL)
{ {
if (tmp_sym != NULL) if (tmp_sym != NULL)
{ {
...@@ -4194,7 +4194,7 @@ get_bind_c_idents (void) ...@@ -4194,7 +4194,7 @@ get_bind_c_idents (void)
!= SUCCESS) != SUCCESS)
return FAILURE; return FAILURE;
} }
/* Look to see if we have another identifier. */ /* Look to see if we have another identifier. */
tmp_sym = NULL; tmp_sym = NULL;
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
...@@ -4230,7 +4230,7 @@ get_bind_c_idents (void) ...@@ -4230,7 +4230,7 @@ get_bind_c_idents (void)
/* Try and match a BIND(C) attribute specification statement. */ /* Try and match a BIND(C) attribute specification statement. */
match match
gfc_match_bind_c_stmt (void) gfc_match_bind_c_stmt (void)
{ {
...@@ -4238,7 +4238,7 @@ gfc_match_bind_c_stmt (void) ...@@ -4238,7 +4238,7 @@ gfc_match_bind_c_stmt (void)
gfc_typespec *ts; gfc_typespec *ts;
ts = &current_ts; ts = &current_ts;
/* This may not be necessary. */ /* This may not be necessary. */
gfc_clear_ts (ts); gfc_clear_ts (ts);
/* Clear the temporary binding label holder. */ /* Clear the temporary binding label holder. */
...@@ -4276,7 +4276,7 @@ gfc_match_data_decl (void) ...@@ -4276,7 +4276,7 @@ gfc_match_data_decl (void)
int elem; int elem;
num_idents_on_line = 0; num_idents_on_line = 0;
m = gfc_match_decl_type_spec (&current_ts, 0); m = gfc_match_decl_type_spec (&current_ts, 0);
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
...@@ -4662,7 +4662,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) ...@@ -4662,7 +4662,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
/* Initialize to having found nothing. */ /* Initialize to having found nothing. */
found_match = MATCH_NO; found_match = MATCH_NO;
is_bind_c = MATCH_NO; is_bind_c = MATCH_NO;
is_result = MATCH_NO; is_result = MATCH_NO;
/* Get the next char to narrow between result and bind(c). */ /* Get the next char to narrow between result and bind(c). */
...@@ -4690,7 +4690,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) ...@@ -4690,7 +4690,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
} }
else else
/* This should only be MATCH_ERROR. */ /* This should only be MATCH_ERROR. */
found_match = is_result; found_match = is_result;
break; break;
case 'b': case 'b':
/* Look for bind(c) first. */ /* Look for bind(c) first. */
...@@ -4728,7 +4728,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) ...@@ -4728,7 +4728,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
== FAILURE) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
} }
return found_match; return found_match;
} }
...@@ -4940,7 +4940,7 @@ match_procedure_decl (void) ...@@ -4940,7 +4940,7 @@ match_procedure_decl (void)
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Set binding label for BIND(C). */ /* Set binding label for BIND(C). */
if (set_binding_label (&sym->binding_label, sym->name, num) if (set_binding_label (&sym->binding_label, sym->name, num)
!= SUCCESS) != SUCCESS)
return MATCH_ERROR; return MATCH_ERROR;
} }
...@@ -5263,7 +5263,7 @@ gfc_match_function_decl (void) ...@@ -5263,7 +5263,7 @@ gfc_match_function_decl (void)
locus old_loc; locus old_loc;
match m; match m;
match suffix_match; match suffix_match;
match found_match; /* Status returned by match func. */ match found_match; /* Status returned by match func. */
if (gfc_current_state () != COMP_NONE if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE && gfc_current_state () != COMP_INTERFACE
...@@ -5346,10 +5346,10 @@ gfc_match_function_decl (void) ...@@ -5346,10 +5346,10 @@ gfc_match_function_decl (void)
{ {
/* Make changes to the symbol. */ /* Make changes to the symbol. */
m = MATCH_ERROR; m = MATCH_ERROR;
if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup; goto cleanup;
if (gfc_missing_attr (&sym->attr, NULL) == FAILURE if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
|| copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
goto cleanup; goto cleanup;
...@@ -5536,7 +5536,7 @@ gfc_match_entry (void) ...@@ -5536,7 +5536,7 @@ gfc_match_entry (void)
gfc_error_now ("BIND(C) attribute at %L can only be used for " gfc_error_now ("BIND(C) attribute at %L can only be used for "
"variables or common blocks", &gfc_current_locus); "variables or common blocks", &gfc_current_locus);
} }
/* Check what next non-whitespace character is so we can tell if there /* Check what next non-whitespace character is so we can tell if there
is the required parens if we have a BIND(C). */ is the required parens if we have a BIND(C). */
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
...@@ -5705,7 +5705,7 @@ gfc_match_subroutine (void) ...@@ -5705,7 +5705,7 @@ gfc_match_subroutine (void)
is the required parens if we have a BIND(C). */ is the required parens if we have a BIND(C). */
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
peek_char = gfc_peek_ascii_char (); peek_char = gfc_peek_ascii_char ();
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -5766,7 +5766,7 @@ gfc_match_subroutine (void) ...@@ -5766,7 +5766,7 @@ gfc_match_subroutine (void)
== FAILURE) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
} }
if (gfc_match_eos () != MATCH_YES) if (gfc_match_eos () != MATCH_YES)
{ {
gfc_syntax_error (ST_SUBROUTINE); gfc_syntax_error (ST_SUBROUTINE);
...@@ -5797,12 +5797,12 @@ gfc_match_subroutine (void) ...@@ -5797,12 +5797,12 @@ gfc_match_subroutine (void)
match match
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{ {
/* binding label, if exists */ /* binding label, if exists */
const char* binding_label = NULL; const char* binding_label = NULL;
match double_quote; match double_quote;
match single_quote; match single_quote;
/* Initialize the flag that specifies whether we encountered a NAME= /* Initialize the flag that specifies whether we encountered a NAME=
specifier or not. */ specifier or not. */
has_name_equals = 0; has_name_equals = 0;
...@@ -5837,12 +5837,12 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) ...@@ -5837,12 +5837,12 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
"at %C"); "at %C");
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Grab the binding label, using functions that will not lower /* Grab the binding label, using functions that will not lower
case the names automatically. */ case the names automatically. */
if (gfc_match_name_C (&binding_label) != MATCH_YES) if (gfc_match_name_C (&binding_label) != MATCH_YES)
return MATCH_ERROR; return MATCH_ERROR;
/* Get the closing quotation. */ /* Get the closing quotation. */
if (double_quote == MATCH_YES) if (double_quote == MATCH_YES)
{ {
...@@ -6236,7 +6236,7 @@ attr_decl1 (void) ...@@ -6236,7 +6236,7 @@ attr_decl1 (void)
m = MATCH_ERROR; m = MATCH_ERROR;
goto cleanup; goto cleanup;
} }
var_locus = gfc_current_locus; var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */ /* Deal with possible array specification for certain attributes. */
...@@ -6307,7 +6307,7 @@ attr_decl1 (void) ...@@ -6307,7 +6307,7 @@ attr_decl1 (void)
goto cleanup; goto cleanup;
} }
} }
if (sym->ts.type == BT_CLASS if (sym->ts.type == BT_CLASS
&& gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE) && gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE)
{ {
...@@ -6324,7 +6324,7 @@ attr_decl1 (void) ...@@ -6324,7 +6324,7 @@ attr_decl1 (void)
if (sym->attr.cray_pointee && sym->as != NULL) if (sym->attr.cray_pointee && sym->as != NULL)
{ {
/* Fix the array spec. */ /* Fix the array spec. */
m = gfc_mod_pointee_as (sym->as); m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
goto cleanup; goto cleanup;
} }
...@@ -6485,7 +6485,7 @@ cray_pointer_decl (void) ...@@ -6485,7 +6485,7 @@ cray_pointer_decl (void)
{ {
gfc_free_array_spec (as); gfc_free_array_spec (as);
as = NULL; as = NULL;
} }
if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE) if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -6503,31 +6503,31 @@ cray_pointer_decl (void) ...@@ -6503,31 +6503,31 @@ cray_pointer_decl (void)
gfc_free_array_spec (as); gfc_free_array_spec (as);
return MATCH_ERROR; return MATCH_ERROR;
} }
as = NULL; as = NULL;
if (cpte->as != NULL) if (cpte->as != NULL)
{ {
/* Fix array spec. */ /* Fix array spec. */
m = gfc_mod_pointee_as (cpte->as); m = gfc_mod_pointee_as (cpte->as);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return m; return m;
} }
/* Point the Pointee at the Pointer. */ /* Point the Pointee at the Pointer. */
cpte->cp_pointer = cptr; cpte->cp_pointer = cptr;
if (gfc_match_char (')') != MATCH_YES) if (gfc_match_char (')') != MATCH_YES)
{ {
gfc_error ("Expected \")\" at %C"); gfc_error ("Expected \")\" at %C");
return MATCH_ERROR; return MATCH_ERROR;
} }
m = gfc_match_char (','); m = gfc_match_char (',');
if (m != MATCH_YES) if (m != MATCH_YES)
done = true; /* Stop searching for more declarations. */ done = true; /* Stop searching for more declarations. */
} }
if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
|| gfc_match_eos () != MATCH_YES) || gfc_match_eos () != MATCH_YES)
{ {
...@@ -6618,7 +6618,7 @@ gfc_match_pointer (void) ...@@ -6618,7 +6618,7 @@ gfc_match_pointer (void)
{ {
gfc_clear_attr (&current_attr); gfc_clear_attr (&current_attr);
current_attr.pointer = 1; current_attr.pointer = 1;
return attr_decl (); return attr_decl ();
} }
} }
...@@ -7163,7 +7163,7 @@ gfc_match_volatile (void) ...@@ -7163,7 +7163,7 @@ gfc_match_volatile (void)
for(;;) for(;;)
{ {
/* VOLATILE is special because it can be added to host-associated /* VOLATILE is special because it can be added to host-associated
symbols locally. Except for coarrays. */ symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1); m = gfc_match_symbol (&sym, 1);
switch (m) switch (m)
...@@ -7224,7 +7224,7 @@ gfc_match_asynchronous (void) ...@@ -7224,7 +7224,7 @@ gfc_match_asynchronous (void)
for(;;) for(;;)
{ {
/* ASYNCHRONOUS is special because it can be added to host-associated /* ASYNCHRONOUS is special because it can be added to host-associated
symbols locally. */ symbols locally. */
m = gfc_match_symbol (&sym, 1); m = gfc_match_symbol (&sym, 1);
switch (m) switch (m)
...@@ -7308,7 +7308,7 @@ gfc_match_modproc (void) ...@@ -7308,7 +7308,7 @@ gfc_match_modproc (void)
} }
else else
gfc_current_locus = old_locus; gfc_current_locus = old_locus;
for (;;) for (;;)
{ {
bool last = false; bool last = false;
...@@ -7622,7 +7622,7 @@ gfc_match_derived_decl (void) ...@@ -7622,7 +7622,7 @@ gfc_match_derived_decl (void)
/* Construct the f2k_derived namespace if it is not yet there. */ /* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived) if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0); sym->f2k_derived = gfc_get_namespace (NULL, 0);
if (extended && !sym->components) if (extended && !sym->components)
{ {
gfc_component *p; gfc_component *p;
...@@ -7636,7 +7636,7 @@ gfc_match_derived_decl (void) ...@@ -7636,7 +7636,7 @@ gfc_match_derived_decl (void)
p->ts.type = BT_DERIVED; p->ts.type = BT_DERIVED;
p->ts.u.derived = extended; p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts); p->initializer = gfc_default_initializer (&p->ts);
/* Set extension level. */ /* Set extension level. */
if (extended->attr.extension == 255) if (extended->attr.extension == 255)
{ {
...@@ -7668,7 +7668,7 @@ gfc_match_derived_decl (void) ...@@ -7668,7 +7668,7 @@ gfc_match_derived_decl (void)
} }
/* Cray Pointees can be declared as: /* Cray Pointees can be declared as:
pointer (ipt, a (n,m,...,*)) */ pointer (ipt, a (n,m,...,*)) */
match match
...@@ -7686,15 +7686,15 @@ gfc_mod_pointee_as (gfc_array_spec *as) ...@@ -7686,15 +7686,15 @@ gfc_mod_pointee_as (gfc_array_spec *as)
} }
/* Match the enum definition statement, here we are trying to match /* Match the enum definition statement, here we are trying to match
the first line of enum definition statement. the first line of enum definition statement.
Returns MATCH_YES if match is found. */ Returns MATCH_YES if match is found. */
match match
gfc_match_enum (void) gfc_match_enum (void)
{ {
match m; match m;
m = gfc_match_eos (); m = gfc_match_eos ();
if (m != MATCH_YES) if (m != MATCH_YES)
return m; return m;
...@@ -8181,7 +8181,7 @@ match_procedure_in_type (void) ...@@ -8181,7 +8181,7 @@ match_procedure_in_type (void)
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Match the binding names. */ /* Match the binding names. */
for(num=1;;num++) for(num=1;;num++)
{ {
m = gfc_match_name (name); m = gfc_match_name (name);
...@@ -8268,7 +8268,7 @@ match_procedure_in_type (void) ...@@ -8268,7 +8268,7 @@ match_procedure_in_type (void)
false)) false))
return MATCH_ERROR; return MATCH_ERROR;
gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
return MATCH_YES; return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES) if (gfc_match_char (',') != MATCH_YES)
...@@ -8325,7 +8325,7 @@ gfc_match_generic (void) ...@@ -8325,7 +8325,7 @@ gfc_match_generic (void)
/* Match the binding name; depending on type (operator / generic) format /* Match the binding name; depending on type (operator / generic) format
it for future error messages into bind_name. */ it for future error messages into bind_name. */
m = gfc_match_generic_spec (&op_type, name, &op); m = gfc_match_generic_spec (&op_type, name, &op);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -8340,11 +8340,11 @@ gfc_match_generic (void) ...@@ -8340,11 +8340,11 @@ gfc_match_generic (void)
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
snprintf (bind_name, sizeof (bind_name), "%s", name); snprintf (bind_name, sizeof (bind_name), "%s", name);
break; break;
case INTERFACE_USER_OP: case INTERFACE_USER_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
break; break;
case INTERFACE_INTRINSIC_OP: case INTERFACE_INTRINSIC_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
gfc_op2string (op)); gfc_op2string (op));
...@@ -8360,7 +8360,7 @@ gfc_match_generic (void) ...@@ -8360,7 +8360,7 @@ gfc_match_generic (void)
gfc_error ("Expected '=>' at %C"); gfc_error ("Expected '=>' at %C");
goto error; goto error;
} }
/* Try to find existing GENERIC binding with this name / for this operator; /* Try to find existing GENERIC binding with this name / for this operator;
if there is something, check that it is another GENERIC and then extend if there is something, check that it is another GENERIC and then extend
it rather than building a new node. Otherwise, create it and put it it rather than building a new node. Otherwise, create it and put it
...@@ -8435,7 +8435,7 @@ gfc_match_generic (void) ...@@ -8435,7 +8435,7 @@ gfc_match_generic (void)
break; break;
} }
case INTERFACE_INTRINSIC_OP: case INTERFACE_INTRINSIC_OP:
ns->tb_op[op] = tb; ns->tb_op[op] = tb;
break; break;
...@@ -8513,7 +8513,7 @@ gfc_match_final_decl (void) ...@@ -8513,7 +8513,7 @@ gfc_match_final_decl (void)
if (!gfc_is_whitespace (c) && c != ':') if (!gfc_is_whitespace (c) && c != ':')
return MATCH_NO; return MATCH_NO;
} }
if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{ {
if (gfc_current_form == FORM_FIXED) if (gfc_current_form == FORM_FIXED)
...@@ -8637,7 +8637,7 @@ const ext_attr_t ext_attr_list[] = { ...@@ -8637,7 +8637,7 @@ const ext_attr_t ext_attr_list[] = {
MATCH_NO. */ MATCH_NO. */
match match
gfc_match_gcc_attributes (void) gfc_match_gcc_attributes (void)
{ {
symbol_attribute attr; symbol_attribute attr;
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
unsigned id; unsigned id;
...@@ -8692,7 +8692,7 @@ gfc_match_gcc_attributes (void) ...@@ -8692,7 +8692,7 @@ gfc_match_gcc_attributes (void)
if (find_special (name, &sym, true)) if (find_special (name, &sym, true))
return MATCH_ERROR; return MATCH_ERROR;
sym->attr.ext_attr |= attr.ext_attr; sym->attr.ext_attr |= attr.ext_attr;
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
......
gcc/testsuite/ChangeLog
2013-01-08 Paul Thomas <pault@gcc.gnu.org>
PR fortran/55868
* gfortran.dg/unlimited_polymorphic_8.f90: Update
scan-tree-dump-times for foo.0.x._vptr to deal with change from
$tar to STAR.
2013-01-11 Andreas Schwab <schwab@linux-m68k.org> 2013-01-11 Andreas Schwab <schwab@linux-m68k.org>
* gcc.c-torture/compile/pr55921.c: Don't use matching constraints. * gcc.c-torture/compile/pr55921.c: Don't use matching constraints.
......
gcc/testsuite/gfortran.dg/unlimited_polymorphic_8.f90
...@@ -16,5 +16,5 @@ contains ...@@ -16,5 +16,5 @@ contains
end end
! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } } ! { dg-final { scan-tree-dump-times "foo.0.x._data = 0B;" 1 "original" } }
! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__.tar;" 1 "original" } } ! { dg-final { scan-tree-dump-times "foo.0.x._vptr = .* &__vtab__STAR;" 1 "original" } }
! { dg-final { cleanup-tree-dump "optimized" } } ! { dg-final { cleanup-tree-dump "optimized" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment