/* Matching subroutines in all sizes, shapes and colors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010, 2011
+ 2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "match.h"
#include "parse.h"
+#include "tree.h"
int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
/* Match a valid name for C, which is almost the same as for Fortran,
except that you can start with an underscore, etc.. It could have
been done by modifying the gfc_match_name, but this way other
- things C allows can be added, such as no limits on the length.
- Right now, the length is limited to the same thing as Fortran..
+ things C allows can be done, such as no limits on the length.
Also, by rewriting it, we use the gfc_next_char_C() to prevent the
input characters from being automatically lower cased, since C is
case sensitive. The parameter, buffer, is used to return the name
- that is matched. Return MATCH_ERROR if the name is too long
- (though this is a self-imposed limit), MATCH_NO if what we're
- seeing isn't a name, and MATCH_YES if we successfully match a C
- name. */
+ that is matched. Return MATCH_ERROR if the name is not a valid C
+ name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
+ we successfully match a C name. */
match
-gfc_match_name_C (char *buffer)
+gfc_match_name_C (const char **buffer)
{
locus old_loc;
- int i = 0;
+ size_t i = 0;
gfc_char_t c;
+ char* buf;
+ size_t cursz = 16;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
symbol name, all lowercase. */
if (c == '"' || c == '\'')
{
- buffer[0] = '\0';
gfc_current_locus = old_loc;
return MATCH_YES;
}
return MATCH_ERROR;
}
+ buf = XNEWVEC (char, cursz);
/* Continue to read valid variable name characters. */
do
{
gcc_assert (gfc_wide_fits_in_byte (c));
- buffer[i++] = (unsigned char) c;
-
- /* C does not define a maximum length of variable names, to my
- knowledge, but the compiler typically places a limit on them.
- For now, i'll use the same as the fortran limit for simplicity,
- but this may need to be changed to a dynamic buffer that can
- be realloc'ed here if necessary, or more likely, a larger
- upper-bound set. */
- if (i > gfc_option.max_identifier_length)
- {
- gfc_error ("Name at %C is too long");
- return MATCH_ERROR;
- }
+ buf[i++] = (unsigned char) c;
+
+ if (i >= cursz)
+ {
+ cursz *= 2;
+ buf = XRESIZEVEC (char, buf, cursz);
+ }
old_loc = gfc_current_locus;
c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_');
- buffer[i] = '\0';
+ /* The binding label will be needed later anyway, so just insert it
+ into the symbol table. */
+ buf[i] = '\0';
+ *buffer = IDENTIFIER_POINTER (get_identifier (buf));
+ XDELETEVEC (buf);
gfc_current_locus = old_loc;
/* See if we stopped because of whitespace. */
gfc_find_symbol (name, NULL, 1, &derived);
+ if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
+
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
goto cleanup;
}
- if (head->next)
- {
- gfc_error ("SOURCE tag at %L requires only a single entity in "
- "the allocation-list", &tmp->where);
- goto cleanup;
- }
+ if (head->next
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SOURCE tag at %L"
+ " with more than a single allocate objects",
+ &tmp->where) == FAILURE)
+ goto cleanup;
source = tmp;
tmp = NULL;
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
+
+/* Copy across the array spec to the selector, taking care as to
+ whether or not it is a class object or not. */
+ if (select_type_stack->selector->ts.type == BT_CLASS
+ && select_type_stack->selector->attr.class_ok
+ && (CLASS_DATA (select_type_stack->selector)->attr.dimension
+ || CLASS_DATA (select_type_stack->selector)->attr.codimension))
+ {
+ if (ts->type == BT_CLASS)
+ {
+ CLASS_DATA (tmp->n.sym)->attr.dimension
+ = CLASS_DATA (select_type_stack->selector)->attr.dimension;
+ CLASS_DATA (tmp->n.sym)->attr.codimension
+ = CLASS_DATA (select_type_stack->selector)->attr.codimension;
+ CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec ();
+ CLASS_DATA (tmp->n.sym)->as
+ = CLASS_DATA (select_type_stack->selector)->as;
+ }
+ else
+ {
+ tmp->n.sym->attr.dimension
+ = CLASS_DATA (select_type_stack->selector)->attr.dimension;
+ tmp->n.sym->attr.codimension
+ = CLASS_DATA (select_type_stack->selector)->attr.codimension;
+ tmp->n.sym->as = gfc_get_array_spec ();
+ tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as;
+ }
+ }
+
gfc_set_sym_referenced (tmp->n.sym);
- if (select_type_stack->selector->ts.type == BT_CLASS &&
- CLASS_DATA (select_type_stack->selector)->attr.allocatable)
- gfc_add_allocatable (&tmp->n.sym->attr, NULL);
- else
- gfc_add_pointer (&tmp->n.sym->attr, NULL);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ tmp->n.sym->attr.select_type_temporary = 1;
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
- tmp->n.sym->attr.select_type_temporary = 1;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
gfc_expr *expr1, *expr2 = NULL;
match m;
char name[GFC_MAX_SYMBOL_LEN];
+ bool class_array;
m = gfc_match_label ();
if (m == MATCH_ERROR)
if (m != MATCH_YES)
goto cleanup;
+ /* This ghastly expression seems to be needed to distinguish a CLASS
+ array, which can have a reference, from other expressions that
+ have references, such as derived type components, and are not
+ allowed by the standard.
+ TODO; see is it is sufficent to exclude component and substring
+ references. */
+ class_array = expr1->expr_type == EXPR_VARIABLE
+ && expr1->ts.type != BT_UNKNOWN
+ && CLASS_DATA (expr1)
+ && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
+ && (CLASS_DATA (expr1)->attr.dimension
+ || CLASS_DATA (expr1)->attr.codimension)
+ && expr1->ref
+ && expr1->ref->type == REF_ARRAY
+ && expr1->ref->next == NULL;
+
/* Check for F03:C811. */
- if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
+ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
+ || (!class_array && expr1->ref != NULL)))
{
gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"use associate-name=>");
OSDN Git Service
