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 /* Initializer of the previous enumerator. */
48 static gfc_expr *last_initializer;
50 /* History of all the enumerators is maintained, so that
51 kind values of all the enumerators could be updated depending
52 upon the maximum initialized value. */
54 typedef struct enumerator_history
57 gfc_expr *initializer;
58 struct enumerator_history *next;
62 /* Header of enum history chain. */
64 static enumerator_history *enum_history = NULL;
66 /* Pointer of enum history node containing largest initializer. */
68 static enumerator_history *max_enum = NULL;
70 /* gfc_new_block points to the symbol of a newly matched block. */
72 gfc_symbol *gfc_new_block;
75 /********************* DATA statement subroutines *********************/
77 /* Free a gfc_data_variable structure and everything beneath it. */
80 free_variable (gfc_data_variable * p)
87 gfc_free_expr (p->expr);
88 gfc_free_iterator (&p->iter, 0);
89 free_variable (p->list);
96 /* Free a gfc_data_value structure and everything beneath it. */
99 free_value (gfc_data_value * p)
106 gfc_free_expr (p->expr);
112 /* Free a list of gfc_data structures. */
115 gfc_free_data (gfc_data * p)
123 free_variable (p->var);
124 free_value (p->value);
131 static match var_element (gfc_data_variable *);
133 /* Match a list of variables terminated by an iterator and a right
137 var_list (gfc_data_variable * parent)
139 gfc_data_variable *tail, var;
142 m = var_element (&var);
143 if (m == MATCH_ERROR)
148 tail = gfc_get_data_variable ();
155 if (gfc_match_char (',') != MATCH_YES)
158 m = gfc_match_iterator (&parent->iter, 1);
161 if (m == MATCH_ERROR)
164 m = var_element (&var);
165 if (m == MATCH_ERROR)
170 tail->next = gfc_get_data_variable ();
176 if (gfc_match_char (')') != MATCH_YES)
181 gfc_syntax_error (ST_DATA);
186 /* Match a single element in a data variable list, which can be a
187 variable-iterator list. */
190 var_element (gfc_data_variable * new)
195 memset (new, 0, sizeof (gfc_data_variable));
197 if (gfc_match_char ('(') == MATCH_YES)
198 return var_list (new);
200 m = gfc_match_variable (&new->expr, 0);
204 sym = new->expr->symtree->n.sym;
206 if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns)
208 gfc_error ("Host associated variable '%s' may not be in the DATA "
209 "statement at %C.", sym->name);
213 if (gfc_current_state () != COMP_BLOCK_DATA
214 && sym->attr.in_common
215 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
216 "common block variable '%s' in DATA statement at %C",
217 sym->name) == FAILURE)
220 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
227 /* Match the top-level list of data variables. */
230 top_var_list (gfc_data * d)
232 gfc_data_variable var, *tail, *new;
239 m = var_element (&var);
242 if (m == MATCH_ERROR)
245 new = gfc_get_data_variable ();
255 if (gfc_match_char ('/') == MATCH_YES)
257 if (gfc_match_char (',') != MATCH_YES)
264 gfc_syntax_error (ST_DATA);
270 match_data_constant (gfc_expr ** result)
272 char name[GFC_MAX_SYMBOL_LEN + 1];
277 m = gfc_match_literal_constant (&expr, 1);
284 if (m == MATCH_ERROR)
287 m = gfc_match_null (result);
291 m = gfc_match_name (name);
295 if (gfc_find_symbol (name, NULL, 1, &sym))
299 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
301 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
305 else if (sym->attr.flavor == FL_DERIVED)
306 return gfc_match_structure_constructor (sym, result);
308 *result = gfc_copy_expr (sym->value);
313 /* Match a list of values in a DATA statement. The leading '/' has
314 already been seen at this point. */
317 top_val_list (gfc_data * data)
319 gfc_data_value *new, *tail;
328 m = match_data_constant (&expr);
331 if (m == MATCH_ERROR)
334 new = gfc_get_data_value ();
343 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
351 msg = gfc_extract_int (expr, &tmp);
352 gfc_free_expr (expr);
360 m = match_data_constant (&tail->expr);
363 if (m == MATCH_ERROR)
367 if (gfc_match_char ('/') == MATCH_YES)
369 if (gfc_match_char (',') == MATCH_NO)
376 gfc_syntax_error (ST_DATA);
381 /* Matches an old style initialization. */
384 match_old_style_init (const char *name)
390 /* Set up data structure to hold initializers. */
391 gfc_find_sym_tree (name, NULL, 0, &st);
393 newdata = gfc_get_data ();
394 newdata->var = gfc_get_data_variable ();
395 newdata->var->expr = gfc_get_variable_expr (st);
397 /* Match initial value list. This also eats the terminal
399 m = top_val_list (newdata);
408 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
413 /* Chain in namespace list of DATA initializers. */
414 newdata->next = gfc_current_ns->data;
415 gfc_current_ns->data = newdata;
420 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
421 we are matching a DATA statement and are therefore issuing an error
422 if we encounter something unexpected, if not, we're trying to match
423 an old-style initialization expression of the form INTEGER I /2/. */
426 gfc_match_data (void)
433 new = gfc_get_data ();
434 new->where = gfc_current_locus;
436 m = top_var_list (new);
440 m = top_val_list (new);
444 new->next = gfc_current_ns->data;
445 gfc_current_ns->data = new;
447 if (gfc_match_eos () == MATCH_YES)
450 gfc_match_char (','); /* Optional comma */
455 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
467 /************************ Declaration statements *********************/
469 /* Match an intent specification. Since this can only happen after an
470 INTENT word, a legal intent-spec must follow. */
473 match_intent_spec (void)
476 if (gfc_match (" ( in out )") == MATCH_YES)
478 if (gfc_match (" ( in )") == MATCH_YES)
480 if (gfc_match (" ( out )") == MATCH_YES)
483 gfc_error ("Bad INTENT specification at %C");
484 return INTENT_UNKNOWN;
488 /* Matches a character length specification, which is either a
489 specification expression or a '*'. */
492 char_len_param_value (gfc_expr ** expr)
495 if (gfc_match_char ('*') == MATCH_YES)
501 return gfc_match_expr (expr);
505 /* A character length is a '*' followed by a literal integer or a
506 char_len_param_value in parenthesis. */
509 match_char_length (gfc_expr ** expr)
514 m = gfc_match_char ('*');
518 /* cnt is unused, here. */
519 m = gfc_match_small_literal_int (&length, &cnt);
520 if (m == MATCH_ERROR)
525 *expr = gfc_int_expr (length);
529 if (gfc_match_char ('(') == MATCH_NO)
532 m = char_len_param_value (expr);
533 if (m == MATCH_ERROR)
538 if (gfc_match_char (')') == MATCH_NO)
540 gfc_free_expr (*expr);
548 gfc_error ("Syntax error in character length specification at %C");
553 /* Special subroutine for finding a symbol. Check if the name is found
554 in the current name space. If not, and we're compiling a function or
555 subroutine and the parent compilation unit is an interface, then check
556 to see if the name we've been given is the name of the interface
557 (located in another namespace). */
560 find_special (const char *name, gfc_symbol ** result)
565 i = gfc_get_symbol (name, NULL, result);
569 if (gfc_current_state () != COMP_SUBROUTINE
570 && gfc_current_state () != COMP_FUNCTION)
573 s = gfc_state_stack->previous;
577 if (s->state != COMP_INTERFACE)
580 goto end; /* Nameless interface */
582 if (strcmp (name, s->sym->name) == 0)
593 /* Special subroutine for getting a symbol node associated with a
594 procedure name, used in SUBROUTINE and FUNCTION statements. The
595 symbol is created in the parent using with symtree node in the
596 child unit pointing to the symbol. If the current namespace has no
597 parent, then the symbol is just created in the current unit. */
600 get_proc_name (const char *name, gfc_symbol ** result)
606 if (gfc_current_ns->parent == NULL)
607 return gfc_get_symbol (name, NULL, result);
609 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
613 /* ??? Deal with ENTRY problem */
615 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
621 /* See if the procedure should be a module procedure */
623 if (sym->ns->proc_name != NULL
624 && sym->ns->proc_name->attr.flavor == FL_MODULE
625 && sym->attr.proc != PROC_MODULE
626 && gfc_add_procedure (&sym->attr, PROC_MODULE,
627 sym->name, NULL) == FAILURE)
634 /* Function called by variable_decl() that adds a name to the symbol
638 build_sym (const char *name, gfc_charlen * cl,
639 gfc_array_spec ** as, locus * var_locus)
641 symbol_attribute attr;
644 /* if (find_special (name, &sym)) */
645 if (gfc_get_symbol (name, NULL, &sym))
648 /* Start updating the symbol table. Add basic type attribute
650 if (current_ts.type != BT_UNKNOWN
651 &&(sym->attr.implicit_type == 0
652 || !gfc_compare_types (&sym->ts, ¤t_ts))
653 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
656 if (sym->ts.type == BT_CHARACTER)
659 /* Add dimension attribute if present. */
660 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
664 /* Add attribute to symbol. The copy is so that we can reset the
665 dimension attribute. */
669 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
675 /* Set character constant to the given length. The constant will be padded or
679 gfc_set_constant_character_len (int len, gfc_expr * expr)
684 gcc_assert (expr->expr_type == EXPR_CONSTANT);
685 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
687 slen = expr->value.character.length;
690 s = gfc_getmem (len);
691 memcpy (s, expr->value.character.string, MIN (len, slen));
693 memset (&s[slen], ' ', len - slen);
694 gfc_free (expr->value.character.string);
695 expr->value.character.string = s;
696 expr->value.character.length = len;
701 /* Function to create and update the enumerator history
702 using the information passed as arguments.
703 Pointer "max_enum" is also updated, to point to
704 enum history node containing largest initializer.
706 SYM points to the symbol node of enumerator.
707 INIT points to its enumerator value. */
710 create_enum_history(gfc_symbol *sym, gfc_expr *init)
712 enumerator_history *new_enum_history;
713 gcc_assert (sym != NULL && init != NULL);
715 new_enum_history = gfc_getmem (sizeof (enumerator_history));
717 new_enum_history->sym = sym;
718 new_enum_history->initializer = init;
719 new_enum_history->next = NULL;
721 if (enum_history == NULL)
723 enum_history = new_enum_history;
724 max_enum = enum_history;
728 new_enum_history->next = enum_history;
729 enum_history = new_enum_history;
731 if (mpz_cmp (max_enum->initializer->value.integer,
732 new_enum_history->initializer->value.integer) < 0)
733 max_enum = new_enum_history;
738 /* Function to free enum kind history. */
741 gfc_free_enum_history(void)
743 enumerator_history *current = enum_history;
744 enumerator_history *next;
746 while (current != NULL)
748 next = current->next;
757 /* Function called by variable_decl() that adds an initialization
758 expression to a symbol. */
761 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
764 symbol_attribute attr;
769 if (find_special (name, &sym))
774 /* If this symbol is confirming an implicit parameter type,
775 then an initialization expression is not allowed. */
776 if (attr.flavor == FL_PARAMETER
777 && sym->value != NULL
780 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
789 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
796 /* An initializer is required for PARAMETER declarations. */
797 if (attr.flavor == FL_PARAMETER)
799 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
805 /* If a variable appears in a DATA block, it cannot have an
810 ("Variable '%s' at %C with an initializer already appears "
811 "in a DATA statement", sym->name);
815 /* Check if the assignment can happen. This has to be put off
816 until later for a derived type variable. */
817 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
818 && gfc_check_assign_symbol (sym, init) == FAILURE)
821 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
823 /* Update symbol character length according initializer. */
824 if (sym->ts.cl->length == NULL)
826 /* If there are multiple CHARACTER variables declared on
827 the same line, we don't want them to share the same
829 sym->ts.cl = gfc_get_charlen ();
830 sym->ts.cl->next = gfc_current_ns->cl_list;
831 gfc_current_ns->cl_list = sym->ts.cl;
833 if (init->expr_type == EXPR_CONSTANT)
835 gfc_int_expr (init->value.character.length);
836 else if (init->expr_type == EXPR_ARRAY)
837 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
839 /* Update initializer character length according symbol. */
840 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
842 int len = mpz_get_si (sym->ts.cl->length->value.integer);
845 if (init->expr_type == EXPR_CONSTANT)
846 gfc_set_constant_character_len (len, init);
847 else if (init->expr_type == EXPR_ARRAY)
849 gfc_free_expr (init->ts.cl->length);
850 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
851 for (p = init->value.constructor; p; p = p->next)
852 gfc_set_constant_character_len (len, p->expr);
857 /* Add initializer. Make sure we keep the ranks sane. */
858 if (sym->attr.dimension && init->rank == 0)
859 init->rank = sym->as->rank;
865 /* Maintain enumerator history. */
866 if (gfc_current_state () == COMP_ENUM)
867 create_enum_history (sym, init);
873 /* Function called by variable_decl() that adds a name to a structure
877 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
878 gfc_array_spec ** as)
882 /* If the current symbol is of the same derived type that we're
883 constructing, it must have the pointer attribute. */
884 if (current_ts.type == BT_DERIVED
885 && current_ts.derived == gfc_current_block ()
886 && current_attr.pointer == 0)
888 gfc_error ("Component at %C must have the POINTER attribute");
892 if (gfc_current_block ()->attr.pointer
895 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
897 gfc_error ("Array component of structure at %C must have explicit "
898 "or deferred shape");
903 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
908 gfc_set_component_attr (c, ¤t_attr);
910 c->initializer = *init;
918 /* Check array components. */
924 if (c->as->type != AS_DEFERRED)
926 gfc_error ("Pointer array component of structure at %C "
927 "must have a deferred shape");
933 if (c->as->type != AS_EXPLICIT)
936 ("Array component of structure at %C must have an explicit "
946 /* Match a 'NULL()', and possibly take care of some side effects. */
949 gfc_match_null (gfc_expr ** result)
955 m = gfc_match (" null ( )");
959 /* The NULL symbol now has to be/become an intrinsic function. */
960 if (gfc_get_symbol ("null", NULL, &sym))
962 gfc_error ("NULL() initialization at %C is ambiguous");
966 gfc_intrinsic_symbol (sym);
968 if (sym->attr.proc != PROC_INTRINSIC
969 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
970 sym->name, NULL) == FAILURE
971 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
975 e->where = gfc_current_locus;
976 e->expr_type = EXPR_NULL;
977 e->ts.type = BT_UNKNOWN;
985 /* Match a variable name with an optional initializer. When this
986 subroutine is called, a variable is expected to be parsed next.
987 Depending on what is happening at the moment, updates either the
988 symbol table or the current interface. */
991 variable_decl (int elem)
993 char name[GFC_MAX_SYMBOL_LEN + 1];
994 gfc_expr *initializer, *char_len;
996 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1007 old_locus = gfc_current_locus;
1009 /* When we get here, we've just matched a list of attributes and
1010 maybe a type and a double colon. The next thing we expect to see
1011 is the name of the symbol. */
1012 m = gfc_match_name (name);
1016 var_locus = gfc_current_locus;
1018 /* Now we could see the optional array spec. or character length. */
1019 m = gfc_match_array_spec (&as);
1020 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1021 cp_as = gfc_copy_array_spec (as);
1022 else if (m == MATCH_ERROR)
1026 as = gfc_copy_array_spec (current_as);
1027 else if (gfc_current_state () == COMP_ENUM)
1029 gfc_error ("Enumerator cannot be array at %C");
1030 gfc_free_enum_history ();
1039 if (current_ts.type == BT_CHARACTER)
1041 switch (match_char_length (&char_len))
1044 cl = gfc_get_charlen ();
1045 cl->next = gfc_current_ns->cl_list;
1046 gfc_current_ns->cl_list = cl;
1048 cl->length = char_len;
1051 /* Non-constant lengths need to be copied after the first
1054 if (elem > 1 && current_ts.cl->length
1055 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1057 cl = gfc_get_charlen ();
1058 cl->next = gfc_current_ns->cl_list;
1059 gfc_current_ns->cl_list = cl;
1060 cl->length = gfc_copy_expr (current_ts.cl->length);
1072 /* If this symbol has already shown up in a Cray Pointer declaration,
1073 then we want to set the type & bail out. */
1074 if (gfc_option.flag_cray_pointer)
1076 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1077 if (sym != NULL && sym->attr.cray_pointee)
1079 sym->ts.type = current_ts.type;
1080 sym->ts.kind = current_ts.kind;
1082 sym->ts.derived = current_ts.derived;
1085 /* Check to see if we have an array specification. */
1088 if (sym->as != NULL)
1090 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1091 gfc_free_array_spec (cp_as);
1097 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1098 gfc_internal_error ("Couldn't set pointee array spec.");
1100 /* Fix the array spec. */
1101 m = gfc_mod_pointee_as (sym->as);
1102 if (m == MATCH_ERROR)
1110 gfc_free_array_spec (cp_as);
1115 /* OK, we've successfully matched the declaration. Now put the
1116 symbol in the current namespace, because it might be used in the
1117 optional initialization expression for this symbol, e.g. this is
1120 integer, parameter :: i = huge(i)
1122 This is only true for parameters or variables of a basic type.
1123 For components of derived types, it is not true, so we don't
1124 create a symbol for those yet. If we fail to create the symbol,
1126 if (gfc_current_state () != COMP_DERIVED
1127 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1133 /* In functions that have a RESULT variable defined, the function
1134 name always refers to function calls. Therefore, the name is
1135 not allowed to appear in specification statements. */
1136 if (gfc_current_state () == COMP_FUNCTION
1137 && gfc_current_block () != NULL
1138 && gfc_current_block ()->result != NULL
1139 && gfc_current_block ()->result != gfc_current_block ()
1140 && strcmp (gfc_current_block ()->name, name) == 0)
1142 gfc_error ("Function name '%s' not allowed at %C", name);
1147 /* We allow old-style initializations of the form
1148 integer i /2/, j(4) /3*3, 1/
1149 (if no colon has been seen). These are different from data
1150 statements in that initializers are only allowed to apply to the
1151 variable immediately preceding, i.e.
1153 is not allowed. Therefore we have to do some work manually, that
1154 could otherwise be left to the matchers for DATA statements. */
1156 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1158 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1159 "initialization at %C") == FAILURE)
1162 return match_old_style_init (name);
1165 /* The double colon must be present in order to have initializers.
1166 Otherwise the statement is ambiguous with an assignment statement. */
1169 if (gfc_match (" =>") == MATCH_YES)
1172 if (!current_attr.pointer)
1174 gfc_error ("Initialization at %C isn't for a pointer variable");
1179 m = gfc_match_null (&initializer);
1182 gfc_error ("Pointer initialization requires a NULL at %C");
1186 if (gfc_pure (NULL))
1189 ("Initialization of pointer at %C is not allowed in a "
1197 initializer->ts = current_ts;
1200 else if (gfc_match_char ('=') == MATCH_YES)
1202 if (current_attr.pointer)
1205 ("Pointer initialization at %C requires '=>', not '='");
1210 m = gfc_match_init_expr (&initializer);
1213 gfc_error ("Expected an initialization expression at %C");
1217 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1220 ("Initialization of variable at %C is not allowed in a "
1230 /* Check if we are parsing an enumeration and if the current enumerator
1231 variable has an initializer or not. If it does not have an
1232 initializer, the initialization value of the previous enumerator
1233 (stored in last_initializer) is incremented by 1 and is used to
1234 initialize the current enumerator. */
1235 if (gfc_current_state () == COMP_ENUM)
1237 if (initializer == NULL)
1238 initializer = gfc_enum_initializer (last_initializer, old_locus);
1240 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
1242 gfc_error("ENUMERATOR %L not initialized with integer expression",
1245 gfc_free_enum_history ();
1249 /* Store this current initializer, for the next enumerator
1250 variable to be parsed. */
1251 last_initializer = initializer;
1254 /* Add the initializer. Note that it is fine if initializer is
1255 NULL here, because we sometimes also need to check if a
1256 declaration *must* have an initialization expression. */
1257 if (gfc_current_state () != COMP_DERIVED)
1258 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1261 if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
1262 initializer = gfc_default_initializer (¤t_ts);
1263 t = build_struct (name, cl, &initializer, &as);
1266 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1269 /* Free stuff up and return. */
1270 gfc_free_expr (initializer);
1271 gfc_free_array_spec (as);
1277 /* Match an extended-f77 kind specification. */
1280 gfc_match_old_kind_spec (gfc_typespec * ts)
1283 int original_kind, cnt;
1285 if (gfc_match_char ('*') != MATCH_YES)
1288 /* cnt is unsed, here. */
1289 m = gfc_match_small_literal_int (&ts->kind, &cnt);
1293 original_kind = ts->kind;
1295 /* Massage the kind numbers for complex types. */
1296 if (ts->type == BT_COMPLEX)
1300 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1301 gfc_basic_typename (ts->type), original_kind);
1307 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1309 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1310 gfc_basic_typename (ts->type), original_kind);
1314 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1315 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1322 /* Match a kind specification. Since kinds are generally optional, we
1323 usually return MATCH_NO if something goes wrong. If a "kind="
1324 string is found, then we know we have an error. */
1327 gfc_match_kind_spec (gfc_typespec * ts)
1337 where = gfc_current_locus;
1339 if (gfc_match_char ('(') == MATCH_NO)
1342 /* Also gobbles optional text. */
1343 if (gfc_match (" kind = ") == MATCH_YES)
1346 n = gfc_match_init_expr (&e);
1348 gfc_error ("Expected initialization expression at %C");
1354 gfc_error ("Expected scalar initialization expression at %C");
1359 msg = gfc_extract_int (e, &ts->kind);
1370 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1372 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1373 gfc_basic_typename (ts->type));
1379 if (gfc_match_char (')') != MATCH_YES)
1381 gfc_error ("Missing right paren at %C");
1389 gfc_current_locus = where;
1394 /* Match the various kind/length specifications in a CHARACTER
1395 declaration. We don't return MATCH_NO. */
1398 match_char_spec (gfc_typespec * ts)
1400 int i, kind, seen_length;
1405 kind = gfc_default_character_kind;
1409 /* Try the old-style specification first. */
1410 old_char_selector = 0;
1412 m = match_char_length (&len);
1416 old_char_selector = 1;
1421 m = gfc_match_char ('(');
1424 m = MATCH_YES; /* character without length is a single char */
1428 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1429 if (gfc_match (" kind =") == MATCH_YES)
1431 m = gfc_match_small_int (&kind);
1432 if (m == MATCH_ERROR)
1437 if (gfc_match (" , len =") == MATCH_NO)
1440 m = char_len_param_value (&len);
1443 if (m == MATCH_ERROR)
1450 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1451 if (gfc_match (" len =") == MATCH_YES)
1453 m = char_len_param_value (&len);
1456 if (m == MATCH_ERROR)
1460 if (gfc_match_char (')') == MATCH_YES)
1463 if (gfc_match (" , kind =") != MATCH_YES)
1466 gfc_match_small_int (&kind);
1468 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1470 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1477 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1478 m = char_len_param_value (&len);
1481 if (m == MATCH_ERROR)
1485 m = gfc_match_char (')');
1489 if (gfc_match_char (',') != MATCH_YES)
1492 gfc_match (" kind ="); /* Gobble optional text */
1494 m = gfc_match_small_int (&kind);
1495 if (m == MATCH_ERROR)
1501 /* Require a right-paren at this point. */
1502 m = gfc_match_char (')');
1507 gfc_error ("Syntax error in CHARACTER declaration at %C");
1511 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1513 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1519 gfc_free_expr (len);
1523 /* Do some final massaging of the length values. */
1524 cl = gfc_get_charlen ();
1525 cl->next = gfc_current_ns->cl_list;
1526 gfc_current_ns->cl_list = cl;
1528 if (seen_length == 0)
1529 cl->length = gfc_int_expr (1);
1532 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1536 gfc_free_expr (len);
1537 cl->length = gfc_int_expr (0);
1548 /* Matches a type specification. If successful, sets the ts structure
1549 to the matched specification. This is necessary for FUNCTION and
1550 IMPLICIT statements.
1552 If implicit_flag is nonzero, then we don't check for the optional
1553 kind specification. Not doing so is needed for matching an IMPLICIT
1554 statement correctly. */
1557 match_type_spec (gfc_typespec * ts, int implicit_flag)
1559 char name[GFC_MAX_SYMBOL_LEN + 1];
1566 if (gfc_match (" byte") == MATCH_YES)
1568 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1572 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1574 gfc_error ("BYTE type used at %C "
1575 "is not available on the target machine");
1579 ts->type = BT_INTEGER;
1584 if (gfc_match (" integer") == MATCH_YES)
1586 ts->type = BT_INTEGER;
1587 ts->kind = gfc_default_integer_kind;
1591 if (gfc_match (" character") == MATCH_YES)
1593 ts->type = BT_CHARACTER;
1594 if (implicit_flag == 0)
1595 return match_char_spec (ts);
1600 if (gfc_match (" real") == MATCH_YES)
1603 ts->kind = gfc_default_real_kind;
1607 if (gfc_match (" double precision") == MATCH_YES)
1610 ts->kind = gfc_default_double_kind;
1614 if (gfc_match (" complex") == MATCH_YES)
1616 ts->type = BT_COMPLEX;
1617 ts->kind = gfc_default_complex_kind;
1621 if (gfc_match (" double complex") == MATCH_YES)
1623 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1624 "conform to the Fortran 95 standard") == FAILURE)
1627 ts->type = BT_COMPLEX;
1628 ts->kind = gfc_default_double_kind;
1632 if (gfc_match (" logical") == MATCH_YES)
1634 ts->type = BT_LOGICAL;
1635 ts->kind = gfc_default_logical_kind;
1639 m = gfc_match (" type ( %n )", name);
1643 /* Search for the name but allow the components to be defined later. */
1644 if (gfc_get_ha_symbol (name, &sym))
1646 gfc_error ("Type name '%s' at %C is ambiguous", name);
1650 if (sym->attr.flavor != FL_DERIVED
1651 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1654 ts->type = BT_DERIVED;
1661 /* For all types except double, derived and character, look for an
1662 optional kind specifier. MATCH_NO is actually OK at this point. */
1663 if (implicit_flag == 1)
1666 if (gfc_current_form == FORM_FREE)
1668 c = gfc_peek_char();
1669 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1670 && c != ':' && c != ',')
1674 m = gfc_match_kind_spec (ts);
1675 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1676 m = gfc_match_old_kind_spec (ts);
1679 m = MATCH_YES; /* No kind specifier found. */
1685 /* Match an IMPLICIT NONE statement. Actually, this statement is
1686 already matched in parse.c, or we would not end up here in the
1687 first place. So the only thing we need to check, is if there is
1688 trailing garbage. If not, the match is successful. */
1691 gfc_match_implicit_none (void)
1694 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1698 /* Match the letter range(s) of an IMPLICIT statement. */
1701 match_implicit_range (void)
1703 int c, c1, c2, inner;
1706 cur_loc = gfc_current_locus;
1708 gfc_gobble_whitespace ();
1709 c = gfc_next_char ();
1712 gfc_error ("Missing character range in IMPLICIT at %C");
1719 gfc_gobble_whitespace ();
1720 c1 = gfc_next_char ();
1724 gfc_gobble_whitespace ();
1725 c = gfc_next_char ();
1730 inner = 0; /* Fall through */
1737 gfc_gobble_whitespace ();
1738 c2 = gfc_next_char ();
1742 gfc_gobble_whitespace ();
1743 c = gfc_next_char ();
1745 if ((c != ',') && (c != ')'))
1758 gfc_error ("Letters must be in alphabetic order in "
1759 "IMPLICIT statement at %C");
1763 /* See if we can add the newly matched range to the pending
1764 implicits from this IMPLICIT statement. We do not check for
1765 conflicts with whatever earlier IMPLICIT statements may have
1766 set. This is done when we've successfully finished matching
1768 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1775 gfc_syntax_error (ST_IMPLICIT);
1777 gfc_current_locus = cur_loc;
1782 /* Match an IMPLICIT statement, storing the types for
1783 gfc_set_implicit() if the statement is accepted by the parser.
1784 There is a strange looking, but legal syntactic construction
1785 possible. It looks like:
1787 IMPLICIT INTEGER (a-b) (c-d)
1789 This is legal if "a-b" is a constant expression that happens to
1790 equal one of the legal kinds for integers. The real problem
1791 happens with an implicit specification that looks like:
1793 IMPLICIT INTEGER (a-b)
1795 In this case, a typespec matcher that is "greedy" (as most of the
1796 matchers are) gobbles the character range as a kindspec, leaving
1797 nothing left. We therefore have to go a bit more slowly in the
1798 matching process by inhibiting the kindspec checking during
1799 typespec matching and checking for a kind later. */
1802 gfc_match_implicit (void)
1809 /* We don't allow empty implicit statements. */
1810 if (gfc_match_eos () == MATCH_YES)
1812 gfc_error ("Empty IMPLICIT statement at %C");
1818 /* First cleanup. */
1819 gfc_clear_new_implicit ();
1821 /* A basic type is mandatory here. */
1822 m = match_type_spec (&ts, 1);
1823 if (m == MATCH_ERROR)
1828 cur_loc = gfc_current_locus;
1829 m = match_implicit_range ();
1833 /* We may have <TYPE> (<RANGE>). */
1834 gfc_gobble_whitespace ();
1835 c = gfc_next_char ();
1836 if ((c == '\n') || (c == ','))
1838 /* Check for CHARACTER with no length parameter. */
1839 if (ts.type == BT_CHARACTER && !ts.cl)
1841 ts.kind = gfc_default_character_kind;
1842 ts.cl = gfc_get_charlen ();
1843 ts.cl->next = gfc_current_ns->cl_list;
1844 gfc_current_ns->cl_list = ts.cl;
1845 ts.cl->length = gfc_int_expr (1);
1848 /* Record the Successful match. */
1849 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1854 gfc_current_locus = cur_loc;
1857 /* Discard the (incorrectly) matched range. */
1858 gfc_clear_new_implicit ();
1860 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1861 if (ts.type == BT_CHARACTER)
1862 m = match_char_spec (&ts);
1865 m = gfc_match_kind_spec (&ts);
1868 m = gfc_match_old_kind_spec (&ts);
1869 if (m == MATCH_ERROR)
1875 if (m == MATCH_ERROR)
1878 m = match_implicit_range ();
1879 if (m == MATCH_ERROR)
1884 gfc_gobble_whitespace ();
1885 c = gfc_next_char ();
1886 if ((c != '\n') && (c != ','))
1889 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1897 gfc_syntax_error (ST_IMPLICIT);
1904 /* Matches an attribute specification including array specs. If
1905 successful, leaves the variables current_attr and current_as
1906 holding the specification. Also sets the colon_seen variable for
1907 later use by matchers associated with initializations.
1909 This subroutine is a little tricky in the sense that we don't know
1910 if we really have an attr-spec until we hit the double colon.
1911 Until that time, we can only return MATCH_NO. This forces us to
1912 check for duplicate specification at this level. */
1915 match_attr_spec (void)
1918 /* Modifiers that can exist in a type statement. */
1920 { GFC_DECL_BEGIN = 0,
1921 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1922 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1923 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1924 DECL_TARGET, DECL_COLON, DECL_NONE,
1925 GFC_DECL_END /* Sentinel */
1929 /* GFC_DECL_END is the sentinel, index starts at 0. */
1930 #define NUM_DECL GFC_DECL_END
1932 static mstring decls[] = {
1933 minit (", allocatable", DECL_ALLOCATABLE),
1934 minit (", dimension", DECL_DIMENSION),
1935 minit (", external", DECL_EXTERNAL),
1936 minit (", intent ( in )", DECL_IN),
1937 minit (", intent ( out )", DECL_OUT),
1938 minit (", intent ( in out )", DECL_INOUT),
1939 minit (", intrinsic", DECL_INTRINSIC),
1940 minit (", optional", DECL_OPTIONAL),
1941 minit (", parameter", DECL_PARAMETER),
1942 minit (", pointer", DECL_POINTER),
1943 minit (", private", DECL_PRIVATE),
1944 minit (", public", DECL_PUBLIC),
1945 minit (", save", DECL_SAVE),
1946 minit (", target", DECL_TARGET),
1947 minit ("::", DECL_COLON),
1948 minit (NULL, DECL_NONE)
1951 locus start, seen_at[NUM_DECL];
1958 gfc_clear_attr (¤t_attr);
1959 start = gfc_current_locus;
1964 /* See if we get all of the keywords up to the final double colon. */
1965 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1970 d = (decl_types) gfc_match_strings (decls);
1971 if (d == DECL_NONE || d == DECL_COLON)
1974 if (gfc_current_state () == COMP_ENUM)
1976 gfc_error ("Enumerator cannot have attributes %C");
1981 seen_at[d] = gfc_current_locus;
1983 if (d == DECL_DIMENSION)
1985 m = gfc_match_array_spec (¤t_as);
1989 gfc_error ("Missing dimension specification at %C");
1993 if (m == MATCH_ERROR)
1998 /* If we are parsing an enumeration and have ensured that no other
1999 attributes are present we can now set the parameter attribute. */
2000 if (gfc_current_state () == COMP_ENUM)
2002 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
2010 /* No double colon, so assume that we've been looking at something
2011 else the whole time. */
2018 /* Since we've seen a double colon, we have to be looking at an
2019 attr-spec. This means that we can now issue errors. */
2020 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2025 case DECL_ALLOCATABLE:
2026 attr = "ALLOCATABLE";
2028 case DECL_DIMENSION:
2035 attr = "INTENT (IN)";
2038 attr = "INTENT (OUT)";
2041 attr = "INTENT (IN OUT)";
2043 case DECL_INTRINSIC:
2049 case DECL_PARAMETER:
2068 attr = NULL; /* This shouldn't happen */
2071 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2076 /* Now that we've dealt with duplicate attributes, add the attributes
2077 to the current attribute. */
2078 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2083 if (gfc_current_state () == COMP_DERIVED
2084 && d != DECL_DIMENSION && d != DECL_POINTER
2085 && d != DECL_COLON && d != DECL_NONE)
2088 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2094 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2095 && gfc_current_state () != COMP_MODULE)
2097 if (d == DECL_PRIVATE)
2102 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2110 case DECL_ALLOCATABLE:
2111 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2114 case DECL_DIMENSION:
2115 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2119 t = gfc_add_external (¤t_attr, &seen_at[d]);
2123 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2127 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2131 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2134 case DECL_INTRINSIC:
2135 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2139 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2142 case DECL_PARAMETER:
2143 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2147 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2151 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2156 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2161 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2165 t = gfc_add_target (¤t_attr, &seen_at[d]);
2169 gfc_internal_error ("match_attr_spec(): Bad attribute");
2183 gfc_current_locus = start;
2184 gfc_free_array_spec (current_as);
2190 /* Match a data declaration statement. */
2193 gfc_match_data_decl (void)
2199 m = match_type_spec (¤t_ts, 0);
2203 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2205 sym = gfc_use_derived (current_ts.derived);
2213 current_ts.derived = sym;
2216 m = match_attr_spec ();
2217 if (m == MATCH_ERROR)
2223 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2226 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2229 gfc_find_symbol (current_ts.derived->name,
2230 current_ts.derived->ns->parent, 1, &sym);
2232 /* Any symbol that we find had better be a type definition
2233 which has its components defined. */
2234 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2235 && current_ts.derived->components != NULL)
2238 /* Now we have an error, which we signal, and then fix up
2239 because the knock-on is plain and simple confusing. */
2240 gfc_error_now ("Derived type at %C has not been previously defined "
2241 "and so cannot appear in a derived type definition.");
2242 current_attr.pointer = 1;
2247 /* If we have an old-style character declaration, and no new-style
2248 attribute specifications, then there a comma is optional between
2249 the type specification and the variable list. */
2250 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2251 gfc_match_char (',');
2253 /* Give the types/attributes to symbols that follow. Give the element
2254 a number so that repeat character length expressions can be copied. */
2258 m = variable_decl (elem++);
2259 if (m == MATCH_ERROR)
2264 if (gfc_match_eos () == MATCH_YES)
2266 if (gfc_match_char (',') != MATCH_YES)
2270 gfc_error ("Syntax error in data declaration at %C");
2274 gfc_free_array_spec (current_as);
2280 /* Match a prefix associated with a function or subroutine
2281 declaration. If the typespec pointer is nonnull, then a typespec
2282 can be matched. Note that if nothing matches, MATCH_YES is
2283 returned (the null string was matched). */
2286 match_prefix (gfc_typespec * ts)
2290 gfc_clear_attr (¤t_attr);
2294 if (!seen_type && ts != NULL
2295 && match_type_spec (ts, 0) == MATCH_YES
2296 && gfc_match_space () == MATCH_YES)
2303 if (gfc_match ("elemental% ") == MATCH_YES)
2305 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2311 if (gfc_match ("pure% ") == MATCH_YES)
2313 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2319 if (gfc_match ("recursive% ") == MATCH_YES)
2321 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2327 /* At this point, the next item is not a prefix. */
2332 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2335 copy_prefix (symbol_attribute * dest, locus * where)
2338 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2341 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2344 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2351 /* Match a formal argument list. */
2354 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2356 gfc_formal_arglist *head, *tail, *p, *q;
2357 char name[GFC_MAX_SYMBOL_LEN + 1];
2363 if (gfc_match_char ('(') != MATCH_YES)
2370 if (gfc_match_char (')') == MATCH_YES)
2375 if (gfc_match_char ('*') == MATCH_YES)
2379 m = gfc_match_name (name);
2383 if (gfc_get_symbol (name, NULL, &sym))
2387 p = gfc_get_formal_arglist ();
2399 /* We don't add the VARIABLE flavor because the name could be a
2400 dummy procedure. We don't apply these attributes to formal
2401 arguments of statement functions. */
2402 if (sym != NULL && !st_flag
2403 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2404 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2410 /* The name of a program unit can be in a different namespace,
2411 so check for it explicitly. After the statement is accepted,
2412 the name is checked for especially in gfc_get_symbol(). */
2413 if (gfc_new_block != NULL && sym != NULL
2414 && strcmp (sym->name, gfc_new_block->name) == 0)
2416 gfc_error ("Name '%s' at %C is the name of the procedure",
2422 if (gfc_match_char (')') == MATCH_YES)
2425 m = gfc_match_char (',');
2428 gfc_error ("Unexpected junk in formal argument list at %C");
2434 /* Check for duplicate symbols in the formal argument list. */
2437 for (p = head; p->next; p = p->next)
2442 for (q = p->next; q; q = q->next)
2443 if (p->sym == q->sym)
2446 ("Duplicate symbol '%s' in formal argument list at %C",
2455 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2465 gfc_free_formal_arglist (head);
2470 /* Match a RESULT specification following a function declaration or
2471 ENTRY statement. Also matches the end-of-statement. */
2474 match_result (gfc_symbol * function, gfc_symbol ** result)
2476 char name[GFC_MAX_SYMBOL_LEN + 1];
2480 if (gfc_match (" result (") != MATCH_YES)
2483 m = gfc_match_name (name);
2487 if (gfc_match (" )%t") != MATCH_YES)
2489 gfc_error ("Unexpected junk following RESULT variable at %C");
2493 if (strcmp (function->name, name) == 0)
2496 ("RESULT variable at %C must be different than function name");
2500 if (gfc_get_symbol (name, NULL, &r))
2503 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2504 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2513 /* Match a function declaration. */
2516 gfc_match_function_decl (void)
2518 char name[GFC_MAX_SYMBOL_LEN + 1];
2519 gfc_symbol *sym, *result;
2523 if (gfc_current_state () != COMP_NONE
2524 && gfc_current_state () != COMP_INTERFACE
2525 && gfc_current_state () != COMP_CONTAINS)
2528 gfc_clear_ts (¤t_ts);
2530 old_loc = gfc_current_locus;
2532 m = match_prefix (¤t_ts);
2535 gfc_current_locus = old_loc;
2539 if (gfc_match ("function% %n", name) != MATCH_YES)
2541 gfc_current_locus = old_loc;
2545 if (get_proc_name (name, &sym))
2547 gfc_new_block = sym;
2549 m = gfc_match_formal_arglist (sym, 0, 0);
2551 gfc_error ("Expected formal argument list in function definition at %C");
2552 else if (m == MATCH_ERROR)
2557 if (gfc_match_eos () != MATCH_YES)
2559 /* See if a result variable is present. */
2560 m = match_result (sym, &result);
2562 gfc_error ("Unexpected junk after function declaration at %C");
2571 /* Make changes to the symbol. */
2574 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2577 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2578 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2581 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
2583 gfc_error ("Function '%s' at %C already has a type of %s", name,
2584 gfc_basic_typename (sym->ts.type));
2590 sym->ts = current_ts;
2595 result->ts = current_ts;
2596 sym->result = result;
2602 gfc_current_locus = old_loc;
2607 /* Match an ENTRY statement. */
2610 gfc_match_entry (void)
2615 char name[GFC_MAX_SYMBOL_LEN + 1];
2616 gfc_compile_state state;
2621 m = gfc_match_name (name);
2625 state = gfc_current_state ();
2626 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2631 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2634 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2636 case COMP_BLOCK_DATA:
2638 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2640 case COMP_INTERFACE:
2642 ("ENTRY statement at %C cannot appear within an INTERFACE");
2646 ("ENTRY statement at %C cannot appear "
2647 "within a DERIVED TYPE block");
2651 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2655 ("ENTRY statement at %C cannot appear within a DO block");
2659 ("ENTRY statement at %C cannot appear within a SELECT block");
2663 ("ENTRY statement at %C cannot appear within a FORALL block");
2667 ("ENTRY statement at %C cannot appear within a WHERE block");
2671 ("ENTRY statement at %C cannot appear "
2672 "within a contained subprogram");
2675 gfc_internal_error ("gfc_match_entry(): Bad state");
2680 if (gfc_current_ns->parent != NULL
2681 && gfc_current_ns->parent->proc_name
2682 && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
2684 gfc_error("ENTRY statement at %C cannot appear in a "
2685 "contained procedure");
2689 if (get_proc_name (name, &entry))
2692 proc = gfc_current_block ();
2694 if (state == COMP_SUBROUTINE)
2696 /* An entry in a subroutine. */
2697 m = gfc_match_formal_arglist (entry, 0, 1);
2701 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2702 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2707 /* An entry in a function.
2708 We need to take special care because writing
2713 ENTRY f() RESULT (r)
2715 ENTRY f RESULT (r). */
2716 old_loc = gfc_current_locus;
2717 if (gfc_match_eos () == MATCH_YES)
2719 gfc_current_locus = old_loc;
2720 /* Match the empty argument list, and add the interface to
2722 m = gfc_match_formal_arglist (entry, 0, 1);
2725 m = gfc_match_formal_arglist (entry, 0, 0);
2732 if (gfc_match_eos () == MATCH_YES)
2734 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2735 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
2738 entry->result = entry;
2742 m = match_result (proc, &result);
2744 gfc_syntax_error (ST_ENTRY);
2748 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2749 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2750 || gfc_add_function (&entry->attr, result->name,
2754 entry->result = result;
2757 if (proc->attr.recursive && result == NULL)
2759 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2764 if (gfc_match_eos () != MATCH_YES)
2766 gfc_syntax_error (ST_ENTRY);
2770 entry->attr.recursive = proc->attr.recursive;
2771 entry->attr.elemental = proc->attr.elemental;
2772 entry->attr.pure = proc->attr.pure;
2774 el = gfc_get_entry_list ();
2776 el->next = gfc_current_ns->entries;
2777 gfc_current_ns->entries = el;
2779 el->id = el->next->id + 1;
2783 new_st.op = EXEC_ENTRY;
2784 new_st.ext.entry = el;
2790 /* Match a subroutine statement, including optional prefixes. */
2793 gfc_match_subroutine (void)
2795 char name[GFC_MAX_SYMBOL_LEN + 1];
2799 if (gfc_current_state () != COMP_NONE
2800 && gfc_current_state () != COMP_INTERFACE
2801 && gfc_current_state () != COMP_CONTAINS)
2804 m = match_prefix (NULL);
2808 m = gfc_match ("subroutine% %n", name);
2812 if (get_proc_name (name, &sym))
2814 gfc_new_block = sym;
2816 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2819 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2822 if (gfc_match_eos () != MATCH_YES)
2824 gfc_syntax_error (ST_SUBROUTINE);
2828 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2835 /* Return nonzero if we're currently compiling a contained procedure. */
2838 contained_procedure (void)
2842 for (s=gfc_state_stack; s; s=s->previous)
2843 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2844 && s->previous != NULL
2845 && s->previous->state == COMP_CONTAINS)
2851 /* Set the kind of each enumerator. The kind is selected such that it is
2852 interoperable with the corresponding C enumeration type, making
2853 sure that -fshort-enums is honored. */
2858 enumerator_history *current_history = NULL;
2862 if (max_enum == NULL || enum_history == NULL)
2865 if (!gfc_option.fshort_enums)
2871 kind = gfc_integer_kinds[i++].kind;
2873 while (kind < gfc_c_int_kind
2874 && gfc_check_integer_range (max_enum->initializer->value.integer,
2877 current_history = enum_history;
2878 while (current_history != NULL)
2880 current_history->sym->ts.kind = kind;
2881 current_history = current_history->next;
2885 /* Match any of the various end-block statements. Returns the type of
2886 END to the caller. The END INTERFACE, END IF, END DO and END
2887 SELECT statements cannot be replaced by a single END statement. */
2890 gfc_match_end (gfc_statement * st)
2892 char name[GFC_MAX_SYMBOL_LEN + 1];
2893 gfc_compile_state state;
2895 const char *block_name;
2900 old_loc = gfc_current_locus;
2901 if (gfc_match ("end") != MATCH_YES)
2904 state = gfc_current_state ();
2906 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2908 if (state == COMP_CONTAINS)
2910 state = gfc_state_stack->previous->state;
2911 block_name = gfc_state_stack->previous->sym == NULL ? NULL
2912 : gfc_state_stack->previous->sym->name;
2919 *st = ST_END_PROGRAM;
2920 target = " program";
2924 case COMP_SUBROUTINE:
2925 *st = ST_END_SUBROUTINE;
2926 target = " subroutine";
2927 eos_ok = !contained_procedure ();
2931 *st = ST_END_FUNCTION;
2932 target = " function";
2933 eos_ok = !contained_procedure ();
2936 case COMP_BLOCK_DATA:
2937 *st = ST_END_BLOCK_DATA;
2938 target = " block data";
2943 *st = ST_END_MODULE;
2948 case COMP_INTERFACE:
2949 *st = ST_END_INTERFACE;
2950 target = " interface";
2973 *st = ST_END_SELECT;
2979 *st = ST_END_FORALL;
2994 last_initializer = NULL;
2996 gfc_free_enum_history ();
3000 gfc_error ("Unexpected END statement at %C");
3004 if (gfc_match_eos () == MATCH_YES)
3008 /* We would have required END [something] */
3009 gfc_error ("%s statement expected at %L",
3010 gfc_ascii_statement (*st), &old_loc);
3017 /* Verify that we've got the sort of end-block that we're expecting. */
3018 if (gfc_match (target) != MATCH_YES)
3020 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3024 /* If we're at the end, make sure a block name wasn't required. */
3025 if (gfc_match_eos () == MATCH_YES)
3028 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3031 if (gfc_current_block () == NULL)
3034 gfc_error ("Expected block name of '%s' in %s statement at %C",
3035 block_name, gfc_ascii_statement (*st));
3040 /* END INTERFACE has a special handler for its several possible endings. */
3041 if (*st == ST_END_INTERFACE)
3042 return gfc_match_end_interface ();
3044 /* We haven't hit the end of statement, so what is left must be an end-name. */
3045 m = gfc_match_space ();
3047 m = gfc_match_name (name);
3050 gfc_error ("Expected terminating name at %C");
3054 if (block_name == NULL)
3057 if (strcmp (name, block_name) != 0)
3059 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3060 gfc_ascii_statement (*st));
3064 if (gfc_match_eos () == MATCH_YES)
3068 gfc_syntax_error (*st);
3071 gfc_current_locus = old_loc;
3077 /***************** Attribute declaration statements ****************/
3079 /* Set the attribute of a single variable. */
3084 char name[GFC_MAX_SYMBOL_LEN + 1];
3092 m = gfc_match_name (name);
3096 if (find_special (name, &sym))
3099 var_locus = gfc_current_locus;
3101 /* Deal with possible array specification for certain attributes. */
3102 if (current_attr.dimension
3103 || current_attr.allocatable
3104 || current_attr.pointer
3105 || current_attr.target)
3107 m = gfc_match_array_spec (&as);
3108 if (m == MATCH_ERROR)
3111 if (current_attr.dimension && m == MATCH_NO)
3114 ("Missing array specification at %L in DIMENSION statement",
3120 if ((current_attr.allocatable || current_attr.pointer)
3121 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3123 gfc_error ("Array specification must be deferred at %L",
3130 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3131 if (current_attr.dimension == 0
3132 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3138 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3144 if (sym->attr.cray_pointee && sym->as != NULL)
3146 /* Fix the array spec. */
3147 m = gfc_mod_pointee_as (sym->as);
3148 if (m == MATCH_ERROR)
3152 if ((current_attr.external || current_attr.intrinsic)
3153 && sym->attr.flavor != FL_PROCEDURE
3154 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3163 gfc_free_array_spec (as);
3168 /* Generic attribute declaration subroutine. Used for attributes that
3169 just have a list of names. */
3176 /* Gobble the optional double colon, by simply ignoring the result
3186 if (gfc_match_eos () == MATCH_YES)
3192 if (gfc_match_char (',') != MATCH_YES)
3194 gfc_error ("Unexpected character in variable list at %C");
3204 /* This routine matches Cray Pointer declarations of the form:
3205 pointer ( <pointer>, <pointee> )
3207 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3208 The pointer, if already declared, should be an integer. Otherwise, we
3209 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3210 be either a scalar, or an array declaration. No space is allocated for
3211 the pointee. For the statement
3212 pointer (ipt, ar(10))
3213 any subsequent uses of ar will be translated (in C-notation) as
3214 ar(i) => ((<type> *) ipt)(i)
3215 After gimplification, pointee variable will disappear in the code. */
3218 cray_pointer_decl (void)
3222 gfc_symbol *cptr; /* Pointer symbol. */
3223 gfc_symbol *cpte; /* Pointee symbol. */
3229 if (gfc_match_char ('(') != MATCH_YES)
3231 gfc_error ("Expected '(' at %C");
3235 /* Match pointer. */
3236 var_locus = gfc_current_locus;
3237 gfc_clear_attr (¤t_attr);
3238 gfc_add_cray_pointer (¤t_attr, &var_locus);
3239 current_ts.type = BT_INTEGER;
3240 current_ts.kind = gfc_index_integer_kind;
3242 m = gfc_match_symbol (&cptr, 0);
3245 gfc_error ("Expected variable name at %C");
3249 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3252 gfc_set_sym_referenced (cptr);
3254 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3256 cptr->ts.type = BT_INTEGER;
3257 cptr->ts.kind = gfc_index_integer_kind;
3259 else if (cptr->ts.type != BT_INTEGER)
3261 gfc_error ("Cray pointer at %C must be an integer.");
3264 else if (cptr->ts.kind < gfc_index_integer_kind)
3265 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3266 " memory addresses require %d bytes.",
3268 gfc_index_integer_kind);
3270 if (gfc_match_char (',') != MATCH_YES)
3272 gfc_error ("Expected \",\" at %C");
3276 /* Match Pointee. */
3277 var_locus = gfc_current_locus;
3278 gfc_clear_attr (¤t_attr);
3279 gfc_add_cray_pointee (¤t_attr, &var_locus);
3280 current_ts.type = BT_UNKNOWN;
3281 current_ts.kind = 0;
3283 m = gfc_match_symbol (&cpte, 0);
3286 gfc_error ("Expected variable name at %C");
3290 /* Check for an optional array spec. */
3291 m = gfc_match_array_spec (&as);
3292 if (m == MATCH_ERROR)
3294 gfc_free_array_spec (as);
3297 else if (m == MATCH_NO)
3299 gfc_free_array_spec (as);
3303 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3306 gfc_set_sym_referenced (cpte);
3308 if (cpte->as == NULL)
3310 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3311 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3313 else if (as != NULL)
3315 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3316 gfc_free_array_spec (as);
3322 if (cpte->as != NULL)
3324 /* Fix array spec. */
3325 m = gfc_mod_pointee_as (cpte->as);
3326 if (m == MATCH_ERROR)
3330 /* Point the Pointee at the Pointer. */
3331 cpte->cp_pointer = cptr;
3333 if (gfc_match_char (')') != MATCH_YES)
3335 gfc_error ("Expected \")\" at %C");
3338 m = gfc_match_char (',');
3340 done = true; /* Stop searching for more declarations. */
3344 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3345 || gfc_match_eos () != MATCH_YES)
3347 gfc_error ("Expected \",\" or end of statement at %C");
3355 gfc_match_external (void)
3358 gfc_clear_attr (¤t_attr);
3359 gfc_add_external (¤t_attr, NULL);
3361 return attr_decl ();
3367 gfc_match_intent (void)
3371 intent = match_intent_spec ();
3372 if (intent == INTENT_UNKNOWN)
3375 gfc_clear_attr (¤t_attr);
3376 gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */
3378 return attr_decl ();
3383 gfc_match_intrinsic (void)
3386 gfc_clear_attr (¤t_attr);
3387 gfc_add_intrinsic (¤t_attr, NULL);
3389 return attr_decl ();
3394 gfc_match_optional (void)
3397 gfc_clear_attr (¤t_attr);
3398 gfc_add_optional (¤t_attr, NULL);
3400 return attr_decl ();
3405 gfc_match_pointer (void)
3407 gfc_gobble_whitespace ();
3408 if (gfc_peek_char () == '(')
3410 if (!gfc_option.flag_cray_pointer)
3412 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3416 return cray_pointer_decl ();
3420 gfc_clear_attr (¤t_attr);
3421 gfc_add_pointer (¤t_attr, NULL);
3423 return attr_decl ();
3429 gfc_match_allocatable (void)
3432 gfc_clear_attr (¤t_attr);
3433 gfc_add_allocatable (¤t_attr, NULL);
3435 return attr_decl ();
3440 gfc_match_dimension (void)
3443 gfc_clear_attr (¤t_attr);
3444 gfc_add_dimension (¤t_attr, NULL, NULL);
3446 return attr_decl ();
3451 gfc_match_target (void)
3454 gfc_clear_attr (¤t_attr);
3455 gfc_add_target (¤t_attr, NULL);
3457 return attr_decl ();
3461 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3465 access_attr_decl (gfc_statement st)
3467 char name[GFC_MAX_SYMBOL_LEN + 1];
3468 interface_type type;
3471 gfc_intrinsic_op operator;
3474 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3479 m = gfc_match_generic_spec (&type, name, &operator);
3482 if (m == MATCH_ERROR)
3487 case INTERFACE_NAMELESS:
3490 case INTERFACE_GENERIC:
3491 if (gfc_get_symbol (name, NULL, &sym))
3494 if (gfc_add_access (&sym->attr,
3496 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3497 sym->name, NULL) == FAILURE)
3502 case INTERFACE_INTRINSIC_OP:
3503 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3505 gfc_current_ns->operator_access[operator] =
3506 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3510 gfc_error ("Access specification of the %s operator at %C has "
3511 "already been specified", gfc_op2string (operator));
3517 case INTERFACE_USER_OP:
3518 uop = gfc_get_uop (name);
3520 if (uop->access == ACCESS_UNKNOWN)
3523 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3528 ("Access specification of the .%s. operator at %C has "
3529 "already been specified", sym->name);
3536 if (gfc_match_char (',') == MATCH_NO)
3540 if (gfc_match_eos () != MATCH_YES)
3545 gfc_syntax_error (st);
3552 /* The PRIVATE statement is a bit weird in that it can be a attribute
3553 declaration, but also works as a standlone statement inside of a
3554 type declaration or a module. */
3557 gfc_match_private (gfc_statement * st)
3560 if (gfc_match ("private") != MATCH_YES)
3563 if (gfc_current_state () == COMP_DERIVED)
3565 if (gfc_match_eos () == MATCH_YES)
3571 gfc_syntax_error (ST_PRIVATE);
3575 if (gfc_match_eos () == MATCH_YES)
3582 return access_attr_decl (ST_PRIVATE);
3587 gfc_match_public (gfc_statement * st)
3590 if (gfc_match ("public") != MATCH_YES)
3593 if (gfc_match_eos () == MATCH_YES)
3600 return access_attr_decl (ST_PUBLIC);
3604 /* Workhorse for gfc_match_parameter. */
3613 m = gfc_match_symbol (&sym, 0);
3615 gfc_error ("Expected variable name at %C in PARAMETER statement");
3620 if (gfc_match_char ('=') == MATCH_NO)
3622 gfc_error ("Expected = sign in PARAMETER statement at %C");
3626 m = gfc_match_init_expr (&init);
3628 gfc_error ("Expected expression at %C in PARAMETER statement");
3632 if (sym->ts.type == BT_UNKNOWN
3633 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3639 if (gfc_check_assign_symbol (sym, init) == FAILURE
3640 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3646 if (sym->ts.type == BT_CHARACTER
3647 && sym->ts.cl != NULL
3648 && sym->ts.cl->length != NULL
3649 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3650 && init->expr_type == EXPR_CONSTANT
3651 && init->ts.type == BT_CHARACTER
3652 && init->ts.kind == 1)
3653 gfc_set_constant_character_len (
3654 mpz_get_si (sym->ts.cl->length->value.integer), init);
3660 gfc_free_expr (init);
3665 /* Match a parameter statement, with the weird syntax that these have. */
3668 gfc_match_parameter (void)
3672 if (gfc_match_char ('(') == MATCH_NO)
3681 if (gfc_match (" )%t") == MATCH_YES)
3684 if (gfc_match_char (',') != MATCH_YES)
3686 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3696 /* Save statements have a special syntax. */
3699 gfc_match_save (void)
3701 char n[GFC_MAX_SYMBOL_LEN+1];
3706 if (gfc_match_eos () == MATCH_YES)
3708 if (gfc_current_ns->seen_save)
3710 if (gfc_notify_std (GFC_STD_LEGACY,
3711 "Blanket SAVE statement at %C follows previous "
3717 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3721 if (gfc_current_ns->save_all)
3723 if (gfc_notify_std (GFC_STD_LEGACY,
3724 "SAVE statement at %C follows blanket SAVE statement")
3733 m = gfc_match_symbol (&sym, 0);
3737 if (gfc_add_save (&sym->attr, sym->name,
3738 &gfc_current_locus) == FAILURE)
3749 m = gfc_match (" / %n /", &n);
3750 if (m == MATCH_ERROR)
3755 c = gfc_get_common (n, 0);
3758 gfc_current_ns->seen_save = 1;
3761 if (gfc_match_eos () == MATCH_YES)
3763 if (gfc_match_char (',') != MATCH_YES)
3770 gfc_error ("Syntax error in SAVE statement at %C");
3775 /* Match a module procedure statement. Note that we have to modify
3776 symbols in the parent's namespace because the current one was there
3777 to receive symbols that are in an interface's formal argument list. */
3780 gfc_match_modproc (void)
3782 char name[GFC_MAX_SYMBOL_LEN + 1];
3786 if (gfc_state_stack->state != COMP_INTERFACE
3787 || gfc_state_stack->previous == NULL
3788 || current_interface.type == INTERFACE_NAMELESS)
3791 ("MODULE PROCEDURE at %C must be in a generic module interface");
3797 m = gfc_match_name (name);
3803 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3806 if (sym->attr.proc != PROC_MODULE
3807 && gfc_add_procedure (&sym->attr, PROC_MODULE,
3808 sym->name, NULL) == FAILURE)
3811 if (gfc_add_interface (sym) == FAILURE)
3814 if (gfc_match_eos () == MATCH_YES)
3816 if (gfc_match_char (',') != MATCH_YES)
3823 gfc_syntax_error (ST_MODULE_PROC);
3828 /* Match the beginning of a derived type declaration. If a type name
3829 was the result of a function, then it is possible to have a symbol
3830 already to be known as a derived type yet have no components. */
3833 gfc_match_derived_decl (void)
3835 char name[GFC_MAX_SYMBOL_LEN + 1];
3836 symbol_attribute attr;
3840 if (gfc_current_state () == COMP_DERIVED)
3843 gfc_clear_attr (&attr);
3846 if (gfc_match (" , private") == MATCH_YES)
3848 if (gfc_find_state (COMP_MODULE) == FAILURE)
3851 ("Derived type at %C can only be PRIVATE within a MODULE");
3855 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3860 if (gfc_match (" , public") == MATCH_YES)
3862 if (gfc_find_state (COMP_MODULE) == FAILURE)
3864 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3868 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3873 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3875 gfc_error ("Expected :: in TYPE definition at %C");
3879 m = gfc_match (" %n%t", name);
3883 /* Make sure the name isn't the name of an intrinsic type. The
3884 'double precision' type doesn't get past the name matcher. */
3885 if (strcmp (name, "integer") == 0
3886 || strcmp (name, "real") == 0
3887 || strcmp (name, "character") == 0
3888 || strcmp (name, "logical") == 0
3889 || strcmp (name, "complex") == 0)
3892 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3897 if (gfc_get_symbol (name, NULL, &sym))
3900 if (sym->ts.type != BT_UNKNOWN)
3902 gfc_error ("Derived type name '%s' at %C already has a basic type "
3903 "of %s", sym->name, gfc_typename (&sym->ts));
3907 /* The symbol may already have the derived attribute without the
3908 components. The ways this can happen is via a function
3909 definition, an INTRINSIC statement or a subtype in another
3910 derived type that is a pointer. The first part of the AND clause
3911 is true if a the symbol is not the return value of a function. */
3912 if (sym->attr.flavor != FL_DERIVED
3913 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3916 if (sym->components != NULL)
3919 ("Derived type definition of '%s' at %C has already been defined",
3924 if (attr.access != ACCESS_UNKNOWN
3925 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3928 gfc_new_block = sym;
3934 /* Cray Pointees can be declared as:
3935 pointer (ipt, a (n,m,...,*))
3936 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
3937 cheat and set a constant bound of 1 for the last dimension, if this
3938 is the case. Since there is no bounds-checking for Cray Pointees,
3939 this will be okay. */
3942 gfc_mod_pointee_as (gfc_array_spec *as)
3944 as->cray_pointee = true; /* This will be useful to know later. */
3945 if (as->type == AS_ASSUMED_SIZE)
3947 as->type = AS_EXPLICIT;
3948 as->upper[as->rank - 1] = gfc_int_expr (1);
3949 as->cp_was_assumed = true;
3951 else if (as->type == AS_ASSUMED_SHAPE)
3953 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
3960 /* Match the enum definition statement, here we are trying to match
3961 the first line of enum definition statement.
3962 Returns MATCH_YES if match is found. */
3965 gfc_match_enum (void)
3969 m = gfc_match_eos ();
3973 if (gfc_notify_std (GFC_STD_F2003,
3974 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
3982 /* Match the enumerator definition statement. */
3985 gfc_match_enumerator_def (void)
3990 gfc_clear_ts (¤t_ts);
3992 m = gfc_match (" enumerator");
3996 if (gfc_current_state () != COMP_ENUM)
3998 gfc_error ("ENUM definition statement expected before %C");
3999 gfc_free_enum_history ();
4003 (¤t_ts)->type = BT_INTEGER;
4004 (¤t_ts)->kind = gfc_c_int_kind;
4006 m = match_attr_spec ();
4007 if (m == MATCH_ERROR)
4016 m = variable_decl (elem++);
4017 if (m == MATCH_ERROR)
4022 if (gfc_match_eos () == MATCH_YES)
4024 if (gfc_match_char (',') != MATCH_YES)
4028 if (gfc_current_state () == COMP_ENUM)
4030 gfc_free_enum_history ();
4031 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4036 gfc_free_array_spec (current_as);