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_NONE)
2297 if (d == DECL_ALLOCATABLE)
2299 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2300 "attribute at %C in a TYPE definition")
2309 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2316 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2317 && gfc_current_state () != COMP_MODULE)
2319 if (d == DECL_PRIVATE)
2324 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2332 case DECL_ALLOCATABLE:
2333 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2336 case DECL_DIMENSION:
2337 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2341 t = gfc_add_external (¤t_attr, &seen_at[d]);
2345 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2349 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2353 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2356 case DECL_INTRINSIC:
2357 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2361 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2364 case DECL_PARAMETER:
2365 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2369 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2372 case DECL_PROTECTED:
2373 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2375 gfc_error ("PROTECTED at %C only allowed in specification "
2376 "part of a module");
2381 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2386 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
2390 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2395 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2400 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2404 t = gfc_add_target (¤t_attr, &seen_at[d]);
2408 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2413 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
2417 if (gfc_notify_std (GFC_STD_F2003,
2418 "Fortran 2003: VOLATILE attribute at %C")
2422 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
2426 gfc_internal_error ("match_attr_spec(): Bad attribute");
2440 gfc_current_locus = start;
2441 gfc_free_array_spec (current_as);
2447 /* Match a data declaration statement. */
2450 gfc_match_data_decl (void)
2456 m = match_type_spec (¤t_ts, 0);
2460 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2462 sym = gfc_use_derived (current_ts.derived);
2470 current_ts.derived = sym;
2473 m = match_attr_spec ();
2474 if (m == MATCH_ERROR)
2480 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2483 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2486 gfc_find_symbol (current_ts.derived->name,
2487 current_ts.derived->ns->parent, 1, &sym);
2489 /* Any symbol that we find had better be a type definition
2490 which has its components defined. */
2491 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2492 && current_ts.derived->components != NULL)
2495 /* Now we have an error, which we signal, and then fix up
2496 because the knock-on is plain and simple confusing. */
2497 gfc_error_now ("Derived type at %C has not been previously defined "
2498 "and so cannot appear in a derived type definition");
2499 current_attr.pointer = 1;
2504 /* If we have an old-style character declaration, and no new-style
2505 attribute specifications, then there a comma is optional between
2506 the type specification and the variable list. */
2507 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2508 gfc_match_char (',');
2510 /* Give the types/attributes to symbols that follow. Give the element
2511 a number so that repeat character length expressions can be copied. */
2515 m = variable_decl (elem++);
2516 if (m == MATCH_ERROR)
2521 if (gfc_match_eos () == MATCH_YES)
2523 if (gfc_match_char (',') != MATCH_YES)
2527 if (gfc_error_flag_test () == 0)
2528 gfc_error ("Syntax error in data declaration at %C");
2531 gfc_free_data_all (gfc_current_ns);
2534 gfc_free_array_spec (current_as);
2540 /* Match a prefix associated with a function or subroutine
2541 declaration. If the typespec pointer is nonnull, then a typespec
2542 can be matched. Note that if nothing matches, MATCH_YES is
2543 returned (the null string was matched). */
2546 match_prefix (gfc_typespec *ts)
2550 gfc_clear_attr (¤t_attr);
2554 if (!seen_type && ts != NULL
2555 && match_type_spec (ts, 0) == MATCH_YES
2556 && gfc_match_space () == MATCH_YES)
2563 if (gfc_match ("elemental% ") == MATCH_YES)
2565 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2571 if (gfc_match ("pure% ") == MATCH_YES)
2573 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2579 if (gfc_match ("recursive% ") == MATCH_YES)
2581 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2587 /* At this point, the next item is not a prefix. */
2592 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2595 copy_prefix (symbol_attribute *dest, locus *where)
2597 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2600 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2603 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2610 /* Match a formal argument list. */
2613 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
2615 gfc_formal_arglist *head, *tail, *p, *q;
2616 char name[GFC_MAX_SYMBOL_LEN + 1];
2622 if (gfc_match_char ('(') != MATCH_YES)
2629 if (gfc_match_char (')') == MATCH_YES)
2634 if (gfc_match_char ('*') == MATCH_YES)
2638 m = gfc_match_name (name);
2642 if (gfc_get_symbol (name, NULL, &sym))
2646 p = gfc_get_formal_arglist ();
2658 /* We don't add the VARIABLE flavor because the name could be a
2659 dummy procedure. We don't apply these attributes to formal
2660 arguments of statement functions. */
2661 if (sym != NULL && !st_flag
2662 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2663 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2669 /* The name of a program unit can be in a different namespace,
2670 so check for it explicitly. After the statement is accepted,
2671 the name is checked for especially in gfc_get_symbol(). */
2672 if (gfc_new_block != NULL && sym != NULL
2673 && strcmp (sym->name, gfc_new_block->name) == 0)
2675 gfc_error ("Name '%s' at %C is the name of the procedure",
2681 if (gfc_match_char (')') == MATCH_YES)
2684 m = gfc_match_char (',');
2687 gfc_error ("Unexpected junk in formal argument list at %C");
2693 /* Check for duplicate symbols in the formal argument list. */
2696 for (p = head; p->next; p = p->next)
2701 for (q = p->next; q; q = q->next)
2702 if (p->sym == q->sym)
2704 gfc_error ("Duplicate symbol '%s' in formal argument list "
2705 "at %C", p->sym->name);
2713 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2723 gfc_free_formal_arglist (head);
2728 /* Match a RESULT specification following a function declaration or
2729 ENTRY statement. Also matches the end-of-statement. */
2732 match_result (gfc_symbol * function, gfc_symbol **result)
2734 char name[GFC_MAX_SYMBOL_LEN + 1];
2738 if (gfc_match (" result (") != MATCH_YES)
2741 m = gfc_match_name (name);
2745 if (gfc_match (" )%t") != MATCH_YES)
2747 gfc_error ("Unexpected junk following RESULT variable at %C");
2751 if (strcmp (function->name, name) == 0)
2753 gfc_error ("RESULT variable at %C must be different than function name");
2757 if (gfc_get_symbol (name, NULL, &r))
2760 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2761 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2770 /* Match a function declaration. */
2773 gfc_match_function_decl (void)
2775 char name[GFC_MAX_SYMBOL_LEN + 1];
2776 gfc_symbol *sym, *result;
2780 if (gfc_current_state () != COMP_NONE
2781 && gfc_current_state () != COMP_INTERFACE
2782 && gfc_current_state () != COMP_CONTAINS)
2785 gfc_clear_ts (¤t_ts);
2787 old_loc = gfc_current_locus;
2789 m = match_prefix (¤t_ts);
2792 gfc_current_locus = old_loc;
2796 if (gfc_match ("function% %n", name) != MATCH_YES)
2798 gfc_current_locus = old_loc;
2802 if (get_proc_name (name, &sym, false))
2804 gfc_new_block = sym;
2806 m = gfc_match_formal_arglist (sym, 0, 0);
2809 gfc_error ("Expected formal argument list in function "
2810 "definition at %C");
2814 else if (m == MATCH_ERROR)
2819 if (gfc_match_eos () != MATCH_YES)
2821 /* See if a result variable is present. */
2822 m = match_result (sym, &result);
2824 gfc_error ("Unexpected junk after function declaration at %C");
2833 /* Make changes to the symbol. */
2836 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2839 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2840 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2843 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
2844 && !sym->attr.implicit_type)
2846 gfc_error ("Function '%s' at %C already has a type of %s", name,
2847 gfc_basic_typename (sym->ts.type));
2853 sym->ts = current_ts;
2858 result->ts = current_ts;
2859 sym->result = result;
2865 gfc_current_locus = old_loc;
2870 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
2871 pass the name of the entry, rather than the gfc_current_block name, and
2872 to return false upon finding an existing global entry. */
2875 add_global_entry (const char *name, int sub)
2879 s = gfc_get_gsymbol(name);
2882 || (s->type != GSYM_UNKNOWN
2883 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2884 global_used(s, NULL);
2887 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2888 s->where = gfc_current_locus;
2896 /* Match an ENTRY statement. */
2899 gfc_match_entry (void)
2904 char name[GFC_MAX_SYMBOL_LEN + 1];
2905 gfc_compile_state state;
2909 bool module_procedure;
2911 m = gfc_match_name (name);
2915 state = gfc_current_state ();
2916 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2921 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2924 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2926 case COMP_BLOCK_DATA:
2927 gfc_error ("ENTRY statement at %C cannot appear within "
2930 case COMP_INTERFACE:
2931 gfc_error ("ENTRY statement at %C cannot appear within "
2935 gfc_error ("ENTRY statement at %C cannot appear within "
2936 "a DERIVED TYPE block");
2939 gfc_error ("ENTRY statement at %C cannot appear within "
2940 "an IF-THEN block");
2943 gfc_error ("ENTRY statement at %C cannot appear within "
2947 gfc_error ("ENTRY statement at %C cannot appear within "
2951 gfc_error ("ENTRY statement at %C cannot appear within "
2955 gfc_error ("ENTRY statement at %C cannot appear within "
2959 gfc_error ("ENTRY statement at %C cannot appear within "
2960 "a contained subprogram");
2963 gfc_internal_error ("gfc_match_entry(): Bad state");
2968 module_procedure = gfc_current_ns->parent != NULL
2969 && gfc_current_ns->parent->proc_name
2970 && gfc_current_ns->parent->proc_name->attr.flavor
2973 if (gfc_current_ns->parent != NULL
2974 && gfc_current_ns->parent->proc_name
2975 && !module_procedure)
2977 gfc_error("ENTRY statement at %C cannot appear in a "
2978 "contained procedure");
2982 /* Module function entries need special care in get_proc_name
2983 because previous references within the function will have
2984 created symbols attached to the current namespace. */
2985 if (get_proc_name (name, &entry,
2986 gfc_current_ns->parent != NULL
2988 && gfc_current_ns->proc_name->attr.function))
2991 proc = gfc_current_block ();
2993 if (state == COMP_SUBROUTINE)
2995 /* An entry in a subroutine. */
2996 if (!add_global_entry (name, 1))
2999 m = gfc_match_formal_arglist (entry, 0, 1);
3003 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3004 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
3009 /* An entry in a function.
3010 We need to take special care because writing
3015 ENTRY f() RESULT (r)
3017 ENTRY f RESULT (r). */
3018 if (!add_global_entry (name, 0))
3021 old_loc = gfc_current_locus;
3022 if (gfc_match_eos () == MATCH_YES)
3024 gfc_current_locus = old_loc;
3025 /* Match the empty argument list, and add the interface to
3027 m = gfc_match_formal_arglist (entry, 0, 1);
3030 m = gfc_match_formal_arglist (entry, 0, 0);
3037 if (gfc_match_eos () == MATCH_YES)
3039 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3040 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3043 entry->result = entry;
3047 m = match_result (proc, &result);
3049 gfc_syntax_error (ST_ENTRY);
3053 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3054 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3055 || gfc_add_function (&entry->attr, result->name, NULL)
3059 entry->result = result;
3063 if (gfc_match_eos () != MATCH_YES)
3065 gfc_syntax_error (ST_ENTRY);
3069 entry->attr.recursive = proc->attr.recursive;
3070 entry->attr.elemental = proc->attr.elemental;
3071 entry->attr.pure = proc->attr.pure;
3073 el = gfc_get_entry_list ();
3075 el->next = gfc_current_ns->entries;
3076 gfc_current_ns->entries = el;
3078 el->id = el->next->id + 1;
3082 new_st.op = EXEC_ENTRY;
3083 new_st.ext.entry = el;
3089 /* Match a subroutine statement, including optional prefixes. */
3092 gfc_match_subroutine (void)
3094 char name[GFC_MAX_SYMBOL_LEN + 1];
3098 if (gfc_current_state () != COMP_NONE
3099 && gfc_current_state () != COMP_INTERFACE
3100 && gfc_current_state () != COMP_CONTAINS)
3103 m = match_prefix (NULL);
3107 m = gfc_match ("subroutine% %n", name);
3111 if (get_proc_name (name, &sym, false))
3113 gfc_new_block = sym;
3115 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3118 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3121 if (gfc_match_eos () != MATCH_YES)
3123 gfc_syntax_error (ST_SUBROUTINE);
3127 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3134 /* Return nonzero if we're currently compiling a contained procedure. */
3137 contained_procedure (void)
3141 for (s=gfc_state_stack; s; s=s->previous)
3142 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3143 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
3149 /* Set the kind of each enumerator. The kind is selected such that it is
3150 interoperable with the corresponding C enumeration type, making
3151 sure that -fshort-enums is honored. */
3156 enumerator_history *current_history = NULL;
3160 if (max_enum == NULL || enum_history == NULL)
3163 if (!gfc_option.fshort_enums)
3169 kind = gfc_integer_kinds[i++].kind;
3171 while (kind < gfc_c_int_kind
3172 && gfc_check_integer_range (max_enum->initializer->value.integer,
3175 current_history = enum_history;
3176 while (current_history != NULL)
3178 current_history->sym->ts.kind = kind;
3179 current_history = current_history->next;
3184 /* Match any of the various end-block statements. Returns the type of
3185 END to the caller. The END INTERFACE, END IF, END DO and END
3186 SELECT statements cannot be replaced by a single END statement. */
3189 gfc_match_end (gfc_statement *st)
3191 char name[GFC_MAX_SYMBOL_LEN + 1];
3192 gfc_compile_state state;
3194 const char *block_name;
3199 old_loc = gfc_current_locus;
3200 if (gfc_match ("end") != MATCH_YES)
3203 state = gfc_current_state ();
3204 block_name = gfc_current_block () == NULL
3205 ? NULL : gfc_current_block ()->name;
3207 if (state == COMP_CONTAINS)
3209 state = gfc_state_stack->previous->state;
3210 block_name = gfc_state_stack->previous->sym == NULL
3211 ? NULL : gfc_state_stack->previous->sym->name;
3218 *st = ST_END_PROGRAM;
3219 target = " program";
3223 case COMP_SUBROUTINE:
3224 *st = ST_END_SUBROUTINE;
3225 target = " subroutine";
3226 eos_ok = !contained_procedure ();
3230 *st = ST_END_FUNCTION;
3231 target = " function";
3232 eos_ok = !contained_procedure ();
3235 case COMP_BLOCK_DATA:
3236 *st = ST_END_BLOCK_DATA;
3237 target = " block data";
3242 *st = ST_END_MODULE;
3247 case COMP_INTERFACE:
3248 *st = ST_END_INTERFACE;
3249 target = " interface";
3272 *st = ST_END_SELECT;
3278 *st = ST_END_FORALL;
3293 last_initializer = NULL;
3295 gfc_free_enum_history ();
3299 gfc_error ("Unexpected END statement at %C");
3303 if (gfc_match_eos () == MATCH_YES)
3307 /* We would have required END [something] */
3308 gfc_error ("%s statement expected at %L",
3309 gfc_ascii_statement (*st), &old_loc);
3316 /* Verify that we've got the sort of end-block that we're expecting. */
3317 if (gfc_match (target) != MATCH_YES)
3319 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3323 /* If we're at the end, make sure a block name wasn't required. */
3324 if (gfc_match_eos () == MATCH_YES)
3327 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3330 if (gfc_current_block () == NULL)
3333 gfc_error ("Expected block name of '%s' in %s statement at %C",
3334 block_name, gfc_ascii_statement (*st));
3339 /* END INTERFACE has a special handler for its several possible endings. */
3340 if (*st == ST_END_INTERFACE)
3341 return gfc_match_end_interface ();
3343 /* We haven't hit the end of statement, so what is left must be an end-name. */
3344 m = gfc_match_space ();
3346 m = gfc_match_name (name);
3349 gfc_error ("Expected terminating name at %C");
3353 if (block_name == NULL)
3356 if (strcmp (name, block_name) != 0)
3358 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3359 gfc_ascii_statement (*st));
3363 if (gfc_match_eos () == MATCH_YES)
3367 gfc_syntax_error (*st);
3370 gfc_current_locus = old_loc;
3376 /***************** Attribute declaration statements ****************/
3378 /* Set the attribute of a single variable. */
3383 char name[GFC_MAX_SYMBOL_LEN + 1];
3391 m = gfc_match_name (name);
3395 if (find_special (name, &sym))
3398 var_locus = gfc_current_locus;
3400 /* Deal with possible array specification for certain attributes. */
3401 if (current_attr.dimension
3402 || current_attr.allocatable
3403 || current_attr.pointer
3404 || current_attr.target)
3406 m = gfc_match_array_spec (&as);
3407 if (m == MATCH_ERROR)
3410 if (current_attr.dimension && m == MATCH_NO)
3412 gfc_error ("Missing array specification at %L in DIMENSION "
3413 "statement", &var_locus);
3418 if ((current_attr.allocatable || current_attr.pointer)
3419 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3421 gfc_error ("Array specification must be deferred at %L", &var_locus);
3427 /* Update symbol table. DIMENSION attribute is set
3428 in gfc_set_array_spec(). */
3429 if (current_attr.dimension == 0
3430 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3436 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3442 if (sym->attr.cray_pointee && sym->as != NULL)
3444 /* Fix the array spec. */
3445 m = gfc_mod_pointee_as (sym->as);
3446 if (m == MATCH_ERROR)
3450 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
3456 if ((current_attr.external || current_attr.intrinsic)
3457 && sym->attr.flavor != FL_PROCEDURE
3458 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3467 gfc_free_array_spec (as);
3472 /* Generic attribute declaration subroutine. Used for attributes that
3473 just have a list of names. */
3480 /* Gobble the optional double colon, by simply ignoring the result
3490 if (gfc_match_eos () == MATCH_YES)
3496 if (gfc_match_char (',') != MATCH_YES)
3498 gfc_error ("Unexpected character in variable list at %C");
3508 /* This routine matches Cray Pointer declarations of the form:
3509 pointer ( <pointer>, <pointee> )
3511 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3512 The pointer, if already declared, should be an integer. Otherwise, we
3513 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3514 be either a scalar, or an array declaration. No space is allocated for
3515 the pointee. For the statement
3516 pointer (ipt, ar(10))
3517 any subsequent uses of ar will be translated (in C-notation) as
3518 ar(i) => ((<type> *) ipt)(i)
3519 After gimplification, pointee variable will disappear in the code. */
3522 cray_pointer_decl (void)
3526 gfc_symbol *cptr; /* Pointer symbol. */
3527 gfc_symbol *cpte; /* Pointee symbol. */
3533 if (gfc_match_char ('(') != MATCH_YES)
3535 gfc_error ("Expected '(' at %C");
3539 /* Match pointer. */
3540 var_locus = gfc_current_locus;
3541 gfc_clear_attr (¤t_attr);
3542 gfc_add_cray_pointer (¤t_attr, &var_locus);
3543 current_ts.type = BT_INTEGER;
3544 current_ts.kind = gfc_index_integer_kind;
3546 m = gfc_match_symbol (&cptr, 0);
3549 gfc_error ("Expected variable name at %C");
3553 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3556 gfc_set_sym_referenced (cptr);
3558 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3560 cptr->ts.type = BT_INTEGER;
3561 cptr->ts.kind = gfc_index_integer_kind;
3563 else if (cptr->ts.type != BT_INTEGER)
3565 gfc_error ("Cray pointer at %C must be an integer");
3568 else if (cptr->ts.kind < gfc_index_integer_kind)
3569 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3570 " memory addresses require %d bytes",
3571 cptr->ts.kind, gfc_index_integer_kind);
3573 if (gfc_match_char (',') != MATCH_YES)
3575 gfc_error ("Expected \",\" at %C");
3579 /* Match Pointee. */
3580 var_locus = gfc_current_locus;
3581 gfc_clear_attr (¤t_attr);
3582 gfc_add_cray_pointee (¤t_attr, &var_locus);
3583 current_ts.type = BT_UNKNOWN;
3584 current_ts.kind = 0;
3586 m = gfc_match_symbol (&cpte, 0);
3589 gfc_error ("Expected variable name at %C");
3593 /* Check for an optional array spec. */
3594 m = gfc_match_array_spec (&as);
3595 if (m == MATCH_ERROR)
3597 gfc_free_array_spec (as);
3600 else if (m == MATCH_NO)
3602 gfc_free_array_spec (as);
3606 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3609 gfc_set_sym_referenced (cpte);
3611 if (cpte->as == NULL)
3613 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3614 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3616 else if (as != NULL)
3618 gfc_error ("Duplicate array spec for Cray pointee at %C");
3619 gfc_free_array_spec (as);
3625 if (cpte->as != NULL)
3627 /* Fix array spec. */
3628 m = gfc_mod_pointee_as (cpte->as);
3629 if (m == MATCH_ERROR)
3633 /* Point the Pointee at the Pointer. */
3634 cpte->cp_pointer = cptr;
3636 if (gfc_match_char (')') != MATCH_YES)
3638 gfc_error ("Expected \")\" at %C");
3641 m = gfc_match_char (',');
3643 done = true; /* Stop searching for more declarations. */
3647 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3648 || gfc_match_eos () != MATCH_YES)
3650 gfc_error ("Expected \",\" or end of statement at %C");
3658 gfc_match_external (void)
3661 gfc_clear_attr (¤t_attr);
3662 current_attr.external = 1;
3664 return attr_decl ();
3669 gfc_match_intent (void)
3673 intent = match_intent_spec ();
3674 if (intent == INTENT_UNKNOWN)
3677 gfc_clear_attr (¤t_attr);
3678 current_attr.intent = intent;
3680 return attr_decl ();
3685 gfc_match_intrinsic (void)
3688 gfc_clear_attr (¤t_attr);
3689 current_attr.intrinsic = 1;
3691 return attr_decl ();
3696 gfc_match_optional (void)
3699 gfc_clear_attr (¤t_attr);
3700 current_attr.optional = 1;
3702 return attr_decl ();
3707 gfc_match_pointer (void)
3709 gfc_gobble_whitespace ();
3710 if (gfc_peek_char () == '(')
3712 if (!gfc_option.flag_cray_pointer)
3714 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3718 return cray_pointer_decl ();
3722 gfc_clear_attr (¤t_attr);
3723 current_attr.pointer = 1;
3725 return attr_decl ();
3731 gfc_match_allocatable (void)
3733 gfc_clear_attr (¤t_attr);
3734 current_attr.allocatable = 1;
3736 return attr_decl ();
3741 gfc_match_dimension (void)
3743 gfc_clear_attr (¤t_attr);
3744 current_attr.dimension = 1;
3746 return attr_decl ();
3751 gfc_match_target (void)
3753 gfc_clear_attr (¤t_attr);
3754 current_attr.target = 1;
3756 return attr_decl ();
3760 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3764 access_attr_decl (gfc_statement st)
3766 char name[GFC_MAX_SYMBOL_LEN + 1];
3767 interface_type type;
3770 gfc_intrinsic_op operator;
3773 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3778 m = gfc_match_generic_spec (&type, name, &operator);
3781 if (m == MATCH_ERROR)
3786 case INTERFACE_NAMELESS:
3789 case INTERFACE_GENERIC:
3790 if (gfc_get_symbol (name, NULL, &sym))
3793 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
3794 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3795 sym->name, NULL) == FAILURE)
3800 case INTERFACE_INTRINSIC_OP:
3801 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3803 gfc_current_ns->operator_access[operator] =
3804 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3808 gfc_error ("Access specification of the %s operator at %C has "
3809 "already been specified", gfc_op2string (operator));
3815 case INTERFACE_USER_OP:
3816 uop = gfc_get_uop (name);
3818 if (uop->access == ACCESS_UNKNOWN)
3820 uop->access = (st == ST_PUBLIC)
3821 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3825 gfc_error ("Access specification of the .%s. operator at %C "
3826 "has already been specified", sym->name);
3833 if (gfc_match_char (',') == MATCH_NO)
3837 if (gfc_match_eos () != MATCH_YES)
3842 gfc_syntax_error (st);
3850 gfc_match_protected (void)
3855 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3857 gfc_error ("PROTECTED at %C only allowed in specification "
3858 "part of a module");
3863 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
3867 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3872 if (gfc_match_eos () == MATCH_YES)
3877 m = gfc_match_symbol (&sym, 0);
3881 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
3894 if (gfc_match_eos () == MATCH_YES)
3896 if (gfc_match_char (',') != MATCH_YES)
3903 gfc_error ("Syntax error in PROTECTED statement at %C");
3908 /* The PRIVATE statement is a bit weird in that it can be a attribute
3909 declaration, but also works as a standlone statement inside of a
3910 type declaration or a module. */
3913 gfc_match_private (gfc_statement *st)
3916 if (gfc_match ("private") != MATCH_YES)
3919 if (gfc_current_state () == COMP_DERIVED)
3921 if (gfc_match_eos () == MATCH_YES)
3927 gfc_syntax_error (ST_PRIVATE);
3931 if (gfc_match_eos () == MATCH_YES)
3938 return access_attr_decl (ST_PRIVATE);
3943 gfc_match_public (gfc_statement *st)
3946 if (gfc_match ("public") != MATCH_YES)
3949 if (gfc_match_eos () == MATCH_YES)
3956 return access_attr_decl (ST_PUBLIC);
3960 /* Workhorse for gfc_match_parameter. */
3969 m = gfc_match_symbol (&sym, 0);
3971 gfc_error ("Expected variable name at %C in PARAMETER statement");
3976 if (gfc_match_char ('=') == MATCH_NO)
3978 gfc_error ("Expected = sign in PARAMETER statement at %C");
3982 m = gfc_match_init_expr (&init);
3984 gfc_error ("Expected expression at %C in PARAMETER statement");
3988 if (sym->ts.type == BT_UNKNOWN
3989 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3995 if (gfc_check_assign_symbol (sym, init) == FAILURE
3996 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
4002 if (sym->ts.type == BT_CHARACTER
4003 && sym->ts.cl != NULL
4004 && sym->ts.cl->length != NULL
4005 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
4006 && init->expr_type == EXPR_CONSTANT
4007 && init->ts.type == BT_CHARACTER
4008 && init->ts.kind == 1)
4009 gfc_set_constant_character_len (
4010 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
4016 gfc_free_expr (init);
4021 /* Match a parameter statement, with the weird syntax that these have. */
4024 gfc_match_parameter (void)
4028 if (gfc_match_char ('(') == MATCH_NO)
4037 if (gfc_match (" )%t") == MATCH_YES)
4040 if (gfc_match_char (',') != MATCH_YES)
4042 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4052 /* Save statements have a special syntax. */
4055 gfc_match_save (void)
4057 char n[GFC_MAX_SYMBOL_LEN+1];
4062 if (gfc_match_eos () == MATCH_YES)
4064 if (gfc_current_ns->seen_save)
4066 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
4067 "follows previous SAVE statement")
4072 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4076 if (gfc_current_ns->save_all)
4078 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
4079 "blanket SAVE statement")
4088 m = gfc_match_symbol (&sym, 0);
4092 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
4104 m = gfc_match (" / %n /", &n);
4105 if (m == MATCH_ERROR)
4110 c = gfc_get_common (n, 0);
4113 gfc_current_ns->seen_save = 1;
4116 if (gfc_match_eos () == MATCH_YES)
4118 if (gfc_match_char (',') != MATCH_YES)
4125 gfc_error ("Syntax error in SAVE statement at %C");
4131 gfc_match_value (void)
4136 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
4140 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4145 if (gfc_match_eos () == MATCH_YES)
4150 m = gfc_match_symbol (&sym, 0);
4154 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
4167 if (gfc_match_eos () == MATCH_YES)
4169 if (gfc_match_char (',') != MATCH_YES)
4176 gfc_error ("Syntax error in VALUE statement at %C");
4181 gfc_match_volatile (void)
4186 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
4190 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4195 if (gfc_match_eos () == MATCH_YES)
4200 /* VOLATILE is special because it can be added to host-associated
4202 m = gfc_match_symbol (&sym, 1);
4206 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
4219 if (gfc_match_eos () == MATCH_YES)
4221 if (gfc_match_char (',') != MATCH_YES)
4228 gfc_error ("Syntax error in VOLATILE statement at %C");
4234 /* Match a module procedure statement. Note that we have to modify
4235 symbols in the parent's namespace because the current one was there
4236 to receive symbols that are in an interface's formal argument list. */
4239 gfc_match_modproc (void)
4241 char name[GFC_MAX_SYMBOL_LEN + 1];
4245 if (gfc_state_stack->state != COMP_INTERFACE
4246 || gfc_state_stack->previous == NULL
4247 || current_interface.type == INTERFACE_NAMELESS)
4249 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4256 m = gfc_match_name (name);
4262 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4265 if (sym->attr.proc != PROC_MODULE
4266 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4267 sym->name, NULL) == FAILURE)
4270 if (gfc_add_interface (sym) == FAILURE)
4273 sym->attr.mod_proc = 1;
4275 if (gfc_match_eos () == MATCH_YES)
4277 if (gfc_match_char (',') != MATCH_YES)
4284 gfc_syntax_error (ST_MODULE_PROC);
4289 /* Match the beginning of a derived type declaration. If a type name
4290 was the result of a function, then it is possible to have a symbol
4291 already to be known as a derived type yet have no components. */
4294 gfc_match_derived_decl (void)
4296 char name[GFC_MAX_SYMBOL_LEN + 1];
4297 symbol_attribute attr;
4301 if (gfc_current_state () == COMP_DERIVED)
4304 gfc_clear_attr (&attr);
4307 if (gfc_match (" , private") == MATCH_YES)
4309 if (gfc_find_state (COMP_MODULE) == FAILURE)
4311 gfc_error ("Derived type at %C can only be PRIVATE within a MODULE");
4315 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4320 if (gfc_match (" , public") == MATCH_YES)
4322 if (gfc_find_state (COMP_MODULE) == FAILURE)
4324 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4328 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4333 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4335 gfc_error ("Expected :: in TYPE definition at %C");
4339 m = gfc_match (" %n%t", name);
4343 /* Make sure the name isn't the name of an intrinsic type. The
4344 'double {precision,complex}' types don't get past the name
4345 matcher, unless they're written as a single word or in fixed
4347 if (strcmp (name, "integer") == 0
4348 || strcmp (name, "real") == 0
4349 || strcmp (name, "character") == 0
4350 || strcmp (name, "logical") == 0
4351 || strcmp (name, "complex") == 0
4352 || strcmp (name, "doubleprecision") == 0
4353 || strcmp (name, "doublecomplex") == 0)
4355 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4360 if (gfc_get_symbol (name, NULL, &sym))
4363 if (sym->ts.type != BT_UNKNOWN)
4365 gfc_error ("Derived type name '%s' at %C already has a basic type "
4366 "of %s", sym->name, gfc_typename (&sym->ts));
4370 /* The symbol may already have the derived attribute without the
4371 components. The ways this can happen is via a function
4372 definition, an INTRINSIC statement or a subtype in another
4373 derived type that is a pointer. The first part of the AND clause
4374 is true if a the symbol is not the return value of a function. */
4375 if (sym->attr.flavor != FL_DERIVED
4376 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4379 if (sym->components != NULL)
4381 gfc_error ("Derived type definition of '%s' at %C has already been "
4382 "defined", sym->name);
4386 if (attr.access != ACCESS_UNKNOWN
4387 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4390 gfc_new_block = sym;
4396 /* Cray Pointees can be declared as:
4397 pointer (ipt, a (n,m,...,*))
4398 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4399 cheat and set a constant bound of 1 for the last dimension, if this
4400 is the case. Since there is no bounds-checking for Cray Pointees,
4401 this will be okay. */
4404 gfc_mod_pointee_as (gfc_array_spec *as)
4406 as->cray_pointee = true; /* This will be useful to know later. */
4407 if (as->type == AS_ASSUMED_SIZE)
4409 as->type = AS_EXPLICIT;
4410 as->upper[as->rank - 1] = gfc_int_expr (1);
4411 as->cp_was_assumed = true;
4413 else if (as->type == AS_ASSUMED_SHAPE)
4415 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4422 /* Match the enum definition statement, here we are trying to match
4423 the first line of enum definition statement.
4424 Returns MATCH_YES if match is found. */
4427 gfc_match_enum (void)
4431 m = gfc_match_eos ();
4435 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
4443 /* Match a variable name with an optional initializer. When this
4444 subroutine is called, a variable is expected to be parsed next.
4445 Depending on what is happening at the moment, updates either the
4446 symbol table or the current interface. */
4449 enumerator_decl (void)
4451 char name[GFC_MAX_SYMBOL_LEN + 1];
4452 gfc_expr *initializer;
4453 gfc_array_spec *as = NULL;
4461 old_locus = gfc_current_locus;
4463 /* When we get here, we've just matched a list of attributes and
4464 maybe a type and a double colon. The next thing we expect to see
4465 is the name of the symbol. */
4466 m = gfc_match_name (name);
4470 var_locus = gfc_current_locus;
4472 /* OK, we've successfully matched the declaration. Now put the
4473 symbol in the current namespace. If we fail to create the symbol,
4475 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
4481 /* The double colon must be present in order to have initializers.
4482 Otherwise the statement is ambiguous with an assignment statement. */
4485 if (gfc_match_char ('=') == MATCH_YES)
4487 m = gfc_match_init_expr (&initializer);
4490 gfc_error ("Expected an initialization expression at %C");
4499 /* If we do not have an initializer, the initialization value of the
4500 previous enumerator (stored in last_initializer) is incremented
4501 by 1 and is used to initialize the current enumerator. */
4502 if (initializer == NULL)
4503 initializer = gfc_enum_initializer (last_initializer, old_locus);
4505 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
4507 gfc_error("ENUMERATOR %L not initialized with integer expression",
4510 gfc_free_enum_history ();
4514 /* Store this current initializer, for the next enumerator variable
4515 to be parsed. add_init_expr_to_sym() zeros initializer, so we
4516 use last_initializer below. */
4517 last_initializer = initializer;
4518 t = add_init_expr_to_sym (name, &initializer, &var_locus);
4520 /* Maintain enumerator history. */
4521 gfc_find_symbol (name, NULL, 0, &sym);
4522 create_enum_history (sym, last_initializer);
4524 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
4527 /* Free stuff up and return. */
4528 gfc_free_expr (initializer);
4534 /* Match the enumerator definition statement. */
4537 gfc_match_enumerator_def (void)
4542 gfc_clear_ts (¤t_ts);
4544 m = gfc_match (" enumerator");
4548 m = gfc_match (" :: ");
4549 if (m == MATCH_ERROR)
4552 colon_seen = (m == MATCH_YES);
4554 if (gfc_current_state () != COMP_ENUM)
4556 gfc_error ("ENUM definition statement expected before %C");
4557 gfc_free_enum_history ();
4561 (¤t_ts)->type = BT_INTEGER;
4562 (¤t_ts)->kind = gfc_c_int_kind;
4564 gfc_clear_attr (¤t_attr);
4565 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
4574 m = enumerator_decl ();
4575 if (m == MATCH_ERROR)
4580 if (gfc_match_eos () == MATCH_YES)
4582 if (gfc_match_char (',') != MATCH_YES)
4586 if (gfc_current_state () == COMP_ENUM)
4588 gfc_free_enum_history ();
4589 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4594 gfc_free_array_spec (current_as);