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;
915 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
926 /* When we get here, we've just matched a list of attributes and
927 maybe a type and a double colon. The next thing we expect to see
928 is the name of the symbol. */
929 m = gfc_match_name (name);
933 var_locus = gfc_current_locus;
935 /* Now we could see the optional array spec. or character length. */
936 m = gfc_match_array_spec (&as);
937 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
938 cp_as = gfc_copy_array_spec (as);
939 else if (m == MATCH_ERROR)
942 as = gfc_copy_array_spec (current_as);
947 if (current_ts.type == BT_CHARACTER)
949 switch (match_char_length (&char_len))
952 cl = gfc_get_charlen ();
953 cl->next = gfc_current_ns->cl_list;
954 gfc_current_ns->cl_list = cl;
956 cl->length = char_len;
959 /* Non-constant lengths need to be copied after the first
962 if (elem > 1 && current_ts.cl->length
963 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
965 cl = gfc_get_charlen ();
966 cl->next = gfc_current_ns->cl_list;
967 gfc_current_ns->cl_list = cl;
968 cl->length = gfc_copy_expr (current_ts.cl->length);
980 /* If this symbol has already shown up in a Cray Pointer declaration,
981 then we want to set the type & bail out. */
982 if (gfc_option.flag_cray_pointer)
984 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
985 if (sym != NULL && sym->attr.cray_pointee)
987 sym->ts.type = current_ts.type;
988 sym->ts.kind = current_ts.kind;
990 sym->ts.derived = current_ts.derived;
993 /* Check to see if we have an array specification. */
998 gfc_error ("Duplicate array spec for Cray pointee at %C.");
999 gfc_free_array_spec (cp_as);
1005 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1006 gfc_internal_error ("Couldn't set pointee array spec.");
1008 /* Fix the array spec. */
1009 m = gfc_mod_pointee_as (sym->as);
1010 if (m == MATCH_ERROR)
1018 gfc_free_array_spec (cp_as);
1023 /* OK, we've successfully matched the declaration. Now put the
1024 symbol in the current namespace, because it might be used in the
1025 optional initialization expression for this symbol, e.g. this is
1028 integer, parameter :: i = huge(i)
1030 This is only true for parameters or variables of a basic type.
1031 For components of derived types, it is not true, so we don't
1032 create a symbol for those yet. If we fail to create the symbol,
1034 if (gfc_current_state () != COMP_DERIVED
1035 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1041 /* In functions that have a RESULT variable defined, the function
1042 name always refers to function calls. Therefore, the name is
1043 not allowed to appear in specification statements. */
1044 if (gfc_current_state () == COMP_FUNCTION
1045 && gfc_current_block () != NULL
1046 && gfc_current_block ()->result != NULL
1047 && gfc_current_block ()->result != gfc_current_block ()
1048 && strcmp (gfc_current_block ()->name, name) == 0)
1050 gfc_error ("Function name '%s' not allowed at %C", name);
1055 /* We allow old-style initializations of the form
1056 integer i /2/, j(4) /3*3, 1/
1057 (if no colon has been seen). These are different from data
1058 statements in that initializers are only allowed to apply to the
1059 variable immediately preceding, i.e.
1061 is not allowed. Therefore we have to do some work manually, that
1062 could otherwise be left to the matchers for DATA statements. */
1064 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1066 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1067 "initialization at %C") == FAILURE)
1070 return match_old_style_init (name);
1073 /* The double colon must be present in order to have initializers.
1074 Otherwise the statement is ambiguous with an assignment statement. */
1077 if (gfc_match (" =>") == MATCH_YES)
1080 if (!current_attr.pointer)
1082 gfc_error ("Initialization at %C isn't for a pointer variable");
1087 m = gfc_match_null (&initializer);
1090 gfc_error ("Pointer initialization requires a NULL at %C");
1094 if (gfc_pure (NULL))
1097 ("Initialization of pointer at %C is not allowed in a "
1105 initializer->ts = current_ts;
1108 else if (gfc_match_char ('=') == MATCH_YES)
1110 if (current_attr.pointer)
1113 ("Pointer initialization at %C requires '=>', not '='");
1118 m = gfc_match_init_expr (&initializer);
1121 gfc_error ("Expected an initialization expression at %C");
1125 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1128 ("Initialization of variable at %C is not allowed in a "
1138 /* Add the initializer. Note that it is fine if initializer is
1139 NULL here, because we sometimes also need to check if a
1140 declaration *must* have an initialization expression. */
1141 if (gfc_current_state () != COMP_DERIVED)
1142 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1145 if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
1146 initializer = gfc_default_initializer (¤t_ts);
1147 t = build_struct (name, cl, &initializer, &as);
1150 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1153 /* Free stuff up and return. */
1154 gfc_free_expr (initializer);
1155 gfc_free_array_spec (as);
1161 /* Match an extended-f77 kind specification. */
1164 gfc_match_old_kind_spec (gfc_typespec * ts)
1168 if (gfc_match_char ('*') != MATCH_YES)
1171 m = gfc_match_small_literal_int (&ts->kind);
1175 /* Massage the kind numbers for complex types. */
1176 if (ts->type == BT_COMPLEX && ts->kind == 8)
1178 if (ts->type == BT_COMPLEX && ts->kind == 16)
1181 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1183 gfc_error ("Old-style kind %d not supported for type %s at %C",
1184 ts->kind, gfc_basic_typename (ts->type));
1193 /* Match a kind specification. Since kinds are generally optional, we
1194 usually return MATCH_NO if something goes wrong. If a "kind="
1195 string is found, then we know we have an error. */
1198 gfc_match_kind_spec (gfc_typespec * ts)
1208 where = gfc_current_locus;
1210 if (gfc_match_char ('(') == MATCH_NO)
1213 /* Also gobbles optional text. */
1214 if (gfc_match (" kind = ") == MATCH_YES)
1217 n = gfc_match_init_expr (&e);
1219 gfc_error ("Expected initialization expression at %C");
1225 gfc_error ("Expected scalar initialization expression at %C");
1230 msg = gfc_extract_int (e, &ts->kind);
1241 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1243 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1244 gfc_basic_typename (ts->type));
1250 if (gfc_match_char (')') != MATCH_YES)
1252 gfc_error ("Missing right paren at %C");
1260 gfc_current_locus = where;
1265 /* Match the various kind/length specifications in a CHARACTER
1266 declaration. We don't return MATCH_NO. */
1269 match_char_spec (gfc_typespec * ts)
1271 int i, kind, seen_length;
1276 kind = gfc_default_character_kind;
1280 /* Try the old-style specification first. */
1281 old_char_selector = 0;
1283 m = match_char_length (&len);
1287 old_char_selector = 1;
1292 m = gfc_match_char ('(');
1295 m = MATCH_YES; /* character without length is a single char */
1299 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1300 if (gfc_match (" kind =") == MATCH_YES)
1302 m = gfc_match_small_int (&kind);
1303 if (m == MATCH_ERROR)
1308 if (gfc_match (" , len =") == MATCH_NO)
1311 m = char_len_param_value (&len);
1314 if (m == MATCH_ERROR)
1321 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1322 if (gfc_match (" len =") == MATCH_YES)
1324 m = char_len_param_value (&len);
1327 if (m == MATCH_ERROR)
1331 if (gfc_match_char (')') == MATCH_YES)
1334 if (gfc_match (" , kind =") != MATCH_YES)
1337 gfc_match_small_int (&kind);
1339 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1341 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1348 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1349 m = char_len_param_value (&len);
1352 if (m == MATCH_ERROR)
1356 m = gfc_match_char (')');
1360 if (gfc_match_char (',') != MATCH_YES)
1363 gfc_match (" kind ="); /* Gobble optional text */
1365 m = gfc_match_small_int (&kind);
1366 if (m == MATCH_ERROR)
1372 /* Require a right-paren at this point. */
1373 m = gfc_match_char (')');
1378 gfc_error ("Syntax error in CHARACTER declaration at %C");
1382 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1384 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1390 gfc_free_expr (len);
1394 /* Do some final massaging of the length values. */
1395 cl = gfc_get_charlen ();
1396 cl->next = gfc_current_ns->cl_list;
1397 gfc_current_ns->cl_list = cl;
1399 if (seen_length == 0)
1400 cl->length = gfc_int_expr (1);
1403 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1407 gfc_free_expr (len);
1408 cl->length = gfc_int_expr (0);
1419 /* Matches a type specification. If successful, sets the ts structure
1420 to the matched specification. This is necessary for FUNCTION and
1421 IMPLICIT statements.
1423 If implicit_flag is nonzero, then we don't check for the optional
1424 kind specification. Not doing so is needed for matching an IMPLICIT
1425 statement correctly. */
1428 match_type_spec (gfc_typespec * ts, int implicit_flag)
1430 char name[GFC_MAX_SYMBOL_LEN + 1];
1437 if (gfc_match (" byte") == MATCH_YES)
1439 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1443 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1445 gfc_error ("BYTE type used at %C "
1446 "is not available on the target machine");
1450 ts->type = BT_INTEGER;
1455 if (gfc_match (" integer") == MATCH_YES)
1457 ts->type = BT_INTEGER;
1458 ts->kind = gfc_default_integer_kind;
1462 if (gfc_match (" character") == MATCH_YES)
1464 ts->type = BT_CHARACTER;
1465 if (implicit_flag == 0)
1466 return match_char_spec (ts);
1471 if (gfc_match (" real") == MATCH_YES)
1474 ts->kind = gfc_default_real_kind;
1478 if (gfc_match (" double precision") == MATCH_YES)
1481 ts->kind = gfc_default_double_kind;
1485 if (gfc_match (" complex") == MATCH_YES)
1487 ts->type = BT_COMPLEX;
1488 ts->kind = gfc_default_complex_kind;
1492 if (gfc_match (" double complex") == MATCH_YES)
1494 ts->type = BT_COMPLEX;
1495 ts->kind = gfc_default_double_kind;
1499 if (gfc_match (" logical") == MATCH_YES)
1501 ts->type = BT_LOGICAL;
1502 ts->kind = gfc_default_logical_kind;
1506 m = gfc_match (" type ( %n )", name);
1510 /* Search for the name but allow the components to be defined later. */
1511 if (gfc_get_ha_symbol (name, &sym))
1513 gfc_error ("Type name '%s' at %C is ambiguous", name);
1517 if (sym->attr.flavor != FL_DERIVED
1518 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1521 ts->type = BT_DERIVED;
1528 /* For all types except double, derived and character, look for an
1529 optional kind specifier. MATCH_NO is actually OK at this point. */
1530 if (implicit_flag == 1)
1533 if (gfc_current_form == FORM_FREE)
1535 c = gfc_peek_char();
1536 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1537 && c != ':' && c != ',')
1541 m = gfc_match_kind_spec (ts);
1542 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1543 m = gfc_match_old_kind_spec (ts);
1546 m = MATCH_YES; /* No kind specifier found. */
1552 /* Match an IMPLICIT NONE statement. Actually, this statement is
1553 already matched in parse.c, or we would not end up here in the
1554 first place. So the only thing we need to check, is if there is
1555 trailing garbage. If not, the match is successful. */
1558 gfc_match_implicit_none (void)
1561 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1565 /* Match the letter range(s) of an IMPLICIT statement. */
1568 match_implicit_range (void)
1570 int c, c1, c2, inner;
1573 cur_loc = gfc_current_locus;
1575 gfc_gobble_whitespace ();
1576 c = gfc_next_char ();
1579 gfc_error ("Missing character range in IMPLICIT at %C");
1586 gfc_gobble_whitespace ();
1587 c1 = gfc_next_char ();
1591 gfc_gobble_whitespace ();
1592 c = gfc_next_char ();
1597 inner = 0; /* Fall through */
1604 gfc_gobble_whitespace ();
1605 c2 = gfc_next_char ();
1609 gfc_gobble_whitespace ();
1610 c = gfc_next_char ();
1612 if ((c != ',') && (c != ')'))
1625 gfc_error ("Letters must be in alphabetic order in "
1626 "IMPLICIT statement at %C");
1630 /* See if we can add the newly matched range to the pending
1631 implicits from this IMPLICIT statement. We do not check for
1632 conflicts with whatever earlier IMPLICIT statements may have
1633 set. This is done when we've successfully finished matching
1635 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1642 gfc_syntax_error (ST_IMPLICIT);
1644 gfc_current_locus = cur_loc;
1649 /* Match an IMPLICIT statement, storing the types for
1650 gfc_set_implicit() if the statement is accepted by the parser.
1651 There is a strange looking, but legal syntactic construction
1652 possible. It looks like:
1654 IMPLICIT INTEGER (a-b) (c-d)
1656 This is legal if "a-b" is a constant expression that happens to
1657 equal one of the legal kinds for integers. The real problem
1658 happens with an implicit specification that looks like:
1660 IMPLICIT INTEGER (a-b)
1662 In this case, a typespec matcher that is "greedy" (as most of the
1663 matchers are) gobbles the character range as a kindspec, leaving
1664 nothing left. We therefore have to go a bit more slowly in the
1665 matching process by inhibiting the kindspec checking during
1666 typespec matching and checking for a kind later. */
1669 gfc_match_implicit (void)
1676 /* We don't allow empty implicit statements. */
1677 if (gfc_match_eos () == MATCH_YES)
1679 gfc_error ("Empty IMPLICIT statement at %C");
1685 /* First cleanup. */
1686 gfc_clear_new_implicit ();
1688 /* A basic type is mandatory here. */
1689 m = match_type_spec (&ts, 1);
1690 if (m == MATCH_ERROR)
1695 cur_loc = gfc_current_locus;
1696 m = match_implicit_range ();
1700 /* We may have <TYPE> (<RANGE>). */
1701 gfc_gobble_whitespace ();
1702 c = gfc_next_char ();
1703 if ((c == '\n') || (c == ','))
1705 /* Check for CHARACTER with no length parameter. */
1706 if (ts.type == BT_CHARACTER && !ts.cl)
1708 ts.kind = gfc_default_character_kind;
1709 ts.cl = gfc_get_charlen ();
1710 ts.cl->next = gfc_current_ns->cl_list;
1711 gfc_current_ns->cl_list = ts.cl;
1712 ts.cl->length = gfc_int_expr (1);
1715 /* Record the Successful match. */
1716 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1721 gfc_current_locus = cur_loc;
1724 /* Discard the (incorrectly) matched range. */
1725 gfc_clear_new_implicit ();
1727 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1728 if (ts.type == BT_CHARACTER)
1729 m = match_char_spec (&ts);
1732 m = gfc_match_kind_spec (&ts);
1735 m = gfc_match_old_kind_spec (&ts);
1736 if (m == MATCH_ERROR)
1742 if (m == MATCH_ERROR)
1745 m = match_implicit_range ();
1746 if (m == MATCH_ERROR)
1751 gfc_gobble_whitespace ();
1752 c = gfc_next_char ();
1753 if ((c != '\n') && (c != ','))
1756 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1764 gfc_syntax_error (ST_IMPLICIT);
1771 /* Matches an attribute specification including array specs. If
1772 successful, leaves the variables current_attr and current_as
1773 holding the specification. Also sets the colon_seen variable for
1774 later use by matchers associated with initializations.
1776 This subroutine is a little tricky in the sense that we don't know
1777 if we really have an attr-spec until we hit the double colon.
1778 Until that time, we can only return MATCH_NO. This forces us to
1779 check for duplicate specification at this level. */
1782 match_attr_spec (void)
1785 /* Modifiers that can exist in a type statement. */
1787 { GFC_DECL_BEGIN = 0,
1788 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1789 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1790 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1791 DECL_TARGET, DECL_COLON, DECL_NONE,
1792 GFC_DECL_END /* Sentinel */
1796 /* GFC_DECL_END is the sentinel, index starts at 0. */
1797 #define NUM_DECL GFC_DECL_END
1799 static mstring decls[] = {
1800 minit (", allocatable", DECL_ALLOCATABLE),
1801 minit (", dimension", DECL_DIMENSION),
1802 minit (", external", DECL_EXTERNAL),
1803 minit (", intent ( in )", DECL_IN),
1804 minit (", intent ( out )", DECL_OUT),
1805 minit (", intent ( in out )", DECL_INOUT),
1806 minit (", intrinsic", DECL_INTRINSIC),
1807 minit (", optional", DECL_OPTIONAL),
1808 minit (", parameter", DECL_PARAMETER),
1809 minit (", pointer", DECL_POINTER),
1810 minit (", private", DECL_PRIVATE),
1811 minit (", public", DECL_PUBLIC),
1812 minit (", save", DECL_SAVE),
1813 minit (", target", DECL_TARGET),
1814 minit ("::", DECL_COLON),
1815 minit (NULL, DECL_NONE)
1818 locus start, seen_at[NUM_DECL];
1825 gfc_clear_attr (¤t_attr);
1826 start = gfc_current_locus;
1831 /* See if we get all of the keywords up to the final double colon. */
1832 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1837 d = (decl_types) gfc_match_strings (decls);
1838 if (d == DECL_NONE || d == DECL_COLON)
1842 seen_at[d] = gfc_current_locus;
1844 if (d == DECL_DIMENSION)
1846 m = gfc_match_array_spec (¤t_as);
1850 gfc_error ("Missing dimension specification at %C");
1854 if (m == MATCH_ERROR)
1859 /* No double colon, so assume that we've been looking at something
1860 else the whole time. */
1867 /* Since we've seen a double colon, we have to be looking at an
1868 attr-spec. This means that we can now issue errors. */
1869 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1874 case DECL_ALLOCATABLE:
1875 attr = "ALLOCATABLE";
1877 case DECL_DIMENSION:
1884 attr = "INTENT (IN)";
1887 attr = "INTENT (OUT)";
1890 attr = "INTENT (IN OUT)";
1892 case DECL_INTRINSIC:
1898 case DECL_PARAMETER:
1917 attr = NULL; /* This shouldn't happen */
1920 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1925 /* Now that we've dealt with duplicate attributes, add the attributes
1926 to the current attribute. */
1927 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1932 if (gfc_current_state () == COMP_DERIVED
1933 && d != DECL_DIMENSION && d != DECL_POINTER
1934 && d != DECL_COLON && d != DECL_NONE)
1937 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1943 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
1944 && gfc_current_state () != COMP_MODULE)
1946 if (d == DECL_PRIVATE)
1951 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
1959 case DECL_ALLOCATABLE:
1960 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
1963 case DECL_DIMENSION:
1964 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
1968 t = gfc_add_external (¤t_attr, &seen_at[d]);
1972 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
1976 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
1980 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
1983 case DECL_INTRINSIC:
1984 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
1988 t = gfc_add_optional (¤t_attr, &seen_at[d]);
1991 case DECL_PARAMETER:
1992 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
1996 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2000 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2005 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2010 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2014 t = gfc_add_target (¤t_attr, &seen_at[d]);
2018 gfc_internal_error ("match_attr_spec(): Bad attribute");
2032 gfc_current_locus = start;
2033 gfc_free_array_spec (current_as);
2039 /* Match a data declaration statement. */
2042 gfc_match_data_decl (void)
2048 m = match_type_spec (¤t_ts, 0);
2052 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2054 sym = gfc_use_derived (current_ts.derived);
2062 current_ts.derived = sym;
2065 m = match_attr_spec ();
2066 if (m == MATCH_ERROR)
2072 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2075 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2078 gfc_find_symbol (current_ts.derived->name,
2079 current_ts.derived->ns->parent, 1, &sym);
2081 /* Any symbol that we find had better be a type definition
2082 which has its components defined. */
2083 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2084 && current_ts.derived->components != NULL)
2087 /* Now we have an error, which we signal, and then fix up
2088 because the knock-on is plain and simple confusing. */
2089 gfc_error_now ("Derived type at %C has not been previously defined "
2090 "and so cannot appear in a derived type definition.");
2091 current_attr.pointer = 1;
2096 /* If we have an old-style character declaration, and no new-style
2097 attribute specifications, then there a comma is optional between
2098 the type specification and the variable list. */
2099 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2100 gfc_match_char (',');
2102 /* Give the types/attributes to symbols that follow. Give the element
2103 a number so that repeat character length expressions can be copied. */
2107 m = variable_decl (elem++);
2108 if (m == MATCH_ERROR)
2113 if (gfc_match_eos () == MATCH_YES)
2115 if (gfc_match_char (',') != MATCH_YES)
2119 gfc_error ("Syntax error in data declaration at %C");
2123 gfc_free_array_spec (current_as);
2129 /* Match a prefix associated with a function or subroutine
2130 declaration. If the typespec pointer is nonnull, then a typespec
2131 can be matched. Note that if nothing matches, MATCH_YES is
2132 returned (the null string was matched). */
2135 match_prefix (gfc_typespec * ts)
2139 gfc_clear_attr (¤t_attr);
2143 if (!seen_type && ts != NULL
2144 && match_type_spec (ts, 0) == MATCH_YES
2145 && gfc_match_space () == MATCH_YES)
2152 if (gfc_match ("elemental% ") == MATCH_YES)
2154 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2160 if (gfc_match ("pure% ") == MATCH_YES)
2162 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2168 if (gfc_match ("recursive% ") == MATCH_YES)
2170 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2176 /* At this point, the next item is not a prefix. */
2181 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2184 copy_prefix (symbol_attribute * dest, locus * where)
2187 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2190 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2193 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2200 /* Match a formal argument list. */
2203 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2205 gfc_formal_arglist *head, *tail, *p, *q;
2206 char name[GFC_MAX_SYMBOL_LEN + 1];
2212 if (gfc_match_char ('(') != MATCH_YES)
2219 if (gfc_match_char (')') == MATCH_YES)
2224 if (gfc_match_char ('*') == MATCH_YES)
2228 m = gfc_match_name (name);
2232 if (gfc_get_symbol (name, NULL, &sym))
2236 p = gfc_get_formal_arglist ();
2248 /* We don't add the VARIABLE flavor because the name could be a
2249 dummy procedure. We don't apply these attributes to formal
2250 arguments of statement functions. */
2251 if (sym != NULL && !st_flag
2252 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2253 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2259 /* The name of a program unit can be in a different namespace,
2260 so check for it explicitly. After the statement is accepted,
2261 the name is checked for especially in gfc_get_symbol(). */
2262 if (gfc_new_block != NULL && sym != NULL
2263 && strcmp (sym->name, gfc_new_block->name) == 0)
2265 gfc_error ("Name '%s' at %C is the name of the procedure",
2271 if (gfc_match_char (')') == MATCH_YES)
2274 m = gfc_match_char (',');
2277 gfc_error ("Unexpected junk in formal argument list at %C");
2283 /* Check for duplicate symbols in the formal argument list. */
2286 for (p = head; p->next; p = p->next)
2291 for (q = p->next; q; q = q->next)
2292 if (p->sym == q->sym)
2295 ("Duplicate symbol '%s' in formal argument list at %C",
2304 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2314 gfc_free_formal_arglist (head);
2319 /* Match a RESULT specification following a function declaration or
2320 ENTRY statement. Also matches the end-of-statement. */
2323 match_result (gfc_symbol * function, gfc_symbol ** result)
2325 char name[GFC_MAX_SYMBOL_LEN + 1];
2329 if (gfc_match (" result (") != MATCH_YES)
2332 m = gfc_match_name (name);
2336 if (gfc_match (" )%t") != MATCH_YES)
2338 gfc_error ("Unexpected junk following RESULT variable at %C");
2342 if (strcmp (function->name, name) == 0)
2345 ("RESULT variable at %C must be different than function name");
2349 if (gfc_get_symbol (name, NULL, &r))
2352 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2353 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2362 /* Match a function declaration. */
2365 gfc_match_function_decl (void)
2367 char name[GFC_MAX_SYMBOL_LEN + 1];
2368 gfc_symbol *sym, *result;
2372 if (gfc_current_state () != COMP_NONE
2373 && gfc_current_state () != COMP_INTERFACE
2374 && gfc_current_state () != COMP_CONTAINS)
2377 gfc_clear_ts (¤t_ts);
2379 old_loc = gfc_current_locus;
2381 m = match_prefix (¤t_ts);
2384 gfc_current_locus = old_loc;
2388 if (gfc_match ("function% %n", name) != MATCH_YES)
2390 gfc_current_locus = old_loc;
2394 if (get_proc_name (name, &sym))
2396 gfc_new_block = sym;
2398 m = gfc_match_formal_arglist (sym, 0, 0);
2400 gfc_error ("Expected formal argument list in function definition at %C");
2401 else if (m == MATCH_ERROR)
2406 if (gfc_match_eos () != MATCH_YES)
2408 /* See if a result variable is present. */
2409 m = match_result (sym, &result);
2411 gfc_error ("Unexpected junk after function declaration at %C");
2420 /* Make changes to the symbol. */
2423 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2426 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2427 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2430 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
2432 gfc_error ("Function '%s' at %C already has a type of %s", name,
2433 gfc_basic_typename (sym->ts.type));
2439 sym->ts = current_ts;
2444 result->ts = current_ts;
2445 sym->result = result;
2451 gfc_current_locus = old_loc;
2456 /* Match an ENTRY statement. */
2459 gfc_match_entry (void)
2464 char name[GFC_MAX_SYMBOL_LEN + 1];
2465 gfc_compile_state state;
2469 m = gfc_match_name (name);
2473 state = gfc_current_state ();
2474 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2479 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2482 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2484 case COMP_BLOCK_DATA:
2486 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2488 case COMP_INTERFACE:
2490 ("ENTRY statement at %C cannot appear within an INTERFACE");
2494 ("ENTRY statement at %C cannot appear "
2495 "within a DERIVED TYPE block");
2499 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2503 ("ENTRY statement at %C cannot appear within a DO block");
2507 ("ENTRY statement at %C cannot appear within a SELECT block");
2511 ("ENTRY statement at %C cannot appear within a FORALL block");
2515 ("ENTRY statement at %C cannot appear within a WHERE block");
2519 ("ENTRY statement at %C cannot appear "
2520 "within a contained subprogram");
2523 gfc_internal_error ("gfc_match_entry(): Bad state");
2528 if (gfc_current_ns->parent != NULL
2529 && gfc_current_ns->parent->proc_name
2530 && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
2532 gfc_error("ENTRY statement at %C cannot appear in a "
2533 "contained procedure");
2537 if (get_proc_name (name, &entry))
2540 proc = gfc_current_block ();
2542 if (state == COMP_SUBROUTINE)
2544 /* An entry in a subroutine. */
2545 m = gfc_match_formal_arglist (entry, 0, 1);
2549 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2550 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2555 /* An entry in a function. */
2556 m = gfc_match_formal_arglist (entry, 0, 1);
2562 if (gfc_match_eos () == MATCH_YES)
2564 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2565 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
2568 entry->result = entry;
2572 m = match_result (proc, &result);
2574 gfc_syntax_error (ST_ENTRY);
2578 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2579 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2580 || gfc_add_function (&entry->attr, result->name,
2584 entry->result = result;
2587 if (proc->attr.recursive && result == NULL)
2589 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2594 if (gfc_match_eos () != MATCH_YES)
2596 gfc_syntax_error (ST_ENTRY);
2600 entry->attr.recursive = proc->attr.recursive;
2601 entry->attr.elemental = proc->attr.elemental;
2602 entry->attr.pure = proc->attr.pure;
2604 el = gfc_get_entry_list ();
2606 el->next = gfc_current_ns->entries;
2607 gfc_current_ns->entries = el;
2609 el->id = el->next->id + 1;
2613 new_st.op = EXEC_ENTRY;
2614 new_st.ext.entry = el;
2620 /* Match a subroutine statement, including optional prefixes. */
2623 gfc_match_subroutine (void)
2625 char name[GFC_MAX_SYMBOL_LEN + 1];
2629 if (gfc_current_state () != COMP_NONE
2630 && gfc_current_state () != COMP_INTERFACE
2631 && gfc_current_state () != COMP_CONTAINS)
2634 m = match_prefix (NULL);
2638 m = gfc_match ("subroutine% %n", name);
2642 if (get_proc_name (name, &sym))
2644 gfc_new_block = sym;
2646 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2649 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2652 if (gfc_match_eos () != MATCH_YES)
2654 gfc_syntax_error (ST_SUBROUTINE);
2658 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2665 /* Return nonzero if we're currently compiling a contained procedure. */
2668 contained_procedure (void)
2672 for (s=gfc_state_stack; s; s=s->previous)
2673 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2674 && s->previous != NULL
2675 && s->previous->state == COMP_CONTAINS)
2681 /* Match any of the various end-block statements. Returns the type of
2682 END to the caller. The END INTERFACE, END IF, END DO and END
2683 SELECT statements cannot be replaced by a single END statement. */
2686 gfc_match_end (gfc_statement * st)
2688 char name[GFC_MAX_SYMBOL_LEN + 1];
2689 gfc_compile_state state;
2691 const char *block_name;
2696 old_loc = gfc_current_locus;
2697 if (gfc_match ("end") != MATCH_YES)
2700 state = gfc_current_state ();
2702 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2704 if (state == COMP_CONTAINS)
2706 state = gfc_state_stack->previous->state;
2707 block_name = gfc_state_stack->previous->sym == NULL ? NULL
2708 : gfc_state_stack->previous->sym->name;
2715 *st = ST_END_PROGRAM;
2716 target = " program";
2720 case COMP_SUBROUTINE:
2721 *st = ST_END_SUBROUTINE;
2722 target = " subroutine";
2723 eos_ok = !contained_procedure ();
2727 *st = ST_END_FUNCTION;
2728 target = " function";
2729 eos_ok = !contained_procedure ();
2732 case COMP_BLOCK_DATA:
2733 *st = ST_END_BLOCK_DATA;
2734 target = " block data";
2739 *st = ST_END_MODULE;
2744 case COMP_INTERFACE:
2745 *st = ST_END_INTERFACE;
2746 target = " interface";
2769 *st = ST_END_SELECT;
2775 *st = ST_END_FORALL;
2787 gfc_error ("Unexpected END statement at %C");
2791 if (gfc_match_eos () == MATCH_YES)
2795 /* We would have required END [something] */
2796 gfc_error ("%s statement expected at %L",
2797 gfc_ascii_statement (*st), &old_loc);
2804 /* Verify that we've got the sort of end-block that we're expecting. */
2805 if (gfc_match (target) != MATCH_YES)
2807 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
2811 /* If we're at the end, make sure a block name wasn't required. */
2812 if (gfc_match_eos () == MATCH_YES)
2815 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
2818 if (gfc_current_block () == NULL)
2821 gfc_error ("Expected block name of '%s' in %s statement at %C",
2822 block_name, gfc_ascii_statement (*st));
2827 /* END INTERFACE has a special handler for its several possible endings. */
2828 if (*st == ST_END_INTERFACE)
2829 return gfc_match_end_interface ();
2831 /* We haven't hit the end of statement, so what is left must be an end-name. */
2832 m = gfc_match_space ();
2834 m = gfc_match_name (name);
2837 gfc_error ("Expected terminating name at %C");
2841 if (block_name == NULL)
2844 if (strcmp (name, block_name) != 0)
2846 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
2847 gfc_ascii_statement (*st));
2851 if (gfc_match_eos () == MATCH_YES)
2855 gfc_syntax_error (*st);
2858 gfc_current_locus = old_loc;
2864 /***************** Attribute declaration statements ****************/
2866 /* Set the attribute of a single variable. */
2871 char name[GFC_MAX_SYMBOL_LEN + 1];
2879 m = gfc_match_name (name);
2883 if (find_special (name, &sym))
2886 var_locus = gfc_current_locus;
2888 /* Deal with possible array specification for certain attributes. */
2889 if (current_attr.dimension
2890 || current_attr.allocatable
2891 || current_attr.pointer
2892 || current_attr.target)
2894 m = gfc_match_array_spec (&as);
2895 if (m == MATCH_ERROR)
2898 if (current_attr.dimension && m == MATCH_NO)
2901 ("Missing array specification at %L in DIMENSION statement",
2907 if ((current_attr.allocatable || current_attr.pointer)
2908 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2910 gfc_error ("Array specification must be deferred at %L",
2917 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2918 if (current_attr.dimension == 0
2919 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
2925 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2931 if (sym->attr.cray_pointee && sym->as != NULL)
2933 /* Fix the array spec. */
2934 m = gfc_mod_pointee_as (sym->as);
2935 if (m == MATCH_ERROR)
2939 if ((current_attr.external || current_attr.intrinsic)
2940 && sym->attr.flavor != FL_PROCEDURE
2941 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
2950 gfc_free_array_spec (as);
2955 /* Generic attribute declaration subroutine. Used for attributes that
2956 just have a list of names. */
2963 /* Gobble the optional double colon, by simply ignoring the result
2973 if (gfc_match_eos () == MATCH_YES)
2979 if (gfc_match_char (',') != MATCH_YES)
2981 gfc_error ("Unexpected character in variable list at %C");
2991 /* This routine matches Cray Pointer declarations of the form:
2992 pointer ( <pointer>, <pointee> )
2994 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
2995 The pointer, if already declared, should be an integer. Otherwise, we
2996 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
2997 be either a scalar, or an array declaration. No space is allocated for
2998 the pointee. For the statement
2999 pointer (ipt, ar(10))
3000 any subsequent uses of ar will be translated (in C-notation) as
3001 ar(i) => ((<type> *) ipt)(i)
3002 After gimplification, pointee variable will disappear in the code. */
3005 cray_pointer_decl (void)
3009 gfc_symbol *cptr; /* Pointer symbol. */
3010 gfc_symbol *cpte; /* Pointee symbol. */
3016 if (gfc_match_char ('(') != MATCH_YES)
3018 gfc_error ("Expected '(' at %C");
3022 /* Match pointer. */
3023 var_locus = gfc_current_locus;
3024 gfc_clear_attr (¤t_attr);
3025 gfc_add_cray_pointer (¤t_attr, &var_locus);
3026 current_ts.type = BT_INTEGER;
3027 current_ts.kind = gfc_index_integer_kind;
3029 m = gfc_match_symbol (&cptr, 0);
3032 gfc_error ("Expected variable name at %C");
3036 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3039 gfc_set_sym_referenced (cptr);
3041 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3043 cptr->ts.type = BT_INTEGER;
3044 cptr->ts.kind = gfc_index_integer_kind;
3046 else if (cptr->ts.type != BT_INTEGER)
3048 gfc_error ("Cray pointer at %C must be an integer.");
3051 else if (cptr->ts.kind < gfc_index_integer_kind)
3052 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3053 " memory addresses require %d bytes.",
3055 gfc_index_integer_kind);
3057 if (gfc_match_char (',') != MATCH_YES)
3059 gfc_error ("Expected \",\" at %C");
3063 /* Match Pointee. */
3064 var_locus = gfc_current_locus;
3065 gfc_clear_attr (¤t_attr);
3066 gfc_add_cray_pointee (¤t_attr, &var_locus);
3067 current_ts.type = BT_UNKNOWN;
3068 current_ts.kind = 0;
3070 m = gfc_match_symbol (&cpte, 0);
3073 gfc_error ("Expected variable name at %C");
3077 /* Check for an optional array spec. */
3078 m = gfc_match_array_spec (&as);
3079 if (m == MATCH_ERROR)
3081 gfc_free_array_spec (as);
3084 else if (m == MATCH_NO)
3086 gfc_free_array_spec (as);
3090 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3093 gfc_set_sym_referenced (cpte);
3095 if (cpte->as == NULL)
3097 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3098 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3100 else if (as != NULL)
3102 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3103 gfc_free_array_spec (as);
3109 if (cpte->as != NULL)
3111 /* Fix array spec. */
3112 m = gfc_mod_pointee_as (cpte->as);
3113 if (m == MATCH_ERROR)
3117 /* Point the Pointee at the Pointer. */
3118 cpte->cp_pointer = cptr;
3120 if (gfc_match_char (')') != MATCH_YES)
3122 gfc_error ("Expected \")\" at %C");
3125 m = gfc_match_char (',');
3127 done = true; /* Stop searching for more declarations. */
3131 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3132 || gfc_match_eos () != MATCH_YES)
3134 gfc_error ("Expected \",\" or end of statement at %C");
3142 gfc_match_external (void)
3145 gfc_clear_attr (¤t_attr);
3146 gfc_add_external (¤t_attr, NULL);
3148 return attr_decl ();
3154 gfc_match_intent (void)
3158 intent = match_intent_spec ();
3159 if (intent == INTENT_UNKNOWN)
3162 gfc_clear_attr (¤t_attr);
3163 gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */
3165 return attr_decl ();
3170 gfc_match_intrinsic (void)
3173 gfc_clear_attr (¤t_attr);
3174 gfc_add_intrinsic (¤t_attr, NULL);
3176 return attr_decl ();
3181 gfc_match_optional (void)
3184 gfc_clear_attr (¤t_attr);
3185 gfc_add_optional (¤t_attr, NULL);
3187 return attr_decl ();
3192 gfc_match_pointer (void)
3194 gfc_gobble_whitespace ();
3195 if (gfc_peek_char () == '(')
3197 if (!gfc_option.flag_cray_pointer)
3199 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3203 return cray_pointer_decl ();
3207 gfc_clear_attr (¤t_attr);
3208 gfc_add_pointer (¤t_attr, NULL);
3210 return attr_decl ();
3216 gfc_match_allocatable (void)
3219 gfc_clear_attr (¤t_attr);
3220 gfc_add_allocatable (¤t_attr, NULL);
3222 return attr_decl ();
3227 gfc_match_dimension (void)
3230 gfc_clear_attr (¤t_attr);
3231 gfc_add_dimension (¤t_attr, NULL, NULL);
3233 return attr_decl ();
3238 gfc_match_target (void)
3241 gfc_clear_attr (¤t_attr);
3242 gfc_add_target (¤t_attr, NULL);
3244 return attr_decl ();
3248 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3252 access_attr_decl (gfc_statement st)
3254 char name[GFC_MAX_SYMBOL_LEN + 1];
3255 interface_type type;
3258 gfc_intrinsic_op operator;
3261 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3266 m = gfc_match_generic_spec (&type, name, &operator);
3269 if (m == MATCH_ERROR)
3274 case INTERFACE_NAMELESS:
3277 case INTERFACE_GENERIC:
3278 if (gfc_get_symbol (name, NULL, &sym))
3281 if (gfc_add_access (&sym->attr,
3283 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3284 sym->name, NULL) == FAILURE)
3289 case INTERFACE_INTRINSIC_OP:
3290 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3292 gfc_current_ns->operator_access[operator] =
3293 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3297 gfc_error ("Access specification of the %s operator at %C has "
3298 "already been specified", gfc_op2string (operator));
3304 case INTERFACE_USER_OP:
3305 uop = gfc_get_uop (name);
3307 if (uop->access == ACCESS_UNKNOWN)
3310 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3315 ("Access specification of the .%s. operator at %C has "
3316 "already been specified", sym->name);
3323 if (gfc_match_char (',') == MATCH_NO)
3327 if (gfc_match_eos () != MATCH_YES)
3332 gfc_syntax_error (st);
3339 /* The PRIVATE statement is a bit weird in that it can be a attribute
3340 declaration, but also works as a standlone statement inside of a
3341 type declaration or a module. */
3344 gfc_match_private (gfc_statement * st)
3347 if (gfc_match ("private") != MATCH_YES)
3350 if (gfc_current_state () == COMP_DERIVED)
3352 if (gfc_match_eos () == MATCH_YES)
3358 gfc_syntax_error (ST_PRIVATE);
3362 if (gfc_match_eos () == MATCH_YES)
3369 return access_attr_decl (ST_PRIVATE);
3374 gfc_match_public (gfc_statement * st)
3377 if (gfc_match ("public") != MATCH_YES)
3380 if (gfc_match_eos () == MATCH_YES)
3387 return access_attr_decl (ST_PUBLIC);
3391 /* Workhorse for gfc_match_parameter. */
3400 m = gfc_match_symbol (&sym, 0);
3402 gfc_error ("Expected variable name at %C in PARAMETER statement");
3407 if (gfc_match_char ('=') == MATCH_NO)
3409 gfc_error ("Expected = sign in PARAMETER statement at %C");
3413 m = gfc_match_init_expr (&init);
3415 gfc_error ("Expected expression at %C in PARAMETER statement");
3419 if (sym->ts.type == BT_UNKNOWN
3420 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3426 if (gfc_check_assign_symbol (sym, init) == FAILURE
3427 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3433 if (sym->ts.type == BT_CHARACTER
3434 && sym->ts.cl != NULL
3435 && sym->ts.cl->length != NULL
3436 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3437 && init->expr_type == EXPR_CONSTANT
3438 && init->ts.type == BT_CHARACTER
3439 && init->ts.kind == 1)
3440 gfc_set_constant_character_len (
3441 mpz_get_si (sym->ts.cl->length->value.integer), init);
3447 gfc_free_expr (init);
3452 /* Match a parameter statement, with the weird syntax that these have. */
3455 gfc_match_parameter (void)
3459 if (gfc_match_char ('(') == MATCH_NO)
3468 if (gfc_match (" )%t") == MATCH_YES)
3471 if (gfc_match_char (',') != MATCH_YES)
3473 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3483 /* Save statements have a special syntax. */
3486 gfc_match_save (void)
3488 char n[GFC_MAX_SYMBOL_LEN+1];
3493 if (gfc_match_eos () == MATCH_YES)
3495 if (gfc_current_ns->seen_save)
3497 if (gfc_notify_std (GFC_STD_LEGACY,
3498 "Blanket SAVE statement at %C follows previous "
3504 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3508 if (gfc_current_ns->save_all)
3510 if (gfc_notify_std (GFC_STD_LEGACY,
3511 "SAVE statement at %C follows blanket SAVE statement")
3520 m = gfc_match_symbol (&sym, 0);
3524 if (gfc_add_save (&sym->attr, sym->name,
3525 &gfc_current_locus) == FAILURE)
3536 m = gfc_match (" / %n /", &n);
3537 if (m == MATCH_ERROR)
3542 c = gfc_get_common (n, 0);
3545 gfc_current_ns->seen_save = 1;
3548 if (gfc_match_eos () == MATCH_YES)
3550 if (gfc_match_char (',') != MATCH_YES)
3557 gfc_error ("Syntax error in SAVE statement at %C");
3562 /* Match a module procedure statement. Note that we have to modify
3563 symbols in the parent's namespace because the current one was there
3564 to receive symbols that are in an interface's formal argument list. */
3567 gfc_match_modproc (void)
3569 char name[GFC_MAX_SYMBOL_LEN + 1];
3573 if (gfc_state_stack->state != COMP_INTERFACE
3574 || gfc_state_stack->previous == NULL
3575 || current_interface.type == INTERFACE_NAMELESS)
3578 ("MODULE PROCEDURE at %C must be in a generic module interface");
3584 m = gfc_match_name (name);
3590 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3593 if (sym->attr.proc != PROC_MODULE
3594 && gfc_add_procedure (&sym->attr, PROC_MODULE,
3595 sym->name, NULL) == FAILURE)
3598 if (gfc_add_interface (sym) == FAILURE)
3601 if (gfc_match_eos () == MATCH_YES)
3603 if (gfc_match_char (',') != MATCH_YES)
3610 gfc_syntax_error (ST_MODULE_PROC);
3615 /* Match the beginning of a derived type declaration. If a type name
3616 was the result of a function, then it is possible to have a symbol
3617 already to be known as a derived type yet have no components. */
3620 gfc_match_derived_decl (void)
3622 char name[GFC_MAX_SYMBOL_LEN + 1];
3623 symbol_attribute attr;
3627 if (gfc_current_state () == COMP_DERIVED)
3630 gfc_clear_attr (&attr);
3633 if (gfc_match (" , private") == MATCH_YES)
3635 if (gfc_find_state (COMP_MODULE) == FAILURE)
3638 ("Derived type at %C can only be PRIVATE within a MODULE");
3642 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3647 if (gfc_match (" , public") == MATCH_YES)
3649 if (gfc_find_state (COMP_MODULE) == FAILURE)
3651 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3655 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3660 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3662 gfc_error ("Expected :: in TYPE definition at %C");
3666 m = gfc_match (" %n%t", name);
3670 /* Make sure the name isn't the name of an intrinsic type. The
3671 'double precision' type doesn't get past the name matcher. */
3672 if (strcmp (name, "integer") == 0
3673 || strcmp (name, "real") == 0
3674 || strcmp (name, "character") == 0
3675 || strcmp (name, "logical") == 0
3676 || strcmp (name, "complex") == 0)
3679 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3684 if (gfc_get_symbol (name, NULL, &sym))
3687 if (sym->ts.type != BT_UNKNOWN)
3689 gfc_error ("Derived type name '%s' at %C already has a basic type "
3690 "of %s", sym->name, gfc_typename (&sym->ts));
3694 /* The symbol may already have the derived attribute without the
3695 components. The ways this can happen is via a function
3696 definition, an INTRINSIC statement or a subtype in another
3697 derived type that is a pointer. The first part of the AND clause
3698 is true if a the symbol is not the return value of a function. */
3699 if (sym->attr.flavor != FL_DERIVED
3700 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3703 if (sym->components != NULL)
3706 ("Derived type definition of '%s' at %C has already been defined",
3711 if (attr.access != ACCESS_UNKNOWN
3712 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3715 gfc_new_block = sym;
3721 /* Cray Pointees can be declared as:
3722 pointer (ipt, a (n,m,...,*))
3723 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
3724 cheat and set a constant bound of 1 for the last dimension, if this
3725 is the case. Since there is no bounds-checking for Cray Pointees,
3726 this will be okay. */
3729 gfc_mod_pointee_as (gfc_array_spec *as)
3731 as->cray_pointee = true; /* This will be useful to know later. */
3732 if (as->type == AS_ASSUMED_SIZE)
3734 as->type = AS_EXPLICIT;
3735 as->upper[as->rank - 1] = gfc_int_expr (1);
3736 as->cp_was_assumed = true;
3738 else if (as->type == AS_ASSUMED_SHAPE)
3740 gfc_error ("Cray Pointee at %C cannot be assumed shape array");