1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006 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 m = gfc_match_small_literal_int (&length, NULL);
519 if (m == MATCH_ERROR)
524 *expr = gfc_int_expr (length);
528 if (gfc_match_char ('(') == MATCH_NO)
531 m = char_len_param_value (expr);
532 if (m == MATCH_ERROR)
537 if (gfc_match_char (')') == MATCH_NO)
539 gfc_free_expr (*expr);
547 gfc_error ("Syntax error in character length specification at %C");
552 /* Special subroutine for finding a symbol. Check if the name is found
553 in the current name space. If not, and we're compiling a function or
554 subroutine and the parent compilation unit is an interface, then check
555 to see if the name we've been given is the name of the interface
556 (located in another namespace). */
559 find_special (const char *name, gfc_symbol ** result)
564 i = gfc_get_symbol (name, NULL, result);
568 if (gfc_current_state () != COMP_SUBROUTINE
569 && gfc_current_state () != COMP_FUNCTION)
572 s = gfc_state_stack->previous;
576 if (s->state != COMP_INTERFACE)
579 goto end; /* Nameless interface */
581 if (strcmp (name, s->sym->name) == 0)
592 /* Special subroutine for getting a symbol node associated with a
593 procedure name, used in SUBROUTINE and FUNCTION statements. The
594 symbol is created in the parent using with symtree node in the
595 child unit pointing to the symbol. If the current namespace has no
596 parent, then the symbol is just created in the current unit. */
599 get_proc_name (const char *name, gfc_symbol ** result)
605 if (gfc_current_ns->parent == NULL)
606 rc = gfc_get_symbol (name, NULL, result);
608 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
612 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
614 /* Trap another encompassed procedure with the same name. All
615 these conditions are necessary to avoid picking up an entry
616 whose name clashes with that of the encompassing procedure;
617 this is handled using gsymbols to register unique,globally
619 if (sym->attr.flavor != 0
620 && sym->attr.proc != 0
622 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
623 name, &sym->declared_at);
625 /* Trap declarations of attributes in encompassing scope. The
626 signature for this is that ts.kind is set. Legitimate
627 references only set ts.type. */
628 if (sym->ts.kind != 0
629 && sym->attr.proc == 0
630 && gfc_current_ns->parent != NULL
631 && sym->attr.access == 0)
632 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
633 " and must not have attributes declared at %L",
634 name, &sym->declared_at);
637 if (gfc_current_ns->parent == NULL || *result == NULL)
640 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
645 /* See if the procedure should be a module procedure */
647 if (sym->ns->proc_name != NULL
648 && sym->ns->proc_name->attr.flavor == FL_MODULE
649 && sym->attr.proc != PROC_MODULE
650 && gfc_add_procedure (&sym->attr, PROC_MODULE,
651 sym->name, NULL) == FAILURE)
658 /* Function called by variable_decl() that adds a name to the symbol
662 build_sym (const char *name, gfc_charlen * cl,
663 gfc_array_spec ** as, locus * var_locus)
665 symbol_attribute attr;
668 /* if (find_special (name, &sym)) */
669 if (gfc_get_symbol (name, NULL, &sym))
672 /* Start updating the symbol table. Add basic type attribute
674 if (current_ts.type != BT_UNKNOWN
675 &&(sym->attr.implicit_type == 0
676 || !gfc_compare_types (&sym->ts, ¤t_ts))
677 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
680 if (sym->ts.type == BT_CHARACTER)
683 /* Add dimension attribute if present. */
684 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
688 /* Add attribute to symbol. The copy is so that we can reset the
689 dimension attribute. */
693 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
699 /* Set character constant to the given length. The constant will be padded or
703 gfc_set_constant_character_len (int len, gfc_expr * expr)
708 gcc_assert (expr->expr_type == EXPR_CONSTANT);
709 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
711 slen = expr->value.character.length;
714 s = gfc_getmem (len);
715 memcpy (s, expr->value.character.string, MIN (len, slen));
717 memset (&s[slen], ' ', len - slen);
718 gfc_free (expr->value.character.string);
719 expr->value.character.string = s;
720 expr->value.character.length = len;
725 /* Function to create and update the enumerator history
726 using the information passed as arguments.
727 Pointer "max_enum" is also updated, to point to
728 enum history node containing largest initializer.
730 SYM points to the symbol node of enumerator.
731 INIT points to its enumerator value. */
734 create_enum_history(gfc_symbol *sym, gfc_expr *init)
736 enumerator_history *new_enum_history;
737 gcc_assert (sym != NULL && init != NULL);
739 new_enum_history = gfc_getmem (sizeof (enumerator_history));
741 new_enum_history->sym = sym;
742 new_enum_history->initializer = init;
743 new_enum_history->next = NULL;
745 if (enum_history == NULL)
747 enum_history = new_enum_history;
748 max_enum = enum_history;
752 new_enum_history->next = enum_history;
753 enum_history = new_enum_history;
755 if (mpz_cmp (max_enum->initializer->value.integer,
756 new_enum_history->initializer->value.integer) < 0)
757 max_enum = new_enum_history;
762 /* Function to free enum kind history. */
765 gfc_free_enum_history(void)
767 enumerator_history *current = enum_history;
768 enumerator_history *next;
770 while (current != NULL)
772 next = current->next;
781 /* Function called by variable_decl() that adds an initialization
782 expression to a symbol. */
785 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
788 symbol_attribute attr;
793 if (find_special (name, &sym))
798 /* If this symbol is confirming an implicit parameter type,
799 then an initialization expression is not allowed. */
800 if (attr.flavor == FL_PARAMETER
801 && sym->value != NULL
804 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
813 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
820 /* An initializer is required for PARAMETER declarations. */
821 if (attr.flavor == FL_PARAMETER)
823 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
829 /* If a variable appears in a DATA block, it cannot have an
834 ("Variable '%s' at %C with an initializer already appears "
835 "in a DATA statement", sym->name);
839 /* Check if the assignment can happen. This has to be put off
840 until later for a derived type variable. */
841 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
842 && gfc_check_assign_symbol (sym, init) == FAILURE)
845 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
847 /* Update symbol character length according initializer. */
848 if (sym->ts.cl->length == NULL)
850 /* If there are multiple CHARACTER variables declared on
851 the same line, we don't want them to share the same
853 sym->ts.cl = gfc_get_charlen ();
854 sym->ts.cl->next = gfc_current_ns->cl_list;
855 gfc_current_ns->cl_list = sym->ts.cl;
857 if (init->expr_type == EXPR_CONSTANT)
859 gfc_int_expr (init->value.character.length);
860 else if (init->expr_type == EXPR_ARRAY)
861 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
863 /* Update initializer character length according symbol. */
864 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
866 int len = mpz_get_si (sym->ts.cl->length->value.integer);
869 if (init->expr_type == EXPR_CONSTANT)
870 gfc_set_constant_character_len (len, init);
871 else if (init->expr_type == EXPR_ARRAY)
873 gfc_free_expr (init->ts.cl->length);
874 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
875 for (p = init->value.constructor; p; p = p->next)
876 gfc_set_constant_character_len (len, p->expr);
881 /* Add initializer. Make sure we keep the ranks sane. */
882 if (sym->attr.dimension && init->rank == 0)
883 init->rank = sym->as->rank;
889 /* Maintain enumerator history. */
890 if (gfc_current_state () == COMP_ENUM)
891 create_enum_history (sym, init);
897 /* Function called by variable_decl() that adds a name to a structure
901 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
902 gfc_array_spec ** as)
906 /* If the current symbol is of the same derived type that we're
907 constructing, it must have the pointer attribute. */
908 if (current_ts.type == BT_DERIVED
909 && current_ts.derived == gfc_current_block ()
910 && current_attr.pointer == 0)
912 gfc_error ("Component at %C must have the POINTER attribute");
916 if (gfc_current_block ()->attr.pointer
919 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
921 gfc_error ("Array component of structure at %C must have explicit "
922 "or deferred shape");
927 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
932 gfc_set_component_attr (c, ¤t_attr);
934 c->initializer = *init;
942 /* Check array components. */
948 if (c->as->type != AS_DEFERRED)
950 gfc_error ("Pointer array component of structure at %C "
951 "must have a deferred shape");
957 if (c->as->type != AS_EXPLICIT)
960 ("Array component of structure at %C must have an explicit "
970 /* Match a 'NULL()', and possibly take care of some side effects. */
973 gfc_match_null (gfc_expr ** result)
979 m = gfc_match (" null ( )");
983 /* The NULL symbol now has to be/become an intrinsic function. */
984 if (gfc_get_symbol ("null", NULL, &sym))
986 gfc_error ("NULL() initialization at %C is ambiguous");
990 gfc_intrinsic_symbol (sym);
992 if (sym->attr.proc != PROC_INTRINSIC
993 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
994 sym->name, NULL) == FAILURE
995 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
999 e->where = gfc_current_locus;
1000 e->expr_type = EXPR_NULL;
1001 e->ts.type = BT_UNKNOWN;
1009 /* Match a variable name with an optional initializer. When this
1010 subroutine is called, a variable is expected to be parsed next.
1011 Depending on what is happening at the moment, updates either the
1012 symbol table or the current interface. */
1015 variable_decl (int elem)
1017 char name[GFC_MAX_SYMBOL_LEN + 1];
1018 gfc_expr *initializer, *char_len;
1020 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1031 old_locus = gfc_current_locus;
1033 /* When we get here, we've just matched a list of attributes and
1034 maybe a type and a double colon. The next thing we expect to see
1035 is the name of the symbol. */
1036 m = gfc_match_name (name);
1040 var_locus = gfc_current_locus;
1042 /* Now we could see the optional array spec. or character length. */
1043 m = gfc_match_array_spec (&as);
1044 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1045 cp_as = gfc_copy_array_spec (as);
1046 else if (m == MATCH_ERROR)
1050 as = gfc_copy_array_spec (current_as);
1051 else if (gfc_current_state () == COMP_ENUM)
1053 gfc_error ("Enumerator cannot be array at %C");
1054 gfc_free_enum_history ();
1063 if (current_ts.type == BT_CHARACTER)
1065 switch (match_char_length (&char_len))
1068 cl = gfc_get_charlen ();
1069 cl->next = gfc_current_ns->cl_list;
1070 gfc_current_ns->cl_list = cl;
1072 cl->length = char_len;
1075 /* Non-constant lengths need to be copied after the first
1078 if (elem > 1 && current_ts.cl->length
1079 && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1081 cl = gfc_get_charlen ();
1082 cl->next = gfc_current_ns->cl_list;
1083 gfc_current_ns->cl_list = cl;
1084 cl->length = gfc_copy_expr (current_ts.cl->length);
1096 /* If this symbol has already shown up in a Cray Pointer declaration,
1097 then we want to set the type & bail out. */
1098 if (gfc_option.flag_cray_pointer)
1100 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1101 if (sym != NULL && sym->attr.cray_pointee)
1103 sym->ts.type = current_ts.type;
1104 sym->ts.kind = current_ts.kind;
1106 sym->ts.derived = current_ts.derived;
1109 /* Check to see if we have an array specification. */
1112 if (sym->as != NULL)
1114 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1115 gfc_free_array_spec (cp_as);
1121 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1122 gfc_internal_error ("Couldn't set pointee array spec.");
1124 /* Fix the array spec. */
1125 m = gfc_mod_pointee_as (sym->as);
1126 if (m == MATCH_ERROR)
1134 gfc_free_array_spec (cp_as);
1139 /* OK, we've successfully matched the declaration. Now put the
1140 symbol in the current namespace, because it might be used in the
1141 optional initialization expression for this symbol, e.g. this is
1144 integer, parameter :: i = huge(i)
1146 This is only true for parameters or variables of a basic type.
1147 For components of derived types, it is not true, so we don't
1148 create a symbol for those yet. If we fail to create the symbol,
1150 if (gfc_current_state () != COMP_DERIVED
1151 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1157 /* In functions that have a RESULT variable defined, the function
1158 name always refers to function calls. Therefore, the name is
1159 not allowed to appear in specification statements. */
1160 if (gfc_current_state () == COMP_FUNCTION
1161 && gfc_current_block () != NULL
1162 && gfc_current_block ()->result != NULL
1163 && gfc_current_block ()->result != gfc_current_block ()
1164 && strcmp (gfc_current_block ()->name, name) == 0)
1166 gfc_error ("Function name '%s' not allowed at %C", name);
1171 /* We allow old-style initializations of the form
1172 integer i /2/, j(4) /3*3, 1/
1173 (if no colon has been seen). These are different from data
1174 statements in that initializers are only allowed to apply to the
1175 variable immediately preceding, i.e.
1177 is not allowed. Therefore we have to do some work manually, that
1178 could otherwise be left to the matchers for DATA statements. */
1180 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1182 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1183 "initialization at %C") == FAILURE)
1186 return match_old_style_init (name);
1189 /* The double colon must be present in order to have initializers.
1190 Otherwise the statement is ambiguous with an assignment statement. */
1193 if (gfc_match (" =>") == MATCH_YES)
1196 if (!current_attr.pointer)
1198 gfc_error ("Initialization at %C isn't for a pointer variable");
1203 m = gfc_match_null (&initializer);
1206 gfc_error ("Pointer initialization requires a NULL() at %C");
1210 if (gfc_pure (NULL))
1213 ("Initialization of pointer at %C is not allowed in a "
1222 else if (gfc_match_char ('=') == MATCH_YES)
1224 if (current_attr.pointer)
1227 ("Pointer initialization at %C requires '=>', not '='");
1232 m = gfc_match_init_expr (&initializer);
1235 gfc_error ("Expected an initialization expression at %C");
1239 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1242 ("Initialization of variable at %C is not allowed in a "
1252 /* Check if we are parsing an enumeration and if the current enumerator
1253 variable has an initializer or not. If it does not have an
1254 initializer, the initialization value of the previous enumerator
1255 (stored in last_initializer) is incremented by 1 and is used to
1256 initialize the current enumerator. */
1257 if (gfc_current_state () == COMP_ENUM)
1259 if (initializer == NULL)
1260 initializer = gfc_enum_initializer (last_initializer, old_locus);
1262 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
1264 gfc_error("ENUMERATOR %L not initialized with integer expression",
1267 gfc_free_enum_history ();
1271 /* Store this current initializer, for the next enumerator
1272 variable to be parsed. */
1273 last_initializer = initializer;
1276 /* Add the initializer. Note that it is fine if initializer is
1277 NULL here, because we sometimes also need to check if a
1278 declaration *must* have an initialization expression. */
1279 if (gfc_current_state () != COMP_DERIVED)
1280 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1283 if (current_ts.type == BT_DERIVED && !current_attr.pointer
1285 initializer = gfc_default_initializer (¤t_ts);
1286 t = build_struct (name, cl, &initializer, &as);
1289 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1292 /* Free stuff up and return. */
1293 gfc_free_expr (initializer);
1294 gfc_free_array_spec (as);
1300 /* Match an extended-f77 kind specification. */
1303 gfc_match_old_kind_spec (gfc_typespec * ts)
1308 if (gfc_match_char ('*') != MATCH_YES)
1311 m = gfc_match_small_literal_int (&ts->kind, NULL);
1315 original_kind = ts->kind;
1317 /* Massage the kind numbers for complex types. */
1318 if (ts->type == BT_COMPLEX)
1322 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1323 gfc_basic_typename (ts->type), original_kind);
1329 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1331 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1332 gfc_basic_typename (ts->type), original_kind);
1336 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1337 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1344 /* Match a kind specification. Since kinds are generally optional, we
1345 usually return MATCH_NO if something goes wrong. If a "kind="
1346 string is found, then we know we have an error. */
1349 gfc_match_kind_spec (gfc_typespec * ts)
1359 where = gfc_current_locus;
1361 if (gfc_match_char ('(') == MATCH_NO)
1364 /* Also gobbles optional text. */
1365 if (gfc_match (" kind = ") == MATCH_YES)
1368 n = gfc_match_init_expr (&e);
1370 gfc_error ("Expected initialization expression at %C");
1376 gfc_error ("Expected scalar initialization expression at %C");
1381 msg = gfc_extract_int (e, &ts->kind);
1392 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1394 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1395 gfc_basic_typename (ts->type));
1401 if (gfc_match_char (')') != MATCH_YES)
1403 gfc_error ("Missing right paren at %C");
1411 gfc_current_locus = where;
1416 /* Match the various kind/length specifications in a CHARACTER
1417 declaration. We don't return MATCH_NO. */
1420 match_char_spec (gfc_typespec * ts)
1422 int i, kind, seen_length;
1427 kind = gfc_default_character_kind;
1431 /* Try the old-style specification first. */
1432 old_char_selector = 0;
1434 m = match_char_length (&len);
1438 old_char_selector = 1;
1443 m = gfc_match_char ('(');
1446 m = MATCH_YES; /* character without length is a single char */
1450 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1451 if (gfc_match (" kind =") == MATCH_YES)
1453 m = gfc_match_small_int (&kind);
1454 if (m == MATCH_ERROR)
1459 if (gfc_match (" , len =") == MATCH_NO)
1462 m = char_len_param_value (&len);
1465 if (m == MATCH_ERROR)
1472 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1473 if (gfc_match (" len =") == MATCH_YES)
1475 m = char_len_param_value (&len);
1478 if (m == MATCH_ERROR)
1482 if (gfc_match_char (')') == MATCH_YES)
1485 if (gfc_match (" , kind =") != MATCH_YES)
1488 gfc_match_small_int (&kind);
1490 if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1492 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1499 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1500 m = char_len_param_value (&len);
1503 if (m == MATCH_ERROR)
1507 m = gfc_match_char (')');
1511 if (gfc_match_char (',') != MATCH_YES)
1514 gfc_match (" kind ="); /* Gobble optional text */
1516 m = gfc_match_small_int (&kind);
1517 if (m == MATCH_ERROR)
1523 /* Require a right-paren at this point. */
1524 m = gfc_match_char (')');
1529 gfc_error ("Syntax error in CHARACTER declaration at %C");
1533 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1535 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1541 gfc_free_expr (len);
1545 /* Do some final massaging of the length values. */
1546 cl = gfc_get_charlen ();
1547 cl->next = gfc_current_ns->cl_list;
1548 gfc_current_ns->cl_list = cl;
1550 if (seen_length == 0)
1551 cl->length = gfc_int_expr (1);
1554 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
1558 gfc_free_expr (len);
1559 cl->length = gfc_int_expr (0);
1570 /* Matches a type specification. If successful, sets the ts structure
1571 to the matched specification. This is necessary for FUNCTION and
1572 IMPLICIT statements.
1574 If implicit_flag is nonzero, then we don't check for the optional
1575 kind specification. Not doing so is needed for matching an IMPLICIT
1576 statement correctly. */
1579 match_type_spec (gfc_typespec * ts, int implicit_flag)
1581 char name[GFC_MAX_SYMBOL_LEN + 1];
1588 if (gfc_match (" byte") == MATCH_YES)
1590 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1594 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1596 gfc_error ("BYTE type used at %C "
1597 "is not available on the target machine");
1601 ts->type = BT_INTEGER;
1606 if (gfc_match (" integer") == MATCH_YES)
1608 ts->type = BT_INTEGER;
1609 ts->kind = gfc_default_integer_kind;
1613 if (gfc_match (" character") == MATCH_YES)
1615 ts->type = BT_CHARACTER;
1616 if (implicit_flag == 0)
1617 return match_char_spec (ts);
1622 if (gfc_match (" real") == MATCH_YES)
1625 ts->kind = gfc_default_real_kind;
1629 if (gfc_match (" double precision") == MATCH_YES)
1632 ts->kind = gfc_default_double_kind;
1636 if (gfc_match (" complex") == MATCH_YES)
1638 ts->type = BT_COMPLEX;
1639 ts->kind = gfc_default_complex_kind;
1643 if (gfc_match (" double complex") == MATCH_YES)
1645 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1646 "conform to the Fortran 95 standard") == FAILURE)
1649 ts->type = BT_COMPLEX;
1650 ts->kind = gfc_default_double_kind;
1654 if (gfc_match (" logical") == MATCH_YES)
1656 ts->type = BT_LOGICAL;
1657 ts->kind = gfc_default_logical_kind;
1661 m = gfc_match (" type ( %n )", name);
1665 /* Search for the name but allow the components to be defined later. */
1666 if (gfc_get_ha_symbol (name, &sym))
1668 gfc_error ("Type name '%s' at %C is ambiguous", name);
1672 if (sym->attr.flavor != FL_DERIVED
1673 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1676 ts->type = BT_DERIVED;
1683 /* For all types except double, derived and character, look for an
1684 optional kind specifier. MATCH_NO is actually OK at this point. */
1685 if (implicit_flag == 1)
1688 if (gfc_current_form == FORM_FREE)
1690 c = gfc_peek_char();
1691 if (!gfc_is_whitespace(c) && c != '*' && c != '('
1692 && c != ':' && c != ',')
1696 m = gfc_match_kind_spec (ts);
1697 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1698 m = gfc_match_old_kind_spec (ts);
1701 m = MATCH_YES; /* No kind specifier found. */
1707 /* Match an IMPLICIT NONE statement. Actually, this statement is
1708 already matched in parse.c, or we would not end up here in the
1709 first place. So the only thing we need to check, is if there is
1710 trailing garbage. If not, the match is successful. */
1713 gfc_match_implicit_none (void)
1716 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1720 /* Match the letter range(s) of an IMPLICIT statement. */
1723 match_implicit_range (void)
1725 int c, c1, c2, inner;
1728 cur_loc = gfc_current_locus;
1730 gfc_gobble_whitespace ();
1731 c = gfc_next_char ();
1734 gfc_error ("Missing character range in IMPLICIT at %C");
1741 gfc_gobble_whitespace ();
1742 c1 = gfc_next_char ();
1746 gfc_gobble_whitespace ();
1747 c = gfc_next_char ();
1752 inner = 0; /* Fall through */
1759 gfc_gobble_whitespace ();
1760 c2 = gfc_next_char ();
1764 gfc_gobble_whitespace ();
1765 c = gfc_next_char ();
1767 if ((c != ',') && (c != ')'))
1780 gfc_error ("Letters must be in alphabetic order in "
1781 "IMPLICIT statement at %C");
1785 /* See if we can add the newly matched range to the pending
1786 implicits from this IMPLICIT statement. We do not check for
1787 conflicts with whatever earlier IMPLICIT statements may have
1788 set. This is done when we've successfully finished matching
1790 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1797 gfc_syntax_error (ST_IMPLICIT);
1799 gfc_current_locus = cur_loc;
1804 /* Match an IMPLICIT statement, storing the types for
1805 gfc_set_implicit() if the statement is accepted by the parser.
1806 There is a strange looking, but legal syntactic construction
1807 possible. It looks like:
1809 IMPLICIT INTEGER (a-b) (c-d)
1811 This is legal if "a-b" is a constant expression that happens to
1812 equal one of the legal kinds for integers. The real problem
1813 happens with an implicit specification that looks like:
1815 IMPLICIT INTEGER (a-b)
1817 In this case, a typespec matcher that is "greedy" (as most of the
1818 matchers are) gobbles the character range as a kindspec, leaving
1819 nothing left. We therefore have to go a bit more slowly in the
1820 matching process by inhibiting the kindspec checking during
1821 typespec matching and checking for a kind later. */
1824 gfc_match_implicit (void)
1831 /* We don't allow empty implicit statements. */
1832 if (gfc_match_eos () == MATCH_YES)
1834 gfc_error ("Empty IMPLICIT statement at %C");
1840 /* First cleanup. */
1841 gfc_clear_new_implicit ();
1843 /* A basic type is mandatory here. */
1844 m = match_type_spec (&ts, 1);
1845 if (m == MATCH_ERROR)
1850 cur_loc = gfc_current_locus;
1851 m = match_implicit_range ();
1855 /* We may have <TYPE> (<RANGE>). */
1856 gfc_gobble_whitespace ();
1857 c = gfc_next_char ();
1858 if ((c == '\n') || (c == ','))
1860 /* Check for CHARACTER with no length parameter. */
1861 if (ts.type == BT_CHARACTER && !ts.cl)
1863 ts.kind = gfc_default_character_kind;
1864 ts.cl = gfc_get_charlen ();
1865 ts.cl->next = gfc_current_ns->cl_list;
1866 gfc_current_ns->cl_list = ts.cl;
1867 ts.cl->length = gfc_int_expr (1);
1870 /* Record the Successful match. */
1871 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1876 gfc_current_locus = cur_loc;
1879 /* Discard the (incorrectly) matched range. */
1880 gfc_clear_new_implicit ();
1882 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1883 if (ts.type == BT_CHARACTER)
1884 m = match_char_spec (&ts);
1887 m = gfc_match_kind_spec (&ts);
1890 m = gfc_match_old_kind_spec (&ts);
1891 if (m == MATCH_ERROR)
1897 if (m == MATCH_ERROR)
1900 m = match_implicit_range ();
1901 if (m == MATCH_ERROR)
1906 gfc_gobble_whitespace ();
1907 c = gfc_next_char ();
1908 if ((c != '\n') && (c != ','))
1911 if (gfc_merge_new_implicit (&ts) != SUCCESS)
1919 gfc_syntax_error (ST_IMPLICIT);
1926 /* Matches an attribute specification including array specs. If
1927 successful, leaves the variables current_attr and current_as
1928 holding the specification. Also sets the colon_seen variable for
1929 later use by matchers associated with initializations.
1931 This subroutine is a little tricky in the sense that we don't know
1932 if we really have an attr-spec until we hit the double colon.
1933 Until that time, we can only return MATCH_NO. This forces us to
1934 check for duplicate specification at this level. */
1937 match_attr_spec (void)
1940 /* Modifiers that can exist in a type statement. */
1942 { GFC_DECL_BEGIN = 0,
1943 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1944 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1945 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1946 DECL_TARGET, DECL_COLON, DECL_NONE,
1947 GFC_DECL_END /* Sentinel */
1951 /* GFC_DECL_END is the sentinel, index starts at 0. */
1952 #define NUM_DECL GFC_DECL_END
1954 static mstring decls[] = {
1955 minit (", allocatable", DECL_ALLOCATABLE),
1956 minit (", dimension", DECL_DIMENSION),
1957 minit (", external", DECL_EXTERNAL),
1958 minit (", intent ( in )", DECL_IN),
1959 minit (", intent ( out )", DECL_OUT),
1960 minit (", intent ( in out )", DECL_INOUT),
1961 minit (", intrinsic", DECL_INTRINSIC),
1962 minit (", optional", DECL_OPTIONAL),
1963 minit (", parameter", DECL_PARAMETER),
1964 minit (", pointer", DECL_POINTER),
1965 minit (", private", DECL_PRIVATE),
1966 minit (", public", DECL_PUBLIC),
1967 minit (", save", DECL_SAVE),
1968 minit (", target", DECL_TARGET),
1969 minit ("::", DECL_COLON),
1970 minit (NULL, DECL_NONE)
1973 locus start, seen_at[NUM_DECL];
1980 gfc_clear_attr (¤t_attr);
1981 start = gfc_current_locus;
1986 /* See if we get all of the keywords up to the final double colon. */
1987 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1992 d = (decl_types) gfc_match_strings (decls);
1993 if (d == DECL_NONE || d == DECL_COLON)
1996 if (gfc_current_state () == COMP_ENUM)
1998 gfc_error ("Enumerator cannot have attributes %C");
2003 seen_at[d] = gfc_current_locus;
2005 if (d == DECL_DIMENSION)
2007 m = gfc_match_array_spec (¤t_as);
2011 gfc_error ("Missing dimension specification at %C");
2015 if (m == MATCH_ERROR)
2020 /* If we are parsing an enumeration and have ensured that no other
2021 attributes are present we can now set the parameter attribute. */
2022 if (gfc_current_state () == COMP_ENUM)
2024 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
2032 /* No double colon, so assume that we've been looking at something
2033 else the whole time. */
2040 /* Since we've seen a double colon, we have to be looking at an
2041 attr-spec. This means that we can now issue errors. */
2042 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2047 case DECL_ALLOCATABLE:
2048 attr = "ALLOCATABLE";
2050 case DECL_DIMENSION:
2057 attr = "INTENT (IN)";
2060 attr = "INTENT (OUT)";
2063 attr = "INTENT (IN OUT)";
2065 case DECL_INTRINSIC:
2071 case DECL_PARAMETER:
2090 attr = NULL; /* This shouldn't happen */
2093 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2098 /* Now that we've dealt with duplicate attributes, add the attributes
2099 to the current attribute. */
2100 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2105 if (gfc_current_state () == COMP_DERIVED
2106 && d != DECL_DIMENSION && d != DECL_POINTER
2107 && d != DECL_COLON && d != DECL_NONE)
2110 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2116 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2117 && gfc_current_state () != COMP_MODULE)
2119 if (d == DECL_PRIVATE)
2124 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2132 case DECL_ALLOCATABLE:
2133 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2136 case DECL_DIMENSION:
2137 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2141 t = gfc_add_external (¤t_attr, &seen_at[d]);
2145 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2149 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2153 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2156 case DECL_INTRINSIC:
2157 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2161 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2164 case DECL_PARAMETER:
2165 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
2169 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
2173 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
2178 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
2183 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
2187 t = gfc_add_target (¤t_attr, &seen_at[d]);
2191 gfc_internal_error ("match_attr_spec(): Bad attribute");
2205 gfc_current_locus = start;
2206 gfc_free_array_spec (current_as);
2212 /* Match a data declaration statement. */
2215 gfc_match_data_decl (void)
2221 m = match_type_spec (¤t_ts, 0);
2225 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2227 sym = gfc_use_derived (current_ts.derived);
2235 current_ts.derived = sym;
2238 m = match_attr_spec ();
2239 if (m == MATCH_ERROR)
2245 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2248 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2251 gfc_find_symbol (current_ts.derived->name,
2252 current_ts.derived->ns->parent, 1, &sym);
2254 /* Any symbol that we find had better be a type definition
2255 which has its components defined. */
2256 if (sym != NULL && sym->attr.flavor == FL_DERIVED
2257 && current_ts.derived->components != NULL)
2260 /* Now we have an error, which we signal, and then fix up
2261 because the knock-on is plain and simple confusing. */
2262 gfc_error_now ("Derived type at %C has not been previously defined "
2263 "and so cannot appear in a derived type definition.");
2264 current_attr.pointer = 1;
2269 /* If we have an old-style character declaration, and no new-style
2270 attribute specifications, then there a comma is optional between
2271 the type specification and the variable list. */
2272 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2273 gfc_match_char (',');
2275 /* Give the types/attributes to symbols that follow. Give the element
2276 a number so that repeat character length expressions can be copied. */
2280 m = variable_decl (elem++);
2281 if (m == MATCH_ERROR)
2286 if (gfc_match_eos () == MATCH_YES)
2288 if (gfc_match_char (',') != MATCH_YES)
2292 gfc_error ("Syntax error in data declaration at %C");
2296 gfc_free_array_spec (current_as);
2302 /* Match a prefix associated with a function or subroutine
2303 declaration. If the typespec pointer is nonnull, then a typespec
2304 can be matched. Note that if nothing matches, MATCH_YES is
2305 returned (the null string was matched). */
2308 match_prefix (gfc_typespec * ts)
2312 gfc_clear_attr (¤t_attr);
2316 if (!seen_type && ts != NULL
2317 && match_type_spec (ts, 0) == MATCH_YES
2318 && gfc_match_space () == MATCH_YES)
2325 if (gfc_match ("elemental% ") == MATCH_YES)
2327 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
2333 if (gfc_match ("pure% ") == MATCH_YES)
2335 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
2341 if (gfc_match ("recursive% ") == MATCH_YES)
2343 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
2349 /* At this point, the next item is not a prefix. */
2354 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2357 copy_prefix (symbol_attribute * dest, locus * where)
2360 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2363 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2366 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2373 /* Match a formal argument list. */
2376 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
2378 gfc_formal_arglist *head, *tail, *p, *q;
2379 char name[GFC_MAX_SYMBOL_LEN + 1];
2385 if (gfc_match_char ('(') != MATCH_YES)
2392 if (gfc_match_char (')') == MATCH_YES)
2397 if (gfc_match_char ('*') == MATCH_YES)
2401 m = gfc_match_name (name);
2405 if (gfc_get_symbol (name, NULL, &sym))
2409 p = gfc_get_formal_arglist ();
2421 /* We don't add the VARIABLE flavor because the name could be a
2422 dummy procedure. We don't apply these attributes to formal
2423 arguments of statement functions. */
2424 if (sym != NULL && !st_flag
2425 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2426 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2432 /* The name of a program unit can be in a different namespace,
2433 so check for it explicitly. After the statement is accepted,
2434 the name is checked for especially in gfc_get_symbol(). */
2435 if (gfc_new_block != NULL && sym != NULL
2436 && strcmp (sym->name, gfc_new_block->name) == 0)
2438 gfc_error ("Name '%s' at %C is the name of the procedure",
2444 if (gfc_match_char (')') == MATCH_YES)
2447 m = gfc_match_char (',');
2450 gfc_error ("Unexpected junk in formal argument list at %C");
2456 /* Check for duplicate symbols in the formal argument list. */
2459 for (p = head; p->next; p = p->next)
2464 for (q = p->next; q; q = q->next)
2465 if (p->sym == q->sym)
2468 ("Duplicate symbol '%s' in formal argument list at %C",
2477 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
2487 gfc_free_formal_arglist (head);
2492 /* Match a RESULT specification following a function declaration or
2493 ENTRY statement. Also matches the end-of-statement. */
2496 match_result (gfc_symbol * function, gfc_symbol ** result)
2498 char name[GFC_MAX_SYMBOL_LEN + 1];
2502 if (gfc_match (" result (") != MATCH_YES)
2505 m = gfc_match_name (name);
2509 if (gfc_match (" )%t") != MATCH_YES)
2511 gfc_error ("Unexpected junk following RESULT variable at %C");
2515 if (strcmp (function->name, name) == 0)
2518 ("RESULT variable at %C must be different than function name");
2522 if (gfc_get_symbol (name, NULL, &r))
2525 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2526 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2535 /* Match a function declaration. */
2538 gfc_match_function_decl (void)
2540 char name[GFC_MAX_SYMBOL_LEN + 1];
2541 gfc_symbol *sym, *result;
2545 if (gfc_current_state () != COMP_NONE
2546 && gfc_current_state () != COMP_INTERFACE
2547 && gfc_current_state () != COMP_CONTAINS)
2550 gfc_clear_ts (¤t_ts);
2552 old_loc = gfc_current_locus;
2554 m = match_prefix (¤t_ts);
2557 gfc_current_locus = old_loc;
2561 if (gfc_match ("function% %n", name) != MATCH_YES)
2563 gfc_current_locus = old_loc;
2567 if (get_proc_name (name, &sym))
2569 gfc_new_block = sym;
2571 m = gfc_match_formal_arglist (sym, 0, 0);
2574 gfc_error ("Expected formal argument list in function "
2575 "definition at %C");
2579 else if (m == MATCH_ERROR)
2584 if (gfc_match_eos () != MATCH_YES)
2586 /* See if a result variable is present. */
2587 m = match_result (sym, &result);
2589 gfc_error ("Unexpected junk after function declaration at %C");
2598 /* Make changes to the symbol. */
2601 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2604 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2605 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2608 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
2610 gfc_error ("Function '%s' at %C already has a type of %s", name,
2611 gfc_basic_typename (sym->ts.type));
2617 sym->ts = current_ts;
2622 result->ts = current_ts;
2623 sym->result = result;
2629 gfc_current_locus = old_loc;
2633 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2634 name of the entry, rather than the gfc_current_block name, and to return false
2635 upon finding an existing global entry. */
2638 add_global_entry (const char * name, int sub)
2642 s = gfc_get_gsymbol(name);
2645 || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2646 global_used(s, NULL);
2649 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2650 s->where = gfc_current_locus;
2657 /* Match an ENTRY statement. */
2660 gfc_match_entry (void)
2665 char name[GFC_MAX_SYMBOL_LEN + 1];
2666 gfc_compile_state state;
2671 m = gfc_match_name (name);
2675 state = gfc_current_state ();
2676 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2681 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2684 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2686 case COMP_BLOCK_DATA:
2688 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2690 case COMP_INTERFACE:
2692 ("ENTRY statement at %C cannot appear within an INTERFACE");
2696 ("ENTRY statement at %C cannot appear "
2697 "within a DERIVED TYPE block");
2701 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2705 ("ENTRY statement at %C cannot appear within a DO block");
2709 ("ENTRY statement at %C cannot appear within a SELECT block");
2713 ("ENTRY statement at %C cannot appear within a FORALL block");
2717 ("ENTRY statement at %C cannot appear within a WHERE block");
2721 ("ENTRY statement at %C cannot appear "
2722 "within a contained subprogram");
2725 gfc_internal_error ("gfc_match_entry(): Bad state");
2730 if (gfc_current_ns->parent != NULL
2731 && gfc_current_ns->parent->proc_name
2732 && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE)
2734 gfc_error("ENTRY statement at %C cannot appear in a "
2735 "contained procedure");
2739 if (get_proc_name (name, &entry))
2742 proc = gfc_current_block ();
2744 if (state == COMP_SUBROUTINE)
2746 /* An entry in a subroutine. */
2747 if (!add_global_entry (name, 1))
2750 m = gfc_match_formal_arglist (entry, 0, 1);
2754 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2755 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
2760 /* An entry in a function.
2761 We need to take special care because writing
2766 ENTRY f() RESULT (r)
2768 ENTRY f RESULT (r). */
2769 if (!add_global_entry (name, 0))
2772 old_loc = gfc_current_locus;
2773 if (gfc_match_eos () == MATCH_YES)
2775 gfc_current_locus = old_loc;
2776 /* Match the empty argument list, and add the interface to
2778 m = gfc_match_formal_arglist (entry, 0, 1);
2781 m = gfc_match_formal_arglist (entry, 0, 0);
2788 if (gfc_match_eos () == MATCH_YES)
2790 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
2791 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
2794 entry->result = entry;
2798 m = match_result (proc, &result);
2800 gfc_syntax_error (ST_ENTRY);
2804 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
2805 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
2806 || gfc_add_function (&entry->attr, result->name,
2810 entry->result = result;
2813 if (proc->attr.recursive && result == NULL)
2815 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2820 if (gfc_match_eos () != MATCH_YES)
2822 gfc_syntax_error (ST_ENTRY);
2826 entry->attr.recursive = proc->attr.recursive;
2827 entry->attr.elemental = proc->attr.elemental;
2828 entry->attr.pure = proc->attr.pure;
2830 el = gfc_get_entry_list ();
2832 el->next = gfc_current_ns->entries;
2833 gfc_current_ns->entries = el;
2835 el->id = el->next->id + 1;
2839 new_st.op = EXEC_ENTRY;
2840 new_st.ext.entry = el;
2846 /* Match a subroutine statement, including optional prefixes. */
2849 gfc_match_subroutine (void)
2851 char name[GFC_MAX_SYMBOL_LEN + 1];
2855 if (gfc_current_state () != COMP_NONE
2856 && gfc_current_state () != COMP_INTERFACE
2857 && gfc_current_state () != COMP_CONTAINS)
2860 m = match_prefix (NULL);
2864 m = gfc_match ("subroutine% %n", name);
2868 if (get_proc_name (name, &sym))
2870 gfc_new_block = sym;
2872 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2875 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
2878 if (gfc_match_eos () != MATCH_YES)
2880 gfc_syntax_error (ST_SUBROUTINE);
2884 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2891 /* Return nonzero if we're currently compiling a contained procedure. */
2894 contained_procedure (void)
2898 for (s=gfc_state_stack; s; s=s->previous)
2899 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
2900 && s->previous != NULL
2901 && s->previous->state == COMP_CONTAINS)
2907 /* Set the kind of each enumerator. The kind is selected such that it is
2908 interoperable with the corresponding C enumeration type, making
2909 sure that -fshort-enums is honored. */
2914 enumerator_history *current_history = NULL;
2918 if (max_enum == NULL || enum_history == NULL)
2921 if (!gfc_option.fshort_enums)
2927 kind = gfc_integer_kinds[i++].kind;
2929 while (kind < gfc_c_int_kind
2930 && gfc_check_integer_range (max_enum->initializer->value.integer,
2933 current_history = enum_history;
2934 while (current_history != NULL)
2936 current_history->sym->ts.kind = kind;
2937 current_history = current_history->next;
2941 /* Match any of the various end-block statements. Returns the type of
2942 END to the caller. The END INTERFACE, END IF, END DO and END
2943 SELECT statements cannot be replaced by a single END statement. */
2946 gfc_match_end (gfc_statement * st)
2948 char name[GFC_MAX_SYMBOL_LEN + 1];
2949 gfc_compile_state state;
2951 const char *block_name;
2956 old_loc = gfc_current_locus;
2957 if (gfc_match ("end") != MATCH_YES)
2960 state = gfc_current_state ();
2962 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
2964 if (state == COMP_CONTAINS)
2966 state = gfc_state_stack->previous->state;
2967 block_name = gfc_state_stack->previous->sym == NULL ? NULL
2968 : gfc_state_stack->previous->sym->name;
2975 *st = ST_END_PROGRAM;
2976 target = " program";
2980 case COMP_SUBROUTINE:
2981 *st = ST_END_SUBROUTINE;
2982 target = " subroutine";
2983 eos_ok = !contained_procedure ();
2987 *st = ST_END_FUNCTION;
2988 target = " function";
2989 eos_ok = !contained_procedure ();
2992 case COMP_BLOCK_DATA:
2993 *st = ST_END_BLOCK_DATA;
2994 target = " block data";
2999 *st = ST_END_MODULE;
3004 case COMP_INTERFACE:
3005 *st = ST_END_INTERFACE;
3006 target = " interface";
3029 *st = ST_END_SELECT;
3035 *st = ST_END_FORALL;
3050 last_initializer = NULL;
3052 gfc_free_enum_history ();
3056 gfc_error ("Unexpected END statement at %C");
3060 if (gfc_match_eos () == MATCH_YES)
3064 /* We would have required END [something] */
3065 gfc_error ("%s statement expected at %L",
3066 gfc_ascii_statement (*st), &old_loc);
3073 /* Verify that we've got the sort of end-block that we're expecting. */
3074 if (gfc_match (target) != MATCH_YES)
3076 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3080 /* If we're at the end, make sure a block name wasn't required. */
3081 if (gfc_match_eos () == MATCH_YES)
3084 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
3087 if (gfc_current_block () == NULL)
3090 gfc_error ("Expected block name of '%s' in %s statement at %C",
3091 block_name, gfc_ascii_statement (*st));
3096 /* END INTERFACE has a special handler for its several possible endings. */
3097 if (*st == ST_END_INTERFACE)
3098 return gfc_match_end_interface ();
3100 /* We haven't hit the end of statement, so what is left must be an end-name. */
3101 m = gfc_match_space ();
3103 m = gfc_match_name (name);
3106 gfc_error ("Expected terminating name at %C");
3110 if (block_name == NULL)
3113 if (strcmp (name, block_name) != 0)
3115 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3116 gfc_ascii_statement (*st));
3120 if (gfc_match_eos () == MATCH_YES)
3124 gfc_syntax_error (*st);
3127 gfc_current_locus = old_loc;
3133 /***************** Attribute declaration statements ****************/
3135 /* Set the attribute of a single variable. */
3140 char name[GFC_MAX_SYMBOL_LEN + 1];
3148 m = gfc_match_name (name);
3152 if (find_special (name, &sym))
3155 var_locus = gfc_current_locus;
3157 /* Deal with possible array specification for certain attributes. */
3158 if (current_attr.dimension
3159 || current_attr.allocatable
3160 || current_attr.pointer
3161 || current_attr.target)
3163 m = gfc_match_array_spec (&as);
3164 if (m == MATCH_ERROR)
3167 if (current_attr.dimension && m == MATCH_NO)
3170 ("Missing array specification at %L in DIMENSION statement",
3176 if ((current_attr.allocatable || current_attr.pointer)
3177 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3179 gfc_error ("Array specification must be deferred at %L",
3186 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3187 if (current_attr.dimension == 0
3188 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3194 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3200 if (sym->attr.cray_pointee && sym->as != NULL)
3202 /* Fix the array spec. */
3203 m = gfc_mod_pointee_as (sym->as);
3204 if (m == MATCH_ERROR)
3208 if (gfc_add_attribute (&sym->attr, &var_locus, current_attr.intent) == FAILURE)
3214 if ((current_attr.external || current_attr.intrinsic)
3215 && sym->attr.flavor != FL_PROCEDURE
3216 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3225 gfc_free_array_spec (as);
3230 /* Generic attribute declaration subroutine. Used for attributes that
3231 just have a list of names. */
3238 /* Gobble the optional double colon, by simply ignoring the result
3248 if (gfc_match_eos () == MATCH_YES)
3254 if (gfc_match_char (',') != MATCH_YES)
3256 gfc_error ("Unexpected character in variable list at %C");
3266 /* This routine matches Cray Pointer declarations of the form:
3267 pointer ( <pointer>, <pointee> )
3269 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3270 The pointer, if already declared, should be an integer. Otherwise, we
3271 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3272 be either a scalar, or an array declaration. No space is allocated for
3273 the pointee. For the statement
3274 pointer (ipt, ar(10))
3275 any subsequent uses of ar will be translated (in C-notation) as
3276 ar(i) => ((<type> *) ipt)(i)
3277 After gimplification, pointee variable will disappear in the code. */
3280 cray_pointer_decl (void)
3284 gfc_symbol *cptr; /* Pointer symbol. */
3285 gfc_symbol *cpte; /* Pointee symbol. */
3291 if (gfc_match_char ('(') != MATCH_YES)
3293 gfc_error ("Expected '(' at %C");
3297 /* Match pointer. */
3298 var_locus = gfc_current_locus;
3299 gfc_clear_attr (¤t_attr);
3300 gfc_add_cray_pointer (¤t_attr, &var_locus);
3301 current_ts.type = BT_INTEGER;
3302 current_ts.kind = gfc_index_integer_kind;
3304 m = gfc_match_symbol (&cptr, 0);
3307 gfc_error ("Expected variable name at %C");
3311 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3314 gfc_set_sym_referenced (cptr);
3316 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
3318 cptr->ts.type = BT_INTEGER;
3319 cptr->ts.kind = gfc_index_integer_kind;
3321 else if (cptr->ts.type != BT_INTEGER)
3323 gfc_error ("Cray pointer at %C must be an integer.");
3326 else if (cptr->ts.kind < gfc_index_integer_kind)
3327 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3328 " memory addresses require %d bytes.",
3330 gfc_index_integer_kind);
3332 if (gfc_match_char (',') != MATCH_YES)
3334 gfc_error ("Expected \",\" at %C");
3338 /* Match Pointee. */
3339 var_locus = gfc_current_locus;
3340 gfc_clear_attr (¤t_attr);
3341 gfc_add_cray_pointee (¤t_attr, &var_locus);
3342 current_ts.type = BT_UNKNOWN;
3343 current_ts.kind = 0;
3345 m = gfc_match_symbol (&cpte, 0);
3348 gfc_error ("Expected variable name at %C");
3352 /* Check for an optional array spec. */
3353 m = gfc_match_array_spec (&as);
3354 if (m == MATCH_ERROR)
3356 gfc_free_array_spec (as);
3359 else if (m == MATCH_NO)
3361 gfc_free_array_spec (as);
3365 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3368 gfc_set_sym_referenced (cpte);
3370 if (cpte->as == NULL)
3372 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3373 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3375 else if (as != NULL)
3377 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3378 gfc_free_array_spec (as);
3384 if (cpte->as != NULL)
3386 /* Fix array spec. */
3387 m = gfc_mod_pointee_as (cpte->as);
3388 if (m == MATCH_ERROR)
3392 /* Point the Pointee at the Pointer. */
3393 cpte->cp_pointer = cptr;
3395 if (gfc_match_char (')') != MATCH_YES)
3397 gfc_error ("Expected \")\" at %C");
3400 m = gfc_match_char (',');
3402 done = true; /* Stop searching for more declarations. */
3406 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
3407 || gfc_match_eos () != MATCH_YES)
3409 gfc_error ("Expected \",\" or end of statement at %C");
3417 gfc_match_external (void)
3420 gfc_clear_attr (¤t_attr);
3421 current_attr.external = 1;
3423 return attr_decl ();
3429 gfc_match_intent (void)
3433 intent = match_intent_spec ();
3434 if (intent == INTENT_UNKNOWN)
3437 gfc_clear_attr (¤t_attr);
3438 current_attr.intent = intent;
3440 return attr_decl ();
3445 gfc_match_intrinsic (void)
3448 gfc_clear_attr (¤t_attr);
3449 current_attr.intrinsic = 1;
3451 return attr_decl ();
3456 gfc_match_optional (void)
3459 gfc_clear_attr (¤t_attr);
3460 current_attr.optional = 1;
3462 return attr_decl ();
3467 gfc_match_pointer (void)
3469 gfc_gobble_whitespace ();
3470 if (gfc_peek_char () == '(')
3472 if (!gfc_option.flag_cray_pointer)
3474 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3478 return cray_pointer_decl ();
3482 gfc_clear_attr (¤t_attr);
3483 current_attr.pointer = 1;
3485 return attr_decl ();
3491 gfc_match_allocatable (void)
3494 gfc_clear_attr (¤t_attr);
3495 current_attr.allocatable = 1;
3497 return attr_decl ();
3502 gfc_match_dimension (void)
3505 gfc_clear_attr (¤t_attr);
3506 current_attr.dimension = 1;
3508 return attr_decl ();
3513 gfc_match_target (void)
3516 gfc_clear_attr (¤t_attr);
3517 current_attr.target = 1;
3519 return attr_decl ();
3523 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3527 access_attr_decl (gfc_statement st)
3529 char name[GFC_MAX_SYMBOL_LEN + 1];
3530 interface_type type;
3533 gfc_intrinsic_op operator;
3536 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3541 m = gfc_match_generic_spec (&type, name, &operator);
3544 if (m == MATCH_ERROR)
3549 case INTERFACE_NAMELESS:
3552 case INTERFACE_GENERIC:
3553 if (gfc_get_symbol (name, NULL, &sym))
3556 if (gfc_add_access (&sym->attr,
3558 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3559 sym->name, NULL) == FAILURE)
3564 case INTERFACE_INTRINSIC_OP:
3565 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3567 gfc_current_ns->operator_access[operator] =
3568 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3572 gfc_error ("Access specification of the %s operator at %C has "
3573 "already been specified", gfc_op2string (operator));
3579 case INTERFACE_USER_OP:
3580 uop = gfc_get_uop (name);
3582 if (uop->access == ACCESS_UNKNOWN)
3585 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3590 ("Access specification of the .%s. operator at %C has "
3591 "already been specified", sym->name);
3598 if (gfc_match_char (',') == MATCH_NO)
3602 if (gfc_match_eos () != MATCH_YES)
3607 gfc_syntax_error (st);
3614 /* The PRIVATE statement is a bit weird in that it can be a attribute
3615 declaration, but also works as a standlone statement inside of a
3616 type declaration or a module. */
3619 gfc_match_private (gfc_statement * st)
3622 if (gfc_match ("private") != MATCH_YES)
3625 if (gfc_current_state () == COMP_DERIVED)
3627 if (gfc_match_eos () == MATCH_YES)
3633 gfc_syntax_error (ST_PRIVATE);
3637 if (gfc_match_eos () == MATCH_YES)
3644 return access_attr_decl (ST_PRIVATE);
3649 gfc_match_public (gfc_statement * st)
3652 if (gfc_match ("public") != MATCH_YES)
3655 if (gfc_match_eos () == MATCH_YES)
3662 return access_attr_decl (ST_PUBLIC);
3666 /* Workhorse for gfc_match_parameter. */
3675 m = gfc_match_symbol (&sym, 0);
3677 gfc_error ("Expected variable name at %C in PARAMETER statement");
3682 if (gfc_match_char ('=') == MATCH_NO)
3684 gfc_error ("Expected = sign in PARAMETER statement at %C");
3688 m = gfc_match_init_expr (&init);
3690 gfc_error ("Expected expression at %C in PARAMETER statement");
3694 if (sym->ts.type == BT_UNKNOWN
3695 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3701 if (gfc_check_assign_symbol (sym, init) == FAILURE
3702 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3708 if (sym->ts.type == BT_CHARACTER
3709 && sym->ts.cl != NULL
3710 && sym->ts.cl->length != NULL
3711 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3712 && init->expr_type == EXPR_CONSTANT
3713 && init->ts.type == BT_CHARACTER
3714 && init->ts.kind == 1)
3715 gfc_set_constant_character_len (
3716 mpz_get_si (sym->ts.cl->length->value.integer), init);
3722 gfc_free_expr (init);
3727 /* Match a parameter statement, with the weird syntax that these have. */
3730 gfc_match_parameter (void)
3734 if (gfc_match_char ('(') == MATCH_NO)
3743 if (gfc_match (" )%t") == MATCH_YES)
3746 if (gfc_match_char (',') != MATCH_YES)
3748 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3758 /* Save statements have a special syntax. */
3761 gfc_match_save (void)
3763 char n[GFC_MAX_SYMBOL_LEN+1];
3768 if (gfc_match_eos () == MATCH_YES)
3770 if (gfc_current_ns->seen_save)
3772 if (gfc_notify_std (GFC_STD_LEGACY,
3773 "Blanket SAVE statement at %C follows previous "
3779 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3783 if (gfc_current_ns->save_all)
3785 if (gfc_notify_std (GFC_STD_LEGACY,
3786 "SAVE statement at %C follows blanket SAVE statement")
3795 m = gfc_match_symbol (&sym, 0);
3799 if (gfc_add_save (&sym->attr, sym->name,
3800 &gfc_current_locus) == FAILURE)
3811 m = gfc_match (" / %n /", &n);
3812 if (m == MATCH_ERROR)
3817 c = gfc_get_common (n, 0);
3820 gfc_current_ns->seen_save = 1;
3823 if (gfc_match_eos () == MATCH_YES)
3825 if (gfc_match_char (',') != MATCH_YES)
3832 gfc_error ("Syntax error in SAVE statement at %C");
3837 /* Match a module procedure statement. Note that we have to modify
3838 symbols in the parent's namespace because the current one was there
3839 to receive symbols that are in an interface's formal argument list. */
3842 gfc_match_modproc (void)
3844 char name[GFC_MAX_SYMBOL_LEN + 1];
3848 if (gfc_state_stack->state != COMP_INTERFACE
3849 || gfc_state_stack->previous == NULL
3850 || current_interface.type == INTERFACE_NAMELESS)
3853 ("MODULE PROCEDURE at %C must be in a generic module interface");
3859 m = gfc_match_name (name);
3865 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3868 if (sym->attr.proc != PROC_MODULE
3869 && gfc_add_procedure (&sym->attr, PROC_MODULE,
3870 sym->name, NULL) == FAILURE)
3873 if (gfc_add_interface (sym) == FAILURE)
3876 if (gfc_match_eos () == MATCH_YES)
3878 if (gfc_match_char (',') != MATCH_YES)
3885 gfc_syntax_error (ST_MODULE_PROC);
3890 /* Match the beginning of a derived type declaration. If a type name
3891 was the result of a function, then it is possible to have a symbol
3892 already to be known as a derived type yet have no components. */
3895 gfc_match_derived_decl (void)
3897 char name[GFC_MAX_SYMBOL_LEN + 1];
3898 symbol_attribute attr;
3902 if (gfc_current_state () == COMP_DERIVED)
3905 gfc_clear_attr (&attr);
3908 if (gfc_match (" , private") == MATCH_YES)
3910 if (gfc_find_state (COMP_MODULE) == FAILURE)
3913 ("Derived type at %C can only be PRIVATE within a MODULE");
3917 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3922 if (gfc_match (" , public") == MATCH_YES)
3924 if (gfc_find_state (COMP_MODULE) == FAILURE)
3926 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3930 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3935 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3937 gfc_error ("Expected :: in TYPE definition at %C");
3941 m = gfc_match (" %n%t", name);
3945 /* Make sure the name isn't the name of an intrinsic type. The
3946 'double precision' type doesn't get past the name matcher. */
3947 if (strcmp (name, "integer") == 0
3948 || strcmp (name, "real") == 0
3949 || strcmp (name, "character") == 0
3950 || strcmp (name, "logical") == 0
3951 || strcmp (name, "complex") == 0)
3954 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3959 if (gfc_get_symbol (name, NULL, &sym))
3962 if (sym->ts.type != BT_UNKNOWN)
3964 gfc_error ("Derived type name '%s' at %C already has a basic type "
3965 "of %s", sym->name, gfc_typename (&sym->ts));
3969 /* The symbol may already have the derived attribute without the
3970 components. The ways this can happen is via a function
3971 definition, an INTRINSIC statement or a subtype in another
3972 derived type that is a pointer. The first part of the AND clause
3973 is true if a the symbol is not the return value of a function. */
3974 if (sym->attr.flavor != FL_DERIVED
3975 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3978 if (sym->components != NULL)
3981 ("Derived type definition of '%s' at %C has already been defined",
3986 if (attr.access != ACCESS_UNKNOWN
3987 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3990 gfc_new_block = sym;
3996 /* Cray Pointees can be declared as:
3997 pointer (ipt, a (n,m,...,*))
3998 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
3999 cheat and set a constant bound of 1 for the last dimension, if this
4000 is the case. Since there is no bounds-checking for Cray Pointees,
4001 this will be okay. */
4004 gfc_mod_pointee_as (gfc_array_spec *as)
4006 as->cray_pointee = true; /* This will be useful to know later. */
4007 if (as->type == AS_ASSUMED_SIZE)
4009 as->type = AS_EXPLICIT;
4010 as->upper[as->rank - 1] = gfc_int_expr (1);
4011 as->cp_was_assumed = true;
4013 else if (as->type == AS_ASSUMED_SHAPE)
4015 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4022 /* Match the enum definition statement, here we are trying to match
4023 the first line of enum definition statement.
4024 Returns MATCH_YES if match is found. */
4027 gfc_match_enum (void)
4031 m = gfc_match_eos ();
4035 if (gfc_notify_std (GFC_STD_F2003,
4036 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
4044 /* Match the enumerator definition statement. */
4047 gfc_match_enumerator_def (void)
4052 gfc_clear_ts (¤t_ts);
4054 m = gfc_match (" enumerator");
4058 if (gfc_current_state () != COMP_ENUM)
4060 gfc_error ("ENUM definition statement expected before %C");
4061 gfc_free_enum_history ();
4065 (¤t_ts)->type = BT_INTEGER;
4066 (¤t_ts)->kind = gfc_c_int_kind;
4068 m = match_attr_spec ();
4069 if (m == MATCH_ERROR)
4078 m = variable_decl (elem++);
4079 if (m == MATCH_ERROR)
4084 if (gfc_match_eos () == MATCH_YES)
4086 if (gfc_match_char (',') != MATCH_YES)
4090 if (gfc_current_state () == COMP_ENUM)
4092 gfc_free_enum_history ();
4093 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4098 gfc_free_array_spec (current_as);