1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* This flag is set if an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector;
35 /* When variables acquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts;
42 static symbol_attribute current_attr;
43 static gfc_array_spec *current_as;
44 static int colon_seen;
46 /* gfc_new_block points to the symbol of a newly matched block. */
48 gfc_symbol *gfc_new_block;
51 /********************* DATA statement subroutines *********************/
53 /* Free a gfc_data_variable structure and everything beneath it. */
56 free_variable (gfc_data_variable * p)
63 gfc_free_expr (p->expr);
64 gfc_free_iterator (&p->iter, 0);
65 free_variable (p->list);
72 /* Free a gfc_data_value structure and everything beneath it. */
75 free_value (gfc_data_value * p)
82 gfc_free_expr (p->expr);
88 /* Free a list of gfc_data structures. */
91 gfc_free_data (gfc_data * p)
99 free_variable (p->var);
100 free_value (p->value);
107 static match var_element (gfc_data_variable *);
109 /* Match a list of variables terminated by an iterator and a right
113 var_list (gfc_data_variable * parent)
115 gfc_data_variable *tail, var;
118 m = var_element (&var);
119 if (m == MATCH_ERROR)
124 tail = gfc_get_data_variable ();
131 if (gfc_match_char (',') != MATCH_YES)
134 m = gfc_match_iterator (&parent->iter, 1);
137 if (m == MATCH_ERROR)
140 m = var_element (&var);
141 if (m == MATCH_ERROR)
146 tail->next = gfc_get_data_variable ();
152 if (gfc_match_char (')') != MATCH_YES)
157 gfc_syntax_error (ST_DATA);
162 /* Match a single element in a data variable list, which can be a
163 variable-iterator list. */
166 var_element (gfc_data_variable * new)
171 memset (new, 0, sizeof (gfc_data_variable));
173 if (gfc_match_char ('(') == MATCH_YES)
174 return var_list (new);
176 m = gfc_match_variable (&new->expr, 0);
180 sym = new->expr->symtree->n.sym;
182 if(sym->value != NULL)
184 gfc_error ("Variable '%s' at %C already has an initialization",
189 #if 0 /* TODO: Find out where to move this message */
190 if (sym->attr.in_common)
191 /* See if sym is in the blank common block. */
192 for (t = &sym->ns->blank_common; t; t = t->common_next)
195 gfc_error ("DATA statement at %C may not initialize variable "
196 "'%s' from blank COMMON", sym->name);
201 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
208 /* Match the top-level list of data variables. */
211 top_var_list (gfc_data * d)
213 gfc_data_variable var, *tail, *new;
220 m = var_element (&var);
223 if (m == MATCH_ERROR)
226 new = gfc_get_data_variable ();
236 if (gfc_match_char ('/') == MATCH_YES)
238 if (gfc_match_char (',') != MATCH_YES)
245 gfc_syntax_error (ST_DATA);
251 match_data_constant (gfc_expr ** result)
253 char name[GFC_MAX_SYMBOL_LEN + 1];
258 m = gfc_match_literal_constant (&expr, 1);
265 if (m == MATCH_ERROR)
268 m = gfc_match_null (result);
272 m = gfc_match_name (name);
276 if (gfc_find_symbol (name, NULL, 1, &sym))
280 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
282 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
286 else if (sym->attr.flavor == FL_DERIVED)
287 return gfc_match_structure_constructor (sym, result);
289 *result = gfc_copy_expr (sym->value);
294 /* Match a list of values in a DATA statement. The leading '/' has
295 already been seen at this point. */
298 top_val_list (gfc_data * data)
300 gfc_data_value *new, *tail;
309 m = match_data_constant (&expr);
312 if (m == MATCH_ERROR)
315 new = gfc_get_data_value ();
324 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
332 msg = gfc_extract_int (expr, &tmp);
333 gfc_free_expr (expr);
341 m = match_data_constant (&tail->expr);
344 if (m == MATCH_ERROR)
348 if (gfc_match_char ('/') == MATCH_YES)
350 if (gfc_match_char (',') == MATCH_NO)
357 gfc_syntax_error (ST_DATA);
362 /* Matches an old style initialization. */
365 match_old_style_init (const char *name)
371 /* Set up data structure to hold initializers. */
372 gfc_find_sym_tree (name, NULL, 0, &st);
374 newdata = gfc_get_data ();
375 newdata->var = gfc_get_data_variable ();
376 newdata->var->expr = gfc_get_variable_expr (st);
378 /* Match initial value list. This also eats the terminal
380 m = top_val_list (newdata);
389 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
394 /* Chain in namespace list of DATA initializers. */
395 newdata->next = gfc_current_ns->data;
396 gfc_current_ns->data = newdata;
401 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
402 we are matching a DATA statement and are therefore issuing an error
403 if we encounter something unexpected, if not, we're trying to match
404 an old-style initialization expression of the form INTEGER I /2/. */
407 gfc_match_data (void)
414 new = gfc_get_data ();
415 new->where = gfc_current_locus;
417 m = top_var_list (new);
421 m = top_val_list (new);
425 new->next = gfc_current_ns->data;
426 gfc_current_ns->data = new;
428 if (gfc_match_eos () == MATCH_YES)
431 gfc_match_char (','); /* Optional comma */
436 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
448 /************************ Declaration statements *********************/
450 /* Match an intent specification. Since this can only happen after an
451 INTENT word, a legal intent-spec must follow. */
454 match_intent_spec (void)
457 if (gfc_match (" ( in out )") == MATCH_YES)
459 if (gfc_match (" ( in )") == MATCH_YES)
461 if (gfc_match (" ( out )") == MATCH_YES)
464 gfc_error ("Bad INTENT specification at %C");
465 return INTENT_UNKNOWN;
469 /* Matches a character length specification, which is either a
470 specification expression or a '*'. */
473 char_len_param_value (gfc_expr ** expr)
476 if (gfc_match_char ('*') == MATCH_YES)
482 return gfc_match_expr (expr);
486 /* A character length is a '*' followed by a literal integer or a
487 char_len_param_value in parenthesis. */
490 match_char_length (gfc_expr ** expr)
495 m = gfc_match_char ('*');
499 m = gfc_match_small_literal_int (&length);
500 if (m == MATCH_ERROR)
505 *expr = gfc_int_expr (length);
509 if (gfc_match_char ('(') == MATCH_NO)
512 m = char_len_param_value (expr);
513 if (m == MATCH_ERROR)
518 if (gfc_match_char (')') == MATCH_NO)
520 gfc_free_expr (*expr);
528 gfc_error ("Syntax error in character length specification at %C");
533 /* Special subroutine for finding a symbol. Check if the name is found
534 in the current name space. If not, and we're compiling a function or
535 subroutine and the parent compilation unit is an interface, then check
536 to see if the name we've been given is the name of the interface
537 (located in another namespace). */
540 find_special (const char *name, gfc_symbol ** result)
545 i = gfc_get_symbol (name, NULL, result);
549 if (gfc_current_state () != COMP_SUBROUTINE
550 && gfc_current_state () != COMP_FUNCTION)
553 s = gfc_state_stack->previous;
557 if (s->state != COMP_INTERFACE)
560 goto end; /* Nameless interface */
562 if (strcmp (name, s->sym->name) == 0)
573 /* Special subroutine for getting a symbol node associated with a
574 procedure name, used in SUBROUTINE and FUNCTION statements. The
575 symbol is created in the parent using with symtree node in the
576 child unit pointing to the symbol. If the current namespace has no
577 parent, then the symbol is just created in the current unit. */
580 get_proc_name (const char *name, gfc_symbol ** result)
586 if (gfc_current_ns->parent == NULL)
587 return gfc_get_symbol (name, NULL, result);
589 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
593 /* ??? Deal with ENTRY problem */
595 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
601 /* See if the procedure should be a module procedure */
603 if (sym->ns->proc_name != NULL
604 && sym->ns->proc_name->attr.flavor == FL_MODULE
605 && sym->attr.proc != PROC_MODULE
606 && gfc_add_procedure (&sym->attr, PROC_MODULE,
607 sym->name, NULL) == FAILURE)
614 /* Function called by variable_decl() that adds a name to the symbol
618 build_sym (const char *name, gfc_charlen * cl,
619 gfc_array_spec ** as, locus * var_locus)
621 symbol_attribute attr;
624 /* if (find_special (name, &sym)) */
625 if (gfc_get_symbol (name, NULL, &sym))
628 /* Start updating the symbol table. Add basic type attribute
630 if (current_ts.type != BT_UNKNOWN
631 &&(sym->attr.implicit_type == 0
632 || !gfc_compare_types (&sym->ts, ¤t_ts))
633 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
636 if (sym->ts.type == BT_CHARACTER)
639 /* Add dimension attribute if present. */
640 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
644 /* Add attribute to symbol. The copy is so that we can reset the
645 dimension attribute. */
649 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
655 /* Set character constant to the given length. The constant will be padded or
659 gfc_set_constant_character_len (int len, gfc_expr * expr)
664 gcc_assert (expr->expr_type == EXPR_CONSTANT);
665 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
667 slen = expr->value.character.length;
670 s = gfc_getmem (len);
671 memcpy (s, expr->value.character.string, MIN (len, slen));
673 memset (&s[slen], ' ', len - slen);
674 gfc_free (expr->value.character.string);
675 expr->value.character.string = s;
676 expr->value.character.length = len;
680 /* Function called by variable_decl() that adds an initialization
681 expression to a symbol. */
684 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
687 symbol_attribute attr;
692 if (find_special (name, &sym))
697 /* If this symbol is confirming an implicit parameter type,
698 then an initialization expression is not allowed. */
699 if (attr.flavor == FL_PARAMETER
700 && sym->value != NULL
703 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
712 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
719 /* An initializer is required for PARAMETER declarations. */
720 if (attr.flavor == FL_PARAMETER)
722 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
728 /* If a variable appears in a DATA block, it cannot have an
733 ("Variable '%s' at %C with an initializer already appears "
734 "in a DATA statement", sym->name);
738 /* Check if the assignment can happen. This has to be put off
739 until later for a derived type variable. */
740 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
741 && gfc_check_assign_symbol (sym, init) == FAILURE)
744 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
746 /* Update symbol character length according initializer. */
747 if (sym->ts.cl->length == NULL)
749 /* If there are multiple CHARACTER variables declared on
750 the same line, we don't want them to share the same
752 sym->ts.cl = gfc_get_charlen ();
753 sym->ts.cl->next = gfc_current_ns->cl_list;
754 gfc_current_ns->cl_list = sym->ts.cl;
756 if (init->expr_type == EXPR_CONSTANT)
758 gfc_int_expr (init->value.character.length);
759 else if (init->expr_type == EXPR_ARRAY)
760 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
762 /* Update initializer character length according symbol. */
763 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
765 int len = mpz_get_si (sym->ts.cl->length->value.integer);
768 if (init->expr_type == EXPR_CONSTANT)
769 gfc_set_constant_character_len (len, init);
770 else if (init->expr_type == EXPR_ARRAY)
772 gfc_free_expr (init->ts.cl->length);
773 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
774 for (p = init->value.constructor; p; p = p->next)
775 gfc_set_constant_character_len (len, p->expr);
780 /* Add initializer. Make sure we keep the ranks sane. */
781 if (sym->attr.dimension && init->rank == 0)
782 init->rank = sym->as->rank;
792 /* Function called by variable_decl() that adds a name to a structure
796 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
797 gfc_array_spec ** as)
801 /* If the current symbol is of the same derived type that we're
802 constructing, it must have the pointer attribute. */
803 if (current_ts.type == BT_DERIVED
804 && current_ts.derived == gfc_current_block ()
805 && current_attr.pointer == 0)
807 gfc_error ("Component at %C must have the POINTER attribute");
811 if (gfc_current_block ()->attr.pointer
814 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
816 gfc_error ("Array component of structure at %C must have explicit "
817 "or deferred shape");
822 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
827 gfc_set_component_attr (c, ¤t_attr);
829 c->initializer = *init;
837 /* Check array components. */
843 if (c->as->type != AS_DEFERRED)
845 gfc_error ("Pointer array component of structure at %C "
846 "must have a deferred shape");
852 if (c->as->type != AS_EXPLICIT)
855 ("Array component of structure at %C must have an explicit "
865 /* Match a 'NULL()', and possibly take care of some side effects. */
868 gfc_match_null (gfc_expr ** result)
874 m = gfc_match (" null ( )");
878 /* The NULL symbol now has to be/become an intrinsic function. */
879 if (gfc_get_symbol ("null", NULL, &sym))
881 gfc_error ("NULL() initialization at %C is ambiguous");
885 gfc_intrinsic_symbol (sym);
887 if (sym->attr.proc != PROC_INTRINSIC
888 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
889 sym->name, NULL) == FAILURE
890 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
894 e->where = gfc_current_locus;
895 e->expr_type = EXPR_NULL;
896 e->ts.type = BT_UNKNOWN;
904 /* Match a variable name with an optional initializer. When this
905 subroutine is called, a variable is expected to be parsed next.
906 Depending on what is happening at the moment, updates either the
907 symbol table or the current interface. */
910 variable_decl (int elem)
912 char name[GFC_MAX_SYMBOL_LEN + 1];
913 gfc_expr *initializer, *char_len;
923 /* When we get here, we've just matched a list of attributes and
924 maybe a type and a double colon. The next thing we expect to see
925 is the name of the symbol. */
926 m = gfc_match_name (name);
930 var_locus = gfc_current_locus;
932 /* Now we could see the optional array spec. or character length. */
933 m = gfc_match_array_spec (&as);
934 if (m == MATCH_ERROR)
937 as = gfc_copy_array_spec (current_as);
942 if (current_ts.type == BT_CHARACTER)
944 switch (match_char_length (&char_len))
947 cl = gfc_get_charlen ();
948 cl->next = gfc_current_ns->cl_list;
949 gfc_current_ns->cl_list = cl;
951 cl->length = char_len;
954 /* Non-constant lengths need to be copied after the first
957 if (elem > 1 && current_ts.cl->length
958 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
960 cl = gfc_get_charlen ();
961 cl->next = gfc_current_ns->cl_list;
962 gfc_current_ns->cl_list = cl;
963 cl->length = gfc_copy_expr (current_ts.cl->length);
975 /* OK, we've successfully matched the declaration. Now put the
976 symbol in the current namespace, because it might be used in the
977 optional initialization expression for this symbol, e.g. this is
980 integer, parameter :: i = huge(i)
982 This is only true for parameters or variables of a basic type.
983 For components of derived types, it is not true, so we don't
984 create a symbol for those yet. If we fail to create the symbol,
986 if (gfc_current_state () != COMP_DERIVED
987 && build_sym (name, cl, &as, &var_locus) == FAILURE)
993 /* In functions that have a RESULT variable defined, the function
994 name always refers to function calls. Therefore, the name is
995 not allowed to appear in specification statements. */
996 if (gfc_current_state () == COMP_FUNCTION
997 && gfc_current_block () != NULL
998 && gfc_current_block ()->result != NULL
999 && gfc_current_block ()->result != gfc_current_block ()
1000 && strcmp (gfc_current_block ()->name, name) == 0)
1002 gfc_error ("Function name '%s' not allowed at %C", name);
1007 /* We allow old-style initializations of the form
1008 integer i /2/, j(4) /3*3, 1/
1009 (if no colon has been seen). These are different from data
1010 statements in that initializers are only allowed to apply to the
1011 variable immediately preceding, i.e.
1013 is not allowed. Therefore we have to do some work manually, that
1014 could otherwise be left to the matchers for DATA statements. */
1016 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1018 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1019 "initialization at %C") == FAILURE)
1022 return match_old_style_init (name);
1025 /* The double colon must be present in order to have initializers.
1026 Otherwise the statement is ambiguous with an assignment statement. */
1029 if (gfc_match (" =>") == MATCH_YES)
1032 if (!current_attr.pointer)
1034 gfc_error ("Initialization at %C isn't for a pointer variable");
1039 m = gfc_match_null (&initializer);
1042 gfc_error ("Pointer initialization requires a NULL at %C");
1046 if (gfc_pure (NULL))
1049 ("Initialization of pointer at %C is not allowed in a "
1057 initializer->ts = current_ts;
1060 else if (gfc_match_char ('=') == MATCH_YES)
1062 if (current_attr.pointer)
1065 ("Pointer initialization at %C requires '=>', not '='");
1070 m = gfc_match_init_expr (&initializer);
1073 gfc_error ("Expected an initialization expression at %C");
1077 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1080 ("Initialization of variable at %C is not allowed in a "
1090 /* Add the initializer. Note that it is fine if initializer is
1091 NULL here, because we sometimes also need to check if a
1092 declaration *must* have an initialization expression. */
1093 if (gfc_current_state () != COMP_DERIVED)
1094 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1097 if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
1098 initializer = gfc_default_initializer (¤t_ts);
1099 t = build_struct (name, cl, &initializer, &as);
1102 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1105 /* Free stuff up and return. */
1106 gfc_free_expr (initializer);
1107 gfc_free_array_spec (as);
1113 /* Match an extended-f77 kind specification. */
1116 gfc_match_old_kind_spec (gfc_typespec * ts)
1120 if (gfc_match_char ('*') != MATCH_YES)
1123 m = gfc_match_small_literal_int (&ts->kind);
1127 /* Massage the kind numbers for complex types. */
1128 if (ts->type == BT_COMPLEX && ts->kind == 8)
1130 if (ts->type == BT_COMPLEX && ts->kind == 16)
1133 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1135 gfc_error ("Old-style kind %d not supported for type %s at %C",
1136 ts->kind, gfc_basic_typename (ts->type));
1145 /* Match a kind specification. Since kinds are generally optional, we
1146 usually return MATCH_NO if something goes wrong. If a "kind="
1147 string is found, then we know we have an error. */
1150 gfc_match_kind_spec (gfc_typespec * ts)
1160 where = gfc_current_locus;
1162 if (gfc_match_char ('(') == MATCH_NO)
1165 /* Also gobbles optional text. */
1166 if (gfc_match (" kind = ") == MATCH_YES)
1169 n = gfc_match_init_expr (&e);
1171 gfc_error ("Expected initialization expression at %C");
1177 gfc_error ("Expected scalar initialization expression at %C");
1182 msg = gfc_extract_int (e, &ts->kind);
1193 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1195 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1196 gfc_basic_typename (ts->type));
1202 if (gfc_match_char (')') != MATCH_YES)
1204 gfc_error ("Missing right paren at %C");
1212 gfc_current_locus = where;
1217 /* Match the various kind/length specifications in a CHARACTER
1218 declaration. We don't return MATCH_NO. */
1221 match_char_spec (gfc_typespec * ts)
1223 int i, kind, seen_length;
1228 kind = gfc_default_character_kind;
1232 /* Try the old-style specification first. */
1233 old_char_selector = 0;
1235 m = match_char_length (&len);
1239 old_char_selector = 1;
1244 m = gfc_match_char ('(');
1247 m = MATCH_YES; /* character without length is a single char */
1251 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1252 if (gfc_match (" kind =") == MATCH_YES)
1254 m = gfc_match_small_int (&kind);
1255 if (m == MATCH_ERROR)
1260 if (gfc_match (" , len =") == MATCH_NO)
1263 m = char_len_param_value (&len);
1266 if (m == MATCH_ERROR)
1273 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1274 if (gfc_match (" len =") == MATCH_YES)
1276 m = char_len_param_value (&len);
1279 if (m == MATCH_ERROR)
1283 if (gfc_match_char (')') == MATCH_YES)
1286 if (gfc_match (" , kind =") != MATCH_YES)
1289 gfc_match_small_int (&kind);
1291 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1293 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1300 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1301 m = char_len_param_value (&len);
1304 if (m == MATCH_ERROR)
1308 m = gfc_match_char (')');
1312 if (gfc_match_char (',') != MATCH_YES)
1315 gfc_match (" kind ="); /* Gobble optional text */
1317 m = gfc_match_small_int (&kind);
1318 if (m == MATCH_ERROR)
1324 /* Require a right-paren at this point. */
1325 m = gfc_match_char (')');
1330 gfc_error ("Syntax error in CHARACTER declaration at %C");
1334 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1336 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1342 gfc_free_expr (len);
1346 /* Do some final massaging of the length values. */
1347 cl = gfc_get_charlen ();
1348 cl->next = gfc_current_ns->cl_list;
1349 gfc_current_ns->cl_list = cl;
1351 if (seen_length == 0)
1352 cl->length = gfc_int_expr (1);
1355 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1359 gfc_free_expr (len);
1360 cl->length = gfc_int_expr (0);
1371 /* Matches a type specification. If successful, sets the ts structure
1372 to the matched specification. This is necessary for FUNCTION and
1373 IMPLICIT statements.
1375 If implicit_flag is nonzero, then we don't check for the optional
1376 kind specification. Not doing so is needed for matching an IMPLICIT
1377 statement correctly. */
1380 match_type_spec (gfc_typespec * ts, int implicit_flag)
1382 char name[GFC_MAX_SYMBOL_LEN + 1];
1389 if (gfc_match (" integer") == MATCH_YES)
1391 ts->type = BT_INTEGER;
1392 ts->kind = gfc_default_integer_kind;
1396 if (gfc_match (" character") == MATCH_YES)
1398 ts->type = BT_CHARACTER;
1399 if (implicit_flag == 0)
1400 return match_char_spec (ts);
1405 if (gfc_match (" real") == MATCH_YES)
1408 ts->kind = gfc_default_real_kind;
1412 if (gfc_match (" double precision") == MATCH_YES)
1415 ts->kind = gfc_default_double_kind;
1419 if (gfc_match (" complex") == MATCH_YES)
1421 ts->type = BT_COMPLEX;
1422 ts->kind = gfc_default_complex_kind;
1426 if (gfc_match (" double complex") == MATCH_YES)
1428 ts->type = BT_COMPLEX;
1429 ts->kind = gfc_default_double_kind;
1433 if (gfc_match (" logical") == MATCH_YES)
1435 ts->type = BT_LOGICAL;
1436 ts->kind = gfc_default_logical_kind;
1440 m = gfc_match (" type ( %n )", name);
1444 /* Search for the name but allow the components to be defined later. */
1445 if (gfc_get_ha_symbol (name, &sym))
1447 gfc_error ("Type name '%s' at %C is ambiguous", name);
1451 if (sym->attr.flavor != FL_DERIVED
1452 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1455 ts->type = BT_DERIVED;
1462 /* For all types except double, derived and character, look for an
1463 optional kind specifier. MATCH_NO is actually OK at this point. */
1464 if (implicit_flag == 1)
1467 if (gfc_current_form == FORM_FREE)
1469 c = gfc_peek_char();
1470 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1471 && c != ':' && c != ',')
1475 m = gfc_match_kind_spec (ts);
1476 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1477 m = gfc_match_old_kind_spec (ts);
1480 m = MATCH_YES; /* No kind specifier found. */
1486 /* Match an IMPLICIT NONE statement. Actually, this statement is
1487 already matched in parse.c, or we would not end up here in the
1488 first place. So the only thing we need to check, is if there is
1489 trailing garbage. If not, the match is successful. */
1492 gfc_match_implicit_none (void)
1495 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1499 /* Match the letter range(s) of an IMPLICIT statement. */
1502 match_implicit_range (void)
1504 int c, c1, c2, inner;
1507 cur_loc = gfc_current_locus;
1509 gfc_gobble_whitespace ();
1510 c = gfc_next_char ();
1513 gfc_error ("Missing character range in IMPLICIT at %C");
1520 gfc_gobble_whitespace ();
1521 c1 = gfc_next_char ();
1525 gfc_gobble_whitespace ();
1526 c = gfc_next_char ();
1531 inner = 0; /* Fall through */
1538 gfc_gobble_whitespace ();
1539 c2 = gfc_next_char ();
1543 gfc_gobble_whitespace ();
1544 c = gfc_next_char ();
1546 if ((c != ',') && (c != ')'))
1559 gfc_error ("Letters must be in alphabetic order in "
1560 "IMPLICIT statement at %C");
1564 /* See if we can add the newly matched range to the pending
1565 implicits from this IMPLICIT statement. We do not check for
1566 conflicts with whatever earlier IMPLICIT statements may have
1567 set. This is done when we've successfully finished matching
1569 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1576 gfc_syntax_error (ST_IMPLICIT);
1578 gfc_current_locus = cur_loc;
1583 /* Match an IMPLICIT statement, storing the types for
1584 gfc_set_implicit() if the statement is accepted by the parser.
1585 There is a strange looking, but legal syntactic construction
1586 possible. It looks like:
1588 IMPLICIT INTEGER (a-b) (c-d)
1590 This is legal if "a-b" is a constant expression that happens to
1591 equal one of the legal kinds for integers. The real problem
1592 happens with an implicit specification that looks like:
1594 IMPLICIT INTEGER (a-b)
1596 In this case, a typespec matcher that is "greedy" (as most of the
1597 matchers are) gobbles the character range as a kindspec, leaving
1598 nothing left. We therefore have to go a bit more slowly in the
1599 matching process by inhibiting the kindspec checking during
1600 typespec matching and checking for a kind later. */
1603 gfc_match_implicit (void)
1610 /* We don't allow empty implicit statements. */
1611 if (gfc_match_eos () == MATCH_YES)
1613 gfc_error ("Empty IMPLICIT statement at %C");
1619 /* First cleanup. */
1620 gfc_clear_new_implicit ();
1622 /* A basic type is mandatory here. */
1623 m = match_type_spec (&ts, 1);
1624 if (m == MATCH_ERROR)
1629 cur_loc = gfc_current_locus;
1630 m = match_implicit_range ();
1634 /* We may have <TYPE> (<RANGE>). */
1635 gfc_gobble_whitespace ();
1636 c = gfc_next_char ();
1637 if ((c == '\n') || (c == ','))
1639 /* Check for CHARACTER with no length parameter. */
1640 if (ts.type == BT_CHARACTER && !ts.cl)
1642 ts.kind = gfc_default_character_kind;
1643 ts.cl = gfc_get_charlen ();
1644 ts.cl->next = gfc_current_ns->cl_list;
1645 gfc_current_ns->cl_list = ts.cl;
1646 ts.cl->length = gfc_int_expr (1);
1649 /* Record the Successful match. */
1650 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1655 gfc_current_locus = cur_loc;
1658 /* Discard the (incorrectly) matched range. */
1659 gfc_clear_new_implicit ();
1661 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1662 if (ts.type == BT_CHARACTER)
1663 m = match_char_spec (&ts);
1666 m = gfc_match_kind_spec (&ts);
1669 m = gfc_match_old_kind_spec (&ts);
1670 if (m == MATCH_ERROR)
1676 if (m == MATCH_ERROR)
1679 m = match_implicit_range ();
1680 if (m == MATCH_ERROR)
1685 gfc_gobble_whitespace ();
1686 c = gfc_next_char ();
1687 if ((c != '\n') && (c != ','))
1690 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1698 gfc_syntax_error (ST_IMPLICIT);
1705 /* Matches an attribute specification including array specs. If
1706 successful, leaves the variables current_attr and current_as
1707 holding the specification. Also sets the colon_seen variable for
1708 later use by matchers associated with initializations.
1710 This subroutine is a little tricky in the sense that we don't know
1711 if we really have an attr-spec until we hit the double colon.
1712 Until that time, we can only return MATCH_NO. This forces us to
1713 check for duplicate specification at this level. */
1716 match_attr_spec (void)
1719 /* Modifiers that can exist in a type statement. */
1721 { GFC_DECL_BEGIN = 0,
1722 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1723 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1724 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1725 DECL_TARGET, DECL_COLON, DECL_NONE,
1726 GFC_DECL_END /* Sentinel */
1730 /* GFC_DECL_END is the sentinel, index starts at 0. */
1731 #define NUM_DECL GFC_DECL_END
1733 static mstring decls[] = {
1734 minit (", allocatable", DECL_ALLOCATABLE),
1735 minit (", dimension", DECL_DIMENSION),
1736 minit (", external", DECL_EXTERNAL),
1737 minit (", intent ( in )", DECL_IN),
1738 minit (", intent ( out )", DECL_OUT),
1739 minit (", intent ( in out )", DECL_INOUT),
1740 minit (", intrinsic", DECL_INTRINSIC),
1741 minit (", optional", DECL_OPTIONAL),
1742 minit (", parameter", DECL_PARAMETER),
1743 minit (", pointer", DECL_POINTER),
1744 minit (", private", DECL_PRIVATE),
1745 minit (", public", DECL_PUBLIC),
1746 minit (", save", DECL_SAVE),
1747 minit (", target", DECL_TARGET),
1748 minit ("::", DECL_COLON),
1749 minit (NULL, DECL_NONE)
1752 locus start, seen_at[NUM_DECL];
1759 gfc_clear_attr (¤t_attr);
1760 start = gfc_current_locus;
1765 /* See if we get all of the keywords up to the final double colon. */
1766 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1771 d = (decl_types) gfc_match_strings (decls);
1772 if (d == DECL_NONE || d == DECL_COLON)
1776 seen_at[d] = gfc_current_locus;
1778 if (d == DECL_DIMENSION)
1780 m = gfc_match_array_spec (¤t_as);
1784 gfc_error ("Missing dimension specification at %C");
1788 if (m == MATCH_ERROR)
1793 /* No double colon, so assume that we've been looking at something
1794 else the whole time. */
1801 /* Since we've seen a double colon, we have to be looking at an
1802 attr-spec. This means that we can now issue errors. */
1803 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1808 case DECL_ALLOCATABLE:
1809 attr = "ALLOCATABLE";
1811 case DECL_DIMENSION:
1818 attr = "INTENT (IN)";
1821 attr = "INTENT (OUT)";
1824 attr = "INTENT (IN OUT)";
1826 case DECL_INTRINSIC:
1832 case DECL_PARAMETER:
1851 attr = NULL; /* This shouldn't happen */
1854 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1859 /* Now that we've dealt with duplicate attributes, add the attributes
1860 to the current attribute. */
1861 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1866 if (gfc_current_state () == COMP_DERIVED
1867 && d != DECL_DIMENSION && d != DECL_POINTER
1868 && d != DECL_COLON && d != DECL_NONE)
1871 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1877 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
1878 && gfc_current_state () != COMP_MODULE)
1880 if (d == DECL_PRIVATE)
1885 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
1893 case DECL_ALLOCATABLE:
1894 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
1897 case DECL_DIMENSION:
1898 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
1902 t = gfc_add_external (¤t_attr, &seen_at[d]);
1906 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
1910 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
1914 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
1917 case DECL_INTRINSIC:
1918 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
1922 t = gfc_add_optional (¤t_attr, &seen_at[d]);
1925 case DECL_PARAMETER:
1926 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
1930 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
1934 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
1939 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
1944 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
1948 t = gfc_add_target (¤t_attr, &seen_at[d]);
1952 gfc_internal_error ("match_attr_spec(): Bad attribute");
1966 gfc_current_locus = start;
1967 gfc_free_array_spec (current_as);
1973 /* Match a data declaration statement. */
1976 gfc_match_data_decl (void)
1982 m = match_type_spec (¤t_ts, 0);
1986 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
1988 sym = gfc_use_derived (current_ts.derived);
1996 current_ts.derived = sym;
1999 m = match_attr_spec ();
2000 if (m == MATCH_ERROR)
2006 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2009 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2012 if (gfc_find_symbol (current_ts.derived->name,
2013 current_ts.derived->ns->parent, 1, &sym) == 0)
2016 /* Hope that an ambiguous symbol is itself masked by a type definition. */
2017 if (sym != NULL && sym->attr.flavor == FL_DERIVED)
2020 gfc_error ("Derived type at %C has not been previously defined");
2026 /* If we have an old-style character declaration, and no new-style
2027 attribute specifications, then there a comma is optional between
2028 the type specification and the variable list. */
2029 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2030 gfc_match_char (',');
2032 /* Give the types/attributes to symbols that follow. Give the element
2033 a number so that repeat character length expressions can be copied. */
2037 m = variable_decl (elem++);
2038 if (m == MATCH_ERROR)
2043 if (gfc_match_eos () == MATCH_YES)
2045 if (gfc_match_char (',') != MATCH_YES)
2049 gfc_error ("Syntax error in data declaration at %C");
2053 gfc_free_array_spec (current_as);
2059 /* Match a prefix associated with a function or subroutine
2060 declaration. If the typespec pointer is nonnull, then a typespec
2061 can be matched. Note that if nothing matches, MATCH_YES is
2062 returned (the null string was matched). */
2065 match_prefix (gfc_typespec * ts)
2069 gfc_clear_attr (¤t_attr);
2073 if (!seen_type && ts != NULL
2074 && match_type_spec (ts, 0) == MATCH_YES
2075 && gfc_match_space () == MATCH_YES)
2082 if (gfc_match ("elemental% ") == MATCH_YES)
2084 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2090 if (gfc_match ("pure% ") == MATCH_YES)
2092 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2098 if (gfc_match ("recursive% ") == MATCH_YES)
2100 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2106 /* At this point, the next item is not a prefix. */
2111 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2114 copy_prefix (symbol_attribute * dest, locus * where)
2117 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2120 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2123 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2130 /* Match a formal argument list. */
2133 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2135 gfc_formal_arglist *head, *tail, *p, *q;
2136 char name[GFC_MAX_SYMBOL_LEN + 1];
2142 if (gfc_match_char ('(') != MATCH_YES)
2149 if (gfc_match_char (')') == MATCH_YES)
2154 if (gfc_match_char ('*') == MATCH_YES)
2158 m = gfc_match_name (name);
2162 if (gfc_get_symbol (name, NULL, &sym))
2166 p = gfc_get_formal_arglist ();
2178 /* We don't add the VARIABLE flavor because the name could be a
2179 dummy procedure. We don't apply these attributes to formal
2180 arguments of statement functions. */
2181 if (sym != NULL && !st_flag
2182 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2183 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2189 /* The name of a program unit can be in a different namespace,
2190 so check for it explicitly. After the statement is accepted,
2191 the name is checked for especially in gfc_get_symbol(). */
2192 if (gfc_new_block != NULL && sym != NULL
2193 && strcmp (sym->name, gfc_new_block->name) == 0)
2195 gfc_error ("Name '%s' at %C is the name of the procedure",
2201 if (gfc_match_char (')') == MATCH_YES)
2204 m = gfc_match_char (',');
2207 gfc_error ("Unexpected junk in formal argument list at %C");
2213 /* Check for duplicate symbols in the formal argument list. */
2216 for (p = head; p->next; p = p->next)
2221 for (q = p->next; q; q = q->next)
2222 if (p->sym == q->sym)
2225 ("Duplicate symbol '%s' in formal argument list at %C",
2234 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2244 gfc_free_formal_arglist (head);
2249 /* Match a RESULT specification following a function declaration or
2250 ENTRY statement. Also matches the end-of-statement. */
2253 match_result (gfc_symbol * function, gfc_symbol ** result)
2255 char name[GFC_MAX_SYMBOL_LEN + 1];
2259 if (gfc_match (" result (") != MATCH_YES)
2262 m = gfc_match_name (name);
2266 if (gfc_match (" )%t") != MATCH_YES)
2268 gfc_error ("Unexpected junk following RESULT variable at %C");
2272 if (strcmp (function->name, name) == 0)
2275 ("RESULT variable at %C must be different than function name");
2279 if (gfc_get_symbol (name, NULL, &r))
2282 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2283 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2292 /* Match a function declaration. */
2295 gfc_match_function_decl (void)
2297 char name[GFC_MAX_SYMBOL_LEN + 1];
2298 gfc_symbol *sym, *result;
2302 if (gfc_current_state () != COMP_NONE
2303 && gfc_current_state () != COMP_INTERFACE
2304 && gfc_current_state () != COMP_CONTAINS)
2307 gfc_clear_ts (¤t_ts);
2309 old_loc = gfc_current_locus;
2311 m = match_prefix (¤t_ts);
2314 gfc_current_locus = old_loc;
2318 if (gfc_match ("function% %n", name) != MATCH_YES)
2320 gfc_current_locus = old_loc;
2324 if (get_proc_name (name, &sym))
2326 gfc_new_block = sym;
2328 m = gfc_match_formal_arglist (sym, 0, 0);
2330 gfc_error ("Expected formal argument list in function definition at %C");
2331 else if (m == MATCH_ERROR)
2336 if (gfc_match_eos () != MATCH_YES)
2338 /* See if a result variable is present. */
2339 m = match_result (sym, &result);
2341 gfc_error ("Unexpected junk after function declaration at %C");
2350 /* Make changes to the symbol. */
2353 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2356 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2357 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2360 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
2362 gfc_error ("Function '%s' at %C already has a type of %s", name,
2363 gfc_basic_typename (sym->ts.type));
2369 sym->ts = current_ts;
2374 result->ts = current_ts;
2375 sym->result = result;
2381 gfc_current_locus = old_loc;
2386 /* Match an ENTRY statement. */
2389 gfc_match_entry (void)
2394 char name[GFC_MAX_SYMBOL_LEN + 1];
2395 gfc_compile_state state;
2399 m = gfc_match_name (name);
2403 state = gfc_current_state ();
2404 if (state != COMP_SUBROUTINE
2405 && state != COMP_FUNCTION)
2407 gfc_error ("ENTRY statement at %C cannot appear within %s",
2408 gfc_state_name (gfc_current_state ()));
2412 if (gfc_current_ns->parent != NULL
2413 && gfc_current_ns->parent->proc_name
2414 && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
2416 gfc_error("ENTRY statement at %C cannot appear in a "
2417 "contained procedure");
2421 if (get_proc_name (name, &entry))
2424 proc = gfc_current_block ();
2426 if (state == COMP_SUBROUTINE)
2428 /* An entry in a subroutine. */
2429 m = gfc_match_formal_arglist (entry, 0, 1);
2433 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2434 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2439 /* An entry in a function. */
2440 m = gfc_match_formal_arglist (entry, 0, 1);
2446 if (gfc_match_eos () == MATCH_YES)
2448 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2449 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
2452 entry->result = entry;
2456 m = match_result (proc, &result);
2458 gfc_syntax_error (ST_ENTRY);
2462 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2463 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2464 || gfc_add_function (&entry->attr, result->name,
2468 entry->result = result;
2471 if (proc->attr.recursive && result == NULL)
2473 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2478 if (gfc_match_eos () != MATCH_YES)
2480 gfc_syntax_error (ST_ENTRY);
2484 entry->attr.recursive = proc->attr.recursive;
2485 entry->attr.elemental = proc->attr.elemental;
2486 entry->attr.pure = proc->attr.pure;
2488 el = gfc_get_entry_list ();
2490 el->next = gfc_current_ns->entries;
2491 gfc_current_ns->entries = el;
2493 el->id = el->next->id + 1;
2497 new_st.op = EXEC_ENTRY;
2498 new_st.ext.entry = el;
2504 /* Match a subroutine statement, including optional prefixes. */
2507 gfc_match_subroutine (void)
2509 char name[GFC_MAX_SYMBOL_LEN + 1];
2513 if (gfc_current_state () != COMP_NONE
2514 && gfc_current_state () != COMP_INTERFACE
2515 && gfc_current_state () != COMP_CONTAINS)
2518 m = match_prefix (NULL);
2522 m = gfc_match ("subroutine% %n", name);
2526 if (get_proc_name (name, &sym))
2528 gfc_new_block = sym;
2530 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2533 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2536 if (gfc_match_eos () != MATCH_YES)
2538 gfc_syntax_error (ST_SUBROUTINE);
2542 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2549 /* Return nonzero if we're currently compiling a contained procedure. */
2552 contained_procedure (void)
2556 for (s=gfc_state_stack; s; s=s->previous)
2557 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2558 && s->previous != NULL
2559 && s->previous->state == COMP_CONTAINS)
2565 /* Match any of the various end-block statements. Returns the type of
2566 END to the caller. The END INTERFACE, END IF, END DO and END
2567 SELECT statements cannot be replaced by a single END statement. */
2570 gfc_match_end (gfc_statement * st)
2572 char name[GFC_MAX_SYMBOL_LEN + 1];
2573 gfc_compile_state state;
2575 const char *block_name;
2580 old_loc = gfc_current_locus;
2581 if (gfc_match ("end") != MATCH_YES)
2584 state = gfc_current_state ();
2586 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2588 if (state == COMP_CONTAINS)
2590 state = gfc_state_stack->previous->state;
2591 block_name = gfc_state_stack->previous->sym == NULL ? NULL
2592 : gfc_state_stack->previous->sym->name;
2599 *st = ST_END_PROGRAM;
2600 target = " program";
2604 case COMP_SUBROUTINE:
2605 *st = ST_END_SUBROUTINE;
2606 target = " subroutine";
2607 eos_ok = !contained_procedure ();
2611 *st = ST_END_FUNCTION;
2612 target = " function";
2613 eos_ok = !contained_procedure ();
2616 case COMP_BLOCK_DATA:
2617 *st = ST_END_BLOCK_DATA;
2618 target = " block data";
2623 *st = ST_END_MODULE;
2628 case COMP_INTERFACE:
2629 *st = ST_END_INTERFACE;
2630 target = " interface";
2653 *st = ST_END_SELECT;
2659 *st = ST_END_FORALL;
2671 gfc_error ("Unexpected END statement at %C");
2675 if (gfc_match_eos () == MATCH_YES)
2679 /* We would have required END [something] */
2680 gfc_error ("%s statement expected at %L",
2681 gfc_ascii_statement (*st), &old_loc);
2688 /* Verify that we've got the sort of end-block that we're expecting. */
2689 if (gfc_match (target) != MATCH_YES)
2691 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
2695 /* If we're at the end, make sure a block name wasn't required. */
2696 if (gfc_match_eos () == MATCH_YES)
2699 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
2702 if (gfc_current_block () == NULL)
2705 gfc_error ("Expected block name of '%s' in %s statement at %C",
2706 block_name, gfc_ascii_statement (*st));
2711 /* END INTERFACE has a special handler for its several possible endings. */
2712 if (*st == ST_END_INTERFACE)
2713 return gfc_match_end_interface ();
2715 /* We haven't hit the end of statement, so what is left must be an end-name. */
2716 m = gfc_match_space ();
2718 m = gfc_match_name (name);
2721 gfc_error ("Expected terminating name at %C");
2725 if (block_name == NULL)
2728 if (strcmp (name, block_name) != 0)
2730 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
2731 gfc_ascii_statement (*st));
2735 if (gfc_match_eos () == MATCH_YES)
2739 gfc_syntax_error (*st);
2742 gfc_current_locus = old_loc;
2748 /***************** Attribute declaration statements ****************/
2750 /* Set the attribute of a single variable. */
2755 char name[GFC_MAX_SYMBOL_LEN + 1];
2763 m = gfc_match_name (name);
2767 if (find_special (name, &sym))
2770 var_locus = gfc_current_locus;
2772 /* Deal with possible array specification for certain attributes. */
2773 if (current_attr.dimension
2774 || current_attr.allocatable
2775 || current_attr.pointer
2776 || current_attr.target)
2778 m = gfc_match_array_spec (&as);
2779 if (m == MATCH_ERROR)
2782 if (current_attr.dimension && m == MATCH_NO)
2785 ("Missing array specification at %L in DIMENSION statement",
2791 if ((current_attr.allocatable || current_attr.pointer)
2792 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2794 gfc_error ("Array specification must be deferred at %L",
2801 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2802 if (current_attr.dimension == 0
2803 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
2809 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2815 if ((current_attr.external || current_attr.intrinsic)
2816 && sym->attr.flavor != FL_PROCEDURE
2817 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
2826 gfc_free_array_spec (as);
2831 /* Generic attribute declaration subroutine. Used for attributes that
2832 just have a list of names. */
2839 /* Gobble the optional double colon, by simply ignoring the result
2849 if (gfc_match_eos () == MATCH_YES)
2855 if (gfc_match_char (',') != MATCH_YES)
2857 gfc_error ("Unexpected character in variable list at %C");
2868 gfc_match_external (void)
2871 gfc_clear_attr (¤t_attr);
2872 gfc_add_external (¤t_attr, NULL);
2874 return attr_decl ();
2880 gfc_match_intent (void)
2884 intent = match_intent_spec ();
2885 if (intent == INTENT_UNKNOWN)
2888 gfc_clear_attr (¤t_attr);
2889 gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */
2891 return attr_decl ();
2896 gfc_match_intrinsic (void)
2899 gfc_clear_attr (¤t_attr);
2900 gfc_add_intrinsic (¤t_attr, NULL);
2902 return attr_decl ();
2907 gfc_match_optional (void)
2910 gfc_clear_attr (¤t_attr);
2911 gfc_add_optional (¤t_attr, NULL);
2913 return attr_decl ();
2918 gfc_match_pointer (void)
2921 gfc_clear_attr (¤t_attr);
2922 gfc_add_pointer (¤t_attr, NULL);
2924 return attr_decl ();
2929 gfc_match_allocatable (void)
2932 gfc_clear_attr (¤t_attr);
2933 gfc_add_allocatable (¤t_attr, NULL);
2935 return attr_decl ();
2940 gfc_match_dimension (void)
2943 gfc_clear_attr (¤t_attr);
2944 gfc_add_dimension (¤t_attr, NULL, NULL);
2946 return attr_decl ();
2951 gfc_match_target (void)
2954 gfc_clear_attr (¤t_attr);
2955 gfc_add_target (¤t_attr, NULL);
2957 return attr_decl ();
2961 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2965 access_attr_decl (gfc_statement st)
2967 char name[GFC_MAX_SYMBOL_LEN + 1];
2968 interface_type type;
2971 gfc_intrinsic_op operator;
2974 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2979 m = gfc_match_generic_spec (&type, name, &operator);
2982 if (m == MATCH_ERROR)
2987 case INTERFACE_NAMELESS:
2990 case INTERFACE_GENERIC:
2991 if (gfc_get_symbol (name, NULL, &sym))
2994 if (gfc_add_access (&sym->attr,
2996 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2997 sym->name, NULL) == FAILURE)
3002 case INTERFACE_INTRINSIC_OP:
3003 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3005 gfc_current_ns->operator_access[operator] =
3006 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3010 gfc_error ("Access specification of the %s operator at %C has "
3011 "already been specified", gfc_op2string (operator));
3017 case INTERFACE_USER_OP:
3018 uop = gfc_get_uop (name);
3020 if (uop->access == ACCESS_UNKNOWN)
3023 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3028 ("Access specification of the .%s. operator at %C has "
3029 "already been specified", sym->name);
3036 if (gfc_match_char (',') == MATCH_NO)
3040 if (gfc_match_eos () != MATCH_YES)
3045 gfc_syntax_error (st);
3052 /* The PRIVATE statement is a bit weird in that it can be a attribute
3053 declaration, but also works as a standlone statement inside of a
3054 type declaration or a module. */
3057 gfc_match_private (gfc_statement * st)
3060 if (gfc_match ("private") != MATCH_YES)
3063 if (gfc_current_state () == COMP_DERIVED)
3065 if (gfc_match_eos () == MATCH_YES)
3071 gfc_syntax_error (ST_PRIVATE);
3075 if (gfc_match_eos () == MATCH_YES)
3082 return access_attr_decl (ST_PRIVATE);
3087 gfc_match_public (gfc_statement * st)
3090 if (gfc_match ("public") != MATCH_YES)
3093 if (gfc_match_eos () == MATCH_YES)
3100 return access_attr_decl (ST_PUBLIC);
3104 /* Workhorse for gfc_match_parameter. */
3113 m = gfc_match_symbol (&sym, 0);
3115 gfc_error ("Expected variable name at %C in PARAMETER statement");
3120 if (gfc_match_char ('=') == MATCH_NO)
3122 gfc_error ("Expected = sign in PARAMETER statement at %C");
3126 m = gfc_match_init_expr (&init);
3128 gfc_error ("Expected expression at %C in PARAMETER statement");
3132 if (sym->ts.type == BT_UNKNOWN
3133 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3139 if (gfc_check_assign_symbol (sym, init) == FAILURE
3140 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3146 if (sym->ts.type == BT_CHARACTER
3147 && sym->ts.cl != NULL
3148 && sym->ts.cl->length != NULL
3149 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3150 && init->expr_type == EXPR_CONSTANT
3151 && init->ts.type == BT_CHARACTER
3152 && init->ts.kind == 1)
3153 gfc_set_constant_character_len (
3154 mpz_get_si (sym->ts.cl->length->value.integer), init);
3160 gfc_free_expr (init);
3165 /* Match a parameter statement, with the weird syntax that these have. */
3168 gfc_match_parameter (void)
3172 if (gfc_match_char ('(') == MATCH_NO)
3181 if (gfc_match (" )%t") == MATCH_YES)
3184 if (gfc_match_char (',') != MATCH_YES)
3186 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3196 /* Save statements have a special syntax. */
3199 gfc_match_save (void)
3201 char n[GFC_MAX_SYMBOL_LEN+1];
3206 if (gfc_match_eos () == MATCH_YES)
3208 if (gfc_current_ns->seen_save)
3210 gfc_error ("Blanket SAVE statement at %C follows previous "
3216 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3220 if (gfc_current_ns->save_all)
3222 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3230 m = gfc_match_symbol (&sym, 0);
3234 if (gfc_add_save (&sym->attr, sym->name,
3235 &gfc_current_locus) == FAILURE)
3246 m = gfc_match (" / %n /", &n);
3247 if (m == MATCH_ERROR)
3252 c = gfc_get_common (n, 0);
3255 gfc_current_ns->seen_save = 1;
3258 if (gfc_match_eos () == MATCH_YES)
3260 if (gfc_match_char (',') != MATCH_YES)
3267 gfc_error ("Syntax error in SAVE statement at %C");
3272 /* Match a module procedure statement. Note that we have to modify
3273 symbols in the parent's namespace because the current one was there
3274 to receive symbols that are in an interface's formal argument list. */
3277 gfc_match_modproc (void)
3279 char name[GFC_MAX_SYMBOL_LEN + 1];
3283 if (gfc_state_stack->state != COMP_INTERFACE
3284 || gfc_state_stack->previous == NULL
3285 || current_interface.type == INTERFACE_NAMELESS)
3288 ("MODULE PROCEDURE at %C must be in a generic module interface");
3294 m = gfc_match_name (name);
3300 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3303 if (sym->attr.proc != PROC_MODULE
3304 && gfc_add_procedure (&sym->attr, PROC_MODULE,
3305 sym->name, NULL) == FAILURE)
3308 if (gfc_add_interface (sym) == FAILURE)
3311 if (gfc_match_eos () == MATCH_YES)
3313 if (gfc_match_char (',') != MATCH_YES)
3320 gfc_syntax_error (ST_MODULE_PROC);
3325 /* Match the beginning of a derived type declaration. If a type name
3326 was the result of a function, then it is possible to have a symbol
3327 already to be known as a derived type yet have no components. */
3330 gfc_match_derived_decl (void)
3332 char name[GFC_MAX_SYMBOL_LEN + 1];
3333 symbol_attribute attr;
3337 if (gfc_current_state () == COMP_DERIVED)
3340 gfc_clear_attr (&attr);
3343 if (gfc_match (" , private") == MATCH_YES)
3345 if (gfc_find_state (COMP_MODULE) == FAILURE)
3348 ("Derived type at %C can only be PRIVATE within a MODULE");
3352 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3357 if (gfc_match (" , public") == MATCH_YES)
3359 if (gfc_find_state (COMP_MODULE) == FAILURE)
3361 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3365 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3370 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3372 gfc_error ("Expected :: in TYPE definition at %C");
3376 m = gfc_match (" %n%t", name);
3380 /* Make sure the name isn't the name of an intrinsic type. The
3381 'double precision' type doesn't get past the name matcher. */
3382 if (strcmp (name, "integer") == 0
3383 || strcmp (name, "real") == 0
3384 || strcmp (name, "character") == 0
3385 || strcmp (name, "logical") == 0
3386 || strcmp (name, "complex") == 0)
3389 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3394 if (gfc_get_symbol (name, NULL, &sym))
3397 if (sym->ts.type != BT_UNKNOWN)
3399 gfc_error ("Derived type name '%s' at %C already has a basic type "
3400 "of %s", sym->name, gfc_typename (&sym->ts));
3404 /* The symbol may already have the derived attribute without the
3405 components. The ways this can happen is via a function
3406 definition, an INTRINSIC statement or a subtype in another
3407 derived type that is a pointer. The first part of the AND clause
3408 is true if a the symbol is not the return value of a function. */
3409 if (sym->attr.flavor != FL_DERIVED
3410 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3413 if (sym->components != NULL)
3416 ("Derived type definition of '%s' at %C has already been defined",
3421 if (attr.access != ACCESS_UNKNOWN
3422 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3425 gfc_new_block = sym;