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];
305 m = gfc_match_literal_constant (&expr, 1);
312 if (m == MATCH_ERROR)
315 m = gfc_match_null (result);
319 m = gfc_match_name (name);
323 if (gfc_find_symbol (name, NULL, 1, &sym))
327 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
329 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
333 else if (sym->attr.flavor == FL_DERIVED)
334 return gfc_match_structure_constructor (sym, result);
336 *result = gfc_copy_expr (sym->value);
341 /* Match a list of values in a DATA statement. The leading '/' has
342 already been seen at this point. */
345 top_val_list (gfc_data *data)
347 gfc_data_value *new, *tail;
356 m = match_data_constant (&expr);
359 if (m == MATCH_ERROR)
362 new = gfc_get_data_value ();
371 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
379 msg = gfc_extract_int (expr, &tmp);
380 gfc_free_expr (expr);
388 m = match_data_constant (&tail->expr);
391 if (m == MATCH_ERROR)
395 if (gfc_match_char ('/') == MATCH_YES)
397 if (gfc_match_char (',') == MATCH_NO)
404 gfc_syntax_error (ST_DATA);
405 gfc_free_data_all (gfc_current_ns);
410 /* Matches an old style initialization. */
413 match_old_style_init (const char *name)
420 /* Set up data structure to hold initializers. */
421 gfc_find_sym_tree (name, NULL, 0, &st);
424 newdata = gfc_get_data ();
425 newdata->var = gfc_get_data_variable ();
426 newdata->var->expr = gfc_get_variable_expr (st);
427 newdata->where = gfc_current_locus;
429 /* Match initial value list. This also eats the terminal
431 m = top_val_list (newdata);
440 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
445 /* Mark the variable as having appeared in a data statement. */
446 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
452 /* Chain in namespace list of DATA initializers. */
453 newdata->next = gfc_current_ns->data;
454 gfc_current_ns->data = newdata;
460 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
461 we are matching a DATA statement and are therefore issuing an error
462 if we encounter something unexpected, if not, we're trying to match
463 an old-style initialization expression of the form INTEGER I /2/. */
466 gfc_match_data (void)
471 gfc_set_in_match_data (true);
475 new = gfc_get_data ();
476 new->where = gfc_current_locus;
478 m = top_var_list (new);
482 m = top_val_list (new);
486 new->next = gfc_current_ns->data;
487 gfc_current_ns->data = new;
489 if (gfc_match_eos () == MATCH_YES)
492 gfc_match_char (','); /* Optional comma */
495 gfc_set_in_match_data (false);
499 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
506 gfc_set_in_match_data (false);
512 /************************ Declaration statements *********************/
514 /* Match an intent specification. Since this can only happen after an
515 INTENT word, a legal intent-spec must follow. */
518 match_intent_spec (void)
521 if (gfc_match (" ( in out )") == MATCH_YES)
523 if (gfc_match (" ( in )") == MATCH_YES)
525 if (gfc_match (" ( out )") == MATCH_YES)
528 gfc_error ("Bad INTENT specification at %C");
529 return INTENT_UNKNOWN;
533 /* Matches a character length specification, which is either a
534 specification expression or a '*'. */
537 char_len_param_value (gfc_expr **expr)
539 if (gfc_match_char ('*') == MATCH_YES)
545 return gfc_match_expr (expr);
549 /* A character length is a '*' followed by a literal integer or a
550 char_len_param_value in parenthesis. */
553 match_char_length (gfc_expr **expr)
558 m = gfc_match_char ('*');
562 m = gfc_match_small_literal_int (&length, NULL);
563 if (m == MATCH_ERROR)
568 *expr = gfc_int_expr (length);
572 if (gfc_match_char ('(') == MATCH_NO)
575 m = char_len_param_value (expr);
576 if (m == MATCH_ERROR)
581 if (gfc_match_char (')') == MATCH_NO)
583 gfc_free_expr (*expr);
591 gfc_error ("Syntax error in character length specification at %C");
596 /* Special subroutine for finding a symbol. Check if the name is found
597 in the current name space. If not, and we're compiling a function or
598 subroutine and the parent compilation unit is an interface, then check
599 to see if the name we've been given is the name of the interface
600 (located in another namespace). */
603 find_special (const char *name, gfc_symbol **result)
608 i = gfc_get_symbol (name, NULL, result);
612 if (gfc_current_state () != COMP_SUBROUTINE
613 && gfc_current_state () != COMP_FUNCTION)
616 s = gfc_state_stack->previous;
620 if (s->state != COMP_INTERFACE)
623 goto end; /* Nameless interface */
625 if (strcmp (name, s->sym->name) == 0)
636 /* Special subroutine for getting a symbol node associated with a
637 procedure name, used in SUBROUTINE and FUNCTION statements. The
638 symbol is created in the parent using with symtree node in the
639 child unit pointing to the symbol. If the current namespace has no
640 parent, then the symbol is just created in the current unit. */
643 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
649 /* Module functions have to be left in their own namespace because
650 they have potentially (almost certainly!) already been referenced.
651 In this sense, they are rather like external functions. This is
652 fixed up in resolve.c(resolve_entries), where the symbol name-
653 space is set to point to the master function, so that the fake
654 result mechanism can work. */
655 if (module_fcn_entry)
656 rc = gfc_get_symbol (name, NULL, result);
658 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
661 gfc_current_ns->refs++;
663 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
665 /* Trap another encompassed procedure with the same name. All
666 these conditions are necessary to avoid picking up an entry
667 whose name clashes with that of the encompassing procedure;
668 this is handled using gsymbols to register unique,globally
670 if (sym->attr.flavor != 0
671 && sym->attr.proc != 0
672 && (sym->attr.subroutine || sym->attr.function)
673 && sym->attr.if_source != IFSRC_UNKNOWN)
674 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
675 name, &sym->declared_at);
677 /* Trap declarations of attributes in encompassing scope. The
678 signature for this is that ts.kind is set. Legitimate
679 references only set ts.type. */
680 if (sym->ts.kind != 0
681 && !sym->attr.implicit_type
682 && sym->attr.proc == 0
683 && gfc_current_ns->parent != NULL
684 && sym->attr.access == 0
685 && !module_fcn_entry)
686 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
687 "and must not have attributes declared at %L",
688 name, &sym->declared_at);
691 if (gfc_current_ns->parent == NULL || *result == NULL)
694 /* Module function entries will already have a symtree in
695 the current namespace but will need one at module level. */
696 if (module_fcn_entry)
697 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
699 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
704 /* See if the procedure should be a module procedure */
706 if (((sym->ns->proc_name != NULL
707 && sym->ns->proc_name->attr.flavor == FL_MODULE
708 && sym->attr.proc != PROC_MODULE) || module_fcn_entry)
709 && gfc_add_procedure (&sym->attr, PROC_MODULE,
710 sym->name, NULL) == FAILURE)
717 /* Function called by variable_decl() that adds a name to the symbol
721 build_sym (const char *name, gfc_charlen *cl,
722 gfc_array_spec **as, locus *var_locus)
724 symbol_attribute attr;
727 if (gfc_get_symbol (name, NULL, &sym))
730 /* Start updating the symbol table. Add basic type attribute
732 if (current_ts.type != BT_UNKNOWN
733 && (sym->attr.implicit_type == 0
734 || !gfc_compare_types (&sym->ts, ¤t_ts))
735 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
738 if (sym->ts.type == BT_CHARACTER)
741 /* Add dimension attribute if present. */
742 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
746 /* Add attribute to symbol. The copy is so that we can reset the
747 dimension attribute. */
751 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
758 /* Set character constant to the given length. The constant will be padded or
762 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
767 gcc_assert (expr->expr_type == EXPR_CONSTANT);
768 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
770 slen = expr->value.character.length;
773 s = gfc_getmem (len + 1);
774 memcpy (s, expr->value.character.string, MIN (len, slen));
776 memset (&s[slen], ' ', len - slen);
778 if (gfc_option.warn_character_truncation && slen > len)
779 gfc_warning_now ("CHARACTER expression at %L is being truncated "
780 "(%d/%d)", &expr->where, slen, len);
782 /* Apply the standard by 'hand' otherwise it gets cleared for
784 if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
785 gfc_error_now ("The CHARACTER elements of the array constructor "
786 "at %L must have the same length (%d/%d)",
787 &expr->where, slen, len);
790 gfc_free (expr->value.character.string);
791 expr->value.character.string = s;
792 expr->value.character.length = len;
797 /* Function to create and update the enumerator history
798 using the information passed as arguments.
799 Pointer "max_enum" is also updated, to point to
800 enum history node containing largest initializer.
802 SYM points to the symbol node of enumerator.
803 INIT points to its enumerator value. */
806 create_enum_history (gfc_symbol *sym, gfc_expr *init)
808 enumerator_history *new_enum_history;
809 gcc_assert (sym != NULL && init != NULL);
811 new_enum_history = gfc_getmem (sizeof (enumerator_history));
813 new_enum_history->sym = sym;
814 new_enum_history->initializer = init;
815 new_enum_history->next = NULL;
817 if (enum_history == NULL)
819 enum_history = new_enum_history;
820 max_enum = enum_history;
824 new_enum_history->next = enum_history;
825 enum_history = new_enum_history;
827 if (mpz_cmp (max_enum->initializer->value.integer,
828 new_enum_history->initializer->value.integer) < 0)
829 max_enum = new_enum_history;
834 /* Function to free enum kind history. */
837 gfc_free_enum_history (void)
839 enumerator_history *current = enum_history;
840 enumerator_history *next;
842 while (current != NULL)
844 next = current->next;
853 /* Function called by variable_decl() that adds an initialization
854 expression to a symbol. */
857 add_init_expr_to_sym (const char *name, gfc_expr **initp,
860 symbol_attribute attr;
865 if (find_special (name, &sym))
870 /* If this symbol is confirming an implicit parameter type,
871 then an initialization expression is not allowed. */
872 if (attr.flavor == FL_PARAMETER
873 && sym->value != NULL
876 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
885 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
892 /* An initializer is required for PARAMETER declarations. */
893 if (attr.flavor == FL_PARAMETER)
895 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
901 /* If a variable appears in a DATA block, it cannot have an
905 gfc_error ("Variable '%s' at %C with an initializer already "
906 "appears in a DATA statement", sym->name);
910 /* Check if the assignment can happen. This has to be put off
911 until later for a derived type variable. */
912 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
913 && gfc_check_assign_symbol (sym, init) == FAILURE)
916 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
918 /* Update symbol character length according initializer. */
919 if (sym->ts.cl->length == NULL)
921 /* If there are multiple CHARACTER variables declared on
922 the same line, we don't want them to share the same
924 sym->ts.cl = gfc_get_charlen ();
925 sym->ts.cl->next = gfc_current_ns->cl_list;
926 gfc_current_ns->cl_list = sym->ts.cl;
928 if (sym->attr.flavor == FL_PARAMETER
929 && init->expr_type == EXPR_ARRAY)
930 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
932 /* Update initializer character length according symbol. */
933 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
935 int len = mpz_get_si (sym->ts.cl->length->value.integer);
938 if (init->expr_type == EXPR_CONSTANT)
939 gfc_set_constant_character_len (len, init, false);
940 else if (init->expr_type == EXPR_ARRAY)
942 /* Build a new charlen to prevent simplification from
943 deleting the length before it is resolved. */
944 init->ts.cl = gfc_get_charlen ();
945 init->ts.cl->next = gfc_current_ns->cl_list;
946 gfc_current_ns->cl_list = sym->ts.cl;
947 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
949 for (p = init->value.constructor; p; p = p->next)
950 gfc_set_constant_character_len (len, p->expr, false);
955 /* Add initializer. Make sure we keep the ranks sane. */
956 if (sym->attr.dimension && init->rank == 0)
957 init->rank = sym->as->rank;
967 /* Function called by variable_decl() that adds a name to a structure
971 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
976 /* If the current symbol is of the same derived type that we're
977 constructing, it must have the pointer attribute. */
978 if (current_ts.type == BT_DERIVED
979 && current_ts.derived == gfc_current_block ()
980 && current_attr.pointer == 0)
982 gfc_error ("Component at %C must have the POINTER attribute");
986 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
988 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
990 gfc_error ("Array component of structure at %C must have explicit "
991 "or deferred shape");
996 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1001 gfc_set_component_attr (c, ¤t_attr);
1003 c->initializer = *init;
1011 /* Check array components. */
1016 gfc_error ("Allocatable component at %C must be an array");
1025 if (c->as->type != AS_DEFERRED)
1027 gfc_error ("Pointer array component of structure at %C must have a "
1032 else if (c->allocatable)
1034 if (c->as->type != AS_DEFERRED)
1036 gfc_error ("Allocatable component of structure at %C must have a "
1043 if (c->as->type != AS_EXPLICIT)
1045 gfc_error ("Array component of structure at %C must have an "
1055 /* Match a 'NULL()', and possibly take care of some side effects. */
1058 gfc_match_null (gfc_expr **result)
1064 m = gfc_match (" null ( )");
1068 /* The NULL symbol now has to be/become an intrinsic function. */
1069 if (gfc_get_symbol ("null", NULL, &sym))
1071 gfc_error ("NULL() initialization at %C is ambiguous");
1075 gfc_intrinsic_symbol (sym);
1077 if (sym->attr.proc != PROC_INTRINSIC
1078 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1079 sym->name, NULL) == FAILURE
1080 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1083 e = gfc_get_expr ();
1084 e->where = gfc_current_locus;
1085 e->expr_type = EXPR_NULL;
1086 e->ts.type = BT_UNKNOWN;
1094 /* Match a variable name with an optional initializer. When this
1095 subroutine is called, a variable is expected to be parsed next.
1096 Depending on what is happening at the moment, updates either the
1097 symbol table or the current interface. */
1100 variable_decl (int elem)
1102 char name[GFC_MAX_SYMBOL_LEN + 1];
1103 gfc_expr *initializer, *char_len;
1105 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1116 old_locus = gfc_current_locus;
1118 /* When we get here, we've just matched a list of attributes and
1119 maybe a type and a double colon. The next thing we expect to see
1120 is the name of the symbol. */
1121 m = gfc_match_name (name);
1125 var_locus = gfc_current_locus;
1127 /* Now we could see the optional array spec. or character length. */
1128 m = gfc_match_array_spec (&as);
1129 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1130 cp_as = gfc_copy_array_spec (as);
1131 else if (m == MATCH_ERROR)
1135 as = gfc_copy_array_spec (current_as);
1140 if (current_ts.type == BT_CHARACTER)
1142 switch (match_char_length (&char_len))
1145 cl = gfc_get_charlen ();
1146 cl->next = gfc_current_ns->cl_list;
1147 gfc_current_ns->cl_list = cl;
1149 cl->length = char_len;
1152 /* Non-constant lengths need to be copied after the first
1155 if (elem > 1 && current_ts.cl->length
1156 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1158 cl = gfc_get_charlen ();
1159 cl->next = gfc_current_ns->cl_list;
1160 gfc_current_ns->cl_list = cl;
1161 cl->length = gfc_copy_expr (current_ts.cl->length);
1173 /* If this symbol has already shown up in a Cray Pointer declaration,
1174 then we want to set the type & bail out. */
1175 if (gfc_option.flag_cray_pointer)
1177 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1178 if (sym != NULL && sym->attr.cray_pointee)
1180 sym->ts.type = current_ts.type;
1181 sym->ts.kind = current_ts.kind;
1183 sym->ts.derived = current_ts.derived;
1186 /* Check to see if we have an array specification. */
1189 if (sym->as != NULL)
1191 gfc_error ("Duplicate array spec for Cray pointee at %C");
1192 gfc_free_array_spec (cp_as);
1198 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1199 gfc_internal_error ("Couldn't set pointee array spec.");
1201 /* Fix the array spec. */
1202 m = gfc_mod_pointee_as (sym->as);
1203 if (m == MATCH_ERROR)
1211 gfc_free_array_spec (cp_as);
1216 /* OK, we've successfully matched the declaration. Now put the
1217 symbol in the current namespace, because it might be used in the
1218 optional initialization expression for this symbol, e.g. this is
1221 integer, parameter :: i = huge(i)
1223 This is only true for parameters or variables of a basic type.
1224 For components of derived types, it is not true, so we don't
1225 create a symbol for those yet. If we fail to create the symbol,
1227 if (gfc_current_state () != COMP_DERIVED
1228 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1234 /* An interface body specifies all of the procedure's
1235 characteristics and these shall be consistent with those
1236 specified in the procedure definition, except that the interface
1237 may specify a procedure that is not pure if the procedure is
1238 defined to be pure(12.3.2). */
1239 if (current_ts.type == BT_DERIVED
1240 && gfc_current_ns->proc_name
1241 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1242 && current_ts.derived->ns != gfc_current_ns
1243 && !gfc_current_ns->has_import_set)
1245 gfc_error ("the type of '%s' at %C has not been declared within the "
1251 /* In functions that have a RESULT variable defined, the function
1252 name always refers to function calls. Therefore, the name is
1253 not allowed to appear in specification statements. */
1254 if (gfc_current_state () == COMP_FUNCTION
1255 && gfc_current_block () != NULL
1256 && gfc_current_block ()->result != NULL
1257 && gfc_current_block ()->result != gfc_current_block ()
1258 && strcmp (gfc_current_block ()->name, name) == 0)
1260 gfc_error ("Function name '%s' not allowed at %C", name);
1265 /* We allow old-style initializations of the form
1266 integer i /2/, j(4) /3*3, 1/
1267 (if no colon has been seen). These are different from data
1268 statements in that initializers are only allowed to apply to the
1269 variable immediately preceding, i.e.
1271 is not allowed. Therefore we have to do some work manually, that
1272 could otherwise be left to the matchers for DATA statements. */
1274 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1276 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1277 "initialization at %C") == FAILURE)
1280 return match_old_style_init (name);
1283 /* The double colon must be present in order to have initializers.
1284 Otherwise the statement is ambiguous with an assignment statement. */
1287 if (gfc_match (" =>") == MATCH_YES)
1289 if (!current_attr.pointer)
1291 gfc_error ("Initialization at %C isn't for a pointer variable");
1296 m = gfc_match_null (&initializer);
1299 gfc_error ("Pointer initialization requires a NULL() at %C");
1303 if (gfc_pure (NULL))
1305 gfc_error ("Initialization of pointer at %C is not allowed in "
1306 "a PURE procedure");
1314 else if (gfc_match_char ('=') == MATCH_YES)
1316 if (current_attr.pointer)
1318 gfc_error ("Pointer initialization at %C requires '=>', "
1324 m = gfc_match_init_expr (&initializer);
1327 gfc_error ("Expected an initialization expression at %C");
1331 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1333 gfc_error ("Initialization of variable at %C is not allowed in "
1334 "a PURE procedure");
1343 if (initializer != NULL && current_attr.allocatable
1344 && gfc_current_state () == COMP_DERIVED)
1346 gfc_error ("Initialization of allocatable component at %C is not "
1352 /* Add the initializer. Note that it is fine if initializer is
1353 NULL here, because we sometimes also need to check if a
1354 declaration *must* have an initialization expression. */
1355 if (gfc_current_state () != COMP_DERIVED)
1356 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1359 if (current_ts.type == BT_DERIVED
1360 && !current_attr.pointer && !initializer)
1361 initializer = gfc_default_initializer (¤t_ts);
1362 t = build_struct (name, cl, &initializer, &as);
1365 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1368 /* Free stuff up and return. */
1369 gfc_free_expr (initializer);
1370 gfc_free_array_spec (as);
1376 /* Match an extended-f77 kind specification. */
1379 gfc_match_old_kind_spec (gfc_typespec *ts)
1384 if (gfc_match_char ('*') != MATCH_YES)
1387 m = gfc_match_small_literal_int (&ts->kind, NULL);
1391 original_kind = ts->kind;
1393 /* Massage the kind numbers for complex types. */
1394 if (ts->type == BT_COMPLEX)
1398 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1399 gfc_basic_typename (ts->type), original_kind);
1405 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1407 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1408 gfc_basic_typename (ts->type), original_kind);
1412 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1413 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1420 /* Match a kind specification. Since kinds are generally optional, we
1421 usually return MATCH_NO if something goes wrong. If a "kind="
1422 string is found, then we know we have an error. */
1425 gfc_match_kind_spec (gfc_typespec *ts)
1435 where = gfc_current_locus;
1437 if (gfc_match_char ('(') == MATCH_NO)
1440 /* Also gobbles optional text. */
1441 if (gfc_match (" kind = ") == MATCH_YES)
1444 n = gfc_match_init_expr (&e);
1446 gfc_error ("Expected initialization expression at %C");
1452 gfc_error ("Expected scalar initialization expression at %C");
1457 msg = gfc_extract_int (e, &ts->kind);
1468 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1470 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1471 gfc_basic_typename (ts->type));
1477 if (gfc_match_char (')') != MATCH_YES)
1479 gfc_error ("Missing right parenthesis at %C");
1487 gfc_current_locus = where;
1492 /* Match the various kind/length specifications in a CHARACTER
1493 declaration. We don't return MATCH_NO. */
1496 match_char_spec (gfc_typespec *ts)
1498 int i, kind, seen_length;
1503 kind = gfc_default_character_kind;
1507 /* Try the old-style specification first. */
1508 old_char_selector = 0;
1510 m = match_char_length (&len);
1514 old_char_selector = 1;
1519 m = gfc_match_char ('(');
1522 m = MATCH_YES; /* character without length is a single char */
1526 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1527 if (gfc_match (" kind =") == MATCH_YES)
1529 m = gfc_match_small_int (&kind);
1530 if (m == MATCH_ERROR)
1535 if (gfc_match (" , len =") == MATCH_NO)
1538 m = char_len_param_value (&len);
1541 if (m == MATCH_ERROR)
1548 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>" */
1549 if (gfc_match (" len =") == MATCH_YES)
1551 m = char_len_param_value (&len);
1554 if (m == MATCH_ERROR)
1558 if (gfc_match_char (')') == MATCH_YES)
1561 if (gfc_match (" , kind =") != MATCH_YES)
1564 gfc_match_small_int (&kind);
1566 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1568 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1575 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1576 m = char_len_param_value (&len);
1579 if (m == MATCH_ERROR)
1583 m = gfc_match_char (')');
1587 if (gfc_match_char (',') != MATCH_YES)
1590 gfc_match (" kind ="); /* Gobble optional text */
1592 m = gfc_match_small_int (&kind);
1593 if (m == MATCH_ERROR)
1599 /* Require a right-paren at this point. */
1600 m = gfc_match_char (')');
1605 gfc_error ("Syntax error in CHARACTER declaration at %C");
1609 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1611 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1617 gfc_free_expr (len);
1621 /* Do some final massaging of the length values. */
1622 cl = gfc_get_charlen ();
1623 cl->next = gfc_current_ns->cl_list;
1624 gfc_current_ns->cl_list = cl;
1626 if (seen_length == 0)
1627 cl->length = gfc_int_expr (1);
1630 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1634 gfc_free_expr (len);
1635 cl->length = gfc_int_expr (0);
1646 /* Matches a type specification. If successful, sets the ts structure
1647 to the matched specification. This is necessary for FUNCTION and
1648 IMPLICIT statements.
1650 If implicit_flag is nonzero, then we don't check for the optional
1651 kind specification. Not doing so is needed for matching an IMPLICIT
1652 statement correctly. */
1655 match_type_spec (gfc_typespec *ts, int implicit_flag)
1657 char name[GFC_MAX_SYMBOL_LEN + 1];
1664 if (gfc_match (" byte") == MATCH_YES)
1666 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1670 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1672 gfc_error ("BYTE type used at %C "
1673 "is not available on the target machine");
1677 ts->type = BT_INTEGER;
1682 if (gfc_match (" integer") == MATCH_YES)
1684 ts->type = BT_INTEGER;
1685 ts->kind = gfc_default_integer_kind;
1689 if (gfc_match (" character") == MATCH_YES)
1691 ts->type = BT_CHARACTER;
1692 if (implicit_flag == 0)
1693 return match_char_spec (ts);
1698 if (gfc_match (" real") == MATCH_YES)
1701 ts->kind = gfc_default_real_kind;
1705 if (gfc_match (" double precision") == MATCH_YES)
1708 ts->kind = gfc_default_double_kind;
1712 if (gfc_match (" complex") == MATCH_YES)
1714 ts->type = BT_COMPLEX;
1715 ts->kind = gfc_default_complex_kind;
1719 if (gfc_match (" double complex") == MATCH_YES)
1721 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1722 "conform to the Fortran 95 standard") == FAILURE)
1725 ts->type = BT_COMPLEX;
1726 ts->kind = gfc_default_double_kind;
1730 if (gfc_match (" logical") == MATCH_YES)
1732 ts->type = BT_LOGICAL;
1733 ts->kind = gfc_default_logical_kind;
1737 m = gfc_match (" type ( %n )", name);
1741 /* Search for the name but allow the components to be defined later. */
1742 if (gfc_get_ha_symbol (name, &sym))
1744 gfc_error ("Type name '%s' at %C is ambiguous", name);
1748 if (sym->attr.flavor != FL_DERIVED
1749 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1752 ts->type = BT_DERIVED;
1759 /* For all types except double, derived and character, look for an
1760 optional kind specifier. MATCH_NO is actually OK at this point. */
1761 if (implicit_flag == 1)
1764 if (gfc_current_form == FORM_FREE)
1766 c = gfc_peek_char();
1767 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1768 && c != ':' && c != ',')
1772 m = gfc_match_kind_spec (ts);
1773 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1774 m = gfc_match_old_kind_spec (ts);
1777 m = MATCH_YES; /* No kind specifier found. */
1783 /* Match an IMPLICIT NONE statement. Actually, this statement is
1784 already matched in parse.c, or we would not end up here in the
1785 first place. So the only thing we need to check, is if there is
1786 trailing garbage. If not, the match is successful. */
1789 gfc_match_implicit_none (void)
1791 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1795 /* Match the letter range(s) of an IMPLICIT statement. */
1798 match_implicit_range (void)
1800 int c, c1, c2, inner;
1803 cur_loc = gfc_current_locus;
1805 gfc_gobble_whitespace ();
1806 c = gfc_next_char ();
1809 gfc_error ("Missing character range in IMPLICIT at %C");
1816 gfc_gobble_whitespace ();
1817 c1 = gfc_next_char ();
1821 gfc_gobble_whitespace ();
1822 c = gfc_next_char ();
1827 inner = 0; /* Fall through */
1834 gfc_gobble_whitespace ();
1835 c2 = gfc_next_char ();
1839 gfc_gobble_whitespace ();
1840 c = gfc_next_char ();
1842 if ((c != ',') && (c != ')'))
1855 gfc_error ("Letters must be in alphabetic order in "
1856 "IMPLICIT statement at %C");
1860 /* See if we can add the newly matched range to the pending
1861 implicits from this IMPLICIT statement. We do not check for
1862 conflicts with whatever earlier IMPLICIT statements may have
1863 set. This is done when we've successfully finished matching
1865 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1872 gfc_syntax_error (ST_IMPLICIT);
1874 gfc_current_locus = cur_loc;
1879 /* Match an IMPLICIT statement, storing the types for
1880 gfc_set_implicit() if the statement is accepted by the parser.
1881 There is a strange looking, but legal syntactic construction
1882 possible. It looks like:
1884 IMPLICIT INTEGER (a-b) (c-d)
1886 This is legal if "a-b" is a constant expression that happens to
1887 equal one of the legal kinds for integers. The real problem
1888 happens with an implicit specification that looks like:
1890 IMPLICIT INTEGER (a-b)
1892 In this case, a typespec matcher that is "greedy" (as most of the
1893 matchers are) gobbles the character range as a kindspec, leaving
1894 nothing left. We therefore have to go a bit more slowly in the
1895 matching process by inhibiting the kindspec checking during
1896 typespec matching and checking for a kind later. */
1899 gfc_match_implicit (void)
1906 /* We don't allow empty implicit statements. */
1907 if (gfc_match_eos () == MATCH_YES)
1909 gfc_error ("Empty IMPLICIT statement at %C");
1915 /* First cleanup. */
1916 gfc_clear_new_implicit ();
1918 /* A basic type is mandatory here. */
1919 m = match_type_spec (&ts, 1);
1920 if (m == MATCH_ERROR)
1925 cur_loc = gfc_current_locus;
1926 m = match_implicit_range ();
1930 /* We may have <TYPE> (<RANGE>). */
1931 gfc_gobble_whitespace ();
1932 c = gfc_next_char ();
1933 if ((c == '\n') || (c == ','))
1935 /* Check for CHARACTER with no length parameter. */
1936 if (ts.type == BT_CHARACTER && !ts.cl)
1938 ts.kind = gfc_default_character_kind;
1939 ts.cl = gfc_get_charlen ();
1940 ts.cl->next = gfc_current_ns->cl_list;
1941 gfc_current_ns->cl_list = ts.cl;
1942 ts.cl->length = gfc_int_expr (1);
1945 /* Record the Successful match. */
1946 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1951 gfc_current_locus = cur_loc;
1954 /* Discard the (incorrectly) matched range. */
1955 gfc_clear_new_implicit ();
1957 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1958 if (ts.type == BT_CHARACTER)
1959 m = match_char_spec (&ts);
1962 m = gfc_match_kind_spec (&ts);
1965 m = gfc_match_old_kind_spec (&ts);
1966 if (m == MATCH_ERROR)
1972 if (m == MATCH_ERROR)
1975 m = match_implicit_range ();
1976 if (m == MATCH_ERROR)
1981 gfc_gobble_whitespace ();
1982 c = gfc_next_char ();
1983 if ((c != '\n') && (c != ','))
1986 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1994 gfc_syntax_error (ST_IMPLICIT);
2001 gfc_match_import (void)
2003 char name[GFC_MAX_SYMBOL_LEN + 1];
2008 if (gfc_current_ns->proc_name == NULL ||
2009 gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2011 gfc_error ("IMPORT statement at %C only permitted in "
2012 "an INTERFACE body");
2016 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2020 if (gfc_match_eos () == MATCH_YES)
2022 /* All host variables should be imported. */
2023 gfc_current_ns->has_import_set = 1;
2027 if (gfc_match (" ::") == MATCH_YES)
2029 if (gfc_match_eos () == MATCH_YES)
2031 gfc_error ("Expecting list of named entities at %C");
2038 m = gfc_match (" %n", name);
2042 if (gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2044 gfc_error ("Type name '%s' at %C is ambiguous", name);
2050 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2051 "at %C - does not exist.", name);
2055 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2057 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2062 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2065 sym->ns = gfc_current_ns;
2077 if (gfc_match_eos () == MATCH_YES)
2079 if (gfc_match_char (',') != MATCH_YES)
2086 gfc_error ("Syntax error in IMPORT statement at %C");
2090 /* Matches an attribute specification including array specs. If
2091 successful, leaves the variables current_attr and current_as
2092 holding the specification. Also sets the colon_seen variable for
2093 later use by matchers associated with initializations.
2095 This subroutine is a little tricky in the sense that we don't know
2096 if we really have an attr-spec until we hit the double colon.
2097 Until that time, we can only return MATCH_NO. This forces us to
2098 check for duplicate specification at this level. */
2101 match_attr_spec (void)
2103 /* Modifiers that can exist in a type statement. */
2105 { GFC_DECL_BEGIN = 0,
2106 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2107 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2108 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2109 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2110 DECL_COLON, DECL_NONE,
2111 GFC_DECL_END /* Sentinel */
2115 /* GFC_DECL_END is the sentinel, index starts at 0. */
2116 #define NUM_DECL GFC_DECL_END
2118 static mstring decls[] = {
2119 minit (", allocatable", DECL_ALLOCATABLE),
2120 minit (", dimension", DECL_DIMENSION),
2121 minit (", external", DECL_EXTERNAL),
2122 minit (", intent ( in )", DECL_IN),
2123 minit (", intent ( out )", DECL_OUT),
2124 minit (", intent ( in out )", DECL_INOUT),
2125 minit (", intrinsic", DECL_INTRINSIC),
2126 minit (", optional", DECL_OPTIONAL),
2127 minit (", parameter", DECL_PARAMETER),
2128 minit (", pointer", DECL_POINTER),
2129 minit (", protected", DECL_PROTECTED),
2130 minit (", private", DECL_PRIVATE),
2131 minit (", public", DECL_PUBLIC),
2132 minit (", save", DECL_SAVE),
2133 minit (", target", DECL_TARGET),
2134 minit (", value", DECL_VALUE),
2135 minit (", volatile", DECL_VOLATILE),
2136 minit ("::", DECL_COLON),
2137 minit (NULL, DECL_NONE)
2140 locus start, seen_at[NUM_DECL];
2147 gfc_clear_attr (¤t_attr);
2148 start = gfc_current_locus;
2153 /* See if we get all of the keywords up to the final double colon. */
2154 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2159 d = (decl_types) gfc_match_strings (decls);
2160 if (d == DECL_NONE || d == DECL_COLON)
2164 seen_at[d] = gfc_current_locus;
2166 if (d == DECL_DIMENSION)
2168 m = gfc_match_array_spec (¤t_as);
2172 gfc_error ("Missing dimension specification at %C");
2176 if (m == MATCH_ERROR)
2181 /* No double colon, so assume that we've been looking at something
2182 else the whole time. */
2189 /* Since we've seen a double colon, we have to be looking at an
2190 attr-spec. This means that we can now issue errors. */
2191 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2196 case DECL_ALLOCATABLE:
2197 attr = "ALLOCATABLE";
2199 case DECL_DIMENSION:
2206 attr = "INTENT (IN)";
2209 attr = "INTENT (OUT)";
2212 attr = "INTENT (IN OUT)";
2214 case DECL_INTRINSIC:
2220 case DECL_PARAMETER:
2226 case DECL_PROTECTED:
2248 attr = NULL; /* This shouldn't happen */
2251 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2256 /* Now that we've dealt with duplicate attributes, add the attributes
2257 to the current attribute. */
2258 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2263 if (gfc_current_state () == COMP_DERIVED
2264 && d != DECL_DIMENSION && d != DECL_POINTER
2265 && d != DECL_COLON && d != DECL_NONE)
2267 if (d == DECL_ALLOCATABLE)
2269 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2270 "attribute at %C in a TYPE definition")
2279 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2286 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2287 && gfc_current_state () != COMP_MODULE)
2289 if (d == DECL_PRIVATE)
2294 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2302 case DECL_ALLOCATABLE:
2303 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2306 case DECL_DIMENSION:
2307 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2311 t = gfc_add_external (¤t_attr, &seen_at[d]);
2315 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2319 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2323 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2326 case DECL_INTRINSIC:
2327 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2331 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2334 case DECL_PARAMETER:
2335 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2339 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2342 case DECL_PROTECTED:
2343 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2345 gfc_error ("PROTECTED at %C only allowed in specification "
2346 "part of a module");
2351 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2356 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
2360 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2365 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2370 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2374 t = gfc_add_target (¤t_attr, &seen_at[d]);
2378 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2383 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
2387 if (gfc_notify_std (GFC_STD_F2003,
2388 "Fortran 2003: VOLATILE attribute at %C")
2392 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
2396 gfc_internal_error ("match_attr_spec(): Bad attribute");
2410 gfc_current_locus = start;
2411 gfc_free_array_spec (current_as);
2417 /* Match a data declaration statement. */
2420 gfc_match_data_decl (void)
2426 m = match_type_spec (¤t_ts, 0);
2430 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2432 sym = gfc_use_derived (current_ts.derived);
2440 current_ts.derived = sym;
2443 m = match_attr_spec ();
2444 if (m == MATCH_ERROR)
2450 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2453 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2456 gfc_find_symbol (current_ts.derived->name,
2457 current_ts.derived->ns->parent, 1, &sym);
2459 /* Any symbol that we find had better be a type definition
2460 which has its components defined. */
2461 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2462 && current_ts.derived->components != NULL)
2465 /* Now we have an error, which we signal, and then fix up
2466 because the knock-on is plain and simple confusing. */
2467 gfc_error_now ("Derived type at %C has not been previously defined "
2468 "and so cannot appear in a derived type definition");
2469 current_attr.pointer = 1;
2474 /* If we have an old-style character declaration, and no new-style
2475 attribute specifications, then there a comma is optional between
2476 the type specification and the variable list. */
2477 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2478 gfc_match_char (',');
2480 /* Give the types/attributes to symbols that follow. Give the element
2481 a number so that repeat character length expressions can be copied. */
2485 m = variable_decl (elem++);
2486 if (m == MATCH_ERROR)
2491 if (gfc_match_eos () == MATCH_YES)
2493 if (gfc_match_char (',') != MATCH_YES)
2497 if (gfc_error_flag_test () == 0)
2498 gfc_error ("Syntax error in data declaration at %C");
2501 gfc_free_data_all (gfc_current_ns);
2504 gfc_free_array_spec (current_as);
2510 /* Match a prefix associated with a function or subroutine
2511 declaration. If the typespec pointer is nonnull, then a typespec
2512 can be matched. Note that if nothing matches, MATCH_YES is
2513 returned (the null string was matched). */
2516 match_prefix (gfc_typespec *ts)
2520 gfc_clear_attr (¤t_attr);
2524 if (!seen_type && ts != NULL
2525 && match_type_spec (ts, 0) == MATCH_YES
2526 && gfc_match_space () == MATCH_YES)
2533 if (gfc_match ("elemental% ") == MATCH_YES)
2535 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2541 if (gfc_match ("pure% ") == MATCH_YES)
2543 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2549 if (gfc_match ("recursive% ") == MATCH_YES)
2551 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2557 /* At this point, the next item is not a prefix. */
2562 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2565 copy_prefix (symbol_attribute *dest, locus *where)
2567 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2570 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2573 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2580 /* Match a formal argument list. */
2583 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
2585 gfc_formal_arglist *head, *tail, *p, *q;
2586 char name[GFC_MAX_SYMBOL_LEN + 1];
2592 if (gfc_match_char ('(') != MATCH_YES)
2599 if (gfc_match_char (')') == MATCH_YES)
2604 if (gfc_match_char ('*') == MATCH_YES)
2608 m = gfc_match_name (name);
2612 if (gfc_get_symbol (name, NULL, &sym))
2616 p = gfc_get_formal_arglist ();
2628 /* We don't add the VARIABLE flavor because the name could be a
2629 dummy procedure. We don't apply these attributes to formal
2630 arguments of statement functions. */
2631 if (sym != NULL && !st_flag
2632 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2633 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2639 /* The name of a program unit can be in a different namespace,
2640 so check for it explicitly. After the statement is accepted,
2641 the name is checked for especially in gfc_get_symbol(). */
2642 if (gfc_new_block != NULL && sym != NULL
2643 && strcmp (sym->name, gfc_new_block->name) == 0)
2645 gfc_error ("Name '%s' at %C is the name of the procedure",
2651 if (gfc_match_char (')') == MATCH_YES)
2654 m = gfc_match_char (',');
2657 gfc_error ("Unexpected junk in formal argument list at %C");
2663 /* Check for duplicate symbols in the formal argument list. */
2666 for (p = head; p->next; p = p->next)
2671 for (q = p->next; q; q = q->next)
2672 if (p->sym == q->sym)
2674 gfc_error ("Duplicate symbol '%s' in formal argument list "
2675 "at %C", p->sym->name);
2683 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2693 gfc_free_formal_arglist (head);
2698 /* Match a RESULT specification following a function declaration or
2699 ENTRY statement. Also matches the end-of-statement. */
2702 match_result (gfc_symbol * function, gfc_symbol **result)
2704 char name[GFC_MAX_SYMBOL_LEN + 1];
2708 if (gfc_match (" result (") != MATCH_YES)
2711 m = gfc_match_name (name);
2715 if (gfc_match (" )%t") != MATCH_YES)
2717 gfc_error ("Unexpected junk following RESULT variable at %C");
2721 if (strcmp (function->name, name) == 0)
2723 gfc_error ("RESULT variable at %C must be different than function name");
2727 if (gfc_get_symbol (name, NULL, &r))
2730 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2731 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2740 /* Match a function declaration. */
2743 gfc_match_function_decl (void)
2745 char name[GFC_MAX_SYMBOL_LEN + 1];
2746 gfc_symbol *sym, *result;
2750 if (gfc_current_state () != COMP_NONE
2751 && gfc_current_state () != COMP_INTERFACE
2752 && gfc_current_state () != COMP_CONTAINS)
2755 gfc_clear_ts (¤t_ts);
2757 old_loc = gfc_current_locus;
2759 m = match_prefix (¤t_ts);
2762 gfc_current_locus = old_loc;
2766 if (gfc_match ("function% %n", name) != MATCH_YES)
2768 gfc_current_locus = old_loc;
2772 if (get_proc_name (name, &sym, false))
2774 gfc_new_block = sym;
2776 m = gfc_match_formal_arglist (sym, 0, 0);
2779 gfc_error ("Expected formal argument list in function "
2780 "definition at %C");
2784 else if (m == MATCH_ERROR)
2789 if (gfc_match_eos () != MATCH_YES)
2791 /* See if a result variable is present. */
2792 m = match_result (sym, &result);
2794 gfc_error ("Unexpected junk after function declaration at %C");
2803 /* Make changes to the symbol. */
2806 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2809 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2810 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2813 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
2814 && !sym->attr.implicit_type)
2816 gfc_error ("Function '%s' at %C already has a type of %s", name,
2817 gfc_basic_typename (sym->ts.type));
2823 sym->ts = current_ts;
2828 result->ts = current_ts;
2829 sym->result = result;
2835 gfc_current_locus = old_loc;
2840 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
2841 pass the name of the entry, rather than the gfc_current_block name, and
2842 to return false upon finding an existing global entry. */
2845 add_global_entry (const char *name, int sub)
2849 s = gfc_get_gsymbol(name);
2852 || (s->type != GSYM_UNKNOWN
2853 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2854 global_used(s, NULL);
2857 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2858 s->where = gfc_current_locus;
2866 /* Match an ENTRY statement. */
2869 gfc_match_entry (void)
2874 char name[GFC_MAX_SYMBOL_LEN + 1];
2875 gfc_compile_state state;
2879 bool module_procedure;
2881 m = gfc_match_name (name);
2885 state = gfc_current_state ();
2886 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2891 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2894 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2896 case COMP_BLOCK_DATA:
2897 gfc_error ("ENTRY statement at %C cannot appear within "
2900 case COMP_INTERFACE:
2901 gfc_error ("ENTRY statement at %C cannot appear within "
2905 gfc_error ("ENTRY statement at %C cannot appear within "
2906 "a DERIVED TYPE block");
2909 gfc_error ("ENTRY statement at %C cannot appear within "
2910 "an IF-THEN block");
2913 gfc_error ("ENTRY statement at %C cannot appear within "
2917 gfc_error ("ENTRY statement at %C cannot appear within "
2921 gfc_error ("ENTRY statement at %C cannot appear within "
2925 gfc_error ("ENTRY statement at %C cannot appear within "
2929 gfc_error ("ENTRY statement at %C cannot appear within "
2930 "a contained subprogram");
2933 gfc_internal_error ("gfc_match_entry(): Bad state");
2938 module_procedure = gfc_current_ns->parent != NULL
2939 && gfc_current_ns->parent->proc_name
2940 && gfc_current_ns->parent->proc_name->attr.flavor
2943 if (gfc_current_ns->parent != NULL
2944 && gfc_current_ns->parent->proc_name
2945 && !module_procedure)
2947 gfc_error("ENTRY statement at %C cannot appear in a "
2948 "contained procedure");
2952 /* Module function entries need special care in get_proc_name
2953 because previous references within the function will have
2954 created symbols attached to the current namespace. */
2955 if (get_proc_name (name, &entry,
2956 gfc_current_ns->parent != NULL
2958 && gfc_current_ns->proc_name->attr.function))
2961 proc = gfc_current_block ();
2963 if (state == COMP_SUBROUTINE)
2965 /* An entry in a subroutine. */
2966 if (!add_global_entry (name, 1))
2969 m = gfc_match_formal_arglist (entry, 0, 1);
2973 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2974 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2979 /* An entry in a function.
2980 We need to take special care because writing
2985 ENTRY f() RESULT (r)
2987 ENTRY f RESULT (r). */
2988 if (!add_global_entry (name, 0))
2991 old_loc = gfc_current_locus;
2992 if (gfc_match_eos () == MATCH_YES)
2994 gfc_current_locus = old_loc;
2995 /* Match the empty argument list, and add the interface to
2997 m = gfc_match_formal_arglist (entry, 0, 1);
3000 m = gfc_match_formal_arglist (entry, 0, 0);
3007 if (gfc_match_eos () == MATCH_YES)
3009 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3010 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3013 entry->result = entry;
3017 m = match_result (proc, &result);
3019 gfc_syntax_error (ST_ENTRY);
3023 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3024 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3025 || gfc_add_function (&entry->attr, result->name, NULL)
3029 entry->result = result;
3032 if (proc->attr.recursive && result == NULL)
3034 gfc_error ("RESULT attribute required in ENTRY statement at %C");
3039 if (gfc_match_eos () != MATCH_YES)
3041 gfc_syntax_error (ST_ENTRY);
3045 entry->attr.recursive = proc->attr.recursive;
3046 entry->attr.elemental = proc->attr.elemental;
3047 entry->attr.pure = proc->attr.pure;
3049 el = gfc_get_entry_list ();
3051 el->next = gfc_current_ns->entries;
3052 gfc_current_ns->entries = el;
3054 el->id = el->next->id + 1;
3058 new_st.op = EXEC_ENTRY;
3059 new_st.ext.entry = el;
3065 /* Match a subroutine statement, including optional prefixes. */
3068 gfc_match_subroutine (void)
3070 char name[GFC_MAX_SYMBOL_LEN + 1];
3074 if (gfc_current_state () != COMP_NONE
3075 && gfc_current_state () != COMP_INTERFACE
3076 && gfc_current_state () != COMP_CONTAINS)
3079 m = match_prefix (NULL);
3083 m = gfc_match ("subroutine% %n", name);
3087 if (get_proc_name (name, &sym, false))
3089 gfc_new_block = sym;
3091 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3094 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3097 if (gfc_match_eos () != MATCH_YES)
3099 gfc_syntax_error (ST_SUBROUTINE);
3103 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3110 /* Return nonzero if we're currently compiling a contained procedure. */
3113 contained_procedure (void)
3117 for (s=gfc_state_stack; s; s=s->previous)
3118 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3119 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
3125 /* Set the kind of each enumerator. The kind is selected such that it is
3126 interoperable with the corresponding C enumeration type, making
3127 sure that -fshort-enums is honored. */
3132 enumerator_history *current_history = NULL;
3136 if (max_enum == NULL || enum_history == NULL)
3139 if (!gfc_option.fshort_enums)
3145 kind = gfc_integer_kinds[i++].kind;
3147 while (kind < gfc_c_int_kind
3148 && gfc_check_integer_range (max_enum->initializer->value.integer,
3151 current_history = enum_history;
3152 while (current_history != NULL)
3154 current_history->sym->ts.kind = kind;
3155 current_history = current_history->next;
3160 /* Match any of the various end-block statements. Returns the type of
3161 END to the caller. The END INTERFACE, END IF, END DO and END
3162 SELECT statements cannot be replaced by a single END statement. */
3165 gfc_match_end (gfc_statement *st)
3167 char name[GFC_MAX_SYMBOL_LEN + 1];
3168 gfc_compile_state state;
3170 const char *block_name;
3175 old_loc = gfc_current_locus;
3176 if (gfc_match ("end") != MATCH_YES)
3179 state = gfc_current_state ();
3180 block_name = gfc_current_block () == NULL
3181 ? NULL : gfc_current_block ()->name;
3183 if (state == COMP_CONTAINS)
3185 state = gfc_state_stack->previous->state;
3186 block_name = gfc_state_stack->previous->sym == NULL
3187 ? NULL : gfc_state_stack->previous->sym->name;
3194 *st = ST_END_PROGRAM;
3195 target = " program";
3199 case COMP_SUBROUTINE:
3200 *st = ST_END_SUBROUTINE;
3201 target = " subroutine";
3202 eos_ok = !contained_procedure ();
3206 *st = ST_END_FUNCTION;
3207 target = " function";
3208 eos_ok = !contained_procedure ();
3211 case COMP_BLOCK_DATA:
3212 *st = ST_END_BLOCK_DATA;
3213 target = " block data";
3218 *st = ST_END_MODULE;
3223 case COMP_INTERFACE:
3224 *st = ST_END_INTERFACE;
3225 target = " interface";
3248 *st = ST_END_SELECT;
3254 *st = ST_END_FORALL;
3269 last_initializer = NULL;
3271 gfc_free_enum_history ();
3275 gfc_error ("Unexpected END statement at %C");
3279 if (gfc_match_eos () == MATCH_YES)
3283 /* We would have required END [something] */
3284 gfc_error ("%s statement expected at %L",
3285 gfc_ascii_statement (*st), &old_loc);
3292 /* Verify that we've got the sort of end-block that we're expecting. */
3293 if (gfc_match (target) != MATCH_YES)
3295 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3299 /* If we're at the end, make sure a block name wasn't required. */
3300 if (gfc_match_eos () == MATCH_YES)
3303 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3306 if (gfc_current_block () == NULL)
3309 gfc_error ("Expected block name of '%s' in %s statement at %C",
3310 block_name, gfc_ascii_statement (*st));
3315 /* END INTERFACE has a special handler for its several possible endings. */
3316 if (*st == ST_END_INTERFACE)
3317 return gfc_match_end_interface ();
3319 /* We haven't hit the end of statement, so what is left must be an end-name. */
3320 m = gfc_match_space ();
3322 m = gfc_match_name (name);
3325 gfc_error ("Expected terminating name at %C");
3329 if (block_name == NULL)
3332 if (strcmp (name, block_name) != 0)
3334 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3335 gfc_ascii_statement (*st));
3339 if (gfc_match_eos () == MATCH_YES)
3343 gfc_syntax_error (*st);
3346 gfc_current_locus = old_loc;
3352 /***************** Attribute declaration statements ****************/
3354 /* Set the attribute of a single variable. */
3359 char name[GFC_MAX_SYMBOL_LEN + 1];
3367 m = gfc_match_name (name);
3371 if (find_special (name, &sym))
3374 var_locus = gfc_current_locus;
3376 /* Deal with possible array specification for certain attributes. */
3377 if (current_attr.dimension
3378 || current_attr.allocatable
3379 || current_attr.pointer
3380 || current_attr.target)
3382 m = gfc_match_array_spec (&as);
3383 if (m == MATCH_ERROR)
3386 if (current_attr.dimension && m == MATCH_NO)
3388 gfc_error ("Missing array specification at %L in DIMENSION "
3389 "statement", &var_locus);
3394 if ((current_attr.allocatable || current_attr.pointer)
3395 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3397 gfc_error ("Array specification must be deferred at %L", &var_locus);
3403 /* Update symbol table. DIMENSION attribute is set
3404 in gfc_set_array_spec(). */
3405 if (current_attr.dimension == 0
3406 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3412 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3418 if (sym->attr.cray_pointee && sym->as != NULL)
3420 /* Fix the array spec. */
3421 m = gfc_mod_pointee_as (sym->as);
3422 if (m == MATCH_ERROR)
3426 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
3432 if ((current_attr.external || current_attr.intrinsic)
3433 && sym->attr.flavor != FL_PROCEDURE
3434 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3443 gfc_free_array_spec (as);
3448 /* Generic attribute declaration subroutine. Used for attributes that
3449 just have a list of names. */
3456 /* Gobble the optional double colon, by simply ignoring the result
3466 if (gfc_match_eos () == MATCH_YES)
3472 if (gfc_match_char (',') != MATCH_YES)
3474 gfc_error ("Unexpected character in variable list at %C");
3484 /* This routine matches Cray Pointer declarations of the form:
3485 pointer ( <pointer>, <pointee> )
3487 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3488 The pointer, if already declared, should be an integer. Otherwise, we
3489 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3490 be either a scalar, or an array declaration. No space is allocated for
3491 the pointee. For the statement
3492 pointer (ipt, ar(10))
3493 any subsequent uses of ar will be translated (in C-notation) as
3494 ar(i) => ((<type> *) ipt)(i)
3495 After gimplification, pointee variable will disappear in the code. */
3498 cray_pointer_decl (void)
3502 gfc_symbol *cptr; /* Pointer symbol. */
3503 gfc_symbol *cpte; /* Pointee symbol. */
3509 if (gfc_match_char ('(') != MATCH_YES)
3511 gfc_error ("Expected '(' at %C");
3515 /* Match pointer. */
3516 var_locus = gfc_current_locus;
3517 gfc_clear_attr (¤t_attr);
3518 gfc_add_cray_pointer (¤t_attr, &var_locus);
3519 current_ts.type = BT_INTEGER;
3520 current_ts.kind = gfc_index_integer_kind;
3522 m = gfc_match_symbol (&cptr, 0);
3525 gfc_error ("Expected variable name at %C");
3529 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3532 gfc_set_sym_referenced (cptr);
3534 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3536 cptr->ts.type = BT_INTEGER;
3537 cptr->ts.kind = gfc_index_integer_kind;
3539 else if (cptr->ts.type != BT_INTEGER)
3541 gfc_error ("Cray pointer at %C must be an integer");
3544 else if (cptr->ts.kind < gfc_index_integer_kind)
3545 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3546 " memory addresses require %d bytes",
3547 cptr->ts.kind, gfc_index_integer_kind);
3549 if (gfc_match_char (',') != MATCH_YES)
3551 gfc_error ("Expected \",\" at %C");
3555 /* Match Pointee. */
3556 var_locus = gfc_current_locus;
3557 gfc_clear_attr (¤t_attr);
3558 gfc_add_cray_pointee (¤t_attr, &var_locus);
3559 current_ts.type = BT_UNKNOWN;
3560 current_ts.kind = 0;
3562 m = gfc_match_symbol (&cpte, 0);
3565 gfc_error ("Expected variable name at %C");
3569 /* Check for an optional array spec. */
3570 m = gfc_match_array_spec (&as);
3571 if (m == MATCH_ERROR)
3573 gfc_free_array_spec (as);
3576 else if (m == MATCH_NO)
3578 gfc_free_array_spec (as);
3582 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3585 gfc_set_sym_referenced (cpte);
3587 if (cpte->as == NULL)
3589 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3590 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3592 else if (as != NULL)
3594 gfc_error ("Duplicate array spec for Cray pointee at %C");
3595 gfc_free_array_spec (as);
3601 if (cpte->as != NULL)
3603 /* Fix array spec. */
3604 m = gfc_mod_pointee_as (cpte->as);
3605 if (m == MATCH_ERROR)
3609 /* Point the Pointee at the Pointer. */
3610 cpte->cp_pointer = cptr;
3612 if (gfc_match_char (')') != MATCH_YES)
3614 gfc_error ("Expected \")\" at %C");
3617 m = gfc_match_char (',');
3619 done = true; /* Stop searching for more declarations. */
3623 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3624 || gfc_match_eos () != MATCH_YES)
3626 gfc_error ("Expected \",\" or end of statement at %C");
3634 gfc_match_external (void)
3637 gfc_clear_attr (¤t_attr);
3638 current_attr.external = 1;
3640 return attr_decl ();
3645 gfc_match_intent (void)
3649 intent = match_intent_spec ();
3650 if (intent == INTENT_UNKNOWN)
3653 gfc_clear_attr (¤t_attr);
3654 current_attr.intent = intent;
3656 return attr_decl ();
3661 gfc_match_intrinsic (void)
3664 gfc_clear_attr (¤t_attr);
3665 current_attr.intrinsic = 1;
3667 return attr_decl ();
3672 gfc_match_optional (void)
3675 gfc_clear_attr (¤t_attr);
3676 current_attr.optional = 1;
3678 return attr_decl ();
3683 gfc_match_pointer (void)
3685 gfc_gobble_whitespace ();
3686 if (gfc_peek_char () == '(')
3688 if (!gfc_option.flag_cray_pointer)
3690 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3694 return cray_pointer_decl ();
3698 gfc_clear_attr (¤t_attr);
3699 current_attr.pointer = 1;
3701 return attr_decl ();
3707 gfc_match_allocatable (void)
3709 gfc_clear_attr (¤t_attr);
3710 current_attr.allocatable = 1;
3712 return attr_decl ();
3717 gfc_match_dimension (void)
3719 gfc_clear_attr (¤t_attr);
3720 current_attr.dimension = 1;
3722 return attr_decl ();
3727 gfc_match_target (void)
3729 gfc_clear_attr (¤t_attr);
3730 current_attr.target = 1;
3732 return attr_decl ();
3736 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3740 access_attr_decl (gfc_statement st)
3742 char name[GFC_MAX_SYMBOL_LEN + 1];
3743 interface_type type;
3746 gfc_intrinsic_op operator;
3749 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3754 m = gfc_match_generic_spec (&type, name, &operator);
3757 if (m == MATCH_ERROR)
3762 case INTERFACE_NAMELESS:
3765 case INTERFACE_GENERIC:
3766 if (gfc_get_symbol (name, NULL, &sym))
3769 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
3770 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3771 sym->name, NULL) == FAILURE)
3776 case INTERFACE_INTRINSIC_OP:
3777 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3779 gfc_current_ns->operator_access[operator] =
3780 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3784 gfc_error ("Access specification of the %s operator at %C has "
3785 "already been specified", gfc_op2string (operator));
3791 case INTERFACE_USER_OP:
3792 uop = gfc_get_uop (name);
3794 if (uop->access == ACCESS_UNKNOWN)
3796 uop->access = (st == ST_PUBLIC)
3797 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3801 gfc_error ("Access specification of the .%s. operator at %C "
3802 "has already been specified", sym->name);
3809 if (gfc_match_char (',') == MATCH_NO)
3813 if (gfc_match_eos () != MATCH_YES)
3818 gfc_syntax_error (st);
3826 gfc_match_protected (void)
3831 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3833 gfc_error ("PROTECTED at %C only allowed in specification "
3834 "part of a module");
3839 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
3843 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3848 if (gfc_match_eos () == MATCH_YES)
3853 m = gfc_match_symbol (&sym, 0);
3857 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
3870 if (gfc_match_eos () == MATCH_YES)
3872 if (gfc_match_char (',') != MATCH_YES)
3879 gfc_error ("Syntax error in PROTECTED statement at %C");
3884 /* The PRIVATE statement is a bit weird in that it can be a attribute
3885 declaration, but also works as a standlone statement inside of a
3886 type declaration or a module. */
3889 gfc_match_private (gfc_statement *st)
3892 if (gfc_match ("private") != MATCH_YES)
3895 if (gfc_current_state () == COMP_DERIVED)
3897 if (gfc_match_eos () == MATCH_YES)
3903 gfc_syntax_error (ST_PRIVATE);
3907 if (gfc_match_eos () == MATCH_YES)
3914 return access_attr_decl (ST_PRIVATE);
3919 gfc_match_public (gfc_statement *st)
3922 if (gfc_match ("public") != MATCH_YES)
3925 if (gfc_match_eos () == MATCH_YES)
3932 return access_attr_decl (ST_PUBLIC);
3936 /* Workhorse for gfc_match_parameter. */
3945 m = gfc_match_symbol (&sym, 0);
3947 gfc_error ("Expected variable name at %C in PARAMETER statement");
3952 if (gfc_match_char ('=') == MATCH_NO)
3954 gfc_error ("Expected = sign in PARAMETER statement at %C");
3958 m = gfc_match_init_expr (&init);
3960 gfc_error ("Expected expression at %C in PARAMETER statement");
3964 if (sym->ts.type == BT_UNKNOWN
3965 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3971 if (gfc_check_assign_symbol (sym, init) == FAILURE
3972 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3978 if (sym->ts.type == BT_CHARACTER
3979 && sym->ts.cl != NULL
3980 && sym->ts.cl->length != NULL
3981 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3982 && init->expr_type == EXPR_CONSTANT
3983 && init->ts.type == BT_CHARACTER
3984 && init->ts.kind == 1)
3985 gfc_set_constant_character_len (
3986 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
3992 gfc_free_expr (init);
3997 /* Match a parameter statement, with the weird syntax that these have. */
4000 gfc_match_parameter (void)
4004 if (gfc_match_char ('(') == MATCH_NO)
4013 if (gfc_match (" )%t") == MATCH_YES)
4016 if (gfc_match_char (',') != MATCH_YES)
4018 gfc_error ("Unexpected characters in PARAMETER statement at %C");
4028 /* Save statements have a special syntax. */
4031 gfc_match_save (void)
4033 char n[GFC_MAX_SYMBOL_LEN+1];
4038 if (gfc_match_eos () == MATCH_YES)
4040 if (gfc_current_ns->seen_save)
4042 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
4043 "follows previous SAVE statement")
4048 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4052 if (gfc_current_ns->save_all)
4054 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
4055 "blanket SAVE statement")
4064 m = gfc_match_symbol (&sym, 0);
4068 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
4080 m = gfc_match (" / %n /", &n);
4081 if (m == MATCH_ERROR)
4086 c = gfc_get_common (n, 0);
4089 gfc_current_ns->seen_save = 1;
4092 if (gfc_match_eos () == MATCH_YES)
4094 if (gfc_match_char (',') != MATCH_YES)
4101 gfc_error ("Syntax error in SAVE statement at %C");
4107 gfc_match_value (void)
4112 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
4116 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4121 if (gfc_match_eos () == MATCH_YES)
4126 m = gfc_match_symbol (&sym, 0);
4130 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
4143 if (gfc_match_eos () == MATCH_YES)
4145 if (gfc_match_char (',') != MATCH_YES)
4152 gfc_error ("Syntax error in VALUE statement at %C");
4157 gfc_match_volatile (void)
4162 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
4166 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4171 if (gfc_match_eos () == MATCH_YES)
4176 /* VOLATILE is special because it can be added to host-associated
4178 m = gfc_match_symbol (&sym, 1);
4182 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
4195 if (gfc_match_eos () == MATCH_YES)
4197 if (gfc_match_char (',') != MATCH_YES)
4204 gfc_error ("Syntax error in VOLATILE statement at %C");
4210 /* Match a module procedure statement. Note that we have to modify
4211 symbols in the parent's namespace because the current one was there
4212 to receive symbols that are in an interface's formal argument list. */
4215 gfc_match_modproc (void)
4217 char name[GFC_MAX_SYMBOL_LEN + 1];
4221 if (gfc_state_stack->state != COMP_INTERFACE
4222 || gfc_state_stack->previous == NULL
4223 || current_interface.type == INTERFACE_NAMELESS)
4225 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4232 m = gfc_match_name (name);
4238 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4241 if (sym->attr.proc != PROC_MODULE
4242 && gfc_add_procedure (&sym->attr, PROC_MODULE,
4243 sym->name, NULL) == FAILURE)
4246 if (gfc_add_interface (sym) == FAILURE)
4249 sym->attr.mod_proc = 1;
4251 if (gfc_match_eos () == MATCH_YES)
4253 if (gfc_match_char (',') != MATCH_YES)
4260 gfc_syntax_error (ST_MODULE_PROC);
4265 /* Match the beginning of a derived type declaration. If a type name
4266 was the result of a function, then it is possible to have a symbol
4267 already to be known as a derived type yet have no components. */
4270 gfc_match_derived_decl (void)
4272 char name[GFC_MAX_SYMBOL_LEN + 1];
4273 symbol_attribute attr;
4277 if (gfc_current_state () == COMP_DERIVED)
4280 gfc_clear_attr (&attr);
4283 if (gfc_match (" , private") == MATCH_YES)
4285 if (gfc_find_state (COMP_MODULE) == FAILURE)
4287 gfc_error ("Derived type at %C can only be PRIVATE within a MODULE");
4291 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4296 if (gfc_match (" , public") == MATCH_YES)
4298 if (gfc_find_state (COMP_MODULE) == FAILURE)
4300 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4304 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4309 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4311 gfc_error ("Expected :: in TYPE definition at %C");
4315 m = gfc_match (" %n%t", name);
4319 /* Make sure the name isn't the name of an intrinsic type. The
4320 'double precision' type doesn't get past the name matcher. */
4321 if (strcmp (name, "integer") == 0
4322 || strcmp (name, "real") == 0
4323 || strcmp (name, "character") == 0
4324 || strcmp (name, "logical") == 0
4325 || strcmp (name, "complex") == 0)
4327 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4332 if (gfc_get_symbol (name, NULL, &sym))
4335 if (sym->ts.type != BT_UNKNOWN)
4337 gfc_error ("Derived type name '%s' at %C already has a basic type "
4338 "of %s", sym->name, gfc_typename (&sym->ts));
4342 /* The symbol may already have the derived attribute without the
4343 components. The ways this can happen is via a function
4344 definition, an INTRINSIC statement or a subtype in another
4345 derived type that is a pointer. The first part of the AND clause
4346 is true if a the symbol is not the return value of a function. */
4347 if (sym->attr.flavor != FL_DERIVED
4348 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4351 if (sym->components != NULL)
4353 gfc_error ("Derived type definition of '%s' at %C has already been "
4354 "defined", sym->name);
4358 if (attr.access != ACCESS_UNKNOWN
4359 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4362 gfc_new_block = sym;
4368 /* Cray Pointees can be declared as:
4369 pointer (ipt, a (n,m,...,*))
4370 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4371 cheat and set a constant bound of 1 for the last dimension, if this
4372 is the case. Since there is no bounds-checking for Cray Pointees,
4373 this will be okay. */
4376 gfc_mod_pointee_as (gfc_array_spec *as)
4378 as->cray_pointee = true; /* This will be useful to know later. */
4379 if (as->type == AS_ASSUMED_SIZE)
4381 as->type = AS_EXPLICIT;
4382 as->upper[as->rank - 1] = gfc_int_expr (1);
4383 as->cp_was_assumed = true;
4385 else if (as->type == AS_ASSUMED_SHAPE)
4387 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4394 /* Match the enum definition statement, here we are trying to match
4395 the first line of enum definition statement.
4396 Returns MATCH_YES if match is found. */
4399 gfc_match_enum (void)
4403 m = gfc_match_eos ();
4407 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
4415 /* Match a variable name with an optional initializer. When this
4416 subroutine is called, a variable is expected to be parsed next.
4417 Depending on what is happening at the moment, updates either the
4418 symbol table or the current interface. */
4421 enumerator_decl (void)
4423 char name[GFC_MAX_SYMBOL_LEN + 1];
4424 gfc_expr *initializer;
4425 gfc_array_spec *as = NULL;
4433 old_locus = gfc_current_locus;
4435 /* When we get here, we've just matched a list of attributes and
4436 maybe a type and a double colon. The next thing we expect to see
4437 is the name of the symbol. */
4438 m = gfc_match_name (name);
4442 var_locus = gfc_current_locus;
4444 /* OK, we've successfully matched the declaration. Now put the
4445 symbol in the current namespace. If we fail to create the symbol,
4447 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
4453 /* The double colon must be present in order to have initializers.
4454 Otherwise the statement is ambiguous with an assignment statement. */
4457 if (gfc_match_char ('=') == MATCH_YES)
4459 m = gfc_match_init_expr (&initializer);
4462 gfc_error ("Expected an initialization expression at %C");
4471 /* If we do not have an initializer, the initialization value of the
4472 previous enumerator (stored in last_initializer) is incremented
4473 by 1 and is used to initialize the current enumerator. */
4474 if (initializer == NULL)
4475 initializer = gfc_enum_initializer (last_initializer, old_locus);
4477 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
4479 gfc_error("ENUMERATOR %L not initialized with integer expression",
4482 gfc_free_enum_history ();
4486 /* Store this current initializer, for the next enumerator variable
4487 to be parsed. add_init_expr_to_sym() zeros initializer, so we
4488 use last_initializer below. */
4489 last_initializer = initializer;
4490 t = add_init_expr_to_sym (name, &initializer, &var_locus);
4492 /* Maintain enumerator history. */
4493 gfc_find_symbol (name, NULL, 0, &sym);
4494 create_enum_history (sym, last_initializer);
4496 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
4499 /* Free stuff up and return. */
4500 gfc_free_expr (initializer);
4506 /* Match the enumerator definition statement. */
4509 gfc_match_enumerator_def (void)
4514 gfc_clear_ts (¤t_ts);
4516 m = gfc_match (" enumerator");
4520 m = gfc_match (" :: ");
4521 if (m == MATCH_ERROR)
4524 colon_seen = (m == MATCH_YES);
4526 if (gfc_current_state () != COMP_ENUM)
4528 gfc_error ("ENUM definition statement expected before %C");
4529 gfc_free_enum_history ();
4533 (¤t_ts)->type = BT_INTEGER;
4534 (¤t_ts)->kind = gfc_c_int_kind;
4536 gfc_clear_attr (¤t_attr);
4537 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
4546 m = enumerator_decl ();
4547 if (m == MATCH_ERROR)
4552 if (gfc_match_eos () == MATCH_YES)
4554 if (gfc_match_char (',') != MATCH_YES)
4558 if (gfc_current_state () == COMP_ENUM)
4560 gfc_free_enum_history ();
4561 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4566 gfc_free_array_spec (current_as);