1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
28 #include "constructor.h"
30 /* Macros to access allocate memory for gfc_data_variable,
31 gfc_data_value and gfc_data. */
32 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
33 #define gfc_get_data_value() XCNEW (gfc_data_value)
34 #define gfc_get_data() XCNEW (gfc_data)
37 /* This flag is set if an old-style length selector is matched
38 during a type-declaration statement. */
40 static int old_char_selector;
42 /* When variables acquire types and attributes from a declaration
43 statement, they get them from the following static variables. The
44 first part of a declaration sets these variables and the second
45 part copies these into symbol structures. */
47 static gfc_typespec current_ts;
49 static symbol_attribute current_attr;
50 static gfc_array_spec *current_as;
51 static int colon_seen;
53 /* The current binding label (if any). */
54 static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
55 /* Need to know how many identifiers are on the current data declaration
56 line in case we're given the BIND(C) attribute with a NAME= specifier. */
57 static int num_idents_on_line;
58 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
59 can supply a name if the curr_binding_label is nil and NAME= was not. */
60 static int has_name_equals = 0;
62 /* Initializer of the previous enumerator. */
64 static gfc_expr *last_initializer;
66 /* History of all the enumerators is maintained, so that
67 kind values of all the enumerators could be updated depending
68 upon the maximum initialized value. */
70 typedef struct enumerator_history
73 gfc_expr *initializer;
74 struct enumerator_history *next;
78 /* Header of enum history chain. */
80 static enumerator_history *enum_history = NULL;
82 /* Pointer of enum history node containing largest initializer. */
84 static enumerator_history *max_enum = NULL;
86 /* gfc_new_block points to the symbol of a newly matched block. */
88 gfc_symbol *gfc_new_block;
90 bool gfc_matching_function;
93 /********************* DATA statement subroutines *********************/
95 static bool in_match_data = false;
98 gfc_in_match_data (void)
100 return in_match_data;
104 set_in_match_data (bool set_value)
106 in_match_data = set_value;
109 /* Free a gfc_data_variable structure and everything beneath it. */
112 free_variable (gfc_data_variable *p)
114 gfc_data_variable *q;
119 gfc_free_expr (p->expr);
120 gfc_free_iterator (&p->iter, 0);
121 free_variable (p->list);
127 /* Free a gfc_data_value structure and everything beneath it. */
130 free_value (gfc_data_value *p)
137 mpz_clear (p->repeat);
138 gfc_free_expr (p->expr);
144 /* Free a list of gfc_data structures. */
147 gfc_free_data (gfc_data *p)
154 free_variable (p->var);
155 free_value (p->value);
161 /* Free all data in a namespace. */
164 gfc_free_data_all (gfc_namespace *ns)
177 static match var_element (gfc_data_variable *);
179 /* Match a list of variables terminated by an iterator and a right
183 var_list (gfc_data_variable *parent)
185 gfc_data_variable *tail, var;
188 m = var_element (&var);
189 if (m == MATCH_ERROR)
194 tail = gfc_get_data_variable ();
201 if (gfc_match_char (',') != MATCH_YES)
204 m = gfc_match_iterator (&parent->iter, 1);
207 if (m == MATCH_ERROR)
210 m = var_element (&var);
211 if (m == MATCH_ERROR)
216 tail->next = gfc_get_data_variable ();
222 if (gfc_match_char (')') != MATCH_YES)
227 gfc_syntax_error (ST_DATA);
232 /* Match a single element in a data variable list, which can be a
233 variable-iterator list. */
236 var_element (gfc_data_variable *new_var)
241 memset (new_var, 0, sizeof (gfc_data_variable));
243 if (gfc_match_char ('(') == MATCH_YES)
244 return var_list (new_var);
246 m = gfc_match_variable (&new_var->expr, 0);
250 sym = new_var->expr->symtree->n.sym;
252 /* Symbol should already have an associated type. */
253 if (gfc_check_symbol_typed (sym, gfc_current_ns,
254 false, gfc_current_locus) == FAILURE)
257 if (!sym->attr.function && gfc_current_ns->parent
258 && gfc_current_ns->parent == sym->ns)
260 gfc_error ("Host associated variable '%s' may not be in the DATA "
261 "statement at %C", sym->name);
265 if (gfc_current_state () != COMP_BLOCK_DATA
266 && sym->attr.in_common
267 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
268 "common block variable '%s' in DATA statement at %C",
269 sym->name) == FAILURE)
272 if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE)
279 /* Match the top-level list of data variables. */
282 top_var_list (gfc_data *d)
284 gfc_data_variable var, *tail, *new_var;
291 m = var_element (&var);
294 if (m == MATCH_ERROR)
297 new_var = gfc_get_data_variable ();
303 tail->next = new_var;
307 if (gfc_match_char ('/') == MATCH_YES)
309 if (gfc_match_char (',') != MATCH_YES)
316 gfc_syntax_error (ST_DATA);
317 gfc_free_data_all (gfc_current_ns);
323 match_data_constant (gfc_expr **result)
325 char name[GFC_MAX_SYMBOL_LEN + 1];
331 m = gfc_match_literal_constant (&expr, 1);
338 if (m == MATCH_ERROR)
341 m = gfc_match_null (result);
345 old_loc = gfc_current_locus;
347 /* Should this be a structure component, try to match it
348 before matching a name. */
349 m = gfc_match_rvalue (result);
350 if (m == MATCH_ERROR)
353 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
355 if (gfc_simplify_expr (*result, 0) == FAILURE)
360 gfc_current_locus = old_loc;
362 m = gfc_match_name (name);
366 if (gfc_find_symbol (name, NULL, 1, &sym))
370 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
372 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
376 else if (sym->attr.flavor == FL_DERIVED)
377 return gfc_match_structure_constructor (sym, result, false);
379 /* Check to see if the value is an initialization array expression. */
380 if (sym->value->expr_type == EXPR_ARRAY)
382 gfc_current_locus = old_loc;
384 m = gfc_match_init_expr (result);
385 if (m == MATCH_ERROR)
390 if (gfc_simplify_expr (*result, 0) == FAILURE)
393 if ((*result)->expr_type == EXPR_CONSTANT)
397 gfc_error ("Invalid initializer %s in Data statement at %C", name);
403 *result = gfc_copy_expr (sym->value);
408 /* Match a list of values in a DATA statement. The leading '/' has
409 already been seen at this point. */
412 top_val_list (gfc_data *data)
414 gfc_data_value *new_val, *tail;
422 m = match_data_constant (&expr);
425 if (m == MATCH_ERROR)
428 new_val = gfc_get_data_value ();
429 mpz_init (new_val->repeat);
432 data->value = new_val;
434 tail->next = new_val;
438 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
441 mpz_set_ui (tail->repeat, 1);
445 if (expr->ts.type == BT_INTEGER)
446 mpz_set (tail->repeat, expr->value.integer);
447 gfc_free_expr (expr);
449 m = match_data_constant (&tail->expr);
452 if (m == MATCH_ERROR)
456 if (gfc_match_char ('/') == MATCH_YES)
458 if (gfc_match_char (',') == MATCH_NO)
465 gfc_syntax_error (ST_DATA);
466 gfc_free_data_all (gfc_current_ns);
471 /* Matches an old style initialization. */
474 match_old_style_init (const char *name)
481 /* Set up data structure to hold initializers. */
482 gfc_find_sym_tree (name, NULL, 0, &st);
485 newdata = gfc_get_data ();
486 newdata->var = gfc_get_data_variable ();
487 newdata->var->expr = gfc_get_variable_expr (st);
488 newdata->where = gfc_current_locus;
490 /* Match initial value list. This also eats the terminal '/'. */
491 m = top_val_list (newdata);
500 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
505 /* Mark the variable as having appeared in a data statement. */
506 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
512 /* Chain in namespace list of DATA initializers. */
513 newdata->next = gfc_current_ns->data;
514 gfc_current_ns->data = newdata;
520 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
521 we are matching a DATA statement and are therefore issuing an error
522 if we encounter something unexpected, if not, we're trying to match
523 an old-style initialization expression of the form INTEGER I /2/. */
526 gfc_match_data (void)
531 set_in_match_data (true);
535 new_data = gfc_get_data ();
536 new_data->where = gfc_current_locus;
538 m = top_var_list (new_data);
542 m = top_val_list (new_data);
546 new_data->next = gfc_current_ns->data;
547 gfc_current_ns->data = new_data;
549 if (gfc_match_eos () == MATCH_YES)
552 gfc_match_char (','); /* Optional comma */
555 set_in_match_data (false);
559 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
566 set_in_match_data (false);
567 gfc_free_data (new_data);
572 /************************ Declaration statements *********************/
575 /* Auxilliary function to merge DIMENSION and CODIMENSION array specs. */
578 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
582 if (to->rank == 0 && from->rank > 0)
584 to->rank = from->rank;
585 to->type = from->type;
586 to->cray_pointee = from->cray_pointee;
587 to->cp_was_assumed = from->cp_was_assumed;
589 for (i = 0; i < to->corank; i++)
591 to->lower[from->rank + i] = to->lower[i];
592 to->upper[from->rank + i] = to->upper[i];
594 for (i = 0; i < from->rank; i++)
598 to->lower[i] = gfc_copy_expr (from->lower[i]);
599 to->upper[i] = gfc_copy_expr (from->upper[i]);
603 to->lower[i] = from->lower[i];
604 to->upper[i] = from->upper[i];
608 else if (to->corank == 0 && from->corank > 0)
610 to->corank = from->corank;
611 to->cotype = from->cotype;
613 for (i = 0; i < from->corank; i++)
617 to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
618 to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
622 to->lower[to->rank + i] = from->lower[i];
623 to->upper[to->rank + i] = from->upper[i];
630 /* Match an intent specification. Since this can only happen after an
631 INTENT word, a legal intent-spec must follow. */
634 match_intent_spec (void)
637 if (gfc_match (" ( in out )") == MATCH_YES)
639 if (gfc_match (" ( in )") == MATCH_YES)
641 if (gfc_match (" ( out )") == MATCH_YES)
644 gfc_error ("Bad INTENT specification at %C");
645 return INTENT_UNKNOWN;
649 /* Matches a character length specification, which is either a
650 specification expression, '*', or ':'. */
653 char_len_param_value (gfc_expr **expr, bool *deferred)
660 if (gfc_match_char ('*') == MATCH_YES)
663 if (gfc_match_char (':') == MATCH_YES)
665 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
666 "parameter at %C") == FAILURE)
674 m = gfc_match_expr (expr);
677 && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
680 if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
682 if ((*expr)->value.function.actual
683 && (*expr)->value.function.actual->expr->symtree)
686 e = (*expr)->value.function.actual->expr;
687 if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
688 && e->expr_type == EXPR_VARIABLE)
690 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
692 if (e->symtree->n.sym->ts.type == BT_CHARACTER
693 && e->symtree->n.sym->ts.u.cl
694 && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
702 gfc_error ("Conflict in attributes of function argument at %C");
707 /* A character length is a '*' followed by a literal integer or a
708 char_len_param_value in parenthesis. */
711 match_char_length (gfc_expr **expr, bool *deferred)
717 m = gfc_match_char ('*');
721 m = gfc_match_small_literal_int (&length, NULL);
722 if (m == MATCH_ERROR)
727 if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
728 "Old-style character length at %C") == FAILURE)
730 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
734 if (gfc_match_char ('(') == MATCH_NO)
737 m = char_len_param_value (expr, deferred);
738 if (m != MATCH_YES && gfc_matching_function)
744 if (m == MATCH_ERROR)
749 if (gfc_match_char (')') == MATCH_NO)
751 gfc_free_expr (*expr);
759 gfc_error ("Syntax error in character length specification at %C");
764 /* Special subroutine for finding a symbol. Check if the name is found
765 in the current name space. If not, and we're compiling a function or
766 subroutine and the parent compilation unit is an interface, then check
767 to see if the name we've been given is the name of the interface
768 (located in another namespace). */
771 find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
777 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
780 *result = st ? st->n.sym : NULL;
784 if (gfc_current_state () != COMP_SUBROUTINE
785 && gfc_current_state () != COMP_FUNCTION)
788 s = gfc_state_stack->previous;
792 if (s->state != COMP_INTERFACE)
795 goto end; /* Nameless interface. */
797 if (strcmp (name, s->sym->name) == 0)
808 /* Special subroutine for getting a symbol node associated with a
809 procedure name, used in SUBROUTINE and FUNCTION statements. The
810 symbol is created in the parent using with symtree node in the
811 child unit pointing to the symbol. If the current namespace has no
812 parent, then the symbol is just created in the current unit. */
815 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
821 /* Module functions have to be left in their own namespace because
822 they have potentially (almost certainly!) already been referenced.
823 In this sense, they are rather like external functions. This is
824 fixed up in resolve.c(resolve_entries), where the symbol name-
825 space is set to point to the master function, so that the fake
826 result mechanism can work. */
827 if (module_fcn_entry)
829 /* Present if entry is declared to be a module procedure. */
830 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
833 rc = gfc_get_symbol (name, NULL, result);
834 else if (!gfc_get_symbol (name, NULL, &sym) && sym
835 && (*result)->ts.type == BT_UNKNOWN
836 && sym->attr.flavor == FL_UNKNOWN)
837 /* Pick up the typespec for the entry, if declared in the function
838 body. Note that this symbol is FL_UNKNOWN because it will
839 only have appeared in a type declaration. The local symtree
840 is set to point to the module symbol and a unique symtree
841 to the local version. This latter ensures a correct clearing
844 /* If the ENTRY proceeds its specification, we need to ensure
845 that this does not raise a "has no IMPLICIT type" error. */
846 if (sym->ts.type == BT_UNKNOWN)
847 sym->attr.untyped = 1;
849 (*result)->ts = sym->ts;
851 /* Put the symbol in the procedure namespace so that, should
852 the ENTRY precede its specification, the specification
854 (*result)->ns = gfc_current_ns;
856 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
858 st = gfc_get_unique_symtree (gfc_current_ns);
863 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
869 gfc_current_ns->refs++;
871 if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
873 /* Trap another encompassed procedure with the same name. All
874 these conditions are necessary to avoid picking up an entry
875 whose name clashes with that of the encompassing procedure;
876 this is handled using gsymbols to register unique,globally
878 if (sym->attr.flavor != 0
879 && sym->attr.proc != 0
880 && (sym->attr.subroutine || sym->attr.function)
881 && sym->attr.if_source != IFSRC_UNKNOWN)
882 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
883 name, &sym->declared_at);
885 /* Trap a procedure with a name the same as interface in the
886 encompassing scope. */
887 if (sym->attr.generic != 0
888 && (sym->attr.subroutine || sym->attr.function)
889 && !sym->attr.mod_proc)
890 gfc_error_now ("Name '%s' at %C is already defined"
891 " as a generic interface at %L",
892 name, &sym->declared_at);
894 /* Trap declarations of attributes in encompassing scope. The
895 signature for this is that ts.kind is set. Legitimate
896 references only set ts.type. */
897 if (sym->ts.kind != 0
898 && !sym->attr.implicit_type
899 && sym->attr.proc == 0
900 && gfc_current_ns->parent != NULL
901 && sym->attr.access == 0
902 && !module_fcn_entry)
903 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
904 "and must not have attributes declared at %L",
905 name, &sym->declared_at);
908 if (gfc_current_ns->parent == NULL || *result == NULL)
911 /* Module function entries will already have a symtree in
912 the current namespace but will need one at module level. */
913 if (module_fcn_entry)
915 /* Present if entry is declared to be a module procedure. */
916 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
918 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
921 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
926 /* See if the procedure should be a module procedure. */
928 if (((sym->ns->proc_name != NULL
929 && sym->ns->proc_name->attr.flavor == FL_MODULE
930 && sym->attr.proc != PROC_MODULE)
931 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
932 && gfc_add_procedure (&sym->attr, PROC_MODULE,
933 sym->name, NULL) == FAILURE)
940 /* Verify that the given symbol representing a parameter is C
941 interoperable, by checking to see if it was marked as such after
942 its declaration. If the given symbol is not interoperable, a
943 warning is reported, thus removing the need to return the status to
944 the calling function. The standard does not require the user use
945 one of the iso_c_binding named constants to declare an
946 interoperable parameter, but we can't be sure if the param is C
947 interop or not if the user doesn't. For example, integer(4) may be
948 legal Fortran, but doesn't have meaning in C. It may interop with
949 a number of the C types, which causes a problem because the
950 compiler can't know which one. This code is almost certainly not
951 portable, and the user will get what they deserve if the C type
952 across platforms isn't always interoperable with integer(4). If
953 the user had used something like integer(c_int) or integer(c_long),
954 the compiler could have automatically handled the varying sizes
958 verify_c_interop_param (gfc_symbol *sym)
960 int is_c_interop = 0;
961 gfc_try retval = SUCCESS;
963 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
964 Don't repeat the checks here. */
965 if (sym->attr.implicit_type)
968 /* For subroutines or functions that are passed to a BIND(C) procedure,
969 they're interoperable if they're BIND(C) and their params are all
971 if (sym->attr.flavor == FL_PROCEDURE)
973 if (sym->attr.is_bind_c == 0)
975 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
976 "attribute to be C interoperable", sym->name,
977 &(sym->declared_at));
983 if (sym->attr.is_c_interop == 1)
984 /* We've already checked this procedure; don't check it again. */
987 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
992 /* See if we've stored a reference to a procedure that owns sym. */
993 if (sym->ns != NULL && sym->ns->proc_name != NULL)
995 if (sym->ns->proc_name->attr.is_bind_c == 1)
998 (verify_c_interop (&(sym->ts))
1001 if (is_c_interop != 1)
1003 /* Make personalized messages to give better feedback. */
1004 if (sym->ts.type == BT_DERIVED)
1005 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
1006 "procedure '%s' but is not C interoperable "
1007 "because derived type '%s' is not C interoperable",
1008 sym->name, &(sym->declared_at),
1009 sym->ns->proc_name->name,
1010 sym->ts.u.derived->name);
1012 gfc_warning ("Variable '%s' at %L is a parameter to the "
1013 "BIND(C) procedure '%s' but may not be C "
1015 sym->name, &(sym->declared_at),
1016 sym->ns->proc_name->name);
1019 /* Character strings are only C interoperable if they have a
1021 if (sym->ts.type == BT_CHARACTER)
1023 gfc_charlen *cl = sym->ts.u.cl;
1024 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
1025 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1027 gfc_error ("Character argument '%s' at %L "
1028 "must be length 1 because "
1029 "procedure '%s' is BIND(C)",
1030 sym->name, &sym->declared_at,
1031 sym->ns->proc_name->name);
1036 /* We have to make sure that any param to a bind(c) routine does
1037 not have the allocatable, pointer, or optional attributes,
1038 according to J3/04-007, section 5.1. */
1039 if (sym->attr.allocatable == 1)
1041 gfc_error ("Variable '%s' at %L cannot have the "
1042 "ALLOCATABLE attribute because procedure '%s'"
1043 " is BIND(C)", sym->name, &(sym->declared_at),
1044 sym->ns->proc_name->name);
1048 if (sym->attr.pointer == 1)
1050 gfc_error ("Variable '%s' at %L cannot have the "
1051 "POINTER attribute because procedure '%s'"
1052 " is BIND(C)", sym->name, &(sym->declared_at),
1053 sym->ns->proc_name->name);
1057 if (sym->attr.optional == 1)
1059 gfc_error ("Variable '%s' at %L cannot have the "
1060 "OPTIONAL attribute because procedure '%s'"
1061 " is BIND(C)", sym->name, &(sym->declared_at),
1062 sym->ns->proc_name->name);
1066 /* Make sure that if it has the dimension attribute, that it is
1067 either assumed size or explicit shape. */
1068 if (sym->as != NULL)
1070 if (sym->as->type == AS_ASSUMED_SHAPE)
1072 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
1073 "argument to the procedure '%s' at %L because "
1074 "the procedure is BIND(C)", sym->name,
1075 &(sym->declared_at), sym->ns->proc_name->name,
1076 &(sym->ns->proc_name->declared_at));
1080 if (sym->as->type == AS_DEFERRED)
1082 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
1083 "argument to the procedure '%s' at %L because "
1084 "the procedure is BIND(C)", sym->name,
1085 &(sym->declared_at), sym->ns->proc_name->name,
1086 &(sym->ns->proc_name->declared_at));
1098 /* Function called by variable_decl() that adds a name to the symbol table. */
1101 build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1102 gfc_array_spec **as, locus *var_locus)
1104 symbol_attribute attr;
1107 if (gfc_get_symbol (name, NULL, &sym))
1110 /* Start updating the symbol table. Add basic type attribute if present. */
1111 if (current_ts.type != BT_UNKNOWN
1112 && (sym->attr.implicit_type == 0
1113 || !gfc_compare_types (&sym->ts, ¤t_ts))
1114 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
1117 if (sym->ts.type == BT_CHARACTER)
1120 sym->ts.deferred = cl_deferred;
1123 /* Add dimension attribute if present. */
1124 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
1128 /* Add attribute to symbol. The copy is so that we can reset the
1129 dimension attribute. */
1130 attr = current_attr;
1132 attr.codimension = 0;
1134 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
1137 /* Finish any work that may need to be done for the binding label,
1138 if it's a bind(c). The bind(c) attr is found before the symbol
1139 is made, and before the symbol name (for data decls), so the
1140 current_ts is holding the binding label, or nothing if the
1141 name= attr wasn't given. Therefore, test here if we're dealing
1142 with a bind(c) and make sure the binding label is set correctly. */
1143 if (sym->attr.is_bind_c == 1)
1145 if (sym->binding_label[0] == '\0')
1147 /* Set the binding label and verify that if a NAME= was specified
1148 then only one identifier was in the entity-decl-list. */
1149 if (set_binding_label (sym->binding_label, sym->name,
1150 num_idents_on_line) == FAILURE)
1155 /* See if we know we're in a common block, and if it's a bind(c)
1156 common then we need to make sure we're an interoperable type. */
1157 if (sym->attr.in_common == 1)
1159 /* Test the common block object. */
1160 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1161 && sym->ts.is_c_interop != 1)
1163 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1164 "must be declared with a C interoperable "
1165 "kind since common block '%s' is BIND(C)",
1166 sym->name, sym->common_block->name,
1167 sym->common_block->name);
1172 sym->attr.implied_index = 0;
1174 if (sym->ts.type == BT_CLASS
1175 && (sym->attr.class_ok = sym->attr.dummy || sym->attr.pointer
1176 || sym->attr.allocatable))
1177 gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
1183 /* Set character constant to the given length. The constant will be padded or
1184 truncated. If we're inside an array constructor without a typespec, we
1185 additionally check that all elements have the same length; check_len -1
1186 means no checking. */
1189 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1194 gcc_assert (expr->expr_type == EXPR_CONSTANT);
1195 gcc_assert (expr->ts.type == BT_CHARACTER);
1197 slen = expr->value.character.length;
1200 s = gfc_get_wide_string (len + 1);
1201 memcpy (s, expr->value.character.string,
1202 MIN (len, slen) * sizeof (gfc_char_t));
1204 gfc_wide_memset (&s[slen], ' ', len - slen);
1206 if (gfc_option.warn_character_truncation && slen > len)
1207 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1208 "(%d/%d)", &expr->where, slen, len);
1210 /* Apply the standard by 'hand' otherwise it gets cleared for
1212 if (check_len != -1 && slen != check_len
1213 && !(gfc_option.allow_std & GFC_STD_GNU))
1214 gfc_error_now ("The CHARACTER elements of the array constructor "
1215 "at %L must have the same length (%d/%d)",
1216 &expr->where, slen, check_len);
1219 gfc_free (expr->value.character.string);
1220 expr->value.character.string = s;
1221 expr->value.character.length = len;
1226 /* Function to create and update the enumerator history
1227 using the information passed as arguments.
1228 Pointer "max_enum" is also updated, to point to
1229 enum history node containing largest initializer.
1231 SYM points to the symbol node of enumerator.
1232 INIT points to its enumerator value. */
1235 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1237 enumerator_history *new_enum_history;
1238 gcc_assert (sym != NULL && init != NULL);
1240 new_enum_history = XCNEW (enumerator_history);
1242 new_enum_history->sym = sym;
1243 new_enum_history->initializer = init;
1244 new_enum_history->next = NULL;
1246 if (enum_history == NULL)
1248 enum_history = new_enum_history;
1249 max_enum = enum_history;
1253 new_enum_history->next = enum_history;
1254 enum_history = new_enum_history;
1256 if (mpz_cmp (max_enum->initializer->value.integer,
1257 new_enum_history->initializer->value.integer) < 0)
1258 max_enum = new_enum_history;
1263 /* Function to free enum kind history. */
1266 gfc_free_enum_history (void)
1268 enumerator_history *current = enum_history;
1269 enumerator_history *next;
1271 while (current != NULL)
1273 next = current->next;
1278 enum_history = NULL;
1282 /* Function called by variable_decl() that adds an initialization
1283 expression to a symbol. */
1286 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1288 symbol_attribute attr;
1293 if (find_special (name, &sym, false))
1298 /* If this symbol is confirming an implicit parameter type,
1299 then an initialization expression is not allowed. */
1300 if (attr.flavor == FL_PARAMETER
1301 && sym->value != NULL
1304 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1311 /* An initializer is required for PARAMETER declarations. */
1312 if (attr.flavor == FL_PARAMETER)
1314 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1320 /* If a variable appears in a DATA block, it cannot have an
1324 gfc_error ("Variable '%s' at %C with an initializer already "
1325 "appears in a DATA statement", sym->name);
1329 /* Check if the assignment can happen. This has to be put off
1330 until later for derived type variables and procedure pointers. */
1331 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1332 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1333 && !sym->attr.proc_pointer
1334 && gfc_check_assign_symbol (sym, init) == FAILURE)
1337 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1338 && init->ts.type == BT_CHARACTER)
1340 /* Update symbol character length according initializer. */
1341 if (gfc_check_assign_symbol (sym, init) == FAILURE)
1344 if (sym->ts.u.cl->length == NULL)
1347 /* If there are multiple CHARACTER variables declared on the
1348 same line, we don't want them to share the same length. */
1349 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1351 if (sym->attr.flavor == FL_PARAMETER)
1353 if (init->expr_type == EXPR_CONSTANT)
1355 clen = init->value.character.length;
1356 sym->ts.u.cl->length
1357 = gfc_get_int_expr (gfc_default_integer_kind,
1360 else if (init->expr_type == EXPR_ARRAY)
1363 c = gfc_constructor_first (init->value.constructor);
1364 clen = c->expr->value.character.length;
1365 sym->ts.u.cl->length
1366 = gfc_get_int_expr (gfc_default_integer_kind,
1369 else if (init->ts.u.cl && init->ts.u.cl->length)
1370 sym->ts.u.cl->length =
1371 gfc_copy_expr (sym->value->ts.u.cl->length);
1374 /* Update initializer character length according symbol. */
1375 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1377 int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1379 if (init->expr_type == EXPR_CONSTANT)
1380 gfc_set_constant_character_len (len, init, -1);
1381 else if (init->expr_type == EXPR_ARRAY)
1385 /* Build a new charlen to prevent simplification from
1386 deleting the length before it is resolved. */
1387 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1388 init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1390 for (c = gfc_constructor_first (init->value.constructor);
1391 c; c = gfc_constructor_next (c))
1392 gfc_set_constant_character_len (len, c->expr, -1);
1397 /* If sym is implied-shape, set its upper bounds from init. */
1398 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1399 && sym->as->type == AS_IMPLIED_SHAPE)
1403 if (init->rank == 0)
1405 gfc_error ("Can't initialize implied-shape array at %L"
1406 " with scalar", &sym->declared_at);
1409 gcc_assert (sym->as->rank == init->rank);
1411 /* Shape should be present, we get an initialization expression. */
1412 gcc_assert (init->shape);
1414 for (dim = 0; dim < sym->as->rank; ++dim)
1420 lower = sym->as->lower[dim];
1421 if (lower->expr_type != EXPR_CONSTANT)
1423 gfc_error ("Non-constant lower bound in implied-shape"
1424 " declaration at %L", &lower->where);
1428 /* All dimensions must be without upper bound. */
1429 gcc_assert (!sym->as->upper[dim]);
1432 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1433 mpz_add (e->value.integer,
1434 lower->value.integer, init->shape[dim]);
1435 mpz_sub_ui (e->value.integer, e->value.integer, 1);
1436 sym->as->upper[dim] = e;
1439 sym->as->type = AS_EXPLICIT;
1442 /* Need to check if the expression we initialized this
1443 to was one of the iso_c_binding named constants. If so,
1444 and we're a parameter (constant), let it be iso_c.
1446 integer(c_int), parameter :: my_int = c_int
1447 integer(my_int) :: my_int_2
1448 If we mark my_int as iso_c (since we can see it's value
1449 is equal to one of the named constants), then my_int_2
1450 will be considered C interoperable. */
1451 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1453 sym->ts.is_iso_c |= init->ts.is_iso_c;
1454 sym->ts.is_c_interop |= init->ts.is_c_interop;
1455 /* attr bits needed for module files. */
1456 sym->attr.is_iso_c |= init->ts.is_iso_c;
1457 sym->attr.is_c_interop |= init->ts.is_c_interop;
1458 if (init->ts.is_iso_c)
1459 sym->ts.f90_type = init->ts.f90_type;
1462 /* Add initializer. Make sure we keep the ranks sane. */
1463 if (sym->attr.dimension && init->rank == 0)
1468 if (sym->attr.flavor == FL_PARAMETER
1469 && init->expr_type == EXPR_CONSTANT
1470 && spec_size (sym->as, &size) == SUCCESS
1471 && mpz_cmp_si (size, 0) > 0)
1473 array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1475 for (n = 0; n < (int)mpz_get_si (size); n++)
1476 gfc_constructor_append_expr (&array->value.constructor,
1479 : gfc_copy_expr (init),
1482 array->shape = gfc_get_shape (sym->as->rank);
1483 for (n = 0; n < sym->as->rank; n++)
1484 spec_dimen_size (sym->as, n, &array->shape[n]);
1489 init->rank = sym->as->rank;
1493 if (sym->attr.save == SAVE_NONE)
1494 sym->attr.save = SAVE_IMPLICIT;
1502 /* Function called by variable_decl() that adds a name to a structure
1506 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1507 gfc_array_spec **as)
1510 gfc_try t = SUCCESS;
1512 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1513 constructing, it must have the pointer attribute. */
1514 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1515 && current_ts.u.derived == gfc_current_block ()
1516 && current_attr.pointer == 0)
1518 gfc_error ("Component at %C must have the POINTER attribute");
1522 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1524 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1526 gfc_error ("Array component of structure at %C must have explicit "
1527 "or deferred shape");
1532 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1536 if (c->ts.type == BT_CHARACTER)
1538 c->attr = current_attr;
1540 c->initializer = *init;
1547 c->attr.codimension = 1;
1549 c->attr.dimension = 1;
1553 /* Should this ever get more complicated, combine with similar section
1554 in add_init_expr_to_sym into a separate function. */
1555 if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.u.cl
1556 && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1560 gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
1561 gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
1562 gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
1564 len = mpz_get_si (c->ts.u.cl->length->value.integer);
1566 if (c->initializer->expr_type == EXPR_CONSTANT)
1567 gfc_set_constant_character_len (len, c->initializer, -1);
1568 else if (mpz_cmp (c->ts.u.cl->length->value.integer,
1569 c->initializer->ts.u.cl->length->value.integer))
1571 gfc_constructor *ctor;
1572 ctor = gfc_constructor_first (c->initializer->value.constructor);
1577 bool has_ts = (c->initializer->ts.u.cl
1578 && c->initializer->ts.u.cl->length_from_typespec);
1580 /* Remember the length of the first element for checking
1581 that all elements *in the constructor* have the same
1582 length. This need not be the length of the LHS! */
1583 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
1584 gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
1585 first_len = ctor->expr->value.character.length;
1587 for ( ; ctor; ctor = gfc_constructor_next (ctor))
1588 if (ctor->expr->expr_type == EXPR_CONSTANT)
1590 gfc_set_constant_character_len (len, ctor->expr,
1591 has_ts ? -1 : first_len);
1592 ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
1598 /* Check array components. */
1599 if (!c->attr.dimension)
1602 if (c->attr.pointer)
1604 if (c->as->type != AS_DEFERRED)
1606 gfc_error ("Pointer array component of structure at %C must have a "
1611 else if (c->attr.allocatable)
1613 if (c->as->type != AS_DEFERRED)
1615 gfc_error ("Allocatable component of structure at %C must have a "
1622 if (c->as->type != AS_EXPLICIT)
1624 gfc_error ("Array component of structure at %C must have an "
1631 if (c->ts.type == BT_CLASS)
1632 gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
1638 /* Match a 'NULL()', and possibly take care of some side effects. */
1641 gfc_match_null (gfc_expr **result)
1646 m = gfc_match (" null ( )");
1650 /* The NULL symbol now has to be/become an intrinsic function. */
1651 if (gfc_get_symbol ("null", NULL, &sym))
1653 gfc_error ("NULL() initialization at %C is ambiguous");
1657 gfc_intrinsic_symbol (sym);
1659 if (sym->attr.proc != PROC_INTRINSIC
1660 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1661 sym->name, NULL) == FAILURE
1662 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1665 *result = gfc_get_null_expr (&gfc_current_locus);
1671 /* Match the initialization expr for a data pointer or procedure pointer. */
1674 match_pointer_init (gfc_expr **init, int procptr)
1678 if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
1680 gfc_error ("Initialization of pointer at %C is not allowed in "
1681 "a PURE procedure");
1685 /* Match NULL() initilization. */
1686 m = gfc_match_null (init);
1690 /* Match non-NULL initialization. */
1691 gfc_matching_ptr_assignment = !procptr;
1692 gfc_matching_procptr_assignment = procptr;
1693 m = gfc_match_rvalue (init);
1694 gfc_matching_ptr_assignment = 0;
1695 gfc_matching_procptr_assignment = 0;
1696 if (m == MATCH_ERROR)
1698 else if (m == MATCH_NO)
1700 gfc_error ("Error in pointer initialization at %C");
1705 gfc_resolve_expr (*init);
1707 if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
1708 "initialization at %C") == FAILURE)
1715 /* Match a variable name with an optional initializer. When this
1716 subroutine is called, a variable is expected to be parsed next.
1717 Depending on what is happening at the moment, updates either the
1718 symbol table or the current interface. */
1721 variable_decl (int elem)
1723 char name[GFC_MAX_SYMBOL_LEN + 1];
1724 gfc_expr *initializer, *char_len;
1726 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1738 /* When we get here, we've just matched a list of attributes and
1739 maybe a type and a double colon. The next thing we expect to see
1740 is the name of the symbol. */
1741 m = gfc_match_name (name);
1745 var_locus = gfc_current_locus;
1747 /* Now we could see the optional array spec. or character length. */
1748 m = gfc_match_array_spec (&as, true, true);
1749 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1750 cp_as = gfc_copy_array_spec (as);
1751 else if (m == MATCH_ERROR)
1755 as = gfc_copy_array_spec (current_as);
1756 else if (current_as)
1757 merge_array_spec (current_as, as, true);
1759 /* At this point, we know for sure if the symbol is PARAMETER and can thus
1760 determine (and check) whether it can be implied-shape. If it
1761 was parsed as assumed-size, change it because PARAMETERs can not
1765 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
1768 gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
1773 if (as->type == AS_ASSUMED_SIZE && as->rank == 1
1774 && current_attr.flavor == FL_PARAMETER)
1775 as->type = AS_IMPLIED_SHAPE;
1777 if (as->type == AS_IMPLIED_SHAPE
1778 && gfc_notify_std (GFC_STD_F2008,
1779 "Fortran 2008: Implied-shape array at %L",
1780 &var_locus) == FAILURE)
1789 cl_deferred = false;
1791 if (current_ts.type == BT_CHARACTER)
1793 switch (match_char_length (&char_len, &cl_deferred))
1796 cl = gfc_new_charlen (gfc_current_ns, NULL);
1798 cl->length = char_len;
1801 /* Non-constant lengths need to be copied after the first
1802 element. Also copy assumed lengths. */
1805 && (current_ts.u.cl->length == NULL
1806 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
1808 cl = gfc_new_charlen (gfc_current_ns, NULL);
1809 cl->length = gfc_copy_expr (current_ts.u.cl->length);
1812 cl = current_ts.u.cl;
1814 cl_deferred = current_ts.deferred;
1823 /* If this symbol has already shown up in a Cray Pointer declaration,
1824 then we want to set the type & bail out. */
1825 if (gfc_option.flag_cray_pointer)
1827 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1828 if (sym != NULL && sym->attr.cray_pointee)
1830 sym->ts.type = current_ts.type;
1831 sym->ts.kind = current_ts.kind;
1833 sym->ts.u.derived = current_ts.u.derived;
1834 sym->ts.is_c_interop = current_ts.is_c_interop;
1835 sym->ts.is_iso_c = current_ts.is_iso_c;
1838 /* Check to see if we have an array specification. */
1841 if (sym->as != NULL)
1843 gfc_error ("Duplicate array spec for Cray pointee at %C");
1844 gfc_free_array_spec (cp_as);
1850 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1851 gfc_internal_error ("Couldn't set pointee array spec.");
1853 /* Fix the array spec. */
1854 m = gfc_mod_pointee_as (sym->as);
1855 if (m == MATCH_ERROR)
1863 gfc_free_array_spec (cp_as);
1867 /* Procedure pointer as function result. */
1868 if (gfc_current_state () == COMP_FUNCTION
1869 && strcmp ("ppr@", gfc_current_block ()->name) == 0
1870 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
1871 strcpy (name, "ppr@");
1873 if (gfc_current_state () == COMP_FUNCTION
1874 && strcmp (name, gfc_current_block ()->name) == 0
1875 && gfc_current_block ()->result
1876 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
1877 strcpy (name, "ppr@");
1879 /* OK, we've successfully matched the declaration. Now put the
1880 symbol in the current namespace, because it might be used in the
1881 optional initialization expression for this symbol, e.g. this is
1884 integer, parameter :: i = huge(i)
1886 This is only true for parameters or variables of a basic type.
1887 For components of derived types, it is not true, so we don't
1888 create a symbol for those yet. If we fail to create the symbol,
1890 if (gfc_current_state () != COMP_DERIVED
1891 && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
1897 /* An interface body specifies all of the procedure's
1898 characteristics and these shall be consistent with those
1899 specified in the procedure definition, except that the interface
1900 may specify a procedure that is not pure if the procedure is
1901 defined to be pure(12.3.2). */
1902 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1903 && gfc_current_ns->proc_name
1904 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1905 && current_ts.u.derived->ns != gfc_current_ns)
1908 st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
1909 if (!(current_ts.u.derived->attr.imported
1911 && st->n.sym == current_ts.u.derived)
1912 && !gfc_current_ns->has_import_set)
1914 gfc_error ("the type of '%s' at %C has not been declared within the "
1921 /* In functions that have a RESULT variable defined, the function
1922 name always refers to function calls. Therefore, the name is
1923 not allowed to appear in specification statements. */
1924 if (gfc_current_state () == COMP_FUNCTION
1925 && gfc_current_block () != NULL
1926 && gfc_current_block ()->result != NULL
1927 && gfc_current_block ()->result != gfc_current_block ()
1928 && strcmp (gfc_current_block ()->name, name) == 0)
1930 gfc_error ("Function name '%s' not allowed at %C", name);
1935 /* We allow old-style initializations of the form
1936 integer i /2/, j(4) /3*3, 1/
1937 (if no colon has been seen). These are different from data
1938 statements in that initializers are only allowed to apply to the
1939 variable immediately preceding, i.e.
1941 is not allowed. Therefore we have to do some work manually, that
1942 could otherwise be left to the matchers for DATA statements. */
1944 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1946 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1947 "initialization at %C") == FAILURE)
1950 return match_old_style_init (name);
1953 /* The double colon must be present in order to have initializers.
1954 Otherwise the statement is ambiguous with an assignment statement. */
1957 if (gfc_match (" =>") == MATCH_YES)
1959 if (!current_attr.pointer)
1961 gfc_error ("Initialization at %C isn't for a pointer variable");
1966 m = match_pointer_init (&initializer, 0);
1970 else if (gfc_match_char ('=') == MATCH_YES)
1972 if (current_attr.pointer)
1974 gfc_error ("Pointer initialization at %C requires '=>', "
1980 m = gfc_match_init_expr (&initializer);
1983 gfc_error ("Expected an initialization expression at %C");
1987 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
1988 && gfc_state_stack->state != COMP_DERIVED)
1990 gfc_error ("Initialization of variable at %C is not allowed in "
1991 "a PURE procedure");
2000 if (initializer != NULL && current_attr.allocatable
2001 && gfc_current_state () == COMP_DERIVED)
2003 gfc_error ("Initialization of allocatable component at %C is not "
2009 /* Add the initializer. Note that it is fine if initializer is
2010 NULL here, because we sometimes also need to check if a
2011 declaration *must* have an initialization expression. */
2012 if (gfc_current_state () != COMP_DERIVED)
2013 t = add_init_expr_to_sym (name, &initializer, &var_locus);
2016 if (current_ts.type == BT_DERIVED
2017 && !current_attr.pointer && !initializer)
2018 initializer = gfc_default_initializer (¤t_ts);
2019 t = build_struct (name, cl, &initializer, &as);
2022 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
2025 /* Free stuff up and return. */
2026 gfc_free_expr (initializer);
2027 gfc_free_array_spec (as);
2033 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2034 This assumes that the byte size is equal to the kind number for
2035 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2038 gfc_match_old_kind_spec (gfc_typespec *ts)
2043 if (gfc_match_char ('*') != MATCH_YES)
2046 m = gfc_match_small_literal_int (&ts->kind, NULL);
2050 original_kind = ts->kind;
2052 /* Massage the kind numbers for complex types. */
2053 if (ts->type == BT_COMPLEX)
2057 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2058 gfc_basic_typename (ts->type), original_kind);
2064 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2066 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2067 gfc_basic_typename (ts->type), original_kind);
2071 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
2072 gfc_basic_typename (ts->type), original_kind) == FAILURE)
2079 /* Match a kind specification. Since kinds are generally optional, we
2080 usually return MATCH_NO if something goes wrong. If a "kind="
2081 string is found, then we know we have an error. */
2084 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2096 where = loc = gfc_current_locus;
2101 if (gfc_match_char ('(') == MATCH_NO)
2104 /* Also gobbles optional text. */
2105 if (gfc_match (" kind = ") == MATCH_YES)
2108 loc = gfc_current_locus;
2111 n = gfc_match_init_expr (&e);
2115 if (gfc_matching_function)
2117 /* The function kind expression might include use associated or
2118 imported parameters and try again after the specification
2120 if (gfc_match_char (')') != MATCH_YES)
2122 gfc_error ("Missing right parenthesis at %C");
2128 gfc_undo_symbols ();
2133 /* ....or else, the match is real. */
2135 gfc_error ("Expected initialization expression at %C");
2143 gfc_error ("Expected scalar initialization expression at %C");
2148 msg = gfc_extract_int (e, &ts->kind);
2157 /* Before throwing away the expression, let's see if we had a
2158 C interoperable kind (and store the fact). */
2159 if (e->ts.is_c_interop == 1)
2161 /* Mark this as c interoperable if being declared with one
2162 of the named constants from iso_c_binding. */
2163 ts->is_c_interop = e->ts.is_iso_c;
2164 ts->f90_type = e->ts.f90_type;
2170 /* Ignore errors to this point, if we've gotten here. This means
2171 we ignore the m=MATCH_ERROR from above. */
2172 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2174 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2175 gfc_basic_typename (ts->type));
2176 gfc_current_locus = where;
2180 /* Warn if, e.g., c_int is used for a REAL variable, but not
2181 if, e.g., c_double is used for COMPLEX as the standard
2182 explicitly says that the kind type parameter for complex and real
2183 variable is the same, i.e. c_float == c_float_complex. */
2184 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2185 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2186 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2187 gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2188 "is %s", gfc_basic_typename (ts->f90_type), &where,
2189 gfc_basic_typename (ts->type));
2191 gfc_gobble_whitespace ();
2192 if ((c = gfc_next_ascii_char ()) != ')'
2193 && (ts->type != BT_CHARACTER || c != ','))
2195 if (ts->type == BT_CHARACTER)
2196 gfc_error ("Missing right parenthesis or comma at %C");
2198 gfc_error ("Missing right parenthesis at %C");
2202 /* All tests passed. */
2205 if(m == MATCH_ERROR)
2206 gfc_current_locus = where;
2208 /* Return what we know from the test(s). */
2213 gfc_current_locus = where;
2219 match_char_kind (int * kind, int * is_iso_c)
2228 where = gfc_current_locus;
2230 n = gfc_match_init_expr (&e);
2232 if (n != MATCH_YES && gfc_matching_function)
2234 /* The expression might include use-associated or imported
2235 parameters and try again after the specification
2238 gfc_undo_symbols ();
2243 gfc_error ("Expected initialization expression at %C");
2249 gfc_error ("Expected scalar initialization expression at %C");
2254 msg = gfc_extract_int (e, kind);
2255 *is_iso_c = e->ts.is_iso_c;
2265 /* Ignore errors to this point, if we've gotten here. This means
2266 we ignore the m=MATCH_ERROR from above. */
2267 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2269 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2273 /* All tests passed. */
2276 if (m == MATCH_ERROR)
2277 gfc_current_locus = where;
2279 /* Return what we know from the test(s). */
2284 gfc_current_locus = where;
2289 /* Match the various kind/length specifications in a CHARACTER
2290 declaration. We don't return MATCH_NO. */
2293 gfc_match_char_spec (gfc_typespec *ts)
2295 int kind, seen_length, is_iso_c;
2307 /* Try the old-style specification first. */
2308 old_char_selector = 0;
2310 m = match_char_length (&len, &deferred);
2314 old_char_selector = 1;
2319 m = gfc_match_char ('(');
2322 m = MATCH_YES; /* Character without length is a single char. */
2326 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2327 if (gfc_match (" kind =") == MATCH_YES)
2329 m = match_char_kind (&kind, &is_iso_c);
2331 if (m == MATCH_ERROR)
2336 if (gfc_match (" , len =") == MATCH_NO)
2339 m = char_len_param_value (&len, &deferred);
2342 if (m == MATCH_ERROR)
2349 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2350 if (gfc_match (" len =") == MATCH_YES)
2352 m = char_len_param_value (&len, &deferred);
2355 if (m == MATCH_ERROR)
2359 if (gfc_match_char (')') == MATCH_YES)
2362 if (gfc_match (" , kind =") != MATCH_YES)
2365 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2371 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2372 m = char_len_param_value (&len, &deferred);
2375 if (m == MATCH_ERROR)
2379 m = gfc_match_char (')');
2383 if (gfc_match_char (',') != MATCH_YES)
2386 gfc_match (" kind ="); /* Gobble optional text. */
2388 m = match_char_kind (&kind, &is_iso_c);
2389 if (m == MATCH_ERROR)
2395 /* Require a right-paren at this point. */
2396 m = gfc_match_char (')');
2401 gfc_error ("Syntax error in CHARACTER declaration at %C");
2403 gfc_free_expr (len);
2407 /* Deal with character functions after USE and IMPORT statements. */
2408 if (gfc_matching_function)
2410 gfc_free_expr (len);
2411 gfc_undo_symbols ();
2417 gfc_free_expr (len);
2421 /* Do some final massaging of the length values. */
2422 cl = gfc_new_charlen (gfc_current_ns, NULL);
2424 if (seen_length == 0)
2425 cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2430 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2431 ts->deferred = deferred;
2433 /* We have to know if it was a c interoperable kind so we can
2434 do accurate type checking of bind(c) procs, etc. */
2436 /* Mark this as c interoperable if being declared with one
2437 of the named constants from iso_c_binding. */
2438 ts->is_c_interop = is_iso_c;
2439 else if (len != NULL)
2440 /* Here, we might have parsed something such as: character(c_char)
2441 In this case, the parsing code above grabs the c_char when
2442 looking for the length (line 1690, roughly). it's the last
2443 testcase for parsing the kind params of a character variable.
2444 However, it's not actually the length. this seems like it
2446 To see if the user used a C interop kind, test the expr
2447 of the so called length, and see if it's C interoperable. */
2448 ts->is_c_interop = len->ts.is_iso_c;
2454 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2455 structure to the matched specification. This is necessary for FUNCTION and
2456 IMPLICIT statements.
2458 If implicit_flag is nonzero, then we don't check for the optional
2459 kind specification. Not doing so is needed for matching an IMPLICIT
2460 statement correctly. */
2463 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2465 char name[GFC_MAX_SYMBOL_LEN + 1];
2469 bool seen_deferred_kind, matched_type;
2471 /* A belt and braces check that the typespec is correctly being treated
2472 as a deferred characteristic association. */
2473 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2474 && (gfc_current_block ()->result->ts.kind == -1)
2475 && (ts->kind == -1);
2477 if (seen_deferred_kind)
2480 /* Clear the current binding label, in case one is given. */
2481 curr_binding_label[0] = '\0';
2483 if (gfc_match (" byte") == MATCH_YES)
2485 if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
2489 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2491 gfc_error ("BYTE type used at %C "
2492 "is not available on the target machine");
2496 ts->type = BT_INTEGER;
2502 m = gfc_match (" type ( %n", name);
2503 matched_type = (m == MATCH_YES);
2505 if ((matched_type && strcmp ("integer", name) == 0)
2506 || (!matched_type && gfc_match (" integer") == MATCH_YES))
2508 ts->type = BT_INTEGER;
2509 ts->kind = gfc_default_integer_kind;
2513 if ((matched_type && strcmp ("character", name) == 0)
2514 || (!matched_type && gfc_match (" character") == MATCH_YES))
2517 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2518 "intrinsic-type-spec at %C") == FAILURE)
2521 ts->type = BT_CHARACTER;
2522 if (implicit_flag == 0)
2523 m = gfc_match_char_spec (ts);
2527 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
2533 if ((matched_type && strcmp ("real", name) == 0)
2534 || (!matched_type && gfc_match (" real") == MATCH_YES))
2537 ts->kind = gfc_default_real_kind;
2542 && (strcmp ("doubleprecision", name) == 0
2543 || (strcmp ("double", name) == 0
2544 && gfc_match (" precision") == MATCH_YES)))
2545 || (!matched_type && gfc_match (" double precision") == MATCH_YES))
2548 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2549 "intrinsic-type-spec at %C") == FAILURE)
2551 if (matched_type && gfc_match_char (')') != MATCH_YES)
2555 ts->kind = gfc_default_double_kind;
2559 if ((matched_type && strcmp ("complex", name) == 0)
2560 || (!matched_type && gfc_match (" complex") == MATCH_YES))
2562 ts->type = BT_COMPLEX;
2563 ts->kind = gfc_default_complex_kind;
2568 && (strcmp ("doublecomplex", name) == 0
2569 || (strcmp ("double", name) == 0
2570 && gfc_match (" complex") == MATCH_YES)))
2571 || (!matched_type && gfc_match (" double complex") == MATCH_YES))
2573 if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
2578 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2579 "intrinsic-type-spec at %C") == FAILURE)
2582 if (matched_type && gfc_match_char (')') != MATCH_YES)
2585 ts->type = BT_COMPLEX;
2586 ts->kind = gfc_default_double_kind;
2590 if ((matched_type && strcmp ("logical", name) == 0)
2591 || (!matched_type && gfc_match (" logical") == MATCH_YES))
2593 ts->type = BT_LOGICAL;
2594 ts->kind = gfc_default_logical_kind;
2599 m = gfc_match_char (')');
2602 ts->type = BT_DERIVED;
2605 m = gfc_match (" class ( %n )", name);
2608 ts->type = BT_CLASS;
2610 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
2615 /* Defer association of the derived type until the end of the
2616 specification block. However, if the derived type can be
2617 found, add it to the typespec. */
2618 if (gfc_matching_function)
2620 ts->u.derived = NULL;
2621 if (gfc_current_state () != COMP_INTERFACE
2622 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2623 ts->u.derived = sym;
2627 /* Search for the name but allow the components to be defined later. If
2628 type = -1, this typespec has been seen in a function declaration but
2629 the type could not be accessed at that point. */
2631 if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2633 gfc_error ("Type name '%s' at %C is ambiguous", name);
2636 else if (ts->kind == -1)
2638 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2639 || gfc_current_ns->has_import_set;
2640 if (gfc_find_symbol (name, NULL, iface, &sym))
2642 gfc_error ("Type name '%s' at %C is ambiguous", name);
2651 if (sym->attr.flavor != FL_DERIVED
2652 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2655 gfc_set_sym_referenced (sym);
2656 ts->u.derived = sym;
2662 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2663 "intrinsic-type-spec at %C") == FAILURE)
2666 /* For all types except double, derived and character, look for an
2667 optional kind specifier. MATCH_NO is actually OK at this point. */
2668 if (implicit_flag == 1)
2670 if (matched_type && gfc_match_char (')') != MATCH_YES)
2676 if (gfc_current_form == FORM_FREE)
2678 c = gfc_peek_ascii_char ();
2679 if (!gfc_is_whitespace (c) && c != '*' && c != '('
2680 && c != ':' && c != ',')
2682 if (matched_type && c == ')')
2684 gfc_next_ascii_char ();
2691 m = gfc_match_kind_spec (ts, false);
2692 if (m == MATCH_NO && ts->type != BT_CHARACTER)
2693 m = gfc_match_old_kind_spec (ts);
2695 if (matched_type && gfc_match_char (')') != MATCH_YES)
2698 /* Defer association of the KIND expression of function results
2699 until after USE and IMPORT statements. */
2700 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2701 || gfc_matching_function)
2705 m = MATCH_YES; /* No kind specifier found. */
2711 /* Match an IMPLICIT NONE statement. Actually, this statement is
2712 already matched in parse.c, or we would not end up here in the
2713 first place. So the only thing we need to check, is if there is
2714 trailing garbage. If not, the match is successful. */
2717 gfc_match_implicit_none (void)
2719 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2723 /* Match the letter range(s) of an IMPLICIT statement. */
2726 match_implicit_range (void)
2732 cur_loc = gfc_current_locus;
2734 gfc_gobble_whitespace ();
2735 c = gfc_next_ascii_char ();
2738 gfc_error ("Missing character range in IMPLICIT at %C");
2745 gfc_gobble_whitespace ();
2746 c1 = gfc_next_ascii_char ();
2750 gfc_gobble_whitespace ();
2751 c = gfc_next_ascii_char ();
2756 inner = 0; /* Fall through. */
2763 gfc_gobble_whitespace ();
2764 c2 = gfc_next_ascii_char ();
2768 gfc_gobble_whitespace ();
2769 c = gfc_next_ascii_char ();
2771 if ((c != ',') && (c != ')'))
2784 gfc_error ("Letters must be in alphabetic order in "
2785 "IMPLICIT statement at %C");
2789 /* See if we can add the newly matched range to the pending
2790 implicits from this IMPLICIT statement. We do not check for
2791 conflicts with whatever earlier IMPLICIT statements may have
2792 set. This is done when we've successfully finished matching
2794 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2801 gfc_syntax_error (ST_IMPLICIT);
2803 gfc_current_locus = cur_loc;
2808 /* Match an IMPLICIT statement, storing the types for
2809 gfc_set_implicit() if the statement is accepted by the parser.
2810 There is a strange looking, but legal syntactic construction
2811 possible. It looks like:
2813 IMPLICIT INTEGER (a-b) (c-d)
2815 This is legal if "a-b" is a constant expression that happens to
2816 equal one of the legal kinds for integers. The real problem
2817 happens with an implicit specification that looks like:
2819 IMPLICIT INTEGER (a-b)
2821 In this case, a typespec matcher that is "greedy" (as most of the
2822 matchers are) gobbles the character range as a kindspec, leaving
2823 nothing left. We therefore have to go a bit more slowly in the
2824 matching process by inhibiting the kindspec checking during
2825 typespec matching and checking for a kind later. */
2828 gfc_match_implicit (void)
2837 /* We don't allow empty implicit statements. */
2838 if (gfc_match_eos () == MATCH_YES)
2840 gfc_error ("Empty IMPLICIT statement at %C");
2846 /* First cleanup. */
2847 gfc_clear_new_implicit ();
2849 /* A basic type is mandatory here. */
2850 m = gfc_match_decl_type_spec (&ts, 1);
2851 if (m == MATCH_ERROR)
2856 cur_loc = gfc_current_locus;
2857 m = match_implicit_range ();
2861 /* We may have <TYPE> (<RANGE>). */
2862 gfc_gobble_whitespace ();
2863 c = gfc_next_ascii_char ();
2864 if ((c == '\n') || (c == ','))
2866 /* Check for CHARACTER with no length parameter. */
2867 if (ts.type == BT_CHARACTER && !ts.u.cl)
2869 ts.kind = gfc_default_character_kind;
2870 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2871 ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
2875 /* Record the Successful match. */
2876 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2881 gfc_current_locus = cur_loc;
2884 /* Discard the (incorrectly) matched range. */
2885 gfc_clear_new_implicit ();
2887 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2888 if (ts.type == BT_CHARACTER)
2889 m = gfc_match_char_spec (&ts);
2892 m = gfc_match_kind_spec (&ts, false);
2895 m = gfc_match_old_kind_spec (&ts);
2896 if (m == MATCH_ERROR)
2902 if (m == MATCH_ERROR)
2905 m = match_implicit_range ();
2906 if (m == MATCH_ERROR)
2911 gfc_gobble_whitespace ();
2912 c = gfc_next_ascii_char ();
2913 if ((c != '\n') && (c != ','))
2916 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2924 gfc_syntax_error (ST_IMPLICIT);
2932 gfc_match_import (void)
2934 char name[GFC_MAX_SYMBOL_LEN + 1];
2939 if (gfc_current_ns->proc_name == NULL
2940 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2942 gfc_error ("IMPORT statement at %C only permitted in "
2943 "an INTERFACE body");
2947 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2951 if (gfc_match_eos () == MATCH_YES)
2953 /* All host variables should be imported. */
2954 gfc_current_ns->has_import_set = 1;
2958 if (gfc_match (" ::") == MATCH_YES)
2960 if (gfc_match_eos () == MATCH_YES)
2962 gfc_error ("Expecting list of named entities at %C");
2969 m = gfc_match (" %n", name);
2973 if (gfc_current_ns->parent != NULL
2974 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2976 gfc_error ("Type name '%s' at %C is ambiguous", name);
2979 else if (gfc_current_ns->proc_name->ns->parent != NULL
2980 && gfc_find_symbol (name,
2981 gfc_current_ns->proc_name->ns->parent,
2984 gfc_error ("Type name '%s' at %C is ambiguous", name);
2990 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2991 "at %C - does not exist.", name);
2995 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2997 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
3002 st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name);
3005 sym->attr.imported = 1;
3017 if (gfc_match_eos () == MATCH_YES)
3019 if (gfc_match_char (',') != MATCH_YES)
3026 gfc_error ("Syntax error in IMPORT statement at %C");
3031 /* A minimal implementation of gfc_match without whitespace, escape
3032 characters or variable arguments. Returns true if the next
3033 characters match the TARGET template exactly. */
3036 match_string_p (const char *target)
3040 for (p = target; *p; p++)
3041 if ((char) gfc_next_ascii_char () != *p)
3046 /* Matches an attribute specification including array specs. If
3047 successful, leaves the variables current_attr and current_as
3048 holding the specification. Also sets the colon_seen variable for
3049 later use by matchers associated with initializations.
3051 This subroutine is a little tricky in the sense that we don't know
3052 if we really have an attr-spec until we hit the double colon.
3053 Until that time, we can only return MATCH_NO. This forces us to
3054 check for duplicate specification at this level. */
3057 match_attr_spec (void)
3059 /* Modifiers that can exist in a type statement. */
3061 { GFC_DECL_BEGIN = 0,
3062 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
3063 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
3064 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
3065 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
3066 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
3067 DECL_NONE, GFC_DECL_END /* Sentinel */
3071 /* GFC_DECL_END is the sentinel, index starts at 0. */
3072 #define NUM_DECL GFC_DECL_END
3074 locus start, seen_at[NUM_DECL];
3081 gfc_clear_attr (¤t_attr);
3082 start = gfc_current_locus;
3087 /* See if we get all of the keywords up to the final double colon. */
3088 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3096 gfc_gobble_whitespace ();
3098 ch = gfc_next_ascii_char ();
3101 /* This is the successful exit condition for the loop. */
3102 if (gfc_next_ascii_char () == ':')
3107 gfc_gobble_whitespace ();
3108 switch (gfc_peek_ascii_char ())
3111 gfc_next_ascii_char ();
3112 switch (gfc_next_ascii_char ())
3115 if (match_string_p ("locatable"))
3117 /* Matched "allocatable". */
3118 d = DECL_ALLOCATABLE;
3123 if (match_string_p ("ynchronous"))
3125 /* Matched "asynchronous". */
3126 d = DECL_ASYNCHRONOUS;
3133 /* Try and match the bind(c). */
3134 m = gfc_match_bind_c (NULL, true);
3137 else if (m == MATCH_ERROR)
3142 gfc_next_ascii_char ();
3143 if ('o' != gfc_next_ascii_char ())
3145 switch (gfc_next_ascii_char ())
3148 if (match_string_p ("imension"))
3150 d = DECL_CODIMENSION;
3154 if (match_string_p ("tiguous"))
3156 d = DECL_CONTIGUOUS;
3163 if (match_string_p ("dimension"))
3168 if (match_string_p ("external"))
3173 if (match_string_p ("int"))
3175 ch = gfc_next_ascii_char ();
3178 if (match_string_p ("nt"))
3180 /* Matched "intent". */
3181 /* TODO: Call match_intent_spec from here. */
3182 if (gfc_match (" ( in out )") == MATCH_YES)
3184 else if (gfc_match (" ( in )") == MATCH_YES)
3186 else if (gfc_match (" ( out )") == MATCH_YES)
3192 if (match_string_p ("insic"))
3194 /* Matched "intrinsic". */
3202 if (match_string_p ("optional"))
3207 gfc_next_ascii_char ();
3208 switch (gfc_next_ascii_char ())
3211 if (match_string_p ("rameter"))
3213 /* Matched "parameter". */
3219 if (match_string_p ("inter"))
3221 /* Matched "pointer". */
3227 ch = gfc_next_ascii_char ();
3230 if (match_string_p ("vate"))
3232 /* Matched "private". */
3238 if (match_string_p ("tected"))
3240 /* Matched "protected". */
3247 if (match_string_p ("blic"))
3249 /* Matched "public". */
3257 if (match_string_p ("save"))
3262 if (match_string_p ("target"))
3267 gfc_next_ascii_char ();
3268 ch = gfc_next_ascii_char ();
3271 if (match_string_p ("lue"))
3273 /* Matched "value". */
3279 if (match_string_p ("latile"))
3281 /* Matched "volatile". */
3289 /* No double colon and no recognizable decl_type, so assume that
3290 we've been looking at something else the whole time. */
3297 /* Check to make sure any parens are paired up correctly. */
3298 if (gfc_match_parens () == MATCH_ERROR)
3305 seen_at[d] = gfc_current_locus;
3307 if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
3309 gfc_array_spec *as = NULL;
3311 m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
3312 d == DECL_CODIMENSION);
3314 if (current_as == NULL)
3316 else if (m == MATCH_YES)
3318 merge_array_spec (as, current_as, false);
3324 if (d == DECL_CODIMENSION)
3325 gfc_error ("Missing codimension specification at %C");
3327 gfc_error ("Missing dimension specification at %C");
3331 if (m == MATCH_ERROR)
3336 /* Since we've seen a double colon, we have to be looking at an
3337 attr-spec. This means that we can now issue errors. */
3338 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3343 case DECL_ALLOCATABLE:
3344 attr = "ALLOCATABLE";
3346 case DECL_ASYNCHRONOUS:
3347 attr = "ASYNCHRONOUS";
3349 case DECL_CODIMENSION:
3350 attr = "CODIMENSION";
3352 case DECL_CONTIGUOUS:
3353 attr = "CONTIGUOUS";
3355 case DECL_DIMENSION:
3362 attr = "INTENT (IN)";
3365 attr = "INTENT (OUT)";
3368 attr = "INTENT (IN OUT)";
3370 case DECL_INTRINSIC:
3376 case DECL_PARAMETER:
3382 case DECL_PROTECTED:
3397 case DECL_IS_BIND_C:
3407 attr = NULL; /* This shouldn't happen. */
3410 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3415 /* Now that we've dealt with duplicate attributes, add the attributes
3416 to the current attribute. */
3417 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3422 if (gfc_current_state () == COMP_DERIVED
3423 && d != DECL_DIMENSION && d != DECL_CODIMENSION
3424 && d != DECL_POINTER && d != DECL_PRIVATE
3425 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
3427 if (d == DECL_ALLOCATABLE)
3429 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3430 "attribute at %C in a TYPE definition")
3439 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3446 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3447 && gfc_current_state () != COMP_MODULE)
3449 if (d == DECL_PRIVATE)
3453 if (gfc_current_state () == COMP_DERIVED
3454 && gfc_state_stack->previous
3455 && gfc_state_stack->previous->state == COMP_MODULE)
3457 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3458 "at %L in a TYPE definition", attr,
3468 gfc_error ("%s attribute at %L is not allowed outside of the "
3469 "specification part of a module", attr, &seen_at[d]);
3477 case DECL_ALLOCATABLE:
3478 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
3481 case DECL_ASYNCHRONOUS:
3482 if (gfc_notify_std (GFC_STD_F2003,
3483 "Fortran 2003: ASYNCHRONOUS attribute at %C")
3487 t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
3490 case DECL_CODIMENSION:
3491 t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
3494 case DECL_CONTIGUOUS:
3495 if (gfc_notify_std (GFC_STD_F2008,
3496 "Fortran 2008: CONTIGUOUS attribute at %C")
3500 t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
3503 case DECL_DIMENSION:
3504 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
3508 t = gfc_add_external (¤t_attr, &seen_at[d]);