/* 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. */
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;
/* 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 &&
- CLASS_DATA (select_type_stack->selector)->attr.dimension)
+ 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 = 1;
+ 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 = 1;
+ 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;
}
&& expr1->ts.type != BT_UNKNOWN
&& CLASS_DATA (expr1)
&& (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
- && CLASS_DATA (expr1)->attr.dimension
+ && (CLASS_DATA (expr1)->attr.dimension
+ || CLASS_DATA (expr1)->attr.codimension)
&& expr1->ref
&& expr1->ref->type == REF_ARRAY
&& expr1->ref->next == NULL;
OSDN Git Service
