1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
29 /* This flag is set if an old-style length selector is matched
30 during a type-declaration statement. */
32 static int old_char_selector;
34 /* When variables acquire types and attributes from a declaration
35 statement, they get them from the following static variables. The
36 first part of a declaration sets these variables and the second
37 part copies these into symbol structures. */
39 static gfc_typespec current_ts;
41 static symbol_attribute current_attr;
42 static gfc_array_spec *current_as;
43 static int colon_seen;
45 /* Initializer of the previous enumerator. */
47 static gfc_expr *last_initializer;
49 /* History of all the enumerators is maintained, so that
50 kind values of all the enumerators could be updated depending
51 upon the maximum initialized value. */
53 typedef struct enumerator_history
56 gfc_expr *initializer;
57 struct enumerator_history *next;
61 /* Header of enum history chain. */
63 static enumerator_history *enum_history = NULL;
65 /* Pointer of enum history node containing largest initializer. */
67 static enumerator_history *max_enum = NULL;
69 /* gfc_new_block points to the symbol of a newly matched block. */
71 gfc_symbol *gfc_new_block;
74 /********************* DATA statement subroutines *********************/
76 static bool in_match_data = false;
79 gfc_in_match_data (void)
85 gfc_set_in_match_data (bool set_value)
87 in_match_data = set_value;
90 /* Free a gfc_data_variable structure and everything beneath it. */
93 free_variable (gfc_data_variable *p)
100 gfc_free_expr (p->expr);
101 gfc_free_iterator (&p->iter, 0);
102 free_variable (p->list);
108 /* Free a gfc_data_value structure and everything beneath it. */
111 free_value (gfc_data_value *p)
118 gfc_free_expr (p->expr);
124 /* Free a list of gfc_data structures. */
127 gfc_free_data (gfc_data *p)
134 free_variable (p->var);
135 free_value (p->value);
141 /* Free all data in a namespace. */
144 gfc_free_data_all (gfc_namespace * ns)
157 static match var_element (gfc_data_variable *);
159 /* Match a list of variables terminated by an iterator and a right
163 var_list (gfc_data_variable *parent)
165 gfc_data_variable *tail, var;
168 m = var_element (&var);
169 if (m == MATCH_ERROR)
174 tail = gfc_get_data_variable ();
181 if (gfc_match_char (',') != MATCH_YES)
184 m = gfc_match_iterator (&parent->iter, 1);
187 if (m == MATCH_ERROR)
190 m = var_element (&var);
191 if (m == MATCH_ERROR)
196 tail->next = gfc_get_data_variable ();
202 if (gfc_match_char (')') != MATCH_YES)
207 gfc_syntax_error (ST_DATA);
212 /* Match a single element in a data variable list, which can be a
213 variable-iterator list. */
216 var_element (gfc_data_variable *new)
221 memset (new, 0, sizeof (gfc_data_variable));
223 if (gfc_match_char ('(') == MATCH_YES)
224 return var_list (new);
226 m = gfc_match_variable (&new->expr, 0);
230 sym = new->expr->symtree->n.sym;
232 if (!sym->attr.function && gfc_current_ns->parent
233 && gfc_current_ns->parent == sym->ns)
235 gfc_error ("Host associated variable '%s' may not be in the DATA "
236 "statement at %C", sym->name);
240 if (gfc_current_state () != COMP_BLOCK_DATA
241 && sym->attr.in_common
242 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
243 "common block variable '%s' in DATA statement at %C",
244 sym->name) == FAILURE)
247 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
254 /* Match the top-level list of data variables. */
257 top_var_list (gfc_data *d)
259 gfc_data_variable var, *tail, *new;
266 m = var_element (&var);
269 if (m == MATCH_ERROR)
272 new = gfc_get_data_variable ();
282 if (gfc_match_char ('/') == MATCH_YES)
284 if (gfc_match_char (',') != MATCH_YES)
291 gfc_syntax_error (ST_DATA);
292 gfc_free_data_all (gfc_current_ns);
298 match_data_constant (gfc_expr **result)
300 char name[GFC_MAX_SYMBOL_LEN + 1];
306 m = gfc_match_literal_constant (&expr, 1);
313 if (m == MATCH_ERROR)
316 m = gfc_match_null (result);
320 old_loc = gfc_current_locus;
322 /* Should this be a structure component, try to match it
323 before matching a name. */
324 m = gfc_match_rvalue (result);
325 if (m == MATCH_ERROR)
328 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
330 if (gfc_simplify_expr (*result, 0) == FAILURE)
335 gfc_current_locus = old_loc;
337 m = gfc_match_name (name);
341 if (gfc_find_symbol (name, NULL, 1, &sym))
345 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
347 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
351 else if (sym->attr.flavor == FL_DERIVED)
352 return gfc_match_structure_constructor (sym, result);
354 *result = gfc_copy_expr (sym->value);
359 /* Match a list of values in a DATA statement. The leading '/' has
360 already been seen at this point. */
363 top_val_list (gfc_data *data)
365 gfc_data_value *new, *tail;
374 m = match_data_constant (&expr);
377 if (m == MATCH_ERROR)
380 new = gfc_get_data_value ();
389 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
397 msg = gfc_extract_int (expr, &tmp);
398 gfc_free_expr (expr);
406 m = match_data_constant (&tail->expr);
409 if (m == MATCH_ERROR)
413 if (gfc_match_char ('/') == MATCH_YES)
415 if (gfc_match_char (',') == MATCH_NO)
422 gfc_syntax_error (ST_DATA);
423 gfc_free_data_all (gfc_current_ns);
428 /* Matches an old style initialization. */
431 match_old_style_init (const char *name)
438 /* Set up data structure to hold initializers. */
439 gfc_find_sym_tree (name, NULL, 0, &st);
442 newdata = gfc_get_data ();
443 newdata->var = gfc_get_data_variable ();
444 newdata->var->expr = gfc_get_variable_expr (st);
445 newdata->where = gfc_current_locus;
447 /* Match initial value list. This also eats the terminal
449 m = top_val_list (newdata);
458 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
463 /* Mark the variable as having appeared in a data statement. */
464 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
470 /* Chain in namespace list of DATA initializers. */
471 newdata->next = gfc_current_ns->data;
472 gfc_current_ns->data = newdata;
478 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
479 we are matching a DATA statement and are therefore issuing an error
480 if we encounter something unexpected, if not, we're trying to match
481 an old-style initialization expression of the form INTEGER I /2/. */
484 gfc_match_data (void)
489 gfc_set_in_match_data (true);
493 new = gfc_get_data ();
494 new->where = gfc_current_locus;
496 m = top_var_list (new);
500 m = top_val_list (new);
504 new->next = gfc_current_ns->data;
505 gfc_current_ns->data = new;
507 if (gfc_match_eos () == MATCH_YES)
510 gfc_match_char (','); /* Optional comma */
513 gfc_set_in_match_data (false);
517 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
524 gfc_set_in_match_data (false);
530 /************************ Declaration statements *********************/
532 /* Match an intent specification. Since this can only happen after an
533 INTENT word, a legal intent-spec must follow. */
536 match_intent_spec (void)
539 if (gfc_match (" ( in out )") == MATCH_YES)
541 if (gfc_match (" ( in )") == MATCH_YES)
543 if (gfc_match (" ( out )") == MATCH_YES)
546 gfc_error ("Bad INTENT specification at %C");
547 return INTENT_UNKNOWN;
551 /* Matches a character length specification, which is either a
552 specification expression or a '*'. */
555 char_len_param_value (gfc_expr **expr)
557 if (gfc_match_char ('*') == MATCH_YES)
563 return gfc_match_expr (expr);
567 /* A character length is a '*' followed by a literal integer or a
568 char_len_param_value in parenthesis. */
571 match_char_length (gfc_expr **expr)
576 m = gfc_match_char ('*');
580 m = gfc_match_small_literal_int (&length, NULL);
581 if (m == MATCH_ERROR)
586 *expr = gfc_int_expr (length);
590 if (gfc_match_char ('(') == MATCH_NO)
593 m = char_len_param_value (expr);
594 if (m == MATCH_ERROR)
599 if (gfc_match_char (')') == MATCH_NO)
601 gfc_free_expr (*expr);
609 gfc_error ("Syntax error in character length specification at %C");
614 /* Special subroutine for finding a symbol. Check if the name is found
615 in the current name space. If not, and we're compiling a function or
616 subroutine and the parent compilation unit is an interface, then check
617 to see if the name we've been given is the name of the interface
618 (located in another namespace). */
621 find_special (const char *name, gfc_symbol **result)
626 i = gfc_get_symbol (name, NULL, result);
630 if (gfc_current_state () != COMP_SUBROUTINE
631 && gfc_current_state () != COMP_FUNCTION)
634 s = gfc_state_stack->previous;
638 if (s->state != COMP_INTERFACE)
641 goto end; /* Nameless interface */
643 if (strcmp (name, s->sym->name) == 0)
654 /* Special subroutine for getting a symbol node associated with a
655 procedure name, used in SUBROUTINE and FUNCTION statements. The
656 symbol is created in the parent using with symtree node in the
657 child unit pointing to the symbol. If the current namespace has no
658 parent, then the symbol is just created in the current unit. */
661 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
667 /* Module functions have to be left in their own namespace because
668 they have potentially (almost certainly!) already been referenced.
669 In this sense, they are rather like external functions. This is
670 fixed up in resolve.c(resolve_entries), where the symbol name-
671 space is set to point to the master function, so that the fake
672 result mechanism can work. */
673 if (module_fcn_entry)
674 rc = gfc_get_symbol (name, NULL, result);
676 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
679 gfc_current_ns->refs++;
681 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
683 /* Trap another encompassed procedure with the same name. All
684 these conditions are necessary to avoid picking up an entry
685 whose name clashes with that of the encompassing procedure;
686 this is handled using gsymbols to register unique,globally
688 if (sym->attr.flavor != 0
689 && sym->attr.proc != 0
690 && (sym->attr.subroutine || sym->attr.function)
691 && sym->attr.if_source != IFSRC_UNKNOWN)
692 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
693 name, &sym->declared_at);
695 /* Trap declarations of attributes in encompassing scope. The
696 signature for this is that ts.kind is set. Legitimate
697 references only set ts.type. */
698 if (sym->ts.kind != 0
699 && !sym->attr.implicit_type
700 && sym->attr.proc == 0
701 && gfc_current_ns->parent != NULL
702 && sym->attr.access == 0
703 && !module_fcn_entry)
704 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
705 "and must not have attributes declared at %L",
706 name, &sym->declared_at);
709 if (gfc_current_ns->parent == NULL || *result == NULL)
712 /* Module function entries will already have a symtree in
713 the current namespace but will need one at module level. */
714 if (module_fcn_entry)
715 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
717 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
722 /* See if the procedure should be a module procedure */
724 if (((sym->ns->proc_name != NULL
725 && sym->ns->proc_name->attr.flavor == FL_MODULE
726 && sym->attr.proc != PROC_MODULE) || module_fcn_entry)
727 && gfc_add_procedure (&sym->attr, PROC_MODULE,
728 sym->name, NULL) == FAILURE)
735 /* Function called by variable_decl() that adds a name to the symbol
739 build_sym (const char *name, gfc_charlen *cl,
740 gfc_array_spec **as, locus *var_locus)
742 symbol_attribute attr;
745 if (gfc_get_symbol (name, NULL, &sym))
748 /* Start updating the symbol table. Add basic type attribute
750 if (current_ts.type != BT_UNKNOWN
751 && (sym->attr.implicit_type == 0
752 || !gfc_compare_types (&sym->ts, ¤t_ts))
753 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
756 if (sym->ts.type == BT_CHARACTER)
759 /* Add dimension attribute if present. */
760 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
764 /* Add attribute to symbol. The copy is so that we can reset the
765 dimension attribute. */
769 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
776 /* Set character constant to the given length. The constant will be padded or
780 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
785 gcc_assert (expr->expr_type == EXPR_CONSTANT);
786 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
788 slen = expr->value.character.length;
791 s = gfc_getmem (len + 1);
792 memcpy (s, expr->value.character.string, MIN (len, slen));
794 memset (&s[slen], ' ', len - slen);
796 if (gfc_option.warn_character_truncation && slen > len)
797 gfc_warning_now ("CHARACTER expression at %L is being truncated "
798 "(%d/%d)", &expr->where, slen, len);
800 /* Apply the standard by 'hand' otherwise it gets cleared for
802 if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
803 gfc_error_now ("The CHARACTER elements of the array constructor "
804 "at %L must have the same length (%d/%d)",
805 &expr->where, slen, len);
808 gfc_free (expr->value.character.string);
809 expr->value.character.string = s;
810 expr->value.character.length = len;
815 /* Function to create and update the enumerator history
816 using the information passed as arguments.
817 Pointer "max_enum" is also updated, to point to
818 enum history node containing largest initializer.
820 SYM points to the symbol node of enumerator.
821 INIT points to its enumerator value. */
824 create_enum_history (gfc_symbol *sym, gfc_expr *init)
826 enumerator_history *new_enum_history;
827 gcc_assert (sym != NULL && init != NULL);
829 new_enum_history = gfc_getmem (sizeof (enumerator_history));
831 new_enum_history->sym = sym;
832 new_enum_history->initializer = init;
833 new_enum_history->next = NULL;
835 if (enum_history == NULL)
837 enum_history = new_enum_history;
838 max_enum = enum_history;
842 new_enum_history->next = enum_history;
843 enum_history = new_enum_history;
845 if (mpz_cmp (max_enum->initializer->value.integer,
846 new_enum_history->initializer->value.integer) < 0)
847 max_enum = new_enum_history;
852 /* Function to free enum kind history. */
855 gfc_free_enum_history (void)
857 enumerator_history *current = enum_history;
858 enumerator_history *next;
860 while (current != NULL)
862 next = current->next;
871 /* Function called by variable_decl() that adds an initialization
872 expression to a symbol. */
875 add_init_expr_to_sym (const char *name, gfc_expr **initp,
878 symbol_attribute attr;
883 if (find_special (name, &sym))
888 /* If this symbol is confirming an implicit parameter type,
889 then an initialization expression is not allowed. */
890 if (attr.flavor == FL_PARAMETER
891 && sym->value != NULL
894 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
903 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
910 /* An initializer is required for PARAMETER declarations. */
911 if (attr.flavor == FL_PARAMETER)
913 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
919 /* If a variable appears in a DATA block, it cannot have an
923 gfc_error ("Variable '%s' at %C with an initializer already "
924 "appears in a DATA statement", sym->name);
928 /* Check if the assignment can happen. This has to be put off
929 until later for a derived type variable. */
930 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
931 && gfc_check_assign_symbol (sym, init) == FAILURE)
934 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
936 /* Update symbol character length according initializer. */
937 if (sym->ts.cl->length == NULL)
939 /* If there are multiple CHARACTER variables declared on
940 the same line, we don't want them to share the same
942 sym->ts.cl = gfc_get_charlen ();
943 sym->ts.cl->next = gfc_current_ns->cl_list;
944 gfc_current_ns->cl_list = sym->ts.cl;
946 if (sym->attr.flavor == FL_PARAMETER
947 && init->expr_type == EXPR_ARRAY)
948 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
950 /* Update initializer character length according symbol. */
951 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
953 int len = mpz_get_si (sym->ts.cl->length->value.integer);
956 if (init->expr_type == EXPR_CONSTANT)
957 gfc_set_constant_character_len (len, init, false);
958 else if (init->expr_type == EXPR_ARRAY)
960 /* Build a new charlen to prevent simplification from
961 deleting the length before it is resolved. */
962 init->ts.cl = gfc_get_charlen ();
963 init->ts.cl->next = gfc_current_ns->cl_list;
964 gfc_current_ns->cl_list = sym->ts.cl;
965 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
967 for (p = init->value.constructor; p; p = p->next)
968 gfc_set_constant_character_len (len, p->expr, false);
973 /* Add initializer. Make sure we keep the ranks sane. */
974 if (sym->attr.dimension && init->rank == 0)
975 init->rank = sym->as->rank;
985 /* Function called by variable_decl() that adds a name to a structure
989 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
994 /* If the current symbol is of the same derived type that we're
995 constructing, it must have the pointer attribute. */
996 if (current_ts.type == BT_DERIVED
997 && current_ts.derived == gfc_current_block ()
998 && current_attr.pointer == 0)
1000 gfc_error ("Component at %C must have the POINTER attribute");
1004 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1006 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1008 gfc_error ("Array component of structure at %C must have explicit "
1009 "or deferred shape");
1014 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1019 gfc_set_component_attr (c, ¤t_attr);
1021 c->initializer = *init;
1029 /* Check array components. */
1034 gfc_error ("Allocatable component at %C must be an array");
1043 if (c->as->type != AS_DEFERRED)
1045 gfc_error ("Pointer array component of structure at %C must have a "
1050 else if (c->allocatable)
1052 if (c->as->type != AS_DEFERRED)
1054 gfc_error ("Allocatable component of structure at %C must have a "
1061 if (c->as->type != AS_EXPLICIT)
1063 gfc_error ("Array component of structure at %C must have an "
1073 /* Match a 'NULL()', and possibly take care of some side effects. */
1076 gfc_match_null (gfc_expr **result)
1082 m = gfc_match (" null ( )");
1086 /* The NULL symbol now has to be/become an intrinsic function. */
1087 if (gfc_get_symbol ("null", NULL, &sym))
1089 gfc_error ("NULL() initialization at %C is ambiguous");
1093 gfc_intrinsic_symbol (sym);
1095 if (sym->attr.proc != PROC_INTRINSIC
1096 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1097 sym->name, NULL) == FAILURE
1098 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1101 e = gfc_get_expr ();
1102 e->where = gfc_current_locus;
1103 e->expr_type = EXPR_NULL;
1104 e->ts.type = BT_UNKNOWN;
1112 /* Match a variable name with an optional initializer. When this
1113 subroutine is called, a variable is expected to be parsed next.
1114 Depending on what is happening at the moment, updates either the
1115 symbol table or the current interface. */
1118 variable_decl (int elem)
1120 char name[GFC_MAX_SYMBOL_LEN + 1];
1121 gfc_expr *initializer, *char_len;
1123 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1134 old_locus = gfc_current_locus;
1136 /* When we get here, we've just matched a list of attributes and
1137 maybe a type and a double colon. The next thing we expect to see
1138 is the name of the symbol. */
1139 m = gfc_match_name (name);
1143 var_locus = gfc_current_locus;
1145 /* Now we could see the optional array spec. or character length. */
1146 m = gfc_match_array_spec (&as);
1147 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1148 cp_as = gfc_copy_array_spec (as);
1149 else if (m == MATCH_ERROR)
1153 as = gfc_copy_array_spec (current_as);
1158 if (current_ts.type == BT_CHARACTER)
1160 switch (match_char_length (&char_len))
1163 cl = gfc_get_charlen ();
1164 cl->next = gfc_current_ns->cl_list;
1165 gfc_current_ns->cl_list = cl;
1167 cl->length = char_len;
1170 /* Non-constant lengths need to be copied after the first
1173 if (elem > 1 && current_ts.cl->length
1174 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1176 cl = gfc_get_charlen ();
1177 cl->next = gfc_current_ns->cl_list;
1178 gfc_current_ns->cl_list = cl;
1179 cl->length = gfc_copy_expr (current_ts.cl->length);
1191 /* If this symbol has already shown up in a Cray Pointer declaration,
1192 then we want to set the type & bail out. */
1193 if (gfc_option.flag_cray_pointer)
1195 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1196 if (sym != NULL && sym->attr.cray_pointee)
1198 sym->ts.type = current_ts.type;
1199 sym->ts.kind = current_ts.kind;
1201 sym->ts.derived = current_ts.derived;
1204 /* Check to see if we have an array specification. */
1207 if (sym->as != NULL)
1209 gfc_error ("Duplicate array spec for Cray pointee at %C");
1210 gfc_free_array_spec (cp_as);
1216 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1217 gfc_internal_error ("Couldn't set pointee array spec.");
1219 /* Fix the array spec. */
1220 m = gfc_mod_pointee_as (sym->as);
1221 if (m == MATCH_ERROR)
1229 gfc_free_array_spec (cp_as);
1234 /* OK, we've successfully matched the declaration. Now put the
1235 symbol in the current namespace, because it might be used in the
1236 optional initialization expression for this symbol, e.g. this is
1239 integer, parameter :: i = huge(i)
1241 This is only true for parameters or variables of a basic type.
1242 For components of derived types, it is not true, so we don't
1243 create a symbol for those yet. If we fail to create the symbol,
1245 if (gfc_current_state () != COMP_DERIVED
1246 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1252 /* An interface body specifies all of the procedure's
1253 characteristics and these shall be consistent with those
1254 specified in the procedure definition, except that the interface
1255 may specify a procedure that is not pure if the procedure is
1256 defined to be pure(12.3.2). */
1257 if (current_ts.type == BT_DERIVED
1258 && gfc_current_ns->proc_name
1259 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1260 && current_ts.derived->ns != gfc_current_ns
1261 && !gfc_current_ns->has_import_set)
1263 gfc_error ("the type of '%s' at %C has not been declared within the "
1269 /* In functions that have a RESULT variable defined, the function
1270 name always refers to function calls. Therefore, the name is
1271 not allowed to appear in specification statements. */
1272 if (gfc_current_state () == COMP_FUNCTION
1273 && gfc_current_block () != NULL
1274 && gfc_current_block ()->result != NULL
1275 && gfc_current_block ()->result != gfc_current_block ()
1276 && strcmp (gfc_current_block ()->name, name) == 0)
1278 gfc_error ("Function name '%s' not allowed at %C", name);
1283 /* We allow old-style initializations of the form
1284 integer i /2/, j(4) /3*3, 1/
1285 (if no colon has been seen). These are different from data
1286 statements in that initializers are only allowed to apply to the
1287 variable immediately preceding, i.e.
1289 is not allowed. Therefore we have to do some work manually, that
1290 could otherwise be left to the matchers for DATA statements. */
1292 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1294 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1295 "initialization at %C") == FAILURE)
1298 return match_old_style_init (name);
1301 /* The double colon must be present in order to have initializers.
1302 Otherwise the statement is ambiguous with an assignment statement. */
1305 if (gfc_match (" =>") == MATCH_YES)
1307 if (!current_attr.pointer)
1309 gfc_error ("Initialization at %C isn't for a pointer variable");
1314 m = gfc_match_null (&initializer);
1317 gfc_error ("Pointer initialization requires a NULL() at %C");
1321 if (gfc_pure (NULL))
1323 gfc_error ("Initialization of pointer at %C is not allowed in "
1324 "a PURE procedure");
1332 else if (gfc_match_char ('=') == MATCH_YES)
1334 if (current_attr.pointer)
1336 gfc_error ("Pointer initialization at %C requires '=>', "
1342 m = gfc_match_init_expr (&initializer);
1345 gfc_error ("Expected an initialization expression at %C");
1349 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1351 gfc_error ("Initialization of variable at %C is not allowed in "
1352 "a PURE procedure");
1361 if (initializer != NULL && current_attr.allocatable
1362 && gfc_current_state () == COMP_DERIVED)
1364 gfc_error ("Initialization of allocatable component at %C is not "
1370 /* Add the initializer. Note that it is fine if initializer is
1371 NULL here, because we sometimes also need to check if a
1372 declaration *must* have an initialization expression. */
1373 if (gfc_current_state () != COMP_DERIVED)
1374 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1377 if (current_ts.type == BT_DERIVED
1378 && !current_attr.pointer && !initializer)
1379 initializer = gfc_default_initializer (¤t_ts);
1380 t = build_struct (name, cl, &initializer, &as);
1383 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1386 /* Free stuff up and return. */
1387 gfc_free_expr (initializer);
1388 gfc_free_array_spec (as);
1394 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1395 This assumes that the byte size is equal to the kind number for
1396 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1399 gfc_match_old_kind_spec (gfc_typespec *ts)
1404 if (gfc_match_char ('*') != MATCH_YES)
1407 m = gfc_match_small_literal_int (&ts->kind, NULL);
1411 original_kind = ts->kind;
1413 /* Massage the kind numbers for complex types. */
1414 if (ts->type == BT_COMPLEX)
1418 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1419 gfc_basic_typename (ts->type), original_kind);
1425 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1427 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1428 gfc_basic_typename (ts->type), original_kind);
1432 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1433 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1440 /* Match a kind specification. Since kinds are generally optional, we
1441 usually return MATCH_NO if something goes wrong. If a "kind="
1442 string is found, then we know we have an error. */
1445 gfc_match_kind_spec (gfc_typespec *ts)
1455 where = gfc_current_locus;
1457 if (gfc_match_char ('(') == MATCH_NO)
1460 /* Also gobbles optional text. */
1461 if (gfc_match (" kind = ") == MATCH_YES)
1464 n = gfc_match_init_expr (&e);
1466 gfc_error ("Expected initialization expression at %C");
1472 gfc_error ("Expected scalar initialization expression at %C");
1477 msg = gfc_extract_int (e, &ts->kind);
1488 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1490 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1491 gfc_basic_typename (ts->type));
1497 if (gfc_match_char (')') != MATCH_YES)
1499 gfc_error ("Missing right parenthesis at %C");
1507 gfc_current_locus = where;
1512 /* Match the various kind/length specifications in a CHARACTER
1513 declaration. We don't return MATCH_NO. */
1516 match_char_spec (gfc_typespec *ts)
1518 int i, kind, seen_length;
1523 kind = gfc_default_character_kind;
1527 /* Try the old-style specification first. */
1528 old_char_selector = 0;
1530 m = match_char_length (&len);
1534 old_char_selector = 1;
1539 m = gfc_match_char ('(');
1542 m = MATCH_YES; /* character without length is a single char */
1546 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1547 if (gfc_match (" kind =") == MATCH_YES)
1549 m = gfc_match_small_int (&kind);
1550 if (m == MATCH_ERROR)
1555 if (gfc_match (" , len =") == MATCH_NO)
1558 m = char_len_param_value (&len);
1561 if (m == MATCH_ERROR)
1568 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>" */
1569 if (gfc_match (" len =") == MATCH_YES)
1571 m = char_len_param_value (&len);
1574 if (m == MATCH_ERROR)
1578 if (gfc_match_char (')') == MATCH_YES)
1581 if (gfc_match (" , kind =") != MATCH_YES)
1584 gfc_match_small_int (&kind);
1586 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1588 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1595 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1596 m = char_len_param_value (&len);
1599 if (m == MATCH_ERROR)
1603 m = gfc_match_char (')');
1607 if (gfc_match_char (',') != MATCH_YES)
1610 gfc_match (" kind ="); /* Gobble optional text */
1612 m = gfc_match_small_int (&kind);
1613 if (m == MATCH_ERROR)
1619 /* Require a right-paren at this point. */
1620 m = gfc_match_char (')');
1625 gfc_error ("Syntax error in CHARACTER declaration at %C");
1629 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1631 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1637 gfc_free_expr (len);
1641 /* Do some final massaging of the length values. */
1642 cl = gfc_get_charlen ();
1643 cl->next = gfc_current_ns->cl_list;
1644 gfc_current_ns->cl_list = cl;
1646 if (seen_length == 0)
1647 cl->length = gfc_int_expr (1);
1650 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1654 gfc_free_expr (len);
1655 cl->length = gfc_int_expr (0);
1666 /* Matches a type specification. If successful, sets the ts structure
1667 to the matched specification. This is necessary for FUNCTION and
1668 IMPLICIT statements.
1670 If implicit_flag is nonzero, then we don't check for the optional
1671 kind specification. Not doing so is needed for matching an IMPLICIT
1672 statement correctly. */
1675 match_type_spec (gfc_typespec *ts, int implicit_flag)
1677 char name[GFC_MAX_SYMBOL_LEN + 1];
1684 if (gfc_match (" byte") == MATCH_YES)
1686 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1690 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1692 gfc_error ("BYTE type used at %C "
1693 "is not available on the target machine");
1697 ts->type = BT_INTEGER;
1702 if (gfc_match (" integer") == MATCH_YES)
1704 ts->type = BT_INTEGER;
1705 ts->kind = gfc_default_integer_kind;
1709 if (gfc_match (" character") == MATCH_YES)
1711 ts->type = BT_CHARACTER;
1712 if (implicit_flag == 0)
1713 return match_char_spec (ts);
1718 if (gfc_match (" real") == MATCH_YES)
1721 ts->kind = gfc_default_real_kind;
1725 if (gfc_match (" double precision") == MATCH_YES)
1728 ts->kind = gfc_default_double_kind;
1732 if (gfc_match (" complex") == MATCH_YES)
1734 ts->type = BT_COMPLEX;
1735 ts->kind = gfc_default_complex_kind;
1739 if (gfc_match (" double complex") == MATCH_YES)
1741 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1742 "conform to the Fortran 95 standard") == FAILURE)
1745 ts->type = BT_COMPLEX;
1746 ts->kind = gfc_default_double_kind;
1750 if (gfc_match (" logical") == MATCH_YES)
1752 ts->type = BT_LOGICAL;
1753 ts->kind = gfc_default_logical_kind;
1757 m = gfc_match (" type ( %n )", name);
1761 /* Search for the name but allow the components to be defined later. */
1762 if (gfc_get_ha_symbol (name, &sym))
1764 gfc_error ("Type name '%s' at %C is ambiguous", name);
1768 if (sym->attr.flavor != FL_DERIVED
1769 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1772 ts->type = BT_DERIVED;
1779 /* For all types except double, derived and character, look for an
1780 optional kind specifier. MATCH_NO is actually OK at this point. */
1781 if (implicit_flag == 1)
1784 if (gfc_current_form == FORM_FREE)
1786 c = gfc_peek_char();
1787 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1788 && c != ':' && c != ',')
1792 m = gfc_match_kind_spec (ts);
1793 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1794 m = gfc_match_old_kind_spec (ts);
1797 m = MATCH_YES; /* No kind specifier found. */
1803 /* Match an IMPLICIT NONE statement. Actually, this statement is
1804 already matched in parse.c, or we would not end up here in the
1805 first place. So the only thing we need to check, is if there is
1806 trailing garbage. If not, the match is successful. */
1809 gfc_match_implicit_none (void)
1811 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1815 /* Match the letter range(s) of an IMPLICIT statement. */
1818 match_implicit_range (void)
1820 int c, c1, c2, inner;
1823 cur_loc = gfc_current_locus;
1825 gfc_gobble_whitespace ();
1826 c = gfc_next_char ();
1829 gfc_error ("Missing character range in IMPLICIT at %C");
1836 gfc_gobble_whitespace ();
1837 c1 = gfc_next_char ();
1841 gfc_gobble_whitespace ();
1842 c = gfc_next_char ();
1847 inner = 0; /* Fall through */
1854 gfc_gobble_whitespace ();
1855 c2 = gfc_next_char ();
1859 gfc_gobble_whitespace ();
1860 c = gfc_next_char ();
1862 if ((c != ',') && (c != ')'))
1875 gfc_error ("Letters must be in alphabetic order in "
1876 "IMPLICIT statement at %C");
1880 /* See if we can add the newly matched range to the pending
1881 implicits from this IMPLICIT statement. We do not check for
1882 conflicts with whatever earlier IMPLICIT statements may have
1883 set. This is done when we've successfully finished matching
1885 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1892 gfc_syntax_error (ST_IMPLICIT);
1894 gfc_current_locus = cur_loc;
1899 /* Match an IMPLICIT statement, storing the types for
1900 gfc_set_implicit() if the statement is accepted by the parser.
1901 There is a strange looking, but legal syntactic construction
1902 possible. It looks like:
1904 IMPLICIT INTEGER (a-b) (c-d)
1906 This is legal if "a-b" is a constant expression that happens to
1907 equal one of the legal kinds for integers. The real problem
1908 happens with an implicit specification that looks like:
1910 IMPLICIT INTEGER (a-b)
1912 In this case, a typespec matcher that is "greedy" (as most of the
1913 matchers are) gobbles the character range as a kindspec, leaving
1914 nothing left. We therefore have to go a bit more slowly in the
1915 matching process by inhibiting the kindspec checking during
1916 typespec matching and checking for a kind later. */
1919 gfc_match_implicit (void)
1926 /* We don't allow empty implicit statements. */
1927 if (gfc_match_eos () == MATCH_YES)
1929 gfc_error ("Empty IMPLICIT statement at %C");
1935 /* First cleanup. */
1936 gfc_clear_new_implicit ();
1938 /* A basic type is mandatory here. */
1939 m = match_type_spec (&ts, 1);
1940 if (m == MATCH_ERROR)
1945 cur_loc = gfc_current_locus;
1946 m = match_implicit_range ();
1950 /* We may have <TYPE> (<RANGE>). */
1951 gfc_gobble_whitespace ();
1952 c = gfc_next_char ();
1953 if ((c == '\n') || (c == ','))
1955 /* Check for CHARACTER with no length parameter. */
1956 if (ts.type == BT_CHARACTER && !ts.cl)
1958 ts.kind = gfc_default_character_kind;
1959 ts.cl = gfc_get_charlen ();
1960 ts.cl->next = gfc_current_ns->cl_list;
1961 gfc_current_ns->cl_list = ts.cl;
1962 ts.cl->length = gfc_int_expr (1);
1965 /* Record the Successful match. */
1966 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1971 gfc_current_locus = cur_loc;
1974 /* Discard the (incorrectly) matched range. */
1975 gfc_clear_new_implicit ();
1977 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1978 if (ts.type == BT_CHARACTER)
1979 m = match_char_spec (&ts);
1982 m = gfc_match_kind_spec (&ts);
1985 m = gfc_match_old_kind_spec (&ts);
1986 if (m == MATCH_ERROR)
1992 if (m == MATCH_ERROR)
1995 m = match_implicit_range ();
1996 if (m == MATCH_ERROR)
2001 gfc_gobble_whitespace ();
2002 c = gfc_next_char ();
2003 if ((c != '\n') && (c != ','))
2006 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2014 gfc_syntax_error (ST_IMPLICIT);
2021 gfc_match_import (void)
2023 char name[GFC_MAX_SYMBOL_LEN + 1];
2028 if (gfc_current_ns->proc_name == NULL ||
2029 gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2031 gfc_error ("IMPORT statement at %C only permitted in "
2032 "an INTERFACE body");
2036 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2040 if (gfc_match_eos () == MATCH_YES)
2042 /* All host variables should be imported. */
2043 gfc_current_ns->has_import_set = 1;
2047 if (gfc_match (" ::") == MATCH_YES)
2049 if (gfc_match_eos () == MATCH_YES)
2051 gfc_error ("Expecting list of named entities at %C");
2058 m = gfc_match (" %n", name);
2062 if (gfc_current_ns->parent != NULL
2063 && gfc_find_symbol (name, gfc_current_ns->parent,
2066 gfc_error ("Type name '%s' at %C is ambiguous", name);
2069 else if (gfc_current_ns->proc_name->ns->parent != NULL
2070 && gfc_find_symbol (name,
2071 gfc_current_ns->proc_name->ns->parent,
2074 gfc_error ("Type name '%s' at %C is ambiguous", name);
2080 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2081 "at %C - does not exist.", name);
2085 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2087 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2092 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2095 sym->ns = gfc_current_ns;
2107 if (gfc_match_eos () == MATCH_YES)
2109 if (gfc_match_char (',') != MATCH_YES)
2116 gfc_error ("Syntax error in IMPORT statement at %C");
2120 /* Matches an attribute specification including array specs. If
2121 successful, leaves the variables current_attr and current_as
2122 holding the specification. Also sets the colon_seen variable for
2123 later use by matchers associated with initializations.
2125 This subroutine is a little tricky in the sense that we don't know
2126 if we really have an attr-spec until we hit the double colon.
2127 Until that time, we can only return MATCH_NO. This forces us to
2128 check for duplicate specification at this level. */
2131 match_attr_spec (void)
2133 /* Modifiers that can exist in a type statement. */
2135 { GFC_DECL_BEGIN = 0,
2136 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2137 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2138 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2139 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2140 DECL_COLON, DECL_NONE,
2141 GFC_DECL_END /* Sentinel */
2145 /* GFC_DECL_END is the sentinel, index starts at 0. */
2146 #define NUM_DECL GFC_DECL_END
2148 static mstring decls[] = {
2149 minit (", allocatable", DECL_ALLOCATABLE),
2150 minit (", dimension", DECL_DIMENSION),
2151 minit (", external", DECL_EXTERNAL),
2152 minit (", intent ( in )", DECL_IN),
2153 minit (", intent ( out )", DECL_OUT),
2154 minit (", intent ( in out )", DECL_INOUT),
2155 minit (", intrinsic", DECL_INTRINSIC),
2156 minit (", optional", DECL_OPTIONAL),
2157 minit (", parameter", DECL_PARAMETER),
2158 minit (", pointer", DECL_POINTER),
2159 minit (", protected", DECL_PROTECTED),
2160 minit (", private", DECL_PRIVATE),
2161 minit (", public", DECL_PUBLIC),
2162 minit (", save", DECL_SAVE),
2163 minit (", target", DECL_TARGET),
2164 minit (", value", DECL_VALUE),
2165 minit (", volatile", DECL_VOLATILE),
2166 minit ("::", DECL_COLON),
2167 minit (NULL, DECL_NONE)
2170 locus start, seen_at[NUM_DECL];
2177 gfc_clear_attr (¤t_attr);
2178 start = gfc_current_locus;
2183 /* See if we get all of the keywords up to the final double colon. */
2184 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2189 d = (decl_types) gfc_match_strings (decls);
2190 if (d == DECL_NONE || d == DECL_COLON)
2194 seen_at[d] = gfc_current_locus;
2196 if (d == DECL_DIMENSION)
2198 m = gfc_match_array_spec (¤t_as);
2202 gfc_error ("Missing dimension specification at %C");
2206 if (m == MATCH_ERROR)
2211 /* No double colon, so assume that we've been looking at something
2212 else the whole time. */
2219 /* Since we've seen a double colon, we have to be looking at an
2220 attr-spec. This means that we can now issue errors. */
2221 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2226 case DECL_ALLOCATABLE:
2227 attr = "ALLOCATABLE";
2229 case DECL_DIMENSION:
2236 attr = "INTENT (IN)";
2239 attr = "INTENT (OUT)";
2242 attr = "INTENT (IN OUT)";
2244 case DECL_INTRINSIC:
2250 case DECL_PARAMETER:
2256 case DECL_PROTECTED:
2278 attr = NULL; /* This shouldn't happen */
2281 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2286 /* Now that we've dealt with duplicate attributes, add the attributes
2287 to the current attribute. */
2288 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2293 if (gfc_current_state () == COMP_DERIVED
2294 && d != DECL_DIMENSION && d != DECL_POINTER
2295 && d != DECL_COLON && d != DECL_PRIVATE
2296 && d != DECL_PUBLIC && d != DECL_NONE)
2298 if (d == DECL_ALLOCATABLE)
2300 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2301 "attribute at %C in a TYPE definition")
2310 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2317 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2318 && gfc_current_state () != COMP_MODULE)
2320 if (d == DECL_PRIVATE)
2324 if (gfc_current_state () == COMP_DERIVED
2325 && gfc_state_stack->previous
2326 && gfc_state_stack->previous->state == COMP_MODULE)
2328 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2329 "at %L in a TYPE definition", attr,
2339 gfc_error ("%s attribute at %L is not allowed outside of the "
2340 "specification part of a module", attr, &seen_at[d]);
2348 case DECL_ALLOCATABLE:
2349 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2352 case DECL_DIMENSION:
2353 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2357 t = gfc_add_external (¤t_attr, &seen_at[d]);
2361 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2365 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2369 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2372 case DECL_INTRINSIC:
2373 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2377 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2380 case DECL_PARAMETER:
2381 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2385 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2388 case DECL_PROTECTED:
2389 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2391 gfc_error ("PROTECTED at %C only allowed in specification "
2392 "part of a module");
2397 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2402 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
2406 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2411 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2416 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2420 t = gfc_add_target (¤t_attr, &seen_at[d]);
2424 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2429 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
2433 if (gfc_notify_std (GFC_STD_F2003,
2434 "Fortran 2003: VOLATILE attribute at %C")
2438 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
2442 gfc_internal_error ("match_attr_spec(): Bad attribute");
2456 gfc_current_locus = start;
2457 gfc_free_array_spec (current_as);
2463 /* Match a data declaration statement. */
2466 gfc_match_data_decl (void)
2472 m = match_type_spec (¤t_ts, 0);
2476 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2478 sym = gfc_use_derived (current_ts.derived);
2486 current_ts.derived = sym;
2489 m = match_attr_spec ();
2490 if (m == MATCH_ERROR)
2496 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2499 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2502 gfc_find_symbol (current_ts.derived->name,
2503 current_ts.derived->ns->parent, 1, &sym);
2505 /* Any symbol that we find had better be a type definition
2506 which has its components defined. */
2507 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2508 && current_ts.derived->components != NULL)
2511 /* Now we have an error, which we signal, and then fix up
2512 because the knock-on is plain and simple confusing. */
2513 gfc_error_now ("Derived type at %C has not been previously defined "
2514 "and so cannot appear in a derived type definition");
2515 current_attr.pointer = 1;
2520 /* If we have an old-style character declaration, and no new-style
2521 attribute specifications, then there a comma is optional between
2522 the type specification and the variable list. */
2523 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2524 gfc_match_char (',');
2526 /* Give the types/attributes to symbols that follow. Give the element
2527 a number so that repeat character length expressions can be copied. */
2531 m = variable_decl (elem++);
2532 if (m == MATCH_ERROR)
2537 if (gfc_match_eos () == MATCH_YES)
2539 if (gfc_match_char (',') != MATCH_YES)
2543 if (gfc_error_flag_test () == 0)
2544 gfc_error ("Syntax error in data declaration at %C");
2547 gfc_free_data_all (gfc_current_ns);
2550 gfc_free_array_spec (current_as);
2556 /* Match a prefix associated with a function or subroutine
2557 declaration. If the typespec pointer is nonnull, then a typespec
2558 can be matched. Note that if nothing matches, MATCH_YES is
2559 returned (the null string was matched). */
2562 match_prefix (gfc_typespec *ts)
2566 gfc_clear_attr (¤t_attr);
2570 if (!seen_type && ts != NULL
2571 && match_type_spec (ts, 0) == MATCH_YES
2572 && gfc_match_space () == MATCH_YES)
2579 if (gfc_match ("elemental% ") == MATCH_YES)
2581 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2587 if (gfc_match ("pure% ") == MATCH_YES)
2589 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2595 if (gfc_match ("recursive% ") == MATCH_YES)
2597 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2603 /* At this point, the next item is not a prefix. */
2608 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2611 copy_prefix (symbol_attribute *dest, locus *where)
2613 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2616 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2619 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2626 /* Match a formal argument list. */
2629 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
2631 gfc_formal_arglist *head, *tail, *p, *q;
2632 char name[GFC_MAX_SYMBOL_LEN + 1];
2638 if (gfc_match_char ('(') != MATCH_YES)
2645 if (gfc_match_char (')') == MATCH_YES)
2650 if (gfc_match_char ('*') == MATCH_YES)
2654 m = gfc_match_name (name);
2658 if (gfc_get_symbol (name, NULL, &sym))
2662 p = gfc_get_formal_arglist ();
2674 /* We don't add the VARIABLE flavor because the name could be a
2675 dummy procedure. We don't apply these attributes to formal
2676 arguments of statement functions. */
2677 if (sym != NULL && !st_flag
2678 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2679 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2685 /* The name of a program unit can be in a different namespace,
2686 so check for it explicitly. After the statement is accepted,
2687 the name is checked for especially in gfc_get_symbol(). */
2688 if (gfc_new_block != NULL && sym != NULL
2689 && strcmp (sym->name, gfc_new_block->name) == 0)
2691 gfc_error ("Name '%s' at %C is the name of the procedure",
2697 if (gfc_match_char (')') == MATCH_YES)
2700 m = gfc_match_char (',');
2703 gfc_error ("Unexpected junk in formal argument list at %C");
2709 /* Check for duplicate symbols in the formal argument list. */
2712 for (p = head; p->next; p = p->next)
2717 for (q = p->next; q; q = q->next)
2718 if (p->sym == q->sym)
2720 gfc_error ("Duplicate symbol '%s' in formal argument list "
2721 "at %C", p->sym->name);
2729 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2739 gfc_free_formal_arglist (head);
2744 /* Match a RESULT specification following a function declaration or
2745 ENTRY statement. Also matches the end-of-statement. */
2748 match_result (gfc_symbol * function, gfc_symbol **result)
2750 char name[GFC_MAX_SYMBOL_LEN + 1];
2754 if (gfc_match (" result (") != MATCH_YES)
2757 m = gfc_match_name (name);
2761 if (gfc_match (" )%t") != MATCH_YES)
2763 gfc_error ("Unexpected junk following RESULT variable at %C");
2767 if (strcmp (function->name, name) == 0)
2769 gfc_error ("RESULT variable at %C must be different than function name");
2773 if (gfc_get_symbol (name, NULL, &r))
2776 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2777 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2786 /* Match a function declaration. */
2789 gfc_match_function_decl (void)
2791 char name[GFC_MAX_SYMBOL_LEN + 1];
2792 gfc_symbol *sym, *result;
2796 if (gfc_current_state () != COMP_NONE
2797 && gfc_current_state () != COMP_INTERFACE
2798 && gfc_current_state () != COMP_CONTAINS)
2801 gfc_clear_ts (¤t_ts);
2803 old_loc = gfc_current_locus;
2805 m = match_prefix (¤t_ts);
2808 gfc_current_locus = old_loc;
2812 if (gfc_match ("function% %n", name) != MATCH_YES)
2814 gfc_current_locus = old_loc;
2818 if (get_proc_name (name, &sym, false))
2820 gfc_new_block = sym;
2822 m = gfc_match_formal_arglist (sym, 0, 0);
2825 gfc_error ("Expected formal argument list in function "
2826 "definition at %C");
2830 else if (m == MATCH_ERROR)
2835 if (gfc_match_eos () != MATCH_YES)
2837 /* See if a result variable is present. */
2838 m = match_result (sym, &result);
2840 gfc_error ("Unexpected junk after function declaration at %C");
2849 /* Make changes to the symbol. */
2852 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2855 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2856 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2859 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
2860 && !sym->attr.implicit_type)
2862 gfc_error ("Function '%s' at %C already has a type of %s", name,
2863 gfc_basic_typename (sym->ts.type));
2869 sym->ts = current_ts;
2874 result->ts = current_ts;
2875 sym->result = result;
2881 gfc_current_locus = old_loc;
2886 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
2887 pass the name of the entry, rather than the gfc_current_block name, and
2888 to return false upon finding an existing global entry. */
2891 add_global_entry (const char *name, int sub)
2895 s = gfc_get_gsymbol(name);
2898 || (s->type != GSYM_UNKNOWN
2899 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2900 global_used(s, NULL);
2903 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2904 s->where = gfc_current_locus;
2912 /* Match an ENTRY statement. */
2915 gfc_match_entry (void)
2920 char name[GFC_MAX_SYMBOL_LEN + 1];
2921 gfc_compile_state state;
2925 bool module_procedure;
2927 m = gfc_match_name (name);
2931 state = gfc_current_state ();
2932 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2937 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2940 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2942 case COMP_BLOCK_DATA:
2943 gfc_error ("ENTRY statement at %C cannot appear within "
2946 case COMP_INTERFACE:
2947 gfc_error ("ENTRY statement at %C cannot appear within "
2951 gfc_error ("ENTRY statement at %C cannot appear within "
2952 "a DERIVED TYPE block");
2955 gfc_error ("ENTRY statement at %C cannot appear within "
2956 "an IF-THEN block");
2959 gfc_error ("ENTRY statement at %C cannot appear within "
2963 gfc_error ("ENTRY statement at %C cannot appear within "
2967 gfc_error ("ENTRY statement at %C cannot appear within "
2971 gfc_error ("ENTRY statement at %C cannot appear within "
2975 gfc_error ("ENTRY statement at %C cannot appear within "
2976 "a contained subprogram");
2979 gfc_internal_error ("gfc_match_entry(): Bad state");
2984 module_procedure = gfc_current_ns->parent != NULL
2985 && gfc_current_ns->parent->proc_name
2986 && gfc_current_ns->parent->proc_name->attr.flavor
2989 if (gfc_current_ns->parent != NULL
2990 && gfc_current_ns->parent->proc_name
2991 && !module_procedure)
2993 gfc_error("ENTRY statement at %C cannot appear in a "
2994 "contained procedure");
2998 /* Module function entries need special care in get_proc_name
2999 because previous references within the function will have
3000 created symbols attached to the current namespace. */
3001 if (get_proc_name (name, &entry,
3002 gfc_current_ns->parent != NULL
3004 && gfc_current_ns->proc_name->attr.function))
3007 proc = gfc_current_block ();
3009 if (state == COMP_SUBROUTINE)
3011 /* An entry in a subroutine. */
3012 if (!add_global_entry (name, 1))
3015 m = gfc_match_formal_arglist (entry, 0, 1);
3019 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3020 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
3025 /* An entry in a function.
3026 We need to take special care because writing
3031 ENTRY f() RESULT (r)
3033 ENTRY f RESULT (r). */
3034 if (!add_global_entry (name, 0))
3037 old_loc = gfc_current_locus;
3038 if (gfc_match_eos () == MATCH_YES)
3040 gfc_current_locus = old_loc;
3041 /* Match the empty argument list, and add the interface to
3043 m = gfc_match_formal_arglist (entry, 0, 1);
3046 m = gfc_match_formal_arglist (entry, 0, 0);
3053 if (gfc_match_eos () == MATCH_YES)
3055 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3056 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3059 entry->result = entry;
3063 m = match_result (proc, &result);
3065 gfc_syntax_error (ST_ENTRY);
3069 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3070 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3071 || gfc_add_function (&entry->attr, result->name, NULL)
3075 entry->result = result;
3079 if (gfc_match_eos () != MATCH_YES)
3081 gfc_syntax_error (ST_ENTRY);
3085 entry->attr.recursive = proc->attr.recursive;
3086 entry->attr.elemental = proc->attr.elemental;
3087 entry->attr.pure = proc->attr.pure;
3089 el = gfc_get_entry_list ();
3091 el->next = gfc_current_ns->entries;
3092 gfc_current_ns->entries = el;
3094 el->id = el->next->id + 1;
3098 new_st.op = EXEC_ENTRY;
3099 new_st.ext.entry = el;
3105 /* Match a subroutine statement, including optional prefixes. */
3108 gfc_match_subroutine (void)
3110 char name[GFC_MAX_SYMBOL_LEN + 1];
3114 if (gfc_current_state () != COMP_NONE
3115 && gfc_current_state () != COMP_INTERFACE
3116 && gfc_current_state () != COMP_CONTAINS)
3119 m = match_prefix (NULL);
3123 m = gfc_match ("subroutine% %n", name);
3127 if (get_proc_name (name, &sym, false))
3129 gfc_new_block = sym;
3131 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3134 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3137 if (gfc_match_eos () != MATCH_YES)
3139 gfc_syntax_error (ST_SUBROUTINE);
3143 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3150 /* Return nonzero if we're currently compiling a contained procedure. */
3153 contained_procedure (void)
3157 for (s=gfc_state_stack; s; s=s->previous)
3158 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3159 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
3165 /* Set the kind of each enumerator. The kind is selected such that it is
3166 interoperable with the corresponding C enumeration type, making
3167 sure that -fshort-enums is honored. */
3172 enumerator_history *current_history = NULL;
3176 if (max_enum == NULL || enum_history == NULL)
3179 if (!gfc_option.fshort_enums)
3185 kind = gfc_integer_kinds[i++].kind;
3187 while (kind < gfc_c_int_kind
3188 && gfc_check_integer_range (max_enum->initializer->value.integer,
3191 current_history = enum_history;
3192 while (current_history != NULL)
3194 current_history->sym->ts.kind = kind;
3195 current_history = current_history->next;
3200 /* Match any of the various end-block statements. Returns the type of
3201 END to the caller. The END INTERFACE, END IF, END DO and END
3202 SELECT statements cannot be replaced by a single END statement. */
3205 gfc_match_end (gfc_statement *st)
3207 char name[GFC_MAX_SYMBOL_LEN + 1];
3208 gfc_compile_state state;
3210 const char *block_name;
3215 old_loc = gfc_current_locus;
3216 if (gfc_match ("end") != MATCH_YES)
3219 state = gfc_current_state ();
3220 block_name = gfc_current_block () == NULL
3221 ? NULL : gfc_current_block ()->name;
3223 if (state == COMP_CONTAINS)
3225 state = gfc_state_stack->previous->state;
3226 block_name = gfc_state_stack->previous->sym == NULL
3227 ? NULL : gfc_state_stack->previous->sym->name;
3234 *st = ST_END_PROGRAM;
3235 target = " program";
3239 case COMP_SUBROUTINE:
3240 *st = ST_END_SUBROUTINE;
3241 target = " subroutine";
3242 eos_ok = !contained_procedure ();
3246 *st = ST_END_FUNCTION;
3247 target = " function";
3248 eos_ok = !contained_procedure ();
3251 case COMP_BLOCK_DATA:
3252 *st = ST_END_BLOCK_DATA;
3253 target = " block data";
3258 *st = ST_END_MODULE;
3263 case COMP_INTERFACE:
3264 *st = ST_END_INTERFACE;
3265 target = " interface";
3288 *st = ST_END_SELECT;
3294 *st = ST_END_FORALL;
3309 last_initializer = NULL;
3311 gfc_free_enum_history ();
3315 gfc_error ("Unexpected END statement at %C");
3319 if (gfc_match_eos () == MATCH_YES)
3323 /* We would have required END [something] */
3324 gfc_error ("%s statement expected at %L",
3325 gfc_ascii_statement (*st), &old_loc);
3332 /* Verify that we've got the sort of end-block that we're expecting. */
3333 if (gfc_match (target) != MATCH_YES)
3335 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3339 /* If we're at the end, make sure a block name wasn't required. */
3340 if (gfc_match_eos () == MATCH_YES)
3343 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
3344 && *st != ST_END_FORALL && *st != ST_END_WHERE)
3347 if (gfc_current_block () == NULL)
3350 gfc_error ("Expected block name of '%s' in %s statement at %C",
3351 block_name, gfc_ascii_statement (*st));
3356 /* END INTERFACE has a special handler for its several possible endings. */
3357 if (*st == ST_END_INTERFACE)
3358 return gfc_match_end_interface ();
3360 /* We haven't hit the end of statement, so what is left must be an end-name. */
3361 m = gfc_match_space ();
3363 m = gfc_match_name (name);
3366 gfc_error ("Expected terminating name at %C");
3370 if (block_name == NULL)
3373 if (strcmp (name, block_name) != 0)
3375 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3376 gfc_ascii_statement (*st));
3380 if (gfc_match_eos () == MATCH_YES)
3384 gfc_syntax_error (*st);
3387 gfc_current_locus = old_loc;
3393 /***************** Attribute declaration statements ****************/
3395 /* Set the attribute of a single variable. */
3400 char name[GFC_MAX_SYMBOL_LEN + 1];
3408 m = gfc_match_name (name);
3412 if (find_special (name, &sym))
3415 var_locus = gfc_current_locus;
3417 /* Deal with possible array specification for certain attributes. */
3418 if (current_attr.dimension
3419 || current_attr.allocatable
3420 || current_attr.pointer
3421 || current_attr.target)
3423 m = gfc_match_array_spec (&as);
3424 if (m == MATCH_ERROR)
3427 if (current_attr.dimension && m == MATCH_NO)
3429 gfc_error ("Missing array specification at %L in DIMENSION "
3430 "statement", &var_locus);
3435 if ((current_attr.allocatable || current_attr.pointer)
3436 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3438 gfc_error ("Array specification must be deferred at %L", &var_locus);
3444 /* Update symbol table. DIMENSION attribute is set
3445 in gfc_set_array_spec(). */
3446 if (current_attr.dimension == 0
3447 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3453 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3459 if (sym->attr.cray_pointee && sym->as != NULL)
3461 /* Fix the array spec. */
3462 m = gfc_mod_pointee_as (sym->as);
3463 if (m == MATCH_ERROR)
3467 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
3473 if ((current_attr.external || current_attr.intrinsic)
3474 && sym->attr.flavor != FL_PROCEDURE
3475 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3484 gfc_free_array_spec (as);
3489 /* Generic attribute declaration subroutine. Used for attributes that
3490 just have a list of names. */
3497 /* Gobble the optional double colon, by simply ignoring the result
3507 if (gfc_match_eos () == MATCH_YES)
3513 if (gfc_match_char (',') != MATCH_YES)
3515 gfc_error ("Unexpected character in variable list at %C");
3525 /* This routine matches Cray Pointer declarations of the form:
3526 pointer ( <pointer>, <pointee> )
3528 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3529 The pointer, if already declared, should be an integer. Otherwise, we
3530 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3531 be either a scalar, or an array declaration. No space is allocated for
3532 the pointee. For the statement
3533 pointer (ipt, ar(10))
3534 any subsequent uses of ar will be translated (in C-notation) as
3535 ar(i) => ((<type> *) ipt)(i)
3536 After gimplification, pointee variable will disappear in the code. */
3539 cray_pointer_decl (void)
3543 gfc_symbol *cptr; /* Pointer symbol. */
3544 gfc_symbol *cpte; /* Pointee symbol. */
3550 if (gfc_match_char ('(') != MATCH_YES)
3552 gfc_error ("Expected '(' at %C");
3556 /* Match pointer. */
3557 var_locus = gfc_current_locus;
3558 gfc_clear_attr (¤t_attr);
3559 gfc_add_cray_pointer (¤t_attr, &var_locus);
3560 current_ts.type = BT_INTEGER;
3561 current_ts.kind = gfc_index_integer_kind;
3563 m = gfc_match_symbol (&cptr, 0);
3566 gfc_error ("Expected variable name at %C");
3570 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3573 gfc_set_sym_referenced (cptr);
3575 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3577 cptr->ts.type = BT_INTEGER;
3578 cptr->ts.kind = gfc_index_integer_kind;
3580 else if (cptr->ts.type != BT_INTEGER)
3582 gfc_error ("Cray pointer at %C must be an integer");
3585 else if (cptr->ts.kind < gfc_index_integer_kind)
3586 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3587 " memory addresses require %d bytes",
3588 cptr->ts.kind, gfc_index_integer_kind);
3590 if (gfc_match_char (',') != MATCH_YES)
3592 gfc_error ("Expected \",\" at %C");
3596 /* Match Pointee. */
3597 var_locus = gfc_current_locus;
3598 gfc_clear_attr (¤t_attr);
3599 gfc_add_cray_pointee (¤t_attr, &var_locus);
3600 current_ts.type = BT_UNKNOWN;
3601 current_ts.kind = 0;
3603 m = gfc_match_symbol (&cpte, 0);
3606 gfc_error ("Expected variable name at %C");
3610 /* Check for an optional array spec. */
3611 m = gfc_match_array_spec (&as);
3612 if (m == MATCH_ERROR)
3614 gfc_free_array_spec (as);
3617 else if (m == MATCH_NO)
3619 gfc_free_array_spec (as);
3623 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3626 gfc_set_sym_referenced (cpte);
3628 if (cpte->as == NULL)
3630 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3631 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3633 else if (as != NULL)
3635 gfc_error ("Duplicate array spec for Cray pointee at %C");
3636 gfc_free_array_spec (as);
3642 if (cpte->as != NULL)
3644 /* Fix array spec. */
3645 m = gfc_mod_pointee_as (cpte->as);
3646 if (m == MATCH_ERROR)
3650 /* Point the Pointee at the Pointer. */
3651 cpte->cp_pointer = cptr;
3653 if (gfc_match_char (')') != MATCH_YES)
3655 gfc_error ("Expected \")\" at %C");
3658 m = gfc_match_char (',');
3660 done = true; /* Stop searching for more declarations. */
3664 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3665 || gfc_match_eos () != MATCH_YES)
3667 gfc_error ("Expected \",\" or end of statement at %C");
3675 gfc_match_external (void)
3678 gfc_clear_attr (¤t_attr);
3679 current_attr.external = 1;
3681 return attr_decl ();
3686 gfc_match_intent (void)
3690 intent = match_intent_spec ();
3691 if (intent == INTENT_UNKNOWN)
3694 gfc_clear_attr (¤t_attr);
3695 current_attr.intent = intent;
3697 return attr_decl ();
3702 gfc_match_intrinsic (void)
3705 gfc_clear_attr (¤t_attr);
3706 current_attr.intrinsic = 1;
3708 return attr_decl ();
3713 gfc_match_optional (void)
3716 gfc_clear_attr (¤t_attr);
3717 current_attr.optional = 1;
3719 return attr_decl ();
3724 gfc_match_pointer (void)
3726 gfc_gobble_whitespace ();
3727 if (gfc_peek_char () == '(')
3729 if (!gfc_option.flag_cray_pointer)
3731 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3735 return cray_pointer_decl ();
3739 gfc_clear_attr (¤t_attr);
3740 current_attr.pointer = 1;
3742 return attr_decl ();
3748 gfc_match_allocatable (void)
3750 gfc_clear_attr (¤t_attr);
3751 current_attr.allocatable = 1;
3753 return attr_decl ();
3758 gfc_match_dimension (void)
3760 gfc_clear_attr (¤t_attr);
3761 current_attr.dimension = 1;
3763 return attr_decl ();
3768 gfc_match_target (void)
3770 gfc_clear_attr (¤t_attr);
3771 current_attr.target = 1;
3773 return attr_decl ();
3777 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3781 access_attr_decl (gfc_statement st)
3783 char name[GFC_MAX_SYMBOL_LEN + 1];
3784 interface_type type;
3787 gfc_intrinsic_op operator;
3790 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3795 m = gfc_match_generic_spec (&type, name, &operator);
3798 if (m == MATCH_ERROR)
3803 case INTERFACE_NAMELESS:
3806 case INTERFACE_GENERIC:
3807 if (gfc_get_symbol (name, NULL, &sym))
3810 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
3811 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3812 sym->name, NULL) == FAILURE)
3817 case INTERFACE_INTRINSIC_OP:
3818 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3820 gfc_current_ns->operator_access[operator] =
3821 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3825 gfc_error ("Access specification of the %s operator at %C has "
3826 "already been specified", gfc_op2string (operator));
3832 case INTERFACE_USER_OP:
3833 uop = gfc_get_uop (name);
3835 if (uop->access == ACCESS_UNKNOWN)
3837 uop->access = (st == ST_PUBLIC)
3838 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3842 gfc_error ("Access specification of the .%s. operator at %C "
3843 "has already been specified", sym->name);
3850 if (gfc_match_char (',') == MATCH_NO)
3854 if (gfc_match_eos () != MATCH_YES)
3859 gfc_syntax_error (st);
3867 gfc_match_protected (void)
3872 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3874 gfc_error ("PROTECTED at %C only allowed in specification "
3875 "part of a module");
3880 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
3884 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3889 if (gfc_match_eos () == MATCH_YES)
3894 m = gfc_match_symbol (&sym, 0);
3898 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
3911 if (gfc_match_eos () == MATCH_YES)
3913 if (gfc_match_char (',') != MATCH_YES)
3920 gfc_error ("Syntax error in PROTECTED statement at %C");
3925 /* The PRIVATE statement is a bit weird in that it can be a attribute
3926 declaration, but also works as a standlone statement inside of a
3927 type declaration or a module. */
3930 gfc_match_private (gfc_statement *st)
3933 if (gfc_match ("private") != MATCH_YES)
3936 if (gfc_current_state () != COMP_MODULE
3937 && (gfc_current_state () != COMP_DERIVED
3938 || !gfc_state_stack->previous
3939 || gfc_state_stack->previous->state != COMP_MODULE))
3941 gfc_error ("PRIVATE statement at %C is only allowed in the "
3942 "specification part of a module");
3946 if (gfc_current_state () == COMP_DERIVED)
3948 if (gfc_match_eos () == MATCH_YES)
3954 gfc_syntax_error (ST_PRIVATE);
3958 if (gfc_match_eos () == MATCH_YES)
3965 return access_attr_decl (ST_PRIVATE);
3970 gfc_match_public (gfc_statement *st)
3973 if (gfc_match ("public") != MATCH_YES)
3976 if (gfc_current_state () != COMP_MODULE)
3978 gfc_error ("PUBLIC statement at %C is only allowed in the "
3979 "specification part of a module");
3983 if (gfc_match_eos () == MATCH_YES)
3990 return access_attr_decl (ST_PUBLIC);
3994 /* Workhorse for gfc_match_parameter. */
4003 m = gfc_match_symbol (&sym, 0);
4005 gfc_error ("Expected variable name at %C in PARAMETER statement");
4010 if (gfc_match_char ('=') == MATCH_NO)
4012 gfc_error ("Expected = sign in PARAMETER statement at %C");
4016 m = gfc_match_init_expr (&init);
4018 gfc_error ("Expected expression at %C in PARAMETER statement");
4022 if (sym->ts.type == BT_UNKNOWN
4023 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
4029 if (gfc_check_assign_symbol (sym, init) == FAILURE
4030 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
4036 if (sym->ts.type == BT_CHARACTER
4037 && sym->ts.cl != NULL
4038 && sym->ts.cl->length != NULL
4039 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
4040 && init->expr_type == EXPR_CONSTANT
4041 && init->ts.type == BT_CHARACTER
4042 && init->ts.kind == 1)
4043 gfc_set_constant_character_len (
4044 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
4050 gfc_free_expr (init);
4055 /* Match a parameter statement, with the weird syntax that these have. */
4058 gfc_match_parameter (void)
4062 if (gfc_match_char ('(') == MATCH_NO)
4071 if (gfc_match (" )%t") == MATCH_YES)
4074 if (gfc_match_char (',') != MATCH_YES)
4076 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4086 /* Save statements have a special syntax. */
4089 gfc_match_save (void)
4091 char n[GFC_MAX_SYMBOL_LEN+1];
4096 if (gfc_match_eos () == MATCH_YES)
4098 if (gfc_current_ns->seen_save)
4100 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
4101 "follows previous SAVE statement")
4106 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4110 if (gfc_current_ns->save_all)
4112 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
4113 "blanket SAVE statement")
4122 m = gfc_match_symbol (&sym, 0);
4126 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
4138 m = gfc_match (" / %n /", &n);
4139 if (m == MATCH_ERROR)
4144 c = gfc_get_common (n, 0);
4147 gfc_current_ns->seen_save = 1;
4150 if (gfc_match_eos () == MATCH_YES)
4152 if (gfc_match_char (',') != MATCH_YES)
4159 gfc_error ("Syntax error in SAVE statement at %C");
4165 gfc_match_value (void)
4170 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
4174 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4179 if (gfc_match_eos () == MATCH_YES)
4184 m = gfc_match_symbol (&sym, 0);
4188 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
4201 if (gfc_match_eos () == MATCH_YES)
4203 if (gfc_match_char (',') != MATCH_YES)
4210 gfc_error ("Syntax error in VALUE statement at %C");
4215 gfc_match_volatile (void)
4220 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
4224 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4229 if (gfc_match_eos () == MATCH_YES)
4234 /* VOLATILE is special because it can be added to host-associated
4236 m = gfc_match_symbol (&sym, 1);
4240 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
4253 if (gfc_match_eos () == MATCH_YES)
4255 if (gfc_match_char (',') != MATCH_YES)
4262 gfc_error ("Syntax error in VOLATILE statement at %C");
4268 /* Match a module procedure statement. Note that we have to modify
4269 symbols in the parent's namespace because the current one was there
4270 to receive symbols that are in an interface's formal argument list. */
4273 gfc_match_modproc (void)
4275 char name[GFC_MAX_SYMBOL_LEN + 1];
4278 gfc_namespace *module_ns;
4280 if (gfc_state_stack->state != COMP_INTERFACE
4281 || gfc_state_stack->previous == NULL
4282 || current_interface.type == INTERFACE_NAMELESS)
4284 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4289 module_ns = gfc_current_ns->parent;
4290 for (; module_ns; module_ns = module_ns->parent)
4291 if (module_ns->proc_name->attr.flavor == FL_MODULE)
4294 if (module_ns == NULL)
4299 m = gfc_match_name (name);
4305 if (gfc_get_symbol (name, module_ns, &sym))
4308 if (sym->attr.proc != PROC_MODULE
4309 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4310 sym->name, NULL) == FAILURE)
4313 if (gfc_add_interface (sym) == FAILURE)
4316 sym->attr.mod_proc = 1;
4318 if (gfc_match_eos () == MATCH_YES)
4320 if (gfc_match_char (',') != MATCH_YES)
4327 gfc_syntax_error (ST_MODULE_PROC);
4332 /* Match the beginning of a derived type declaration. If a type name
4333 was the result of a function, then it is possible to have a symbol
4334 already to be known as a derived type yet have no components. */
4337 gfc_match_derived_decl (void)
4339 char name[GFC_MAX_SYMBOL_LEN + 1];
4340 symbol_attribute attr;
4344 if (gfc_current_state () == COMP_DERIVED)
4347 gfc_clear_attr (&attr);
4350 if (gfc_match (" , private") == MATCH_YES)
4352 if (gfc_current_state () != COMP_MODULE)
4354 gfc_error ("Derived type at %C can only be PRIVATE in the "
4355 "specification part of a module");
4359 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4364 if (gfc_match (" , public") == MATCH_YES)
4366 if (gfc_current_state () != COMP_MODULE)
4368 gfc_error ("Derived type at %C can only be PUBLIC in the "
4369 "specification part of a module");
4373 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4378 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4380 gfc_error ("Expected :: in TYPE definition at %C");
4384 m = gfc_match (" %n%t", name);
4388 /* Make sure the name isn't the name of an intrinsic type. The
4389 'double {precision,complex}' types don't get past the name
4390 matcher, unless they're written as a single word or in fixed
4392 if (strcmp (name, "integer") == 0
4393 || strcmp (name, "real") == 0
4394 || strcmp (name, "character") == 0
4395 || strcmp (name, "logical") == 0
4396 || strcmp (name, "complex") == 0
4397 || strcmp (name, "doubleprecision") == 0
4398 || strcmp (name, "doublecomplex") == 0)
4400 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4405 if (gfc_get_symbol (name, NULL, &sym))
4408 if (sym->ts.type != BT_UNKNOWN)
4410 gfc_error ("Derived type name '%s' at %C already has a basic type "
4411 "of %s", sym->name, gfc_typename (&sym->ts));
4415 /* The symbol may already have the derived attribute without the
4416 components. The ways this can happen is via a function
4417 definition, an INTRINSIC statement or a subtype in another
4418 derived type that is a pointer. The first part of the AND clause
4419 is true if a the symbol is not the return value of a function. */
4420 if (sym->attr.flavor != FL_DERIVED
4421 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4424 if (sym->components != NULL)
4426 gfc_error ("Derived type definition of '%s' at %C has already been "
4427 "defined", sym->name);
4431 if (attr.access != ACCESS_UNKNOWN
4432 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4435 gfc_new_block = sym;
4441 /* Cray Pointees can be declared as:
4442 pointer (ipt, a (n,m,...,*))
4443 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4444 cheat and set a constant bound of 1 for the last dimension, if this
4445 is the case. Since there is no bounds-checking for Cray Pointees,
4446 this will be okay. */
4449 gfc_mod_pointee_as (gfc_array_spec *as)
4451 as->cray_pointee = true; /* This will be useful to know later. */
4452 if (as->type == AS_ASSUMED_SIZE)
4454 as->type = AS_EXPLICIT;
4455 as->upper[as->rank - 1] = gfc_int_expr (1);
4456 as->cp_was_assumed = true;
4458 else if (as->type == AS_ASSUMED_SHAPE)
4460 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4467 /* Match the enum definition statement, here we are trying to match
4468 the first line of enum definition statement.
4469 Returns MATCH_YES if match is found. */
4472 gfc_match_enum (void)
4476 m = gfc_match_eos ();
4480 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
4488 /* Match a variable name with an optional initializer. When this
4489 subroutine is called, a variable is expected to be parsed next.
4490 Depending on what is happening at the moment, updates either the
4491 symbol table or the current interface. */
4494 enumerator_decl (void)
4496 char name[GFC_MAX_SYMBOL_LEN + 1];
4497 gfc_expr *initializer;
4498 gfc_array_spec *as = NULL;
4506 old_locus = gfc_current_locus;
4508 /* When we get here, we've just matched a list of attributes and
4509 maybe a type and a double colon. The next thing we expect to see
4510 is the name of the symbol. */
4511 m = gfc_match_name (name);
4515 var_locus = gfc_current_locus;
4517 /* OK, we've successfully matched the declaration. Now put the
4518 symbol in the current namespace. If we fail to create the symbol,
4520 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
4526 /* The double colon must be present in order to have initializers.
4527 Otherwise the statement is ambiguous with an assignment statement. */
4530 if (gfc_match_char ('=') == MATCH_YES)
4532 m = gfc_match_init_expr (&initializer);
4535 gfc_error ("Expected an initialization expression at %C");
4544 /* If we do not have an initializer, the initialization value of the
4545 previous enumerator (stored in last_initializer) is incremented
4546 by 1 and is used to initialize the current enumerator. */
4547 if (initializer == NULL)
4548 initializer = gfc_enum_initializer (last_initializer, old_locus);
4550 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
4552 gfc_error("ENUMERATOR %L not initialized with integer expression",
4555 gfc_free_enum_history ();
4559 /* Store this current initializer, for the next enumerator variable
4560 to be parsed. add_init_expr_to_sym() zeros initializer, so we
4561 use last_initializer below. */
4562 last_initializer = initializer;
4563 t = add_init_expr_to_sym (name, &initializer, &var_locus);
4565 /* Maintain enumerator history. */
4566 gfc_find_symbol (name, NULL, 0, &sym);
4567 create_enum_history (sym, last_initializer);
4569 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
4572 /* Free stuff up and return. */
4573 gfc_free_expr (initializer);
4579 /* Match the enumerator definition statement. */
4582 gfc_match_enumerator_def (void)
4587 gfc_clear_ts (¤t_ts);
4589 m = gfc_match (" enumerator");
4593 m = gfc_match (" :: ");
4594 if (m == MATCH_ERROR)
4597 colon_seen = (m == MATCH_YES);
4599 if (gfc_current_state () != COMP_ENUM)
4601 gfc_error ("ENUM definition statement expected before %C");
4602 gfc_free_enum_history ();
4606 (¤t_ts)->type = BT_INTEGER;
4607 (¤t_ts)->kind = gfc_c_int_kind;
4609 gfc_clear_attr (¤t_attr);
4610 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
4619 m = enumerator_decl ();
4620 if (m == MATCH_ERROR)
4625 if (gfc_match_eos () == MATCH_YES)
4627 if (gfc_match_char (',') != MATCH_YES)
4631 if (gfc_current_state () == COMP_ENUM)
4633 gfc_free_enum_history ();
4634 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4639 gfc_free_array_spec (current_as);