1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* This flag is set if an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector;
35 /* When variables acquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts;
42 static symbol_attribute current_attr;
43 static gfc_array_spec *current_as;
44 static int colon_seen;
46 /* Initializer of the previous enumerator. */
48 static gfc_expr *last_initializer;
50 /* History of all the enumerators is maintained, so that
51 kind values of all the enumerators could be updated depending
52 upon the maximum initialized value. */
54 typedef struct enumerator_history
57 gfc_expr *initializer;
58 struct enumerator_history *next;
62 /* Header of enum history chain. */
64 static enumerator_history *enum_history = NULL;
66 /* Pointer of enum history node containing largest initializer. */
68 static enumerator_history *max_enum = NULL;
70 /* gfc_new_block points to the symbol of a newly matched block. */
72 gfc_symbol *gfc_new_block;
75 /********************* DATA statement subroutines *********************/
77 /* Free a gfc_data_variable structure and everything beneath it. */
80 free_variable (gfc_data_variable * p)
87 gfc_free_expr (p->expr);
88 gfc_free_iterator (&p->iter, 0);
89 free_variable (p->list);
96 /* Free a gfc_data_value structure and everything beneath it. */
99 free_value (gfc_data_value * p)
106 gfc_free_expr (p->expr);
112 /* Free a list of gfc_data structures. */
115 gfc_free_data (gfc_data * p)
123 free_variable (p->var);
124 free_value (p->value);
131 /* Free all data in a namespace. */
133 gfc_free_data_all (gfc_namespace * ns)
146 static match var_element (gfc_data_variable *);
148 /* Match a list of variables terminated by an iterator and a right
152 var_list (gfc_data_variable * parent)
154 gfc_data_variable *tail, var;
157 m = var_element (&var);
158 if (m == MATCH_ERROR)
163 tail = gfc_get_data_variable ();
170 if (gfc_match_char (',') != MATCH_YES)
173 m = gfc_match_iterator (&parent->iter, 1);
176 if (m == MATCH_ERROR)
179 m = var_element (&var);
180 if (m == MATCH_ERROR)
185 tail->next = gfc_get_data_variable ();
191 if (gfc_match_char (')') != MATCH_YES)
196 gfc_syntax_error (ST_DATA);
201 /* Match a single element in a data variable list, which can be a
202 variable-iterator list. */
205 var_element (gfc_data_variable * new)
210 memset (new, 0, sizeof (gfc_data_variable));
212 if (gfc_match_char ('(') == MATCH_YES)
213 return var_list (new);
215 m = gfc_match_variable (&new->expr, 0);
219 sym = new->expr->symtree->n.sym;
221 if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
223 gfc_error ("Host associated variable '%s' may not be in the DATA "
224 "statement at %C", sym->name);
228 if (gfc_current_state () != COMP_BLOCK_DATA
229 && sym->attr.in_common
230 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
231 "common block variable '%s' in DATA statement at %C",
232 sym->name) == FAILURE)
235 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
242 /* Match the top-level list of data variables. */
245 top_var_list (gfc_data * d)
247 gfc_data_variable var, *tail, *new;
254 m = var_element (&var);
257 if (m == MATCH_ERROR)
260 new = gfc_get_data_variable ();
270 if (gfc_match_char ('/') == MATCH_YES)
272 if (gfc_match_char (',') != MATCH_YES)
279 gfc_syntax_error (ST_DATA);
280 gfc_free_data_all (gfc_current_ns);
286 match_data_constant (gfc_expr ** result)
288 char name[GFC_MAX_SYMBOL_LEN + 1];
293 m = gfc_match_literal_constant (&expr, 1);
300 if (m == MATCH_ERROR)
303 m = gfc_match_null (result);
307 m = gfc_match_name (name);
311 if (gfc_find_symbol (name, NULL, 1, &sym))
315 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
317 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
321 else if (sym->attr.flavor == FL_DERIVED)
322 return gfc_match_structure_constructor (sym, result);
324 *result = gfc_copy_expr (sym->value);
329 /* Match a list of values in a DATA statement. The leading '/' has
330 already been seen at this point. */
333 top_val_list (gfc_data * data)
335 gfc_data_value *new, *tail;
344 m = match_data_constant (&expr);
347 if (m == MATCH_ERROR)
350 new = gfc_get_data_value ();
359 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
367 msg = gfc_extract_int (expr, &tmp);
368 gfc_free_expr (expr);
376 m = match_data_constant (&tail->expr);
379 if (m == MATCH_ERROR)
383 if (gfc_match_char ('/') == MATCH_YES)
385 if (gfc_match_char (',') == MATCH_NO)
392 gfc_syntax_error (ST_DATA);
393 gfc_free_data_all (gfc_current_ns);
398 /* Matches an old style initialization. */
401 match_old_style_init (const char *name)
408 /* Set up data structure to hold initializers. */
409 gfc_find_sym_tree (name, NULL, 0, &st);
412 newdata = gfc_get_data ();
413 newdata->var = gfc_get_data_variable ();
414 newdata->var->expr = gfc_get_variable_expr (st);
415 newdata->where = gfc_current_locus;
417 /* Match initial value list. This also eats the terminal
419 m = top_val_list (newdata);
428 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
433 /* Mark the variable as having appeared in a data statement. */
434 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
440 /* Chain in namespace list of DATA initializers. */
441 newdata->next = gfc_current_ns->data;
442 gfc_current_ns->data = newdata;
447 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
448 we are matching a DATA statement and are therefore issuing an error
449 if we encounter something unexpected, if not, we're trying to match
450 an old-style initialization expression of the form INTEGER I /2/. */
453 gfc_match_data (void)
460 new = gfc_get_data ();
461 new->where = gfc_current_locus;
463 m = top_var_list (new);
467 m = top_val_list (new);
471 new->next = gfc_current_ns->data;
472 gfc_current_ns->data = new;
474 if (gfc_match_eos () == MATCH_YES)
477 gfc_match_char (','); /* Optional comma */
482 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
494 /************************ Declaration statements *********************/
496 /* Match an intent specification. Since this can only happen after an
497 INTENT word, a legal intent-spec must follow. */
500 match_intent_spec (void)
503 if (gfc_match (" ( in out )") == MATCH_YES)
505 if (gfc_match (" ( in )") == MATCH_YES)
507 if (gfc_match (" ( out )") == MATCH_YES)
510 gfc_error ("Bad INTENT specification at %C");
511 return INTENT_UNKNOWN;
515 /* Matches a character length specification, which is either a
516 specification expression or a '*'. */
519 char_len_param_value (gfc_expr ** expr)
522 if (gfc_match_char ('*') == MATCH_YES)
528 return gfc_match_expr (expr);
532 /* A character length is a '*' followed by a literal integer or a
533 char_len_param_value in parenthesis. */
536 match_char_length (gfc_expr ** expr)
541 m = gfc_match_char ('*');
545 m = gfc_match_small_literal_int (&length, NULL);
546 if (m == MATCH_ERROR)
551 *expr = gfc_int_expr (length);
555 if (gfc_match_char ('(') == MATCH_NO)
558 m = char_len_param_value (expr);
559 if (m == MATCH_ERROR)
564 if (gfc_match_char (')') == MATCH_NO)
566 gfc_free_expr (*expr);
574 gfc_error ("Syntax error in character length specification at %C");
579 /* Special subroutine for finding a symbol. Check if the name is found
580 in the current name space. If not, and we're compiling a function or
581 subroutine and the parent compilation unit is an interface, then check
582 to see if the name we've been given is the name of the interface
583 (located in another namespace). */
586 find_special (const char *name, gfc_symbol ** result)
591 i = gfc_get_symbol (name, NULL, result);
595 if (gfc_current_state () != COMP_SUBROUTINE
596 && gfc_current_state () != COMP_FUNCTION)
599 s = gfc_state_stack->previous;
603 if (s->state != COMP_INTERFACE)
606 goto end; /* Nameless interface */
608 if (strcmp (name, s->sym->name) == 0)
619 /* Special subroutine for getting a symbol node associated with a
620 procedure name, used in SUBROUTINE and FUNCTION statements. The
621 symbol is created in the parent using with symtree node in the
622 child unit pointing to the symbol. If the current namespace has no
623 parent, then the symbol is just created in the current unit. */
626 get_proc_name (const char *name, gfc_symbol ** result,
627 bool module_fcn_entry)
633 /* Module functions have to be left in their own namespace because
634 they have potentially (almost certainly!) already been referenced.
635 In this sense, they are rather like external functions. This is
636 fixed up in resolve.c(resolve_entries), where the symbol name-
637 space is set to point to the master function, so that the fake
638 result mechanism can work. */
639 if (module_fcn_entry)
640 rc = gfc_get_symbol (name, NULL, result);
642 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
645 gfc_current_ns->refs++;
647 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
649 /* Trap another encompassed procedure with the same name. All
650 these conditions are necessary to avoid picking up an entry
651 whose name clashes with that of the encompassing procedure;
652 this is handled using gsymbols to register unique,globally
654 if (sym->attr.flavor != 0
655 && sym->attr.proc != 0
656 && (sym->attr.subroutine || sym->attr.function)
657 && sym->attr.if_source != IFSRC_UNKNOWN)
658 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
659 name, &sym->declared_at);
661 /* Trap declarations of attributes in encompassing scope. The
662 signature for this is that ts.kind is set. Legitimate
663 references only set ts.type. */
664 if (sym->ts.kind != 0
665 && !sym->attr.implicit_type
666 && sym->attr.proc == 0
667 && gfc_current_ns->parent != NULL
668 && sym->attr.access == 0
669 && !module_fcn_entry)
670 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
671 " and must not have attributes declared at %L",
672 name, &sym->declared_at);
675 if (gfc_current_ns->parent == NULL || *result == NULL)
678 /* Module function entries will already have a symtree in
679 the current namespace but will need one at module level. */
680 if (module_fcn_entry)
681 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
683 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
688 /* See if the procedure should be a module procedure */
690 if (((sym->ns->proc_name != NULL
691 && sym->ns->proc_name->attr.flavor == FL_MODULE
692 && sym->attr.proc != PROC_MODULE) || module_fcn_entry)
693 && gfc_add_procedure (&sym->attr, PROC_MODULE,
694 sym->name, NULL) == FAILURE)
701 /* Function called by variable_decl() that adds a name to the symbol
705 build_sym (const char *name, gfc_charlen * cl,
706 gfc_array_spec ** as, locus * var_locus)
708 symbol_attribute attr;
711 /* if (find_special (name, &sym)) */
712 if (gfc_get_symbol (name, NULL, &sym))
715 /* Start updating the symbol table. Add basic type attribute
717 if (current_ts.type != BT_UNKNOWN
718 &&(sym->attr.implicit_type == 0
719 || !gfc_compare_types (&sym->ts, ¤t_ts))
720 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
723 if (sym->ts.type == BT_CHARACTER)
726 /* Add dimension attribute if present. */
727 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
731 /* Add attribute to symbol. The copy is so that we can reset the
732 dimension attribute. */
736 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
742 /* Set character constant to the given length. The constant will be padded or
746 gfc_set_constant_character_len (int len, gfc_expr * expr)
751 gcc_assert (expr->expr_type == EXPR_CONSTANT);
752 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
754 slen = expr->value.character.length;
757 s = gfc_getmem (len + 1);
758 memcpy (s, expr->value.character.string, MIN (len, slen));
760 memset (&s[slen], ' ', len - slen);
762 gfc_free (expr->value.character.string);
763 expr->value.character.string = s;
764 expr->value.character.length = len;
769 /* Function to create and update the enumerator history
770 using the information passed as arguments.
771 Pointer "max_enum" is also updated, to point to
772 enum history node containing largest initializer.
774 SYM points to the symbol node of enumerator.
775 INIT points to its enumerator value. */
778 create_enum_history(gfc_symbol *sym, gfc_expr *init)
780 enumerator_history *new_enum_history;
781 gcc_assert (sym != NULL && init != NULL);
783 new_enum_history = gfc_getmem (sizeof (enumerator_history));
785 new_enum_history->sym = sym;
786 new_enum_history->initializer = init;
787 new_enum_history->next = NULL;
789 if (enum_history == NULL)
791 enum_history = new_enum_history;
792 max_enum = enum_history;
796 new_enum_history->next = enum_history;
797 enum_history = new_enum_history;
799 if (mpz_cmp (max_enum->initializer->value.integer,
800 new_enum_history->initializer->value.integer) < 0)
801 max_enum = new_enum_history;
806 /* Function to free enum kind history. */
809 gfc_free_enum_history(void)
811 enumerator_history *current = enum_history;
812 enumerator_history *next;
814 while (current != NULL)
816 next = current->next;
825 /* Function called by variable_decl() that adds an initialization
826 expression to a symbol. */
829 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
832 symbol_attribute attr;
837 if (find_special (name, &sym))
842 /* If this symbol is confirming an implicit parameter type,
843 then an initialization expression is not allowed. */
844 if (attr.flavor == FL_PARAMETER
845 && sym->value != NULL
848 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
857 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
864 /* An initializer is required for PARAMETER declarations. */
865 if (attr.flavor == FL_PARAMETER)
867 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
873 /* If a variable appears in a DATA block, it cannot have an
878 ("Variable '%s' at %C with an initializer already appears "
879 "in a DATA statement", sym->name);
883 /* Check if the assignment can happen. This has to be put off
884 until later for a derived type variable. */
885 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
886 && gfc_check_assign_symbol (sym, init) == FAILURE)
889 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
891 /* Update symbol character length according initializer. */
892 if (sym->ts.cl->length == NULL)
894 /* If there are multiple CHARACTER variables declared on
895 the same line, we don't want them to share the same
897 sym->ts.cl = gfc_get_charlen ();
898 sym->ts.cl->next = gfc_current_ns->cl_list;
899 gfc_current_ns->cl_list = sym->ts.cl;
901 if (sym->attr.flavor == FL_PARAMETER
902 && init->expr_type == EXPR_ARRAY)
903 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
905 /* Update initializer character length according symbol. */
906 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
908 int len = mpz_get_si (sym->ts.cl->length->value.integer);
911 if (init->expr_type == EXPR_CONSTANT)
912 gfc_set_constant_character_len (len, init);
913 else if (init->expr_type == EXPR_ARRAY)
915 gfc_free_expr (init->ts.cl->length);
916 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
917 for (p = init->value.constructor; p; p = p->next)
918 gfc_set_constant_character_len (len, p->expr);
923 /* Add initializer. Make sure we keep the ranks sane. */
924 if (sym->attr.dimension && init->rank == 0)
925 init->rank = sym->as->rank;
931 /* Maintain enumerator history. */
932 if (gfc_current_state () == COMP_ENUM)
933 create_enum_history (sym, init);
939 /* Function called by variable_decl() that adds a name to a structure
943 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
944 gfc_array_spec ** as)
948 /* If the current symbol is of the same derived type that we're
949 constructing, it must have the pointer attribute. */
950 if (current_ts.type == BT_DERIVED
951 && current_ts.derived == gfc_current_block ()
952 && current_attr.pointer == 0)
954 gfc_error ("Component at %C must have the POINTER attribute");
958 if (gfc_current_block ()->attr.pointer
961 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
963 gfc_error ("Array component of structure at %C must have explicit "
964 "or deferred shape");
969 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
974 gfc_set_component_attr (c, ¤t_attr);
976 c->initializer = *init;
984 /* Check array components. */
989 gfc_error ("Allocatable component at %C must be an array");
998 if (c->as->type != AS_DEFERRED)
1000 gfc_error ("Pointer array component of structure at %C must have a "
1005 else if (c->allocatable)
1007 if (c->as->type != AS_DEFERRED)
1009 gfc_error ("Allocatable component of structure at %C must have a "
1016 if (c->as->type != AS_EXPLICIT)
1019 ("Array component of structure at %C must have an explicit "
1029 /* Match a 'NULL()', and possibly take care of some side effects. */
1032 gfc_match_null (gfc_expr ** result)
1038 m = gfc_match (" null ( )");
1042 /* The NULL symbol now has to be/become an intrinsic function. */
1043 if (gfc_get_symbol ("null", NULL, &sym))
1045 gfc_error ("NULL() initialization at %C is ambiguous");
1049 gfc_intrinsic_symbol (sym);
1051 if (sym->attr.proc != PROC_INTRINSIC
1052 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1053 sym->name, NULL) == FAILURE
1054 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1057 e = gfc_get_expr ();
1058 e->where = gfc_current_locus;
1059 e->expr_type = EXPR_NULL;
1060 e->ts.type = BT_UNKNOWN;
1068 /* Match a variable name with an optional initializer. When this
1069 subroutine is called, a variable is expected to be parsed next.
1070 Depending on what is happening at the moment, updates either the
1071 symbol table or the current interface. */
1074 variable_decl (int elem)
1076 char name[GFC_MAX_SYMBOL_LEN + 1];
1077 gfc_expr *initializer, *char_len;
1079 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1090 old_locus = gfc_current_locus;
1092 /* When we get here, we've just matched a list of attributes and
1093 maybe a type and a double colon. The next thing we expect to see
1094 is the name of the symbol. */
1095 m = gfc_match_name (name);
1099 var_locus = gfc_current_locus;
1101 /* Now we could see the optional array spec. or character length. */
1102 m = gfc_match_array_spec (&as);
1103 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1104 cp_as = gfc_copy_array_spec (as);
1105 else if (m == MATCH_ERROR)
1109 as = gfc_copy_array_spec (current_as);
1110 else if (gfc_current_state () == COMP_ENUM)
1112 gfc_error ("Enumerator cannot be array at %C");
1113 gfc_free_enum_history ();
1122 if (current_ts.type == BT_CHARACTER)
1124 switch (match_char_length (&char_len))
1127 cl = gfc_get_charlen ();
1128 cl->next = gfc_current_ns->cl_list;
1129 gfc_current_ns->cl_list = cl;
1131 cl->length = char_len;
1134 /* Non-constant lengths need to be copied after the first
1137 if (elem > 1 && current_ts.cl->length
1138 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1140 cl = gfc_get_charlen ();
1141 cl->next = gfc_current_ns->cl_list;
1142 gfc_current_ns->cl_list = cl;
1143 cl->length = gfc_copy_expr (current_ts.cl->length);
1155 /* If this symbol has already shown up in a Cray Pointer declaration,
1156 then we want to set the type & bail out. */
1157 if (gfc_option.flag_cray_pointer)
1159 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1160 if (sym != NULL && sym->attr.cray_pointee)
1162 sym->ts.type = current_ts.type;
1163 sym->ts.kind = current_ts.kind;
1165 sym->ts.derived = current_ts.derived;
1168 /* Check to see if we have an array specification. */
1171 if (sym->as != NULL)
1173 gfc_error ("Duplicate array spec for Cray pointee at %C");
1174 gfc_free_array_spec (cp_as);
1180 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1181 gfc_internal_error ("Couldn't set pointee array spec.");
1183 /* Fix the array spec. */
1184 m = gfc_mod_pointee_as (sym->as);
1185 if (m == MATCH_ERROR)
1193 gfc_free_array_spec (cp_as);
1198 /* OK, we've successfully matched the declaration. Now put the
1199 symbol in the current namespace, because it might be used in the
1200 optional initialization expression for this symbol, e.g. this is
1203 integer, parameter :: i = huge(i)
1205 This is only true for parameters or variables of a basic type.
1206 For components of derived types, it is not true, so we don't
1207 create a symbol for those yet. If we fail to create the symbol,
1209 if (gfc_current_state () != COMP_DERIVED
1210 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1216 /* An interface body specifies all of the procedure's characteristics and these
1217 shall be consistent with those specified in the procedure definition, except
1218 that the interface may specify a procedure that is not pure if the procedure
1219 is defined to be pure(12.3.2). */
1220 if (current_ts.type == BT_DERIVED
1221 && gfc_current_ns->proc_name
1222 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1223 && current_ts.derived->ns != gfc_current_ns
1224 && !gfc_current_ns->has_import_set)
1226 gfc_error ("the type of '%s' at %C has not been declared within the "
1232 /* In functions that have a RESULT variable defined, the function
1233 name always refers to function calls. Therefore, the name is
1234 not allowed to appear in specification statements. */
1235 if (gfc_current_state () == COMP_FUNCTION
1236 && gfc_current_block () != NULL
1237 && gfc_current_block ()->result != NULL
1238 && gfc_current_block ()->result != gfc_current_block ()
1239 && strcmp (gfc_current_block ()->name, name) == 0)
1241 gfc_error ("Function name '%s' not allowed at %C", name);
1246 /* We allow old-style initializations of the form
1247 integer i /2/, j(4) /3*3, 1/
1248 (if no colon has been seen). These are different from data
1249 statements in that initializers are only allowed to apply to the
1250 variable immediately preceding, i.e.
1252 is not allowed. Therefore we have to do some work manually, that
1253 could otherwise be left to the matchers for DATA statements. */
1255 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1257 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1258 "initialization at %C") == FAILURE)
1261 return match_old_style_init (name);
1264 /* The double colon must be present in order to have initializers.
1265 Otherwise the statement is ambiguous with an assignment statement. */
1268 if (gfc_match (" =>") == MATCH_YES)
1271 if (!current_attr.pointer)
1273 gfc_error ("Initialization at %C isn't for a pointer variable");
1278 m = gfc_match_null (&initializer);
1281 gfc_error ("Pointer initialization requires a NULL() at %C");
1285 if (gfc_pure (NULL))
1288 ("Initialization of pointer at %C is not allowed in a "
1297 else if (gfc_match_char ('=') == MATCH_YES)
1299 if (current_attr.pointer)
1302 ("Pointer initialization at %C requires '=>', not '='");
1307 m = gfc_match_init_expr (&initializer);
1310 gfc_error ("Expected an initialization expression at %C");
1314 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1317 ("Initialization of variable at %C is not allowed in a "
1327 if (initializer != NULL && current_attr.allocatable
1328 && gfc_current_state () == COMP_DERIVED)
1330 gfc_error ("Initialization of allocatable component at %C is not allowed");
1335 /* Check if we are parsing an enumeration and if the current enumerator
1336 variable has an initializer or not. If it does not have an
1337 initializer, the initialization value of the previous enumerator
1338 (stored in last_initializer) is incremented by 1 and is used to
1339 initialize the current enumerator. */
1340 if (gfc_current_state () == COMP_ENUM)
1342 if (initializer == NULL)
1343 initializer = gfc_enum_initializer (last_initializer, old_locus);
1345 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
1347 gfc_error("ENUMERATOR %L not initialized with integer expression",
1350 gfc_free_enum_history ();
1354 /* Store this current initializer, for the next enumerator
1355 variable to be parsed. */
1356 last_initializer = initializer;
1359 /* Add the initializer. Note that it is fine if initializer is
1360 NULL here, because we sometimes also need to check if a
1361 declaration *must* have an initialization expression. */
1362 if (gfc_current_state () != COMP_DERIVED)
1363 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1366 if (current_ts.type == BT_DERIVED
1367 && !current_attr.pointer
1369 initializer = gfc_default_initializer (¤t_ts);
1370 t = build_struct (name, cl, &initializer, &as);
1373 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1376 /* Free stuff up and return. */
1377 gfc_free_expr (initializer);
1378 gfc_free_array_spec (as);
1384 /* Match an extended-f77 kind specification. */
1387 gfc_match_old_kind_spec (gfc_typespec * ts)
1392 if (gfc_match_char ('*') != MATCH_YES)
1395 m = gfc_match_small_literal_int (&ts->kind, NULL);
1399 original_kind = ts->kind;
1401 /* Massage the kind numbers for complex types. */
1402 if (ts->type == BT_COMPLEX)
1406 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1407 gfc_basic_typename (ts->type), original_kind);
1413 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1415 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1416 gfc_basic_typename (ts->type), original_kind);
1420 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1421 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1428 /* Match a kind specification. Since kinds are generally optional, we
1429 usually return MATCH_NO if something goes wrong. If a "kind="
1430 string is found, then we know we have an error. */
1433 gfc_match_kind_spec (gfc_typespec * ts)
1443 where = gfc_current_locus;
1445 if (gfc_match_char ('(') == MATCH_NO)
1448 /* Also gobbles optional text. */
1449 if (gfc_match (" kind = ") == MATCH_YES)
1452 n = gfc_match_init_expr (&e);
1454 gfc_error ("Expected initialization expression at %C");
1460 gfc_error ("Expected scalar initialization expression at %C");
1465 msg = gfc_extract_int (e, &ts->kind);
1476 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1478 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1479 gfc_basic_typename (ts->type));
1485 if (gfc_match_char (')') != MATCH_YES)
1487 gfc_error ("Missing right parenthesis at %C");
1495 gfc_current_locus = where;
1500 /* Match the various kind/length specifications in a CHARACTER
1501 declaration. We don't return MATCH_NO. */
1504 match_char_spec (gfc_typespec * ts)
1506 int i, kind, seen_length;
1511 kind = gfc_default_character_kind;
1515 /* Try the old-style specification first. */
1516 old_char_selector = 0;
1518 m = match_char_length (&len);
1522 old_char_selector = 1;
1527 m = gfc_match_char ('(');
1530 m = MATCH_YES; /* character without length is a single char */
1534 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1535 if (gfc_match (" kind =") == MATCH_YES)
1537 m = gfc_match_small_int (&kind);
1538 if (m == MATCH_ERROR)
1543 if (gfc_match (" , len =") == MATCH_NO)
1546 m = char_len_param_value (&len);
1549 if (m == MATCH_ERROR)
1556 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1557 if (gfc_match (" len =") == MATCH_YES)
1559 m = char_len_param_value (&len);
1562 if (m == MATCH_ERROR)
1566 if (gfc_match_char (')') == MATCH_YES)
1569 if (gfc_match (" , kind =") != MATCH_YES)
1572 gfc_match_small_int (&kind);
1574 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1576 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1583 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1584 m = char_len_param_value (&len);
1587 if (m == MATCH_ERROR)
1591 m = gfc_match_char (')');
1595 if (gfc_match_char (',') != MATCH_YES)
1598 gfc_match (" kind ="); /* Gobble optional text */
1600 m = gfc_match_small_int (&kind);
1601 if (m == MATCH_ERROR)
1607 /* Require a right-paren at this point. */
1608 m = gfc_match_char (')');
1613 gfc_error ("Syntax error in CHARACTER declaration at %C");
1617 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1619 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1625 gfc_free_expr (len);
1629 /* Do some final massaging of the length values. */
1630 cl = gfc_get_charlen ();
1631 cl->next = gfc_current_ns->cl_list;
1632 gfc_current_ns->cl_list = cl;
1634 if (seen_length == 0)
1635 cl->length = gfc_int_expr (1);
1638 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1642 gfc_free_expr (len);
1643 cl->length = gfc_int_expr (0);
1654 /* Matches a type specification. If successful, sets the ts structure
1655 to the matched specification. This is necessary for FUNCTION and
1656 IMPLICIT statements.
1658 If implicit_flag is nonzero, then we don't check for the optional
1659 kind specification. Not doing so is needed for matching an IMPLICIT
1660 statement correctly. */
1663 match_type_spec (gfc_typespec * ts, int implicit_flag)
1665 char name[GFC_MAX_SYMBOL_LEN + 1];
1672 if (gfc_match (" byte") == MATCH_YES)
1674 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1678 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1680 gfc_error ("BYTE type used at %C "
1681 "is not available on the target machine");
1685 ts->type = BT_INTEGER;
1690 if (gfc_match (" integer") == MATCH_YES)
1692 ts->type = BT_INTEGER;
1693 ts->kind = gfc_default_integer_kind;
1697 if (gfc_match (" character") == MATCH_YES)
1699 ts->type = BT_CHARACTER;
1700 if (implicit_flag == 0)
1701 return match_char_spec (ts);
1706 if (gfc_match (" real") == MATCH_YES)
1709 ts->kind = gfc_default_real_kind;
1713 if (gfc_match (" double precision") == MATCH_YES)
1716 ts->kind = gfc_default_double_kind;
1720 if (gfc_match (" complex") == MATCH_YES)
1722 ts->type = BT_COMPLEX;
1723 ts->kind = gfc_default_complex_kind;
1727 if (gfc_match (" double complex") == MATCH_YES)
1729 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1730 "conform to the Fortran 95 standard") == FAILURE)
1733 ts->type = BT_COMPLEX;
1734 ts->kind = gfc_default_double_kind;
1738 if (gfc_match (" logical") == MATCH_YES)
1740 ts->type = BT_LOGICAL;
1741 ts->kind = gfc_default_logical_kind;
1745 m = gfc_match (" type ( %n )", name);
1749 /* Search for the name but allow the components to be defined later. */
1750 if (gfc_get_ha_symbol (name, &sym))
1752 gfc_error ("Type name '%s' at %C is ambiguous", name);
1756 if (sym->attr.flavor != FL_DERIVED
1757 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1760 ts->type = BT_DERIVED;
1767 /* For all types except double, derived and character, look for an
1768 optional kind specifier. MATCH_NO is actually OK at this point. */
1769 if (implicit_flag == 1)
1772 if (gfc_current_form == FORM_FREE)
1774 c = gfc_peek_char();
1775 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1776 && c != ':' && c != ',')
1780 m = gfc_match_kind_spec (ts);
1781 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1782 m = gfc_match_old_kind_spec (ts);
1785 m = MATCH_YES; /* No kind specifier found. */
1791 /* Match an IMPLICIT NONE statement. Actually, this statement is
1792 already matched in parse.c, or we would not end up here in the
1793 first place. So the only thing we need to check, is if there is
1794 trailing garbage. If not, the match is successful. */
1797 gfc_match_implicit_none (void)
1800 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1804 /* Match the letter range(s) of an IMPLICIT statement. */
1807 match_implicit_range (void)
1809 int c, c1, c2, inner;
1812 cur_loc = gfc_current_locus;
1814 gfc_gobble_whitespace ();
1815 c = gfc_next_char ();
1818 gfc_error ("Missing character range in IMPLICIT at %C");
1825 gfc_gobble_whitespace ();
1826 c1 = gfc_next_char ();
1830 gfc_gobble_whitespace ();
1831 c = gfc_next_char ();
1836 inner = 0; /* Fall through */
1843 gfc_gobble_whitespace ();
1844 c2 = gfc_next_char ();
1848 gfc_gobble_whitespace ();
1849 c = gfc_next_char ();
1851 if ((c != ',') && (c != ')'))
1864 gfc_error ("Letters must be in alphabetic order in "
1865 "IMPLICIT statement at %C");
1869 /* See if we can add the newly matched range to the pending
1870 implicits from this IMPLICIT statement. We do not check for
1871 conflicts with whatever earlier IMPLICIT statements may have
1872 set. This is done when we've successfully finished matching
1874 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1881 gfc_syntax_error (ST_IMPLICIT);
1883 gfc_current_locus = cur_loc;
1888 /* Match an IMPLICIT statement, storing the types for
1889 gfc_set_implicit() if the statement is accepted by the parser.
1890 There is a strange looking, but legal syntactic construction
1891 possible. It looks like:
1893 IMPLICIT INTEGER (a-b) (c-d)
1895 This is legal if "a-b" is a constant expression that happens to
1896 equal one of the legal kinds for integers. The real problem
1897 happens with an implicit specification that looks like:
1899 IMPLICIT INTEGER (a-b)
1901 In this case, a typespec matcher that is "greedy" (as most of the
1902 matchers are) gobbles the character range as a kindspec, leaving
1903 nothing left. We therefore have to go a bit more slowly in the
1904 matching process by inhibiting the kindspec checking during
1905 typespec matching and checking for a kind later. */
1908 gfc_match_implicit (void)
1915 /* We don't allow empty implicit statements. */
1916 if (gfc_match_eos () == MATCH_YES)
1918 gfc_error ("Empty IMPLICIT statement at %C");
1924 /* First cleanup. */
1925 gfc_clear_new_implicit ();
1927 /* A basic type is mandatory here. */
1928 m = match_type_spec (&ts, 1);
1929 if (m == MATCH_ERROR)
1934 cur_loc = gfc_current_locus;
1935 m = match_implicit_range ();
1939 /* We may have <TYPE> (<RANGE>). */
1940 gfc_gobble_whitespace ();
1941 c = gfc_next_char ();
1942 if ((c == '\n') || (c == ','))
1944 /* Check for CHARACTER with no length parameter. */
1945 if (ts.type == BT_CHARACTER && !ts.cl)
1947 ts.kind = gfc_default_character_kind;
1948 ts.cl = gfc_get_charlen ();
1949 ts.cl->next = gfc_current_ns->cl_list;
1950 gfc_current_ns->cl_list = ts.cl;
1951 ts.cl->length = gfc_int_expr (1);
1954 /* Record the Successful match. */
1955 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1960 gfc_current_locus = cur_loc;
1963 /* Discard the (incorrectly) matched range. */
1964 gfc_clear_new_implicit ();
1966 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1967 if (ts.type == BT_CHARACTER)
1968 m = match_char_spec (&ts);
1971 m = gfc_match_kind_spec (&ts);
1974 m = gfc_match_old_kind_spec (&ts);
1975 if (m == MATCH_ERROR)
1981 if (m == MATCH_ERROR)
1984 m = match_implicit_range ();
1985 if (m == MATCH_ERROR)
1990 gfc_gobble_whitespace ();
1991 c = gfc_next_char ();
1992 if ((c != '\n') && (c != ','))
1995 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2003 gfc_syntax_error (ST_IMPLICIT);
2010 gfc_match_import (void)
2012 char name[GFC_MAX_SYMBOL_LEN + 1];
2017 if (gfc_current_ns->proc_name == NULL ||
2018 gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2020 gfc_error ("IMPORT statement at %C only permitted in "
2021 "an INTERFACE body");
2025 if (gfc_notify_std (GFC_STD_F2003,
2026 "Fortran 2003: IMPORT statement at %C")
2030 if (gfc_match_eos () == MATCH_YES)
2032 /* All host variables should be imported. */
2033 gfc_current_ns->has_import_set = 1;
2037 if (gfc_match (" ::") == MATCH_YES)
2039 if (gfc_match_eos () == MATCH_YES)
2041 gfc_error ("Expecting list of named entities at %C");
2048 m = gfc_match (" %n", name);
2052 if (gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2054 gfc_error ("Type name '%s' at %C is ambiguous", name);
2060 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2061 "at %C - does not exist.", name);
2065 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2067 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2072 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2075 sym->ns = gfc_current_ns;
2087 if (gfc_match_eos () == MATCH_YES)
2089 if (gfc_match_char (',') != MATCH_YES)
2096 gfc_error ("Syntax error in IMPORT statement at %C");
2100 /* Matches an attribute specification including array specs. If
2101 successful, leaves the variables current_attr and current_as
2102 holding the specification. Also sets the colon_seen variable for
2103 later use by matchers associated with initializations.
2105 This subroutine is a little tricky in the sense that we don't know
2106 if we really have an attr-spec until we hit the double colon.
2107 Until that time, we can only return MATCH_NO. This forces us to
2108 check for duplicate specification at this level. */
2111 match_attr_spec (void)
2114 /* Modifiers that can exist in a type statement. */
2116 { GFC_DECL_BEGIN = 0,
2117 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2118 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2119 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
2120 DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
2121 GFC_DECL_END /* Sentinel */
2125 /* GFC_DECL_END is the sentinel, index starts at 0. */
2126 #define NUM_DECL GFC_DECL_END
2128 static mstring decls[] = {
2129 minit (", allocatable", DECL_ALLOCATABLE),
2130 minit (", dimension", DECL_DIMENSION),
2131 minit (", external", DECL_EXTERNAL),
2132 minit (", intent ( in )", DECL_IN),
2133 minit (", intent ( out )", DECL_OUT),
2134 minit (", intent ( in out )", DECL_INOUT),
2135 minit (", intrinsic", DECL_INTRINSIC),
2136 minit (", optional", DECL_OPTIONAL),
2137 minit (", parameter", DECL_PARAMETER),
2138 minit (", pointer", DECL_POINTER),
2139 minit (", private", DECL_PRIVATE),
2140 minit (", public", DECL_PUBLIC),
2141 minit (", save", DECL_SAVE),
2142 minit (", target", DECL_TARGET),
2143 minit (", value", DECL_VALUE),
2144 minit (", volatile", DECL_VOLATILE),
2145 minit ("::", DECL_COLON),
2146 minit (NULL, DECL_NONE)
2149 locus start, seen_at[NUM_DECL];
2156 gfc_clear_attr (¤t_attr);
2157 start = gfc_current_locus;
2162 /* See if we get all of the keywords up to the final double colon. */
2163 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2168 d = (decl_types) gfc_match_strings (decls);
2169 if (d == DECL_NONE || d == DECL_COLON)
2172 if (gfc_current_state () == COMP_ENUM)
2174 gfc_error ("Enumerator cannot have attributes %C");
2179 seen_at[d] = gfc_current_locus;
2181 if (d == DECL_DIMENSION)
2183 m = gfc_match_array_spec (¤t_as);
2187 gfc_error ("Missing dimension specification at %C");
2191 if (m == MATCH_ERROR)
2196 /* If we are parsing an enumeration and have ensured that no other
2197 attributes are present we can now set the parameter attribute. */
2198 if (gfc_current_state () == COMP_ENUM)
2200 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
2208 /* No double colon, so assume that we've been looking at something
2209 else the whole time. */
2216 /* Since we've seen a double colon, we have to be looking at an
2217 attr-spec. This means that we can now issue errors. */
2218 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2223 case DECL_ALLOCATABLE:
2224 attr = "ALLOCATABLE";
2226 case DECL_DIMENSION:
2233 attr = "INTENT (IN)";
2236 attr = "INTENT (OUT)";
2239 attr = "INTENT (IN OUT)";
2241 case DECL_INTRINSIC:
2247 case DECL_PARAMETER:
2272 attr = NULL; /* This shouldn't happen */
2275 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2280 /* Now that we've dealt with duplicate attributes, add the attributes
2281 to the current attribute. */
2282 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2287 if (gfc_current_state () == COMP_DERIVED
2288 && d != DECL_DIMENSION && d != DECL_POINTER
2289 && d != DECL_COLON && d != DECL_NONE)
2291 if (d == DECL_ALLOCATABLE)
2293 if (gfc_notify_std (GFC_STD_F2003,
2294 "Fortran 2003: ALLOCATABLE "
2295 "attribute at %C in a TYPE "
2296 "definition") == FAILURE)
2304 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2311 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2312 && gfc_current_state () != COMP_MODULE)
2314 if (d == DECL_PRIVATE)
2319 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2327 case DECL_ALLOCATABLE:
2328 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2331 case DECL_DIMENSION:
2332 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2336 t = gfc_add_external (¤t_attr, &seen_at[d]);
2340 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2344 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2348 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2351 case DECL_INTRINSIC:
2352 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2356 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2359 case DECL_PARAMETER:
2360 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2364 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2368 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2373 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2378 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2382 t = gfc_add_target (¤t_attr, &seen_at[d]);
2386 if (gfc_notify_std (GFC_STD_F2003,
2387 "Fortran 2003: VALUE attribute at %C")
2391 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
2395 if (gfc_notify_std (GFC_STD_F2003,
2396 "Fortran 2003: VOLATILE attribute at %C")
2400 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
2404 gfc_internal_error ("match_attr_spec(): Bad attribute");
2418 gfc_current_locus = start;
2419 gfc_free_array_spec (current_as);
2425 /* Match a data declaration statement. */
2428 gfc_match_data_decl (void)
2434 m = match_type_spec (¤t_ts, 0);
2438 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2440 sym = gfc_use_derived (current_ts.derived);
2448 current_ts.derived = sym;
2451 m = match_attr_spec ();
2452 if (m == MATCH_ERROR)
2458 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2461 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2464 gfc_find_symbol (current_ts.derived->name,
2465 current_ts.derived->ns->parent, 1, &sym);
2467 /* Any symbol that we find had better be a type definition
2468 which has its components defined. */
2469 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2470 && current_ts.derived->components != NULL)
2473 /* Now we have an error, which we signal, and then fix up
2474 because the knock-on is plain and simple confusing. */
2475 gfc_error_now ("Derived type at %C has not been previously defined "
2476 "and so cannot appear in a derived type definition");
2477 current_attr.pointer = 1;
2482 /* If we have an old-style character declaration, and no new-style
2483 attribute specifications, then there a comma is optional between
2484 the type specification and the variable list. */
2485 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2486 gfc_match_char (',');
2488 /* Give the types/attributes to symbols that follow. Give the element
2489 a number so that repeat character length expressions can be copied. */
2493 m = variable_decl (elem++);
2494 if (m == MATCH_ERROR)
2499 if (gfc_match_eos () == MATCH_YES)
2501 if (gfc_match_char (',') != MATCH_YES)
2505 if (gfc_error_flag_test () == 0)
2506 gfc_error ("Syntax error in data declaration at %C");
2509 gfc_free_data_all (gfc_current_ns);
2512 gfc_free_array_spec (current_as);
2518 /* Match a prefix associated with a function or subroutine
2519 declaration. If the typespec pointer is nonnull, then a typespec
2520 can be matched. Note that if nothing matches, MATCH_YES is
2521 returned (the null string was matched). */
2524 match_prefix (gfc_typespec * ts)
2528 gfc_clear_attr (¤t_attr);
2532 if (!seen_type && ts != NULL
2533 && match_type_spec (ts, 0) == MATCH_YES
2534 && gfc_match_space () == MATCH_YES)
2541 if (gfc_match ("elemental% ") == MATCH_YES)
2543 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2549 if (gfc_match ("pure% ") == MATCH_YES)
2551 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2557 if (gfc_match ("recursive% ") == MATCH_YES)
2559 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2565 /* At this point, the next item is not a prefix. */
2570 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2573 copy_prefix (symbol_attribute * dest, locus * where)
2576 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2579 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2582 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2589 /* Match a formal argument list. */
2592 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2594 gfc_formal_arglist *head, *tail, *p, *q;
2595 char name[GFC_MAX_SYMBOL_LEN + 1];
2601 if (gfc_match_char ('(') != MATCH_YES)
2608 if (gfc_match_char (')') == MATCH_YES)
2613 if (gfc_match_char ('*') == MATCH_YES)
2617 m = gfc_match_name (name);
2621 if (gfc_get_symbol (name, NULL, &sym))
2625 p = gfc_get_formal_arglist ();
2637 /* We don't add the VARIABLE flavor because the name could be a
2638 dummy procedure. We don't apply these attributes to formal
2639 arguments of statement functions. */
2640 if (sym != NULL && !st_flag
2641 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2642 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2648 /* The name of a program unit can be in a different namespace,
2649 so check for it explicitly. After the statement is accepted,
2650 the name is checked for especially in gfc_get_symbol(). */
2651 if (gfc_new_block != NULL && sym != NULL
2652 && strcmp (sym->name, gfc_new_block->name) == 0)
2654 gfc_error ("Name '%s' at %C is the name of the procedure",
2660 if (gfc_match_char (')') == MATCH_YES)
2663 m = gfc_match_char (',');
2666 gfc_error ("Unexpected junk in formal argument list at %C");
2672 /* Check for duplicate symbols in the formal argument list. */
2675 for (p = head; p->next; p = p->next)
2680 for (q = p->next; q; q = q->next)
2681 if (p->sym == q->sym)
2684 ("Duplicate symbol '%s' in formal argument list at %C",
2693 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2703 gfc_free_formal_arglist (head);
2708 /* Match a RESULT specification following a function declaration or
2709 ENTRY statement. Also matches the end-of-statement. */
2712 match_result (gfc_symbol * function, gfc_symbol ** result)
2714 char name[GFC_MAX_SYMBOL_LEN + 1];
2718 if (gfc_match (" result (") != MATCH_YES)
2721 m = gfc_match_name (name);
2725 if (gfc_match (" )%t") != MATCH_YES)
2727 gfc_error ("Unexpected junk following RESULT variable at %C");
2731 if (strcmp (function->name, name) == 0)
2734 ("RESULT variable at %C must be different than function name");
2738 if (gfc_get_symbol (name, NULL, &r))
2741 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2742 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2751 /* Match a function declaration. */
2754 gfc_match_function_decl (void)
2756 char name[GFC_MAX_SYMBOL_LEN + 1];
2757 gfc_symbol *sym, *result;
2761 if (gfc_current_state () != COMP_NONE
2762 && gfc_current_state () != COMP_INTERFACE
2763 && gfc_current_state () != COMP_CONTAINS)
2766 gfc_clear_ts (¤t_ts);
2768 old_loc = gfc_current_locus;
2770 m = match_prefix (¤t_ts);
2773 gfc_current_locus = old_loc;
2777 if (gfc_match ("function% %n", name) != MATCH_YES)
2779 gfc_current_locus = old_loc;
2783 if (get_proc_name (name, &sym, false))
2785 gfc_new_block = sym;
2787 m = gfc_match_formal_arglist (sym, 0, 0);
2790 gfc_error ("Expected formal argument list in function "
2791 "definition at %C");
2795 else if (m == MATCH_ERROR)
2800 if (gfc_match_eos () != MATCH_YES)
2802 /* See if a result variable is present. */
2803 m = match_result (sym, &result);
2805 gfc_error ("Unexpected junk after function declaration at %C");
2814 /* Make changes to the symbol. */
2817 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2820 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2821 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2824 if (current_ts.type != BT_UNKNOWN
2825 && sym->ts.type != BT_UNKNOWN
2826 && !sym->attr.implicit_type)
2828 gfc_error ("Function '%s' at %C already has a type of %s", name,
2829 gfc_basic_typename (sym->ts.type));
2835 sym->ts = current_ts;
2840 result->ts = current_ts;
2841 sym->result = result;
2847 gfc_current_locus = old_loc;
2851 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2852 name of the entry, rather than the gfc_current_block name, and to return false
2853 upon finding an existing global entry. */
2856 add_global_entry (const char * name, int sub)
2860 s = gfc_get_gsymbol(name);
2863 || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2864 global_used(s, NULL);
2867 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2868 s->where = gfc_current_locus;
2875 /* Match an ENTRY statement. */
2878 gfc_match_entry (void)
2883 char name[GFC_MAX_SYMBOL_LEN + 1];
2884 gfc_compile_state state;
2888 bool module_procedure;
2890 m = gfc_match_name (name);
2894 state = gfc_current_state ();
2895 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2900 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2903 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2905 case COMP_BLOCK_DATA:
2907 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2909 case COMP_INTERFACE:
2911 ("ENTRY statement at %C cannot appear within an INTERFACE");
2915 ("ENTRY statement at %C cannot appear "
2916 "within a DERIVED TYPE block");
2920 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2924 ("ENTRY statement at %C cannot appear within a DO block");
2928 ("ENTRY statement at %C cannot appear within a SELECT block");
2932 ("ENTRY statement at %C cannot appear within a FORALL block");
2936 ("ENTRY statement at %C cannot appear within a WHERE block");
2940 ("ENTRY statement at %C cannot appear "
2941 "within a contained subprogram");
2944 gfc_internal_error ("gfc_match_entry(): Bad state");
2949 module_procedure = gfc_current_ns->parent != NULL
2950 && gfc_current_ns->parent->proc_name
2951 && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE;
2953 if (gfc_current_ns->parent != NULL
2954 && gfc_current_ns->parent->proc_name
2955 && !module_procedure)
2957 gfc_error("ENTRY statement at %C cannot appear in a "
2958 "contained procedure");
2962 /* Module function entries need special care in get_proc_name
2963 because previous references within the function will have
2964 created symbols attached to the current namespace. */
2965 if (get_proc_name (name, &entry,
2966 gfc_current_ns->parent != NULL
2968 && gfc_current_ns->proc_name->attr.function))
2971 proc = gfc_current_block ();
2973 if (state == COMP_SUBROUTINE)
2975 /* An entry in a subroutine. */
2976 if (!add_global_entry (name, 1))
2979 m = gfc_match_formal_arglist (entry, 0, 1);
2983 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2984 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2989 /* An entry in a function.
2990 We need to take special care because writing
2995 ENTRY f() RESULT (r)
2997 ENTRY f RESULT (r). */
2998 if (!add_global_entry (name, 0))
3001 old_loc = gfc_current_locus;
3002 if (gfc_match_eos () == MATCH_YES)
3004 gfc_current_locus = old_loc;
3005 /* Match the empty argument list, and add the interface to
3007 m = gfc_match_formal_arglist (entry, 0, 1);
3010 m = gfc_match_formal_arglist (entry, 0, 0);
3017 if (gfc_match_eos () == MATCH_YES)
3019 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3020 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3023 entry->result = entry;
3027 m = match_result (proc, &result);
3029 gfc_syntax_error (ST_ENTRY);
3033 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3034 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3035 || gfc_add_function (&entry->attr, result->name,
3039 entry->result = result;
3042 if (proc->attr.recursive && result == NULL)
3044 gfc_error ("RESULT attribute required in ENTRY statement at %C");
3049 if (gfc_match_eos () != MATCH_YES)
3051 gfc_syntax_error (ST_ENTRY);
3055 entry->attr.recursive = proc->attr.recursive;
3056 entry->attr.elemental = proc->attr.elemental;
3057 entry->attr.pure = proc->attr.pure;
3059 el = gfc_get_entry_list ();
3061 el->next = gfc_current_ns->entries;
3062 gfc_current_ns->entries = el;
3064 el->id = el->next->id + 1;
3068 new_st.op = EXEC_ENTRY;
3069 new_st.ext.entry = el;
3075 /* Match a subroutine statement, including optional prefixes. */
3078 gfc_match_subroutine (void)
3080 char name[GFC_MAX_SYMBOL_LEN + 1];
3084 if (gfc_current_state () != COMP_NONE
3085 && gfc_current_state () != COMP_INTERFACE
3086 && gfc_current_state () != COMP_CONTAINS)
3089 m = match_prefix (NULL);
3093 m = gfc_match ("subroutine% %n", name);
3097 if (get_proc_name (name, &sym, false))
3099 gfc_new_block = sym;
3101 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3104 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3107 if (gfc_match_eos () != MATCH_YES)
3109 gfc_syntax_error (ST_SUBROUTINE);
3113 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3120 /* Return nonzero if we're currently compiling a contained procedure. */
3123 contained_procedure (void)
3127 for (s=gfc_state_stack; s; s=s->previous)
3128 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3129 && s->previous != NULL
3130 && s->previous->state == COMP_CONTAINS)
3136 /* Set the kind of each enumerator. The kind is selected such that it is
3137 interoperable with the corresponding C enumeration type, making
3138 sure that -fshort-enums is honored. */
3143 enumerator_history *current_history = NULL;
3147 if (max_enum == NULL || enum_history == NULL)
3150 if (!gfc_option.fshort_enums)
3156 kind = gfc_integer_kinds[i++].kind;
3158 while (kind < gfc_c_int_kind
3159 && gfc_check_integer_range (max_enum->initializer->value.integer,
3162 current_history = enum_history;
3163 while (current_history != NULL)
3165 current_history->sym->ts.kind = kind;
3166 current_history = current_history->next;
3170 /* Match any of the various end-block statements. Returns the type of
3171 END to the caller. The END INTERFACE, END IF, END DO and END
3172 SELECT statements cannot be replaced by a single END statement. */
3175 gfc_match_end (gfc_statement * st)
3177 char name[GFC_MAX_SYMBOL_LEN + 1];
3178 gfc_compile_state state;
3180 const char *block_name;
3185 old_loc = gfc_current_locus;
3186 if (gfc_match ("end") != MATCH_YES)
3189 state = gfc_current_state ();
3191 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
3193 if (state == COMP_CONTAINS)
3195 state = gfc_state_stack->previous->state;
3196 block_name = gfc_state_stack->previous->sym == NULL ? NULL
3197 : gfc_state_stack->previous->sym->name;
3204 *st = ST_END_PROGRAM;
3205 target = " program";
3209 case COMP_SUBROUTINE:
3210 *st = ST_END_SUBROUTINE;
3211 target = " subroutine";
3212 eos_ok = !contained_procedure ();
3216 *st = ST_END_FUNCTION;
3217 target = " function";
3218 eos_ok = !contained_procedure ();
3221 case COMP_BLOCK_DATA:
3222 *st = ST_END_BLOCK_DATA;
3223 target = " block data";
3228 *st = ST_END_MODULE;
3233 case COMP_INTERFACE:
3234 *st = ST_END_INTERFACE;
3235 target = " interface";
3258 *st = ST_END_SELECT;
3264 *st = ST_END_FORALL;
3279 last_initializer = NULL;
3281 gfc_free_enum_history ();
3285 gfc_error ("Unexpected END statement at %C");
3289 if (gfc_match_eos () == MATCH_YES)
3293 /* We would have required END [something] */
3294 gfc_error ("%s statement expected at %L",
3295 gfc_ascii_statement (*st), &old_loc);
3302 /* Verify that we've got the sort of end-block that we're expecting. */
3303 if (gfc_match (target) != MATCH_YES)
3305 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3309 /* If we're at the end, make sure a block name wasn't required. */
3310 if (gfc_match_eos () == MATCH_YES)
3313 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3316 if (gfc_current_block () == NULL)
3319 gfc_error ("Expected block name of '%s' in %s statement at %C",
3320 block_name, gfc_ascii_statement (*st));
3325 /* END INTERFACE has a special handler for its several possible endings. */
3326 if (*st == ST_END_INTERFACE)
3327 return gfc_match_end_interface ();
3329 /* We haven't hit the end of statement, so what is left must be an end-name. */
3330 m = gfc_match_space ();
3332 m = gfc_match_name (name);
3335 gfc_error ("Expected terminating name at %C");
3339 if (block_name == NULL)
3342 if (strcmp (name, block_name) != 0)
3344 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3345 gfc_ascii_statement (*st));
3349 if (gfc_match_eos () == MATCH_YES)
3353 gfc_syntax_error (*st);
3356 gfc_current_locus = old_loc;
3362 /***************** Attribute declaration statements ****************/
3364 /* Set the attribute of a single variable. */
3369 char name[GFC_MAX_SYMBOL_LEN + 1];
3377 m = gfc_match_name (name);
3381 if (find_special (name, &sym))
3384 var_locus = gfc_current_locus;
3386 /* Deal with possible array specification for certain attributes. */
3387 if (current_attr.dimension
3388 || current_attr.allocatable
3389 || current_attr.pointer
3390 || current_attr.target)
3392 m = gfc_match_array_spec (&as);
3393 if (m == MATCH_ERROR)
3396 if (current_attr.dimension && m == MATCH_NO)
3399 ("Missing array specification at %L in DIMENSION statement",
3405 if ((current_attr.allocatable || current_attr.pointer)
3406 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3408 gfc_error ("Array specification must be deferred at %L",
3415 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3416 if (current_attr.dimension == 0
3417 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3423 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3429 if (sym->attr.cray_pointee && sym->as != NULL)
3431 /* Fix the array spec. */
3432 m = gfc_mod_pointee_as (sym->as);
3433 if (m == MATCH_ERROR)
3437 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
3443 if ((current_attr.external || current_attr.intrinsic)
3444 && sym->attr.flavor != FL_PROCEDURE
3445 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3454 gfc_free_array_spec (as);
3459 /* Generic attribute declaration subroutine. Used for attributes that
3460 just have a list of names. */
3467 /* Gobble the optional double colon, by simply ignoring the result
3477 if (gfc_match_eos () == MATCH_YES)
3483 if (gfc_match_char (',') != MATCH_YES)
3485 gfc_error ("Unexpected character in variable list at %C");
3495 /* This routine matches Cray Pointer declarations of the form:
3496 pointer ( <pointer>, <pointee> )
3498 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3499 The pointer, if already declared, should be an integer. Otherwise, we
3500 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3501 be either a scalar, or an array declaration. No space is allocated for
3502 the pointee. For the statement
3503 pointer (ipt, ar(10))
3504 any subsequent uses of ar will be translated (in C-notation) as
3505 ar(i) => ((<type> *) ipt)(i)
3506 After gimplification, pointee variable will disappear in the code. */
3509 cray_pointer_decl (void)
3513 gfc_symbol *cptr; /* Pointer symbol. */
3514 gfc_symbol *cpte; /* Pointee symbol. */
3520 if (gfc_match_char ('(') != MATCH_YES)
3522 gfc_error ("Expected '(' at %C");
3526 /* Match pointer. */
3527 var_locus = gfc_current_locus;
3528 gfc_clear_attr (¤t_attr);
3529 gfc_add_cray_pointer (¤t_attr, &var_locus);
3530 current_ts.type = BT_INTEGER;
3531 current_ts.kind = gfc_index_integer_kind;
3533 m = gfc_match_symbol (&cptr, 0);
3536 gfc_error ("Expected variable name at %C");
3540 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3543 gfc_set_sym_referenced (cptr);
3545 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3547 cptr->ts.type = BT_INTEGER;
3548 cptr->ts.kind = gfc_index_integer_kind;
3550 else if (cptr->ts.type != BT_INTEGER)
3552 gfc_error ("Cray pointer at %C must be an integer");
3555 else if (cptr->ts.kind < gfc_index_integer_kind)
3556 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3557 " memory addresses require %d bytes",
3559 gfc_index_integer_kind);
3561 if (gfc_match_char (',') != MATCH_YES)
3563 gfc_error ("Expected \",\" at %C");
3567 /* Match Pointee. */
3568 var_locus = gfc_current_locus;
3569 gfc_clear_attr (¤t_attr);
3570 gfc_add_cray_pointee (¤t_attr, &var_locus);
3571 current_ts.type = BT_UNKNOWN;
3572 current_ts.kind = 0;
3574 m = gfc_match_symbol (&cpte, 0);
3577 gfc_error ("Expected variable name at %C");
3581 /* Check for an optional array spec. */
3582 m = gfc_match_array_spec (&as);
3583 if (m == MATCH_ERROR)
3585 gfc_free_array_spec (as);
3588 else if (m == MATCH_NO)
3590 gfc_free_array_spec (as);
3594 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3597 gfc_set_sym_referenced (cpte);
3599 if (cpte->as == NULL)
3601 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3602 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3604 else if (as != NULL)
3606 gfc_error ("Duplicate array spec for Cray pointee at %C");
3607 gfc_free_array_spec (as);
3613 if (cpte->as != NULL)
3615 /* Fix array spec. */
3616 m = gfc_mod_pointee_as (cpte->as);
3617 if (m == MATCH_ERROR)
3621 /* Point the Pointee at the Pointer. */
3622 cpte->cp_pointer = cptr;
3624 if (gfc_match_char (')') != MATCH_YES)
3626 gfc_error ("Expected \")\" at %C");
3629 m = gfc_match_char (',');
3631 done = true; /* Stop searching for more declarations. */
3635 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3636 || gfc_match_eos () != MATCH_YES)
3638 gfc_error ("Expected \",\" or end of statement at %C");
3646 gfc_match_external (void)
3649 gfc_clear_attr (¤t_attr);
3650 current_attr.external = 1;
3652 return attr_decl ();
3658 gfc_match_intent (void)
3662 intent = match_intent_spec ();
3663 if (intent == INTENT_UNKNOWN)
3666 gfc_clear_attr (¤t_attr);
3667 current_attr.intent = intent;
3669 return attr_decl ();
3674 gfc_match_intrinsic (void)
3677 gfc_clear_attr (¤t_attr);
3678 current_attr.intrinsic = 1;
3680 return attr_decl ();
3685 gfc_match_optional (void)
3688 gfc_clear_attr (¤t_attr);
3689 current_attr.optional = 1;
3691 return attr_decl ();
3696 gfc_match_pointer (void)
3698 gfc_gobble_whitespace ();
3699 if (gfc_peek_char () == '(')
3701 if (!gfc_option.flag_cray_pointer)
3703 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3707 return cray_pointer_decl ();
3711 gfc_clear_attr (¤t_attr);
3712 current_attr.pointer = 1;
3714 return attr_decl ();
3720 gfc_match_allocatable (void)
3723 gfc_clear_attr (¤t_attr);
3724 current_attr.allocatable = 1;
3726 return attr_decl ();
3731 gfc_match_dimension (void)
3734 gfc_clear_attr (¤t_attr);
3735 current_attr.dimension = 1;
3737 return attr_decl ();
3742 gfc_match_target (void)
3745 gfc_clear_attr (¤t_attr);
3746 current_attr.target = 1;
3748 return attr_decl ();
3752 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3756 access_attr_decl (gfc_statement st)
3758 char name[GFC_MAX_SYMBOL_LEN + 1];
3759 interface_type type;
3762 gfc_intrinsic_op operator;
3765 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3770 m = gfc_match_generic_spec (&type, name, &operator);
3773 if (m == MATCH_ERROR)
3778 case INTERFACE_NAMELESS:
3781 case INTERFACE_GENERIC:
3782 if (gfc_get_symbol (name, NULL, &sym))
3785 if (gfc_add_access (&sym->attr,
3787 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3788 sym->name, NULL) == FAILURE)
3793 case INTERFACE_INTRINSIC_OP:
3794 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3796 gfc_current_ns->operator_access[operator] =
3797 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3801 gfc_error ("Access specification of the %s operator at %C has "
3802 "already been specified", gfc_op2string (operator));
3808 case INTERFACE_USER_OP:
3809 uop = gfc_get_uop (name);
3811 if (uop->access == ACCESS_UNKNOWN)
3814 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3819 ("Access specification of the .%s. operator at %C has "
3820 "already been specified", sym->name);
3827 if (gfc_match_char (',') == MATCH_NO)
3831 if (gfc_match_eos () != MATCH_YES)
3836 gfc_syntax_error (st);
3843 /* The PRIVATE statement is a bit weird in that it can be a attribute
3844 declaration, but also works as a standlone statement inside of a
3845 type declaration or a module. */
3848 gfc_match_private (gfc_statement * st)
3851 if (gfc_match ("private") != MATCH_YES)
3854 if (gfc_current_state () == COMP_DERIVED)
3856 if (gfc_match_eos () == MATCH_YES)
3862 gfc_syntax_error (ST_PRIVATE);
3866 if (gfc_match_eos () == MATCH_YES)
3873 return access_attr_decl (ST_PRIVATE);
3878 gfc_match_public (gfc_statement * st)
3881 if (gfc_match ("public") != MATCH_YES)
3884 if (gfc_match_eos () == MATCH_YES)
3891 return access_attr_decl (ST_PUBLIC);
3895 /* Workhorse for gfc_match_parameter. */
3904 m = gfc_match_symbol (&sym, 0);
3906 gfc_error ("Expected variable name at %C in PARAMETER statement");
3911 if (gfc_match_char ('=') == MATCH_NO)
3913 gfc_error ("Expected = sign in PARAMETER statement at %C");
3917 m = gfc_match_init_expr (&init);
3919 gfc_error ("Expected expression at %C in PARAMETER statement");
3923 if (sym->ts.type == BT_UNKNOWN
3924 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3930 if (gfc_check_assign_symbol (sym, init) == FAILURE
3931 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3937 if (sym->ts.type == BT_CHARACTER
3938 && sym->ts.cl != NULL
3939 && sym->ts.cl->length != NULL
3940 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3941 && init->expr_type == EXPR_CONSTANT
3942 && init->ts.type == BT_CHARACTER
3943 && init->ts.kind == 1)
3944 gfc_set_constant_character_len (
3945 mpz_get_si (sym->ts.cl->length->value.integer), init);
3951 gfc_free_expr (init);
3956 /* Match a parameter statement, with the weird syntax that these have. */
3959 gfc_match_parameter (void)
3963 if (gfc_match_char ('(') == MATCH_NO)
3972 if (gfc_match (" )%t") == MATCH_YES)
3975 if (gfc_match_char (',') != MATCH_YES)
3977 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3987 /* Save statements have a special syntax. */
3990 gfc_match_save (void)
3992 char n[GFC_MAX_SYMBOL_LEN+1];
3997 if (gfc_match_eos () == MATCH_YES)
3999 if (gfc_current_ns->seen_save)
4001 if (gfc_notify_std (GFC_STD_LEGACY,
4002 "Blanket SAVE statement at %C follows previous "
4008 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4012 if (gfc_current_ns->save_all)
4014 if (gfc_notify_std (GFC_STD_LEGACY,
4015 "SAVE statement at %C follows blanket SAVE statement")
4024 m = gfc_match_symbol (&sym, 0);
4028 if (gfc_add_save (&sym->attr, sym->name,
4029 &gfc_current_locus) == FAILURE)
4040 m = gfc_match (" / %n /", &n);
4041 if (m == MATCH_ERROR)
4046 c = gfc_get_common (n, 0);
4049 gfc_current_ns->seen_save = 1;
4052 if (gfc_match_eos () == MATCH_YES)
4054 if (gfc_match_char (',') != MATCH_YES)
4061 gfc_error ("Syntax error in SAVE statement at %C");
4067 gfc_match_value (void)
4072 if (gfc_notify_std (GFC_STD_F2003,
4073 "Fortran 2003: VALUE statement at %C")
4077 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4082 if (gfc_match_eos () == MATCH_YES)
4087 m = gfc_match_symbol (&sym, 0);
4091 if (gfc_add_value (&sym->attr, sym->name,
4092 &gfc_current_locus) == FAILURE)
4104 if (gfc_match_eos () == MATCH_YES)
4106 if (gfc_match_char (',') != MATCH_YES)
4113 gfc_error ("Syntax error in VALUE statement at %C");
4118 gfc_match_volatile (void)
4123 if (gfc_notify_std (GFC_STD_F2003,
4124 "Fortran 2003: VOLATILE statement at %C")
4128 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4133 if (gfc_match_eos () == MATCH_YES)
4138 m = gfc_match_symbol (&sym, 0);
4142 if (gfc_add_volatile (&sym->attr, sym->name,
4143 &gfc_current_locus) == FAILURE)
4155 if (gfc_match_eos () == MATCH_YES)
4157 if (gfc_match_char (',') != MATCH_YES)
4164 gfc_error ("Syntax error in VOLATILE statement at %C");
4170 /* Match a module procedure statement. Note that we have to modify
4171 symbols in the parent's namespace because the current one was there
4172 to receive symbols that are in an interface's formal argument list. */
4175 gfc_match_modproc (void)
4177 char name[GFC_MAX_SYMBOL_LEN + 1];
4181 if (gfc_state_stack->state != COMP_INTERFACE
4182 || gfc_state_stack->previous == NULL
4183 || current_interface.type == INTERFACE_NAMELESS)
4186 ("MODULE PROCEDURE at %C must be in a generic module interface");
4192 m = gfc_match_name (name);
4198 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4201 if (sym->attr.proc != PROC_MODULE
4202 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4203 sym->name, NULL) == FAILURE)
4206 if (gfc_add_interface (sym) == FAILURE)
4209 if (gfc_match_eos () == MATCH_YES)
4211 if (gfc_match_char (',') != MATCH_YES)
4218 gfc_syntax_error (ST_MODULE_PROC);
4223 /* Match the beginning of a derived type declaration. If a type name
4224 was the result of a function, then it is possible to have a symbol
4225 already to be known as a derived type yet have no components. */
4228 gfc_match_derived_decl (void)
4230 char name[GFC_MAX_SYMBOL_LEN + 1];
4231 symbol_attribute attr;
4235 if (gfc_current_state () == COMP_DERIVED)
4238 gfc_clear_attr (&attr);
4241 if (gfc_match (" , private") == MATCH_YES)
4243 if (gfc_find_state (COMP_MODULE) == FAILURE)
4246 ("Derived type at %C can only be PRIVATE within a MODULE");
4250 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4255 if (gfc_match (" , public") == MATCH_YES)
4257 if (gfc_find_state (COMP_MODULE) == FAILURE)
4259 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4263 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4268 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4270 gfc_error ("Expected :: in TYPE definition at %C");
4274 m = gfc_match (" %n%t", name);
4278 /* Make sure the name isn't the name of an intrinsic type. The
4279 'double precision' type doesn't get past the name matcher. */
4280 if (strcmp (name, "integer") == 0
4281 || strcmp (name, "real") == 0
4282 || strcmp (name, "character") == 0
4283 || strcmp (name, "logical") == 0
4284 || strcmp (name, "complex") == 0)
4287 ("Type name '%s' at %C cannot be the same as an intrinsic type",
4292 if (gfc_get_symbol (name, NULL, &sym))
4295 if (sym->ts.type != BT_UNKNOWN)
4297 gfc_error ("Derived type name '%s' at %C already has a basic type "
4298 "of %s", sym->name, gfc_typename (&sym->ts));
4302 /* The symbol may already have the derived attribute without the
4303 components. The ways this can happen is via a function
4304 definition, an INTRINSIC statement or a subtype in another
4305 derived type that is a pointer. The first part of the AND clause
4306 is true if a the symbol is not the return value of a function. */
4307 if (sym->attr.flavor != FL_DERIVED
4308 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4311 if (sym->components != NULL)
4314 ("Derived type definition of '%s' at %C has already been defined",
4319 if (attr.access != ACCESS_UNKNOWN
4320 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4323 gfc_new_block = sym;
4329 /* Cray Pointees can be declared as:
4330 pointer (ipt, a (n,m,...,*))
4331 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4332 cheat and set a constant bound of 1 for the last dimension, if this
4333 is the case. Since there is no bounds-checking for Cray Pointees,
4334 this will be okay. */
4337 gfc_mod_pointee_as (gfc_array_spec *as)
4339 as->cray_pointee = true; /* This will be useful to know later. */
4340 if (as->type == AS_ASSUMED_SIZE)
4342 as->type = AS_EXPLICIT;
4343 as->upper[as->rank - 1] = gfc_int_expr (1);
4344 as->cp_was_assumed = true;
4346 else if (as->type == AS_ASSUMED_SHAPE)
4348 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4355 /* Match the enum definition statement, here we are trying to match
4356 the first line of enum definition statement.
4357 Returns MATCH_YES if match is found. */
4360 gfc_match_enum (void)
4364 m = gfc_match_eos ();
4368 if (gfc_notify_std (GFC_STD_F2003,
4369 "Fortran 2003: ENUM AND ENUMERATOR at %C")
4377 /* Match the enumerator definition statement. */
4380 gfc_match_enumerator_def (void)
4385 gfc_clear_ts (¤t_ts);
4387 m = gfc_match (" enumerator");
4391 if (gfc_current_state () != COMP_ENUM)
4393 gfc_error ("ENUM definition statement expected before %C");
4394 gfc_free_enum_history ();
4398 (¤t_ts)->type = BT_INTEGER;
4399 (¤t_ts)->kind = gfc_c_int_kind;
4401 m = match_attr_spec ();
4402 if (m == MATCH_ERROR)
4411 m = variable_decl (elem++);
4412 if (m == MATCH_ERROR)
4417 if (gfc_match_eos () == MATCH_YES)
4419 if (gfc_match_char (',') != MATCH_YES)
4423 if (gfc_current_state () == COMP_ENUM)
4425 gfc_free_enum_history ();
4426 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4431 gfc_free_array_spec (current_as);