1 /* Declaration statement matcher
2 Copyright (C) 2002 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, 59 Temple Place - Suite 330, Boston, MA
30 /* This flag is set if a an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector;
35 /* When variables aquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts;
42 static symbol_attribute current_attr;
43 static gfc_array_spec *current_as;
44 static int colon_seen;
46 /* gfc_new_block points to the symbol of a newly matched block. */
48 gfc_symbol *gfc_new_block;
51 /* Match an intent specification. Since this can only happen after an
52 INTENT word, a legal intent-spec must follow. */
55 match_intent_spec (void)
58 if (gfc_match (" ( in out )") == MATCH_YES)
60 if (gfc_match (" ( in )") == MATCH_YES)
62 if (gfc_match (" ( out )") == MATCH_YES)
65 gfc_error ("Bad INTENT specification at %C");
66 return INTENT_UNKNOWN;
70 /* Matches a character length specification, which is either a
71 specification expression or a '*'. */
74 char_len_param_value (gfc_expr ** expr)
77 if (gfc_match_char ('*') == MATCH_YES)
83 return gfc_match_expr (expr);
87 /* A character length is a '*' followed by a literal integer or a
88 char_len_param_value in parenthesis. */
91 match_char_length (gfc_expr ** expr)
96 m = gfc_match_char ('*');
100 m = gfc_match_small_literal_int (&length);
101 if (m == MATCH_ERROR)
106 *expr = gfc_int_expr (length);
110 if (gfc_match_char ('(') == MATCH_NO)
113 m = char_len_param_value (expr);
114 if (m == MATCH_ERROR)
119 if (gfc_match_char (')') == MATCH_NO)
121 gfc_free_expr (*expr);
129 gfc_error ("Syntax error in character length specification at %C");
134 /* Special subroutine for finding a symbol. If we're compiling a
135 function or subroutine and the parent compilation unit is an
136 interface, then check to see if the name we've been given is the
137 name of the interface (located in another namespace). If so,
138 return that symbol. If not, use gfc_get_symbol(). */
141 find_special (const char *name, gfc_symbol ** result)
145 if (gfc_current_state () != COMP_SUBROUTINE
146 && gfc_current_state () != COMP_FUNCTION)
149 s = gfc_state_stack->previous;
153 if (s->state != COMP_INTERFACE)
156 goto normal; /* Nameless interface */
158 if (strcmp (name, s->sym->name) == 0)
165 return gfc_get_symbol (name, NULL, result);
169 /* Special subroutine for getting a symbol node associated with a
170 procedure name, used in SUBROUTINE and FUNCTION statements. The
171 symbol is created in the parent using with symtree node in the
172 child unit pointing to the symbol. If the current namespace has no
173 parent, then the symbol is just created in the current unit. */
176 get_proc_name (const char *name, gfc_symbol ** result)
182 if (gfc_current_ns->parent == NULL)
183 return gfc_get_symbol (name, NULL, result);
185 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
189 /* Deal with ENTRY problem */
191 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
197 /* See if the procedure should be a module procedure */
199 if (sym->ns->proc_name != NULL
200 && sym->ns->proc_name->attr.flavor == FL_MODULE
201 && sym->attr.proc != PROC_MODULE
202 && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
209 /* Function called by variable_decl() that adds a name to the symbol
213 build_sym (const char *name, gfc_charlen * cl,
214 gfc_array_spec ** as, locus * var_locus)
216 symbol_attribute attr;
219 if (find_special (name, &sym))
222 /* Start updating the symbol table. Add basic type attribute
224 if (current_ts.type != BT_UNKNOWN
225 &&(sym->attr.implicit_type == 0
226 || !gfc_compare_types (&sym->ts, ¤t_ts))
227 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
230 if (sym->ts.type == BT_CHARACTER)
233 /* Add dimension attribute if present. */
234 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
238 /* Add attribute to symbol. The copy is so that we can reset the
239 dimension attribute. */
243 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
250 /* Function called by variable_decl() that adds an initialization
251 expression to a symbol. */
254 add_init_expr_to_sym (const char *name, gfc_expr ** initp,
258 symbol_attribute attr;
263 if (find_special (name, &sym))
268 /* If this symbol is confirming an implicit parameter type,
269 then an initialization expression is not allowed. */
270 if (attr.flavor == FL_PARAMETER
271 && sym->value != NULL
274 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
283 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
290 /* An initializer is required for PARAMETER declarations. */
291 if (attr.flavor == FL_PARAMETER)
293 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
299 /* If a variable appears in a DATA block, it cannot have an
304 ("Variable '%s' at %C with an initializer already appears "
305 "in a DATA statement", sym->name);
309 /* Checking a derived type parameter has to be put off until later. */
310 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
311 && gfc_check_assign_symbol (sym, init) == FAILURE)
314 for (i = 0; i < sym->attr.dimension; i++)
316 if (sym->as->lower[i] == NULL
317 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
318 || sym->as->upper[i] == NULL
319 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
321 gfc_error ("Array '%s' at %C cannot have initializer",
327 /* Add initializer. Make sure we keep the ranks sane. */
328 if (sym->attr.dimension && init->rank == 0)
329 init->rank = sym->as->rank;
339 /* Function called by variable_decl() that adds a name to a structure
343 build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init,
344 gfc_array_spec ** as)
348 /* If the current symbol is of the same derived type that we're
349 constructing, it must have the pointer attribute. */
350 if (current_ts.type == BT_DERIVED
351 && current_ts.derived == gfc_current_block ()
352 && current_attr.pointer == 0)
354 gfc_error ("Component at %C must have the POINTER attribute");
358 if (gfc_current_block ()->attr.pointer
361 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
363 gfc_error ("Array component of structure at %C must have explicit "
364 "or deferred shape");
369 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
374 gfc_set_component_attr (c, ¤t_attr);
376 c->initializer = *init;
384 /* Check array components. */
390 if (c->as->type != AS_DEFERRED)
392 gfc_error ("Pointer array component of structure at %C "
393 "must have a deferred shape");
399 if (c->as->type != AS_EXPLICIT)
402 ("Array component of structure at %C must have an explicit "
412 /* Match a 'NULL()', and possibly take care of some side effects. */
415 gfc_match_null (gfc_expr ** result)
421 m = gfc_match (" null ( )");
425 /* The NULL symbol now has to be/become an intrinsic function. */
426 if (gfc_get_symbol ("null", NULL, &sym))
428 gfc_error ("NULL() initialization at %C is ambiguous");
432 gfc_intrinsic_symbol (sym);
434 if (sym->attr.proc != PROC_INTRINSIC
435 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
436 || gfc_add_function (&sym->attr, NULL) == FAILURE))
440 e->where = *gfc_current_locus ();
441 e->expr_type = EXPR_NULL;
442 e->ts.type = BT_UNKNOWN;
450 /* Get an expression for a default initializer. */
452 default_initializer (void)
454 gfc_constructor *tail;
460 /* First see if we have a default initializer. */
461 for (c = current_ts.derived->components; c; c = c->next)
463 if (c->initializer && init == NULL)
464 init = gfc_get_expr ();
470 init->expr_type = EXPR_STRUCTURE;
471 init->ts = current_ts;
472 init->where = current_ts.derived->declared_at;
474 for (c = current_ts.derived->components; c; c = c->next)
477 init->value.constructor = tail = gfc_get_constructor ();
480 tail->next = gfc_get_constructor ();
485 tail->expr = gfc_copy_expr (c->initializer);
491 /* Match a variable name with an optional initializer. When this
492 subroutine is called, a variable is expected to be parsed next.
493 Depending on what is happening at the moment, updates either the
494 symbol table or the current interface. */
499 char name[GFC_MAX_SYMBOL_LEN + 1];
500 gfc_expr *initializer, *char_len;
510 /* When we get here, we've just matched a list of attributes and
511 maybe a type and a double colon. The next thing we expect to see
512 is the name of the symbol. */
513 m = gfc_match_name (name);
517 var_locus = *gfc_current_locus ();
519 /* Now we could see the optional array spec. or character length. */
520 m = gfc_match_array_spec (&as);
521 if (m == MATCH_ERROR)
524 as = gfc_copy_array_spec (current_as);
529 if (current_ts.type == BT_CHARACTER)
531 switch (match_char_length (&char_len))
534 cl = gfc_get_charlen ();
535 cl->next = gfc_current_ns->cl_list;
536 gfc_current_ns->cl_list = cl;
538 cl->length = char_len;
550 /* OK, we've successfully matched the declaration. Now put the
551 symbol in the current namespace, because it might be used in the
552 optional intialization expression for this symbol, e.g. this is
555 integer, parameter :: i = huge(i)
557 This is only true for parameters or variables of a basic type.
558 For components of derived types, it is not true, so we don't
559 create a symbol for those yet. If we fail to create the symbol,
561 if (gfc_current_state () != COMP_DERIVED
562 && build_sym (name, cl, &as, &var_locus) == FAILURE)
568 /* In functions that have a RESULT variable defined, the function
569 name always refers to function calls. Therefore, the name is
570 not allowed to appear in specification statements. */
571 if (gfc_current_state () == COMP_FUNCTION
572 && gfc_current_block () != NULL
573 && gfc_current_block ()->result != NULL
574 && gfc_current_block ()->result != gfc_current_block ()
575 && strcmp (gfc_current_block ()->name, name) == 0)
577 gfc_error ("Function name '%s' not allowed at %C", name);
582 /* The double colon must be present in order to have initializers.
583 Otherwise the statement is ambiguous with an assignment statement. */
586 if (gfc_match (" =>") == MATCH_YES)
589 if (!current_attr.pointer)
591 gfc_error ("Initialization at %C isn't for a pointer variable");
596 m = gfc_match_null (&initializer);
599 gfc_error ("Pointer initialization requires a NULL at %C");
606 ("Initialization of pointer at %C is not allowed in a "
614 initializer->ts = current_ts;
617 else if (gfc_match_char ('=') == MATCH_YES)
619 if (current_attr.pointer)
622 ("Pointer initialization at %C requires '=>', not '='");
627 m = gfc_match_init_expr (&initializer);
630 gfc_error ("Expected an initialization expression at %C");
634 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
637 ("Initialization of variable at %C is not allowed in a "
647 if (current_ts.type == BT_DERIVED && !initializer)
649 initializer = default_initializer ();
652 /* Add the initializer. Note that it is fine if &initializer is
653 NULL here, because we sometimes also need to check if a
654 declaration *must* have an initialization expression. */
655 if (gfc_current_state () != COMP_DERIVED)
656 t = add_init_expr_to_sym (name, &initializer, &var_locus);
658 t = build_struct (name, cl, &initializer, &as);
660 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
663 /* Free stuff up and return. */
664 gfc_free_expr (initializer);
665 gfc_free_array_spec (as);
671 /* Match an extended-f77 kind specification. */
674 gfc_match_old_kind_spec (gfc_typespec * ts)
678 if (gfc_match_char ('*') != MATCH_YES)
681 m = gfc_match_small_literal_int (&ts->kind);
685 /* Massage the kind numbers for complex types. */
686 if (ts->type == BT_COMPLEX && ts->kind == 8)
688 if (ts->type == BT_COMPLEX && ts->kind == 16)
691 if (gfc_validate_kind (ts->type, ts->kind) == -1)
693 gfc_error ("Old-style kind %d not supported for type %s at %C",
694 ts->kind, gfc_basic_typename (ts->type));
703 /* Match a kind specification. Since kinds are generally optional, we
704 usually return MATCH_NO if something goes wrong. If a "kind="
705 string is found, then we know we have an error. */
708 gfc_match_kind_spec (gfc_typespec * ts)
718 where = *gfc_current_locus ();
720 if (gfc_match_char ('(') == MATCH_NO)
723 /* Also gobbles optional text. */
724 if (gfc_match (" kind = ") == MATCH_YES)
727 n = gfc_match_init_expr (&e);
729 gfc_error ("Expected initialization expression at %C");
735 gfc_error ("Expected scalar initialization expression at %C");
740 msg = gfc_extract_int (e, &ts->kind);
751 if (gfc_validate_kind (ts->type, ts->kind) == -1)
753 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
754 gfc_basic_typename (ts->type));
760 if (gfc_match_char (')') != MATCH_YES)
762 gfc_error ("Missing right paren at %C");
770 gfc_set_locus (&where);
775 /* Match the various kind/length specifications in a CHARACTER
776 declaration. We don't return MATCH_NO. */
779 match_char_spec (gfc_typespec * ts)
781 int i, kind, seen_length;
786 kind = gfc_default_character_kind ();
790 /* Try the old-style specification first. */
791 old_char_selector = 0;
793 m = match_char_length (&len);
797 old_char_selector = 1;
802 m = gfc_match_char ('(');
805 m = MATCH_YES; /* character without length is a single char */
809 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
810 if (gfc_match (" kind =") == MATCH_YES)
812 m = gfc_match_small_int (&kind);
813 if (m == MATCH_ERROR)
818 if (gfc_match (" , len =") == MATCH_NO)
821 m = char_len_param_value (&len);
824 if (m == MATCH_ERROR)
831 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
832 if (gfc_match (" len =") == MATCH_YES)
834 m = char_len_param_value (&len);
837 if (m == MATCH_ERROR)
841 if (gfc_match_char (')') == MATCH_YES)
844 if (gfc_match (" , kind =") != MATCH_YES)
847 gfc_match_small_int (&kind);
849 if (gfc_validate_kind (BT_CHARACTER, kind) == -1)
851 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
858 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
859 m = char_len_param_value (&len);
862 if (m == MATCH_ERROR)
866 m = gfc_match_char (')');
870 if (gfc_match_char (',') != MATCH_YES)
873 gfc_match (" kind ="); /* Gobble optional text */
875 m = gfc_match_small_int (&kind);
876 if (m == MATCH_ERROR)
882 /* Require a right-paren at this point. */
883 m = gfc_match_char (')');
888 gfc_error ("Syntax error in CHARACTER declaration at %C");
892 if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind) == -1)
894 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
904 /* Do some final massaging of the length values. */
905 cl = gfc_get_charlen ();
906 cl->next = gfc_current_ns->cl_list;
907 gfc_current_ns->cl_list = cl;
909 if (seen_length == 0)
910 cl->length = gfc_int_expr (1);
913 if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0)
918 cl->length = gfc_int_expr (0);
929 /* Matches a type specification. If successful, sets the ts structure
930 to the matched specification. This is necessary for FUNCTION and
933 If kind_flag is nonzero, then we check for the optional kind
934 specification. Not doing so is needed for matching an IMPLICIT
935 statement correctly. */
938 gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
940 char name[GFC_MAX_SYMBOL_LEN + 1];
946 if (gfc_match (" integer") == MATCH_YES)
948 ts->type = BT_INTEGER;
949 ts->kind = gfc_default_integer_kind ();
953 if (gfc_match (" character") == MATCH_YES)
955 ts->type = BT_CHARACTER;
956 return match_char_spec (ts);
959 if (gfc_match (" real") == MATCH_YES)
962 ts->kind = gfc_default_real_kind ();
966 if (gfc_match (" double precision") == MATCH_YES)
969 ts->kind = gfc_default_double_kind ();
973 if (gfc_match (" complex") == MATCH_YES)
975 ts->type = BT_COMPLEX;
976 ts->kind = gfc_default_complex_kind ();
980 if (gfc_match (" double complex") == MATCH_YES)
982 ts->type = BT_COMPLEX;
983 ts->kind = gfc_default_double_kind ();
987 if (gfc_match (" logical") == MATCH_YES)
989 ts->type = BT_LOGICAL;
990 ts->kind = gfc_default_logical_kind ();
994 m = gfc_match (" type ( %n )", name);
998 /* Search for the name but allow the components to be defined later. */
999 if (gfc_get_ha_symbol (name, &sym))
1001 gfc_error ("Type name '%s' at %C is ambiguous", name);
1005 if (sym->attr.flavor != FL_DERIVED
1006 && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
1009 ts->type = BT_DERIVED;
1016 /* For all types except double, derived and character, look for an
1017 optional kind specifier. MATCH_NO is actually OK at this point. */
1021 m = gfc_match_kind_spec (ts);
1022 if (m == MATCH_NO && ts->type != BT_CHARACTER)
1023 m = gfc_match_old_kind_spec (ts);
1026 m = MATCH_YES; /* No kind specifier found. */
1032 /* Matches an attribute specification including array specs. If
1033 successful, leaves the variables current_attr and current_as
1034 holding the specification. Also sets the colon_seen variable for
1035 later use by matchers associated with initializations.
1037 This subroutine is a little tricky in the sense that we don't know
1038 if we really have an attr-spec until we hit the double colon.
1039 Until that time, we can only return MATCH_NO. This forces us to
1040 check for duplicate specification at this level. */
1043 match_attr_spec (void)
1046 /* Modifiers that can exist in a type statement. */
1048 { GFC_DECL_BEGIN = 0,
1049 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
1050 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
1051 DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
1052 DECL_TARGET, DECL_COLON, DECL_NONE,
1053 GFC_DECL_END /* Sentinel */
1057 /* GFC_DECL_END is the sentinel, index starts at 0. */
1058 #define NUM_DECL GFC_DECL_END
1060 static mstring decls[] = {
1061 minit (", allocatable", DECL_ALLOCATABLE),
1062 minit (", dimension", DECL_DIMENSION),
1063 minit (", external", DECL_EXTERNAL),
1064 minit (", intent ( in )", DECL_IN),
1065 minit (", intent ( out )", DECL_OUT),
1066 minit (", intent ( in out )", DECL_INOUT),
1067 minit (", intrinsic", DECL_INTRINSIC),
1068 minit (", optional", DECL_OPTIONAL),
1069 minit (", parameter", DECL_PARAMETER),
1070 minit (", pointer", DECL_POINTER),
1071 minit (", private", DECL_PRIVATE),
1072 minit (", public", DECL_PUBLIC),
1073 minit (", save", DECL_SAVE),
1074 minit (", target", DECL_TARGET),
1075 minit ("::", DECL_COLON),
1076 minit (NULL, DECL_NONE)
1079 locus start, seen_at[NUM_DECL];
1086 gfc_clear_attr (¤t_attr);
1087 start = *gfc_current_locus ();
1092 /* See if we get all of the keywords up to the final double colon. */
1093 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1098 d = (decl_types) gfc_match_strings (decls);
1099 if (d == DECL_NONE || d == DECL_COLON)
1103 seen_at[d] = *gfc_current_locus ();
1105 if (d == DECL_DIMENSION)
1107 m = gfc_match_array_spec (¤t_as);
1111 gfc_error ("Missing dimension specification at %C");
1115 if (m == MATCH_ERROR)
1120 /* No double colon, so assume that we've been looking at something
1121 else the whole time. */
1128 /* Since we've seen a double colon, we have to be looking at an
1129 attr-spec. This means that we can now issue errors. */
1130 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1135 case DECL_ALLOCATABLE:
1136 attr = "ALLOCATABLE";
1138 case DECL_DIMENSION:
1145 attr = "INTENT (IN)";
1148 attr = "INTENT (OUT)";
1151 attr = "INTENT (IN OUT)";
1153 case DECL_INTRINSIC:
1159 case DECL_PARAMETER:
1178 attr = NULL; /* This shouldn't happen */
1181 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
1186 /* Now that we've dealt with duplicate attributes, add the attributes
1187 to the current attribute. */
1188 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
1193 if (gfc_current_state () == COMP_DERIVED
1194 && d != DECL_DIMENSION && d != DECL_POINTER
1195 && d != DECL_COLON && d != DECL_NONE)
1198 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1206 case DECL_ALLOCATABLE:
1207 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
1210 case DECL_DIMENSION:
1211 t = gfc_add_dimension (¤t_attr, &seen_at[d]);
1215 t = gfc_add_external (¤t_attr, &seen_at[d]);
1219 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
1223 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
1227 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
1230 case DECL_INTRINSIC:
1231 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
1235 t = gfc_add_optional (¤t_attr, &seen_at[d]);
1238 case DECL_PARAMETER:
1239 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]);
1243 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
1247 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]);
1251 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]);
1255 t = gfc_add_save (¤t_attr, &seen_at[d]);
1259 t = gfc_add_target (¤t_attr, &seen_at[d]);
1263 gfc_internal_error ("match_attr_spec(): Bad attribute");
1277 gfc_set_locus (&start);
1278 gfc_free_array_spec (current_as);
1284 /* Match a data declaration statement. */
1287 gfc_match_data_decl (void)
1292 m = gfc_match_type_spec (¤t_ts, 1);
1296 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
1298 sym = gfc_use_derived (current_ts.derived);
1306 current_ts.derived = sym;
1309 m = match_attr_spec ();
1310 if (m == MATCH_ERROR)
1316 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
1319 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
1322 if (gfc_find_symbol (current_ts.derived->name,
1323 current_ts.derived->ns->parent, 1, &sym) == 0)
1326 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1327 if (sym != NULL && sym->attr.flavor == FL_DERIVED)
1330 gfc_error ("Derived type at %C has not been previously defined");
1336 /* If we have an old-style character declaration, and no new-style
1337 attribute specifications, then there a comma is optional between
1338 the type specification and the variable list. */
1339 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
1340 gfc_match_char (',');
1342 /* Give the types/attributes to symbols that follow. */
1345 m = variable_decl ();
1346 if (m == MATCH_ERROR)
1351 if (gfc_match_eos () == MATCH_YES)
1353 if (gfc_match_char (',') != MATCH_YES)
1357 gfc_error ("Syntax error in data declaration at %C");
1361 gfc_free_array_spec (current_as);
1367 /* Match a prefix associated with a function or subroutine
1368 declaration. If the typespec pointer is nonnull, then a typespec
1369 can be matched. Note that if nothing matches, MATCH_YES is
1370 returned (the null string was matched). */
1373 match_prefix (gfc_typespec * ts)
1377 gfc_clear_attr (¤t_attr);
1381 if (!seen_type && ts != NULL
1382 && gfc_match_type_spec (ts, 1) == MATCH_YES
1383 && gfc_match_space () == MATCH_YES)
1390 if (gfc_match ("elemental% ") == MATCH_YES)
1392 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
1398 if (gfc_match ("pure% ") == MATCH_YES)
1400 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
1406 if (gfc_match ("recursive% ") == MATCH_YES)
1408 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
1414 /* At this point, the next item is not a prefix. */
1419 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
1422 copy_prefix (symbol_attribute * dest, locus * where)
1425 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
1428 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
1431 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
1438 /* Match a formal argument list. */
1441 gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
1443 gfc_formal_arglist *head, *tail, *p, *q;
1444 char name[GFC_MAX_SYMBOL_LEN + 1];
1450 if (gfc_match_char ('(') != MATCH_YES)
1457 if (gfc_match_char (')') == MATCH_YES)
1462 if (gfc_match_char ('*') == MATCH_YES)
1466 m = gfc_match_name (name);
1470 if (gfc_get_symbol (name, NULL, &sym))
1474 p = gfc_get_formal_arglist ();
1486 /* We don't add the VARIABLE flavor because the name could be a
1487 dummy procedure. We don't apply these attributes to formal
1488 arguments of statement functions. */
1489 if (sym != NULL && !st_flag
1490 && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
1491 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
1497 /* The name of a program unit can be in a different namespace,
1498 so check for it explicitly. After the statement is accepted,
1499 the name is checked for especially in gfc_get_symbol(). */
1500 if (gfc_new_block != NULL && sym != NULL
1501 && strcmp (sym->name, gfc_new_block->name) == 0)
1503 gfc_error ("Name '%s' at %C is the name of the procedure",
1509 if (gfc_match_char (')') == MATCH_YES)
1512 m = gfc_match_char (',');
1515 gfc_error ("Unexpected junk in formal argument list at %C");
1521 /* Check for duplicate symbols in the formal argument list. */
1524 for (p = head; p->next; p = p->next)
1529 for (q = p->next; q; q = q->next)
1530 if (p->sym == q->sym)
1533 ("Duplicate symbol '%s' in formal argument list at %C",
1542 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) ==
1552 gfc_free_formal_arglist (head);
1557 /* Match a RESULT specification following a function declaration or
1558 ENTRY statement. Also matches the end-of-statement. */
1561 match_result (gfc_symbol * function, gfc_symbol ** result)
1563 char name[GFC_MAX_SYMBOL_LEN + 1];
1567 if (gfc_match (" result (") != MATCH_YES)
1570 m = gfc_match_name (name);
1574 if (gfc_match (" )%t") != MATCH_YES)
1576 gfc_error ("Unexpected junk following RESULT variable at %C");
1580 if (strcmp (function->name, name) == 0)
1583 ("RESULT variable at %C must be different than function name");
1587 if (gfc_get_symbol (name, NULL, &r))
1590 if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
1591 || gfc_add_result (&r->attr, NULL) == FAILURE)
1600 /* Match a function declaration. */
1603 gfc_match_function_decl (void)
1605 char name[GFC_MAX_SYMBOL_LEN + 1];
1606 gfc_symbol *sym, *result;
1610 if (gfc_current_state () != COMP_NONE
1611 && gfc_current_state () != COMP_INTERFACE
1612 && gfc_current_state () != COMP_CONTAINS)
1615 gfc_clear_ts (¤t_ts);
1617 old_loc = *gfc_current_locus ();
1619 m = match_prefix (¤t_ts);
1622 gfc_set_locus (&old_loc);
1626 if (gfc_match ("function% %n", name) != MATCH_YES)
1628 gfc_set_locus (&old_loc);
1632 if (get_proc_name (name, &sym))
1634 gfc_new_block = sym;
1636 m = gfc_match_formal_arglist (sym, 0, 0);
1638 gfc_error ("Expected formal argument list in function definition at %C");
1639 else if (m == MATCH_ERROR)
1644 if (gfc_match_eos () != MATCH_YES)
1646 /* See if a result variable is present. */
1647 m = match_result (sym, &result);
1649 gfc_error ("Unexpected junk after function declaration at %C");
1658 /* Make changes to the symbol. */
1661 if (gfc_add_function (&sym->attr, NULL) == FAILURE)
1664 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
1665 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1668 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN)
1670 gfc_error ("Function '%s' at %C already has a type of %s", name,
1671 gfc_basic_typename (sym->ts.type));
1677 sym->ts = current_ts;
1682 result->ts = current_ts;
1683 sym->result = result;
1689 gfc_set_locus (&old_loc);
1694 /* Match an ENTRY statement. */
1697 gfc_match_entry (void)
1699 gfc_symbol *function, *result, *entry;
1700 char name[GFC_MAX_SYMBOL_LEN + 1];
1701 gfc_compile_state state;
1704 m = gfc_match_name (name);
1708 if (get_proc_name (name, &entry))
1711 gfc_enclosing_unit (&state);
1714 case COMP_SUBROUTINE:
1715 m = gfc_match_formal_arglist (entry, 0, 1);
1719 if (gfc_current_state () != COMP_SUBROUTINE)
1720 goto exec_construct;
1722 if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1723 || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
1729 m = gfc_match_formal_arglist (entry, 0, 0);
1733 if (gfc_current_state () != COMP_FUNCTION)
1734 goto exec_construct;
1735 function = gfc_state_stack->sym;
1739 if (gfc_match_eos () == MATCH_YES)
1741 if (gfc_add_entry (&entry->attr, NULL) == FAILURE
1742 || gfc_add_function (&entry->attr, NULL) == FAILURE)
1745 entry->result = function->result;
1750 m = match_result (function, &result);
1752 gfc_syntax_error (ST_ENTRY);
1756 if (gfc_add_result (&result->attr, NULL) == FAILURE
1757 || gfc_add_entry (&entry->attr, NULL) == FAILURE
1758 || gfc_add_function (&entry->attr, NULL) == FAILURE)
1762 if (function->attr.recursive && result == NULL)
1764 gfc_error ("RESULT attribute required in ENTRY statement at %C");
1771 goto exec_construct;
1774 if (gfc_match_eos () != MATCH_YES)
1776 gfc_syntax_error (ST_ENTRY);
1783 gfc_error ("ENTRY statement at %C cannot appear within %s",
1784 gfc_state_name (gfc_current_state ()));
1790 /* Match a subroutine statement, including optional prefixes. */
1793 gfc_match_subroutine (void)
1795 char name[GFC_MAX_SYMBOL_LEN + 1];
1799 if (gfc_current_state () != COMP_NONE
1800 && gfc_current_state () != COMP_INTERFACE
1801 && gfc_current_state () != COMP_CONTAINS)
1804 m = match_prefix (NULL);
1808 m = gfc_match ("subroutine% %n", name);
1812 if (get_proc_name (name, &sym))
1814 gfc_new_block = sym;
1816 if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
1819 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
1822 if (gfc_match_eos () != MATCH_YES)
1824 gfc_syntax_error (ST_SUBROUTINE);
1828 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
1835 /* Match any of the various end-block statements. Returns the type of
1836 END to the caller. The END INTERFACE, END IF, END DO and END
1837 SELECT statements cannot be replaced by a single END statement. */
1840 gfc_match_end (gfc_statement * st)
1842 char name[GFC_MAX_SYMBOL_LEN + 1];
1843 gfc_compile_state state;
1845 const char *block_name;
1849 old_loc = *gfc_current_locus ();
1850 if (gfc_match ("end") != MATCH_YES)
1853 state = gfc_current_state ();
1855 gfc_current_block () == NULL ? NULL : gfc_current_block ()->name;
1857 if (state == COMP_CONTAINS)
1859 state = gfc_state_stack->previous->state;
1860 block_name = gfc_state_stack->previous->sym == NULL ? NULL
1861 : gfc_state_stack->previous->sym->name;
1868 *st = ST_END_PROGRAM;
1869 target = " program";
1872 case COMP_SUBROUTINE:
1873 *st = ST_END_SUBROUTINE;
1874 target = " subroutine";
1878 *st = ST_END_FUNCTION;
1879 target = " function";
1882 case COMP_BLOCK_DATA:
1883 *st = ST_END_BLOCK_DATA;
1884 target = " block data";
1888 *st = ST_END_MODULE;
1892 case COMP_INTERFACE:
1893 *st = ST_END_INTERFACE;
1894 target = " interface";
1913 *st = ST_END_SELECT;
1918 *st = ST_END_FORALL;
1928 gfc_error ("Unexpected END statement at %C");
1932 if (gfc_match_eos () == MATCH_YES)
1935 if (*st == ST_ENDIF || *st == ST_ENDDO || *st == ST_END_SELECT
1936 || *st == ST_END_INTERFACE || *st == ST_END_FORALL
1937 || *st == ST_END_WHERE)
1940 gfc_error ("%s statement expected at %C",
1941 gfc_ascii_statement (*st));
1948 /* Verify that we've got the sort of end-block that we're expecting. */
1949 if (gfc_match (target) != MATCH_YES)
1951 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
1955 /* If we're at the end, make sure a block name wasn't required. */
1956 if (gfc_match_eos () == MATCH_YES)
1959 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT)
1962 if (gfc_current_block () == NULL)
1965 gfc_error ("Expected block name of '%s' in %s statement at %C",
1966 block_name, gfc_ascii_statement (*st));
1971 /* END INTERFACE has a special handler for its several possible endings. */
1972 if (*st == ST_END_INTERFACE)
1973 return gfc_match_end_interface ();
1975 /* We haven't hit the end of statement, so what is left must be an end-name. */
1976 m = gfc_match_space ();
1978 m = gfc_match_name (name);
1981 gfc_error ("Expected terminating name at %C");
1985 if (block_name == NULL)
1988 if (strcmp (name, block_name) != 0)
1990 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
1991 gfc_ascii_statement (*st));
1995 if (gfc_match_eos () == MATCH_YES)
1999 gfc_syntax_error (*st);
2002 gfc_set_locus (&old_loc);
2008 /***************** Attribute declaration statements ****************/
2010 /* Set the attribute of a single variable. */
2015 char name[GFC_MAX_SYMBOL_LEN + 1];
2023 m = gfc_match_name (name);
2027 if (find_special (name, &sym))
2030 var_locus = *gfc_current_locus ();
2032 /* Deal with possible array specification for certain attributes. */
2033 if (current_attr.dimension
2034 || current_attr.allocatable
2035 || current_attr.pointer
2036 || current_attr.target)
2038 m = gfc_match_array_spec (&as);
2039 if (m == MATCH_ERROR)
2042 if (current_attr.dimension && m == MATCH_NO)
2045 ("Missing array specification at %L in DIMENSION statement",
2051 if ((current_attr.allocatable || current_attr.pointer)
2052 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
2054 gfc_error ("Array specification must be deferred at %L",
2061 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2062 if (current_attr.dimension == 0
2063 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
2069 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
2075 if ((current_attr.external || current_attr.intrinsic)
2076 && sym->attr.flavor != FL_PROCEDURE
2077 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
2086 gfc_free_array_spec (as);
2091 /* Generic attribute declaration subroutine. Used for attributes that
2092 just have a list of names. */
2099 /* Gobble the optional double colon, by simply ignoring the result
2109 if (gfc_match_eos () == MATCH_YES)
2115 if (gfc_match_char (',') != MATCH_YES)
2117 gfc_error ("Unexpected character in variable list at %C");
2128 gfc_match_external (void)
2131 gfc_clear_attr (¤t_attr);
2132 gfc_add_external (¤t_attr, NULL);
2134 return attr_decl ();
2140 gfc_match_intent (void)
2144 intent = match_intent_spec ();
2145 if (intent == INTENT_UNKNOWN)
2148 gfc_clear_attr (¤t_attr);
2149 gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */
2151 return attr_decl ();
2156 gfc_match_intrinsic (void)
2159 gfc_clear_attr (¤t_attr);
2160 gfc_add_intrinsic (¤t_attr, NULL);
2162 return attr_decl ();
2167 gfc_match_optional (void)
2170 gfc_clear_attr (¤t_attr);
2171 gfc_add_optional (¤t_attr, NULL);
2173 return attr_decl ();
2178 gfc_match_pointer (void)
2181 gfc_clear_attr (¤t_attr);
2182 gfc_add_pointer (¤t_attr, NULL);
2184 return attr_decl ();
2189 gfc_match_allocatable (void)
2192 gfc_clear_attr (¤t_attr);
2193 gfc_add_allocatable (¤t_attr, NULL);
2195 return attr_decl ();
2200 gfc_match_dimension (void)
2203 gfc_clear_attr (¤t_attr);
2204 gfc_add_dimension (¤t_attr, NULL);
2206 return attr_decl ();
2211 gfc_match_target (void)
2214 gfc_clear_attr (¤t_attr);
2215 gfc_add_target (¤t_attr, NULL);
2217 return attr_decl ();
2221 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2225 access_attr_decl (gfc_statement st)
2227 char name[GFC_MAX_SYMBOL_LEN + 1];
2228 interface_type type;
2231 gfc_intrinsic_op operator;
2234 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
2239 m = gfc_match_generic_spec (&type, name, &operator);
2242 if (m == MATCH_ERROR)
2247 case INTERFACE_NAMELESS:
2250 case INTERFACE_GENERIC:
2251 if (gfc_get_symbol (name, NULL, &sym))
2254 if (gfc_add_access (&sym->attr,
2256 ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
2262 case INTERFACE_INTRINSIC_OP:
2263 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
2265 gfc_current_ns->operator_access[operator] =
2266 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2270 gfc_error ("Access specification of the %s operator at %C has "
2271 "already been specified", gfc_op2string (operator));
2277 case INTERFACE_USER_OP:
2278 uop = gfc_get_uop (name);
2280 if (uop->access == ACCESS_UNKNOWN)
2283 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2288 ("Access specification of the .%s. operator at %C has "
2289 "already been specified", sym->name);
2296 if (gfc_match_char (',') == MATCH_NO)
2300 if (gfc_match_eos () != MATCH_YES)
2305 gfc_syntax_error (st);
2312 /* The PRIVATE statement is a bit weird in that it can be a attribute
2313 declaration, but also works as a standlone statement inside of a
2314 type declaration or a module. */
2317 gfc_match_private (gfc_statement * st)
2320 if (gfc_match ("private") != MATCH_YES)
2323 if (gfc_current_state () == COMP_DERIVED)
2325 if (gfc_match_eos () == MATCH_YES)
2331 gfc_syntax_error (ST_PRIVATE);
2335 if (gfc_match_eos () == MATCH_YES)
2342 return access_attr_decl (ST_PRIVATE);
2347 gfc_match_public (gfc_statement * st)
2350 if (gfc_match ("public") != MATCH_YES)
2353 if (gfc_match_eos () == MATCH_YES)
2360 return access_attr_decl (ST_PUBLIC);
2364 /* Workhorse for gfc_match_parameter. */
2373 m = gfc_match_symbol (&sym, 0);
2375 gfc_error ("Expected variable name at %C in PARAMETER statement");
2380 if (gfc_match_char ('=') == MATCH_NO)
2382 gfc_error ("Expected = sign in PARAMETER statement at %C");
2386 m = gfc_match_init_expr (&init);
2388 gfc_error ("Expected expression at %C in PARAMETER statement");
2392 if (sym->ts.type == BT_UNKNOWN
2393 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2399 if (gfc_check_assign_symbol (sym, init) == FAILURE
2400 || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
2410 gfc_free_expr (init);
2415 /* Match a parameter statement, with the weird syntax that these have. */
2418 gfc_match_parameter (void)
2422 if (gfc_match_char ('(') == MATCH_NO)
2431 if (gfc_match (" )%t") == MATCH_YES)
2434 if (gfc_match_char (',') != MATCH_YES)
2436 gfc_error ("Unexpected characters in PARAMETER statement at %C");
2446 /* Save statements have a special syntax. */
2449 gfc_match_save (void)
2454 if (gfc_match_eos () == MATCH_YES)
2456 if (gfc_current_ns->seen_save)
2458 gfc_error ("Blanket SAVE statement at %C follows previous "
2464 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
2468 if (gfc_current_ns->save_all)
2470 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
2478 m = gfc_match_symbol (&sym, 0);
2482 if (gfc_add_save (&sym->attr, gfc_current_locus ()) == FAILURE)
2493 m = gfc_match (" / %s /", &sym);
2494 if (m == MATCH_ERROR)
2499 if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE)
2501 gfc_current_ns->seen_save = 1;
2504 if (gfc_match_eos () == MATCH_YES)
2506 if (gfc_match_char (',') != MATCH_YES)
2513 gfc_error ("Syntax error in SAVE statement at %C");
2518 /* Match a module procedure statement. Note that we have to modify
2519 symbols in the parent's namespace because the current one was there
2520 to receive symbols that are in a interface's formal argument list. */
2523 gfc_match_modproc (void)
2525 char name[GFC_MAX_SYMBOL_LEN + 1];
2529 if (gfc_state_stack->state != COMP_INTERFACE
2530 || gfc_state_stack->previous == NULL
2531 || current_interface.type == INTERFACE_NAMELESS)
2534 ("MODULE PROCEDURE at %C must be in a generic module interface");
2540 m = gfc_match_name (name);
2546 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
2549 if (sym->attr.proc != PROC_MODULE
2550 && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
2553 if (gfc_add_interface (sym) == FAILURE)
2556 if (gfc_match_eos () == MATCH_YES)
2558 if (gfc_match_char (',') != MATCH_YES)
2565 gfc_syntax_error (ST_MODULE_PROC);
2570 /* Match the beginning of a derived type declaration. If a type name
2571 was the result of a function, then it is possible to have a symbol
2572 already to be known as a derived type yet have no components. */
2575 gfc_match_derived_decl (void)
2577 char name[GFC_MAX_SYMBOL_LEN + 1];
2578 symbol_attribute attr;
2582 if (gfc_current_state () == COMP_DERIVED)
2585 gfc_clear_attr (&attr);
2588 if (gfc_match (" , private") == MATCH_YES)
2590 if (gfc_find_state (COMP_MODULE) == FAILURE)
2593 ("Derived type at %C can only be PRIVATE within a MODULE");
2597 if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
2602 if (gfc_match (" , public") == MATCH_YES)
2604 if (gfc_find_state (COMP_MODULE) == FAILURE)
2606 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
2610 if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
2615 if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
2617 gfc_error ("Expected :: in TYPE definition at %C");
2621 m = gfc_match (" %n%t", name);
2625 /* Make sure the name isn't the name of an intrinsic type. The
2626 'double precision' type doesn't get past the name matcher. */
2627 if (strcmp (name, "integer") == 0
2628 || strcmp (name, "real") == 0
2629 || strcmp (name, "character") == 0
2630 || strcmp (name, "logical") == 0
2631 || strcmp (name, "complex") == 0)
2634 ("Type name '%s' at %C cannot be the same as an intrinsic type",
2639 if (gfc_get_symbol (name, NULL, &sym))
2642 if (sym->ts.type != BT_UNKNOWN)
2644 gfc_error ("Derived type name '%s' at %C already has a basic type "
2645 "of %s", sym->name, gfc_typename (&sym->ts));
2649 /* The symbol may already have the derived attribute without the
2650 components. The ways this can happen is via a function
2651 definition, an INTRINSIC statement or a subtype in another
2652 derived type that is a pointer. The first part of the AND clause
2653 is true if a the symbol is not the return value of a function. */
2654 if (sym->attr.flavor != FL_DERIVED
2655 && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
2658 if (sym->components != NULL)
2661 ("Derived type definition of '%s' at %C has already been defined",
2666 if (attr.access != ACCESS_UNKNOWN
2667 && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
2670 gfc_new_block = sym;