1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 /* Macros to access allocate memory for gfc_data_variable,
30 gfc_data_value and gfc_data. */
31 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
32 #define gfc_get_data_value() XCNEW (gfc_data_value)
33 #define gfc_get_data() XCNEW (gfc_data)
36 /* This flag is set if an old-style length selector is matched
37 during a type-declaration statement. */
39 static int old_char_selector;
41 /* When variables acquire types and attributes from a declaration
42 statement, they get them from the following static variables. The
43 first part of a declaration sets these variables and the second
44 part copies these into symbol structures. */
46 static gfc_typespec current_ts;
48 static symbol_attribute current_attr;
49 static gfc_array_spec *current_as;
50 static int colon_seen;
52 /* The current binding label (if any). */
53 static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
54 /* Need to know how many identifiers are on the current data declaration
55 line in case we're given the BIND(C) attribute with a NAME= specifier. */
56 static int num_idents_on_line;
57 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
58 can supply a name if the curr_binding_label is nil and NAME= was not. */
59 static int has_name_equals = 0;
61 /* Initializer of the previous enumerator. */
63 static gfc_expr *last_initializer;
65 /* History of all the enumerators is maintained, so that
66 kind values of all the enumerators could be updated depending
67 upon the maximum initialized value. */
69 typedef struct enumerator_history
72 gfc_expr *initializer;
73 struct enumerator_history *next;
77 /* Header of enum history chain. */
79 static enumerator_history *enum_history = NULL;
81 /* Pointer of enum history node containing largest initializer. */
83 static enumerator_history *max_enum = NULL;
85 /* gfc_new_block points to the symbol of a newly matched block. */
87 gfc_symbol *gfc_new_block;
89 bool gfc_matching_function;
92 /********************* DATA statement subroutines *********************/
94 static bool in_match_data = false;
97 gfc_in_match_data (void)
103 set_in_match_data (bool set_value)
105 in_match_data = set_value;
108 /* Free a gfc_data_variable structure and everything beneath it. */
111 free_variable (gfc_data_variable *p)
113 gfc_data_variable *q;
118 gfc_free_expr (p->expr);
119 gfc_free_iterator (&p->iter, 0);
120 free_variable (p->list);
126 /* Free a gfc_data_value structure and everything beneath it. */
129 free_value (gfc_data_value *p)
136 gfc_free_expr (p->expr);
142 /* Free a list of gfc_data structures. */
145 gfc_free_data (gfc_data *p)
152 free_variable (p->var);
153 free_value (p->value);
159 /* Free all data in a namespace. */
162 gfc_free_data_all (gfc_namespace *ns)
175 static match var_element (gfc_data_variable *);
177 /* Match a list of variables terminated by an iterator and a right
181 var_list (gfc_data_variable *parent)
183 gfc_data_variable *tail, var;
186 m = var_element (&var);
187 if (m == MATCH_ERROR)
192 tail = gfc_get_data_variable ();
199 if (gfc_match_char (',') != MATCH_YES)
202 m = gfc_match_iterator (&parent->iter, 1);
205 if (m == MATCH_ERROR)
208 m = var_element (&var);
209 if (m == MATCH_ERROR)
214 tail->next = gfc_get_data_variable ();
220 if (gfc_match_char (')') != MATCH_YES)
225 gfc_syntax_error (ST_DATA);
230 /* Match a single element in a data variable list, which can be a
231 variable-iterator list. */
234 var_element (gfc_data_variable *new)
239 memset (new, 0, sizeof (gfc_data_variable));
241 if (gfc_match_char ('(') == MATCH_YES)
242 return var_list (new);
244 m = gfc_match_variable (&new->expr, 0);
248 sym = new->expr->symtree->n.sym;
250 if (!sym->attr.function && gfc_current_ns->parent
251 && gfc_current_ns->parent == sym->ns)
253 gfc_error ("Host associated variable '%s' may not be in the DATA "
254 "statement at %C", sym->name);
258 if (gfc_current_state () != COMP_BLOCK_DATA
259 && sym->attr.in_common
260 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
261 "common block variable '%s' in DATA statement at %C",
262 sym->name) == FAILURE)
265 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
272 /* Match the top-level list of data variables. */
275 top_var_list (gfc_data *d)
277 gfc_data_variable var, *tail, *new;
284 m = var_element (&var);
287 if (m == MATCH_ERROR)
290 new = gfc_get_data_variable ();
300 if (gfc_match_char ('/') == MATCH_YES)
302 if (gfc_match_char (',') != MATCH_YES)
309 gfc_syntax_error (ST_DATA);
310 gfc_free_data_all (gfc_current_ns);
316 match_data_constant (gfc_expr **result)
318 char name[GFC_MAX_SYMBOL_LEN + 1];
324 m = gfc_match_literal_constant (&expr, 1);
331 if (m == MATCH_ERROR)
334 m = gfc_match_null (result);
338 old_loc = gfc_current_locus;
340 /* Should this be a structure component, try to match it
341 before matching a name. */
342 m = gfc_match_rvalue (result);
343 if (m == MATCH_ERROR)
346 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
348 if (gfc_simplify_expr (*result, 0) == FAILURE)
353 gfc_current_locus = old_loc;
355 m = gfc_match_name (name);
359 if (gfc_find_symbol (name, NULL, 1, &sym))
363 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
365 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
369 else if (sym->attr.flavor == FL_DERIVED)
370 return gfc_match_structure_constructor (sym, result);
372 /* Check to see if the value is an initialization array expression. */
373 if (sym->value->expr_type == EXPR_ARRAY)
375 gfc_current_locus = old_loc;
377 m = gfc_match_init_expr (result);
378 if (m == MATCH_ERROR)
383 if (gfc_simplify_expr (*result, 0) == FAILURE)
386 if ((*result)->expr_type == EXPR_CONSTANT)
390 gfc_error ("Invalid initializer %s in Data statement at %C", name);
396 *result = gfc_copy_expr (sym->value);
401 /* Match a list of values in a DATA statement. The leading '/' has
402 already been seen at this point. */
405 top_val_list (gfc_data *data)
407 gfc_data_value *new, *tail;
415 m = match_data_constant (&expr);
418 if (m == MATCH_ERROR)
421 new = gfc_get_data_value ();
422 mpz_init (new->repeat);
431 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
434 mpz_set_ui (tail->repeat, 1);
438 if (expr->ts.type == BT_INTEGER)
439 mpz_set (tail->repeat, expr->value.integer);
440 gfc_free_expr (expr);
442 m = match_data_constant (&tail->expr);
445 if (m == MATCH_ERROR)
449 if (gfc_match_char ('/') == MATCH_YES)
451 if (gfc_match_char (',') == MATCH_NO)
458 gfc_syntax_error (ST_DATA);
459 gfc_free_data_all (gfc_current_ns);
464 /* Matches an old style initialization. */
467 match_old_style_init (const char *name)
474 /* Set up data structure to hold initializers. */
475 gfc_find_sym_tree (name, NULL, 0, &st);
478 newdata = gfc_get_data ();
479 newdata->var = gfc_get_data_variable ();
480 newdata->var->expr = gfc_get_variable_expr (st);
481 newdata->where = gfc_current_locus;
483 /* Match initial value list. This also eats the terminal '/'. */
484 m = top_val_list (newdata);
493 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
498 /* Mark the variable as having appeared in a data statement. */
499 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
505 /* Chain in namespace list of DATA initializers. */
506 newdata->next = gfc_current_ns->data;
507 gfc_current_ns->data = newdata;
513 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
514 we are matching a DATA statement and are therefore issuing an error
515 if we encounter something unexpected, if not, we're trying to match
516 an old-style initialization expression of the form INTEGER I /2/. */
519 gfc_match_data (void)
524 set_in_match_data (true);
528 new = gfc_get_data ();
529 new->where = gfc_current_locus;
531 m = top_var_list (new);
535 m = top_val_list (new);
539 new->next = gfc_current_ns->data;
540 gfc_current_ns->data = new;
542 if (gfc_match_eos () == MATCH_YES)
545 gfc_match_char (','); /* Optional comma */
548 set_in_match_data (false);
552 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
559 set_in_match_data (false);
565 /************************ Declaration statements *********************/
567 /* Match an intent specification. Since this can only happen after an
568 INTENT word, a legal intent-spec must follow. */
571 match_intent_spec (void)
574 if (gfc_match (" ( in out )") == MATCH_YES)
576 if (gfc_match (" ( in )") == MATCH_YES)
578 if (gfc_match (" ( out )") == MATCH_YES)
581 gfc_error ("Bad INTENT specification at %C");
582 return INTENT_UNKNOWN;
586 /* Matches a character length specification, which is either a
587 specification expression or a '*'. */
590 char_len_param_value (gfc_expr **expr)
594 if (gfc_match_char ('*') == MATCH_YES)
600 m = gfc_match_expr (expr);
601 if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
603 if ((*expr)->value.function.actual
604 && (*expr)->value.function.actual->expr->symtree)
607 e = (*expr)->value.function.actual->expr;
608 if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
609 && e->expr_type == EXPR_VARIABLE)
611 if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
613 if (e->symtree->n.sym->ts.type == BT_CHARACTER
614 && e->symtree->n.sym->ts.cl
615 && e->symtree->n.sym->ts.cl->length->ts.type == BT_UNKNOWN)
623 gfc_error ("Conflict in attributes of function argument at %C");
628 /* A character length is a '*' followed by a literal integer or a
629 char_len_param_value in parenthesis. */
632 match_char_length (gfc_expr **expr)
637 m = gfc_match_char ('*');
641 m = gfc_match_small_literal_int (&length, NULL);
642 if (m == MATCH_ERROR)
647 *expr = gfc_int_expr (length);
651 if (gfc_match_char ('(') == MATCH_NO)
654 m = char_len_param_value (expr);
655 if (m != MATCH_YES && gfc_matching_function)
661 if (m == MATCH_ERROR)
666 if (gfc_match_char (')') == MATCH_NO)
668 gfc_free_expr (*expr);
676 gfc_error ("Syntax error in character length specification at %C");
681 /* Special subroutine for finding a symbol. Check if the name is found
682 in the current name space. If not, and we're compiling a function or
683 subroutine and the parent compilation unit is an interface, then check
684 to see if the name we've been given is the name of the interface
685 (located in another namespace). */
688 find_special (const char *name, gfc_symbol **result)
693 i = gfc_get_symbol (name, NULL, result);
697 if (gfc_current_state () != COMP_SUBROUTINE
698 && gfc_current_state () != COMP_FUNCTION)
701 s = gfc_state_stack->previous;
705 if (s->state != COMP_INTERFACE)
708 goto end; /* Nameless interface. */
710 if (strcmp (name, s->sym->name) == 0)
721 /* Special subroutine for getting a symbol node associated with a
722 procedure name, used in SUBROUTINE and FUNCTION statements. The
723 symbol is created in the parent using with symtree node in the
724 child unit pointing to the symbol. If the current namespace has no
725 parent, then the symbol is just created in the current unit. */
728 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
734 /* Module functions have to be left in their own namespace because
735 they have potentially (almost certainly!) already been referenced.
736 In this sense, they are rather like external functions. This is
737 fixed up in resolve.c(resolve_entries), where the symbol name-
738 space is set to point to the master function, so that the fake
739 result mechanism can work. */
740 if (module_fcn_entry)
742 /* Present if entry is declared to be a module procedure. */
743 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
746 rc = gfc_get_symbol (name, NULL, result);
747 else if (!gfc_get_symbol (name, NULL, &sym) && sym
748 && (*result)->ts.type == BT_UNKNOWN
749 && sym->attr.flavor == FL_UNKNOWN)
750 /* Pick up the typespec for the entry, if declared in the function
751 body. Note that this symbol is FL_UNKNOWN because it will
752 only have appeared in a type declaration. The local symtree
753 is set to point to the module symbol and a unique symtree
754 to the local version. This latter ensures a correct clearing
757 /* If the ENTRY proceeds its specification, we need to ensure
758 that this does not raise a "has no IMPLICIT type" error. */
759 if (sym->ts.type == BT_UNKNOWN)
760 sym->attr.untyped = 1;
762 (*result)->ts = sym->ts;
764 /* Put the symbol in the procedure namespace so that, should
765 the ENTRY preceed its specification, the specification
767 (*result)->ns = gfc_current_ns;
769 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
771 st = gfc_get_unique_symtree (gfc_current_ns);
776 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
782 gfc_current_ns->refs++;
784 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
786 /* Trap another encompassed procedure with the same name. All
787 these conditions are necessary to avoid picking up an entry
788 whose name clashes with that of the encompassing procedure;
789 this is handled using gsymbols to register unique,globally
791 if (sym->attr.flavor != 0
792 && sym->attr.proc != 0
793 && (sym->attr.subroutine || sym->attr.function)
794 && sym->attr.if_source != IFSRC_UNKNOWN)
795 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
796 name, &sym->declared_at);
798 /* Trap a procedure with a name the same as interface in the
799 encompassing scope. */
800 if (sym->attr.generic != 0
801 && (sym->attr.subroutine || sym->attr.function)
802 && !sym->attr.mod_proc)
803 gfc_error_now ("Name '%s' at %C is already defined"
804 " as a generic interface at %L",
805 name, &sym->declared_at);
807 /* Trap declarations of attributes in encompassing scope. The
808 signature for this is that ts.kind is set. Legitimate
809 references only set ts.type. */
810 if (sym->ts.kind != 0
811 && !sym->attr.implicit_type
812 && sym->attr.proc == 0
813 && gfc_current_ns->parent != NULL
814 && sym->attr.access == 0
815 && !module_fcn_entry)
816 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
817 "and must not have attributes declared at %L",
818 name, &sym->declared_at);
821 if (gfc_current_ns->parent == NULL || *result == NULL)
824 /* Module function entries will already have a symtree in
825 the current namespace but will need one at module level. */
826 if (module_fcn_entry)
828 /* Present if entry is declared to be a module procedure. */
829 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
831 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
834 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
839 /* See if the procedure should be a module procedure. */
841 if (((sym->ns->proc_name != NULL
842 && sym->ns->proc_name->attr.flavor == FL_MODULE
843 && sym->attr.proc != PROC_MODULE)
844 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
845 && gfc_add_procedure (&sym->attr, PROC_MODULE,
846 sym->name, NULL) == FAILURE)
853 /* Verify that the given symbol representing a parameter is C
854 interoperable, by checking to see if it was marked as such after
855 its declaration. If the given symbol is not interoperable, a
856 warning is reported, thus removing the need to return the status to
857 the calling function. The standard does not require the user use
858 one of the iso_c_binding named constants to declare an
859 interoperable parameter, but we can't be sure if the param is C
860 interop or not if the user doesn't. For example, integer(4) may be
861 legal Fortran, but doesn't have meaning in C. It may interop with
862 a number of the C types, which causes a problem because the
863 compiler can't know which one. This code is almost certainly not
864 portable, and the user will get what they deserve if the C type
865 across platforms isn't always interoperable with integer(4). If
866 the user had used something like integer(c_int) or integer(c_long),
867 the compiler could have automatically handled the varying sizes
871 verify_c_interop_param (gfc_symbol *sym)
873 int is_c_interop = 0;
874 try retval = SUCCESS;
876 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
877 Don't repeat the checks here. */
878 if (sym->attr.implicit_type)
881 /* For subroutines or functions that are passed to a BIND(C) procedure,
882 they're interoperable if they're BIND(C) and their params are all
884 if (sym->attr.flavor == FL_PROCEDURE)
886 if (sym->attr.is_bind_c == 0)
888 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
889 "attribute to be C interoperable", sym->name,
890 &(sym->declared_at));
896 if (sym->attr.is_c_interop == 1)
897 /* We've already checked this procedure; don't check it again. */
900 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
905 /* See if we've stored a reference to a procedure that owns sym. */
906 if (sym->ns != NULL && sym->ns->proc_name != NULL)
908 if (sym->ns->proc_name->attr.is_bind_c == 1)
911 (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
914 if (is_c_interop != 1)
916 /* Make personalized messages to give better feedback. */
917 if (sym->ts.type == BT_DERIVED)
918 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
919 " procedure '%s' but is not C interoperable "
920 "because derived type '%s' is not C interoperable",
921 sym->name, &(sym->declared_at),
922 sym->ns->proc_name->name,
923 sym->ts.derived->name);
925 gfc_warning ("Variable '%s' at %L is a parameter to the "
926 "BIND(C) procedure '%s' but may not be C "
928 sym->name, &(sym->declared_at),
929 sym->ns->proc_name->name);
932 /* Character strings are only C interoperable if they have a
934 if (sym->ts.type == BT_CHARACTER)
936 gfc_charlen *cl = sym->ts.cl;
937 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
938 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
940 gfc_error ("Character argument '%s' at %L "
941 "must be length 1 because "
942 "procedure '%s' is BIND(C)",
943 sym->name, &sym->declared_at,
944 sym->ns->proc_name->name);
949 /* We have to make sure that any param to a bind(c) routine does
950 not have the allocatable, pointer, or optional attributes,
951 according to J3/04-007, section 5.1. */
952 if (sym->attr.allocatable == 1)
954 gfc_error ("Variable '%s' at %L cannot have the "
955 "ALLOCATABLE attribute because procedure '%s'"
956 " is BIND(C)", sym->name, &(sym->declared_at),
957 sym->ns->proc_name->name);
961 if (sym->attr.pointer == 1)
963 gfc_error ("Variable '%s' at %L cannot have the "
964 "POINTER attribute because procedure '%s'"
965 " is BIND(C)", sym->name, &(sym->declared_at),
966 sym->ns->proc_name->name);
970 if (sym->attr.optional == 1)
972 gfc_error ("Variable '%s' at %L cannot have the "
973 "OPTIONAL attribute because procedure '%s'"
974 " is BIND(C)", sym->name, &(sym->declared_at),
975 sym->ns->proc_name->name);
979 /* Make sure that if it has the dimension attribute, that it is
980 either assumed size or explicit shape. */
983 if (sym->as->type == AS_ASSUMED_SHAPE)
985 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
986 "argument to the procedure '%s' at %L because "
987 "the procedure is BIND(C)", sym->name,
988 &(sym->declared_at), sym->ns->proc_name->name,
989 &(sym->ns->proc_name->declared_at));
993 if (sym->as->type == AS_DEFERRED)
995 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
996 "argument to the procedure '%s' at %L because "
997 "the procedure is BIND(C)", sym->name,
998 &(sym->declared_at), sym->ns->proc_name->name,
999 &(sym->ns->proc_name->declared_at));
1010 /* Function called by variable_decl() that adds a name to the symbol table. */
1013 build_sym (const char *name, gfc_charlen *cl,
1014 gfc_array_spec **as, locus *var_locus)
1016 symbol_attribute attr;
1019 if (gfc_get_symbol (name, NULL, &sym))
1022 /* Start updating the symbol table. Add basic type attribute if present. */
1023 if (current_ts.type != BT_UNKNOWN
1024 && (sym->attr.implicit_type == 0
1025 || !gfc_compare_types (&sym->ts, ¤t_ts))
1026 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
1029 if (sym->ts.type == BT_CHARACTER)
1032 /* Add dimension attribute if present. */
1033 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
1037 /* Add attribute to symbol. The copy is so that we can reset the
1038 dimension attribute. */
1039 attr = current_attr;
1042 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
1045 /* Finish any work that may need to be done for the binding label,
1046 if it's a bind(c). The bind(c) attr is found before the symbol
1047 is made, and before the symbol name (for data decls), so the
1048 current_ts is holding the binding label, or nothing if the
1049 name= attr wasn't given. Therefore, test here if we're dealing
1050 with a bind(c) and make sure the binding label is set correctly. */
1051 if (sym->attr.is_bind_c == 1)
1053 if (sym->binding_label[0] == '\0')
1055 /* Set the binding label and verify that if a NAME= was specified
1056 then only one identifier was in the entity-decl-list. */
1057 if (set_binding_label (sym->binding_label, sym->name,
1058 num_idents_on_line) == FAILURE)
1063 /* See if we know we're in a common block, and if it's a bind(c)
1064 common then we need to make sure we're an interoperable type. */
1065 if (sym->attr.in_common == 1)
1067 /* Test the common block object. */
1068 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1069 && sym->ts.is_c_interop != 1)
1071 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1072 "must be declared with a C interoperable "
1073 "kind since common block '%s' is BIND(C)",
1074 sym->name, sym->common_block->name,
1075 sym->common_block->name);
1080 sym->attr.implied_index = 0;
1086 /* Set character constant to the given length. The constant will be padded or
1087 truncated. If we're inside an array constructor without a typespec, we
1088 additionally check that all elements have the same length; check_len -1
1089 means no checking. */
1092 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1097 gcc_assert (expr->expr_type == EXPR_CONSTANT);
1098 gcc_assert (expr->ts.type == BT_CHARACTER);
1100 slen = expr->value.character.length;
1103 s = gfc_get_wide_string (len + 1);
1104 memcpy (s, expr->value.character.string,
1105 MIN (len, slen) * sizeof (gfc_char_t));
1107 gfc_wide_memset (&s[slen], ' ', len - slen);
1109 if (gfc_option.warn_character_truncation && slen > len)
1110 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1111 "(%d/%d)", &expr->where, slen, len);
1113 /* Apply the standard by 'hand' otherwise it gets cleared for
1115 if (check_len != -1 && slen != check_len
1116 && !(gfc_option.allow_std & GFC_STD_GNU))
1117 gfc_error_now ("The CHARACTER elements of the array constructor "
1118 "at %L must have the same length (%d/%d)",
1119 &expr->where, slen, check_len);
1122 gfc_free (expr->value.character.string);
1123 expr->value.character.string = s;
1124 expr->value.character.length = len;
1129 /* Function to create and update the enumerator history
1130 using the information passed as arguments.
1131 Pointer "max_enum" is also updated, to point to
1132 enum history node containing largest initializer.
1134 SYM points to the symbol node of enumerator.
1135 INIT points to its enumerator value. */
1138 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1140 enumerator_history *new_enum_history;
1141 gcc_assert (sym != NULL && init != NULL);
1143 new_enum_history = XCNEW (enumerator_history);
1145 new_enum_history->sym = sym;
1146 new_enum_history->initializer = init;
1147 new_enum_history->next = NULL;
1149 if (enum_history == NULL)
1151 enum_history = new_enum_history;
1152 max_enum = enum_history;
1156 new_enum_history->next = enum_history;
1157 enum_history = new_enum_history;
1159 if (mpz_cmp (max_enum->initializer->value.integer,
1160 new_enum_history->initializer->value.integer) < 0)
1161 max_enum = new_enum_history;
1166 /* Function to free enum kind history. */
1169 gfc_free_enum_history (void)
1171 enumerator_history *current = enum_history;
1172 enumerator_history *next;
1174 while (current != NULL)
1176 next = current->next;
1181 enum_history = NULL;
1185 /* Function called by variable_decl() that adds an initialization
1186 expression to a symbol. */
1189 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1191 symbol_attribute attr;
1196 if (find_special (name, &sym))
1201 /* If this symbol is confirming an implicit parameter type,
1202 then an initialization expression is not allowed. */
1203 if (attr.flavor == FL_PARAMETER
1204 && sym->value != NULL
1207 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1214 /* An initializer is required for PARAMETER declarations. */
1215 if (attr.flavor == FL_PARAMETER)
1217 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1223 /* If a variable appears in a DATA block, it cannot have an
1227 gfc_error ("Variable '%s' at %C with an initializer already "
1228 "appears in a DATA statement", sym->name);
1232 /* Check if the assignment can happen. This has to be put off
1233 until later for a derived type variable. */
1234 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1235 && gfc_check_assign_symbol (sym, init) == FAILURE)
1238 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1240 /* Update symbol character length according initializer. */
1241 if (sym->ts.cl->length == NULL)
1244 /* If there are multiple CHARACTER variables declared on the
1245 same line, we don't want them to share the same length. */
1246 sym->ts.cl = gfc_get_charlen ();
1247 sym->ts.cl->next = gfc_current_ns->cl_list;
1248 gfc_current_ns->cl_list = sym->ts.cl;
1250 if (sym->attr.flavor == FL_PARAMETER)
1252 if (init->expr_type == EXPR_CONSTANT)
1254 clen = init->value.character.length;
1255 sym->ts.cl->length = gfc_int_expr (clen);
1257 else if (init->expr_type == EXPR_ARRAY)
1259 gfc_expr *p = init->value.constructor->expr;
1260 clen = p->value.character.length;
1261 sym->ts.cl->length = gfc_int_expr (clen);
1263 else if (init->ts.cl && init->ts.cl->length)
1264 sym->ts.cl->length =
1265 gfc_copy_expr (sym->value->ts.cl->length);
1268 /* Update initializer character length according symbol. */
1269 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1271 int len = mpz_get_si (sym->ts.cl->length->value.integer);
1272 gfc_constructor * p;
1274 if (init->expr_type == EXPR_CONSTANT)
1275 gfc_set_constant_character_len (len, init, -1);
1276 else if (init->expr_type == EXPR_ARRAY)
1278 /* Build a new charlen to prevent simplification from
1279 deleting the length before it is resolved. */
1280 init->ts.cl = gfc_get_charlen ();
1281 init->ts.cl->next = gfc_current_ns->cl_list;
1282 gfc_current_ns->cl_list = sym->ts.cl;
1283 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
1285 for (p = init->value.constructor; p; p = p->next)
1286 gfc_set_constant_character_len (len, p->expr, -1);
1291 /* Need to check if the expression we initialized this
1292 to was one of the iso_c_binding named constants. If so,
1293 and we're a parameter (constant), let it be iso_c.
1295 integer(c_int), parameter :: my_int = c_int
1296 integer(my_int) :: my_int_2
1297 If we mark my_int as iso_c (since we can see it's value
1298 is equal to one of the named constants), then my_int_2
1299 will be considered C interoperable. */
1300 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1302 sym->ts.is_iso_c |= init->ts.is_iso_c;
1303 sym->ts.is_c_interop |= init->ts.is_c_interop;
1304 /* attr bits needed for module files. */
1305 sym->attr.is_iso_c |= init->ts.is_iso_c;
1306 sym->attr.is_c_interop |= init->ts.is_c_interop;
1307 if (init->ts.is_iso_c)
1308 sym->ts.f90_type = init->ts.f90_type;
1311 /* Add initializer. Make sure we keep the ranks sane. */
1312 if (sym->attr.dimension && init->rank == 0)
1318 if (sym->attr.flavor == FL_PARAMETER
1319 && init->expr_type == EXPR_CONSTANT
1320 && spec_size (sym->as, &size) == SUCCESS
1321 && mpz_cmp_si (size, 0) > 0)
1323 array = gfc_start_constructor (init->ts.type, init->ts.kind,
1326 array->value.constructor = c = NULL;
1327 for (n = 0; n < (int)mpz_get_si (size); n++)
1329 if (array->value.constructor == NULL)
1331 array->value.constructor = c = gfc_get_constructor ();
1336 c->next = gfc_get_constructor ();
1338 c->expr = gfc_copy_expr (init);
1342 array->shape = gfc_get_shape (sym->as->rank);
1343 for (n = 0; n < sym->as->rank; n++)
1344 spec_dimen_size (sym->as, n, &array->shape[n]);
1349 init->rank = sym->as->rank;
1353 if (sym->attr.save == SAVE_NONE)
1354 sym->attr.save = SAVE_IMPLICIT;
1362 /* Function called by variable_decl() that adds a name to a structure
1366 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1367 gfc_array_spec **as)
1371 /* If the current symbol is of the same derived type that we're
1372 constructing, it must have the pointer attribute. */
1373 if (current_ts.type == BT_DERIVED
1374 && current_ts.derived == gfc_current_block ()
1375 && current_attr.pointer == 0)
1377 gfc_error ("Component at %C must have the POINTER attribute");
1381 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1383 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1385 gfc_error ("Array component of structure at %C must have explicit "
1386 "or deferred shape");
1391 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1396 gfc_set_component_attr (c, ¤t_attr);
1398 c->initializer = *init;
1406 /* Should this ever get more complicated, combine with similar section
1407 in add_init_expr_to_sym into a separate function. */
1408 if (c->ts.type == BT_CHARACTER && !c->pointer && c->initializer && c->ts.cl
1409 && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
1413 gcc_assert (c->ts.cl && c->ts.cl->length);
1414 gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT);
1415 gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER);
1417 len = mpz_get_si (c->ts.cl->length->value.integer);
1419 if (c->initializer->expr_type == EXPR_CONSTANT)
1420 gfc_set_constant_character_len (len, c->initializer, -1);
1421 else if (mpz_cmp (c->ts.cl->length->value.integer,
1422 c->initializer->ts.cl->length->value.integer))
1425 gfc_constructor *ctor = c->initializer->value.constructor;
1430 has_ts = (c->initializer->ts.cl
1431 && c->initializer->ts.cl->length_from_typespec);
1433 for (; ctor; ctor = ctor->next)
1435 /* Remember the length of the first element for checking that
1436 all elements *in the constructor* have the same length. This
1437 need not be the length of the LHS! */
1440 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
1441 gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
1442 first_len = ctor->expr->value.character.length;
1446 if (ctor->expr->expr_type == EXPR_CONSTANT)
1447 gfc_set_constant_character_len (len, ctor->expr,
1448 has_ts ? -1 : first_len);
1453 /* Check array components. */
1458 gfc_error ("Allocatable component at %C must be an array");
1467 if (c->as->type != AS_DEFERRED)
1469 gfc_error ("Pointer array component of structure at %C must have a "
1474 else if (c->allocatable)
1476 if (c->as->type != AS_DEFERRED)
1478 gfc_error ("Allocatable component of structure at %C must have a "
1485 if (c->as->type != AS_EXPLICIT)
1487 gfc_error ("Array component of structure at %C must have an "
1497 /* Match a 'NULL()', and possibly take care of some side effects. */
1500 gfc_match_null (gfc_expr **result)
1506 m = gfc_match (" null ( )");
1510 /* The NULL symbol now has to be/become an intrinsic function. */
1511 if (gfc_get_symbol ("null", NULL, &sym))
1513 gfc_error ("NULL() initialization at %C is ambiguous");
1517 gfc_intrinsic_symbol (sym);
1519 if (sym->attr.proc != PROC_INTRINSIC
1520 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1521 sym->name, NULL) == FAILURE
1522 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1525 e = gfc_get_expr ();
1526 e->where = gfc_current_locus;
1527 e->expr_type = EXPR_NULL;
1528 e->ts.type = BT_UNKNOWN;
1536 /* Match a variable name with an optional initializer. When this
1537 subroutine is called, a variable is expected to be parsed next.
1538 Depending on what is happening at the moment, updates either the
1539 symbol table or the current interface. */
1542 variable_decl (int elem)
1544 char name[GFC_MAX_SYMBOL_LEN + 1];
1545 gfc_expr *initializer, *char_len;
1547 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1558 old_locus = gfc_current_locus;
1560 /* When we get here, we've just matched a list of attributes and
1561 maybe a type and a double colon. The next thing we expect to see
1562 is the name of the symbol. */
1563 m = gfc_match_name (name);
1567 var_locus = gfc_current_locus;
1569 /* Now we could see the optional array spec. or character length. */
1570 m = gfc_match_array_spec (&as);
1571 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1572 cp_as = gfc_copy_array_spec (as);
1573 else if (m == MATCH_ERROR)
1577 as = gfc_copy_array_spec (current_as);
1582 if (current_ts.type == BT_CHARACTER)
1584 switch (match_char_length (&char_len))
1587 cl = gfc_get_charlen ();
1588 cl->next = gfc_current_ns->cl_list;
1589 gfc_current_ns->cl_list = cl;
1591 cl->length = char_len;
1594 /* Non-constant lengths need to be copied after the first
1595 element. Also copy assumed lengths. */
1598 && (current_ts.cl->length == NULL
1599 || current_ts.cl->length->expr_type != EXPR_CONSTANT))
1601 cl = gfc_get_charlen ();
1602 cl->next = gfc_current_ns->cl_list;
1603 gfc_current_ns->cl_list = cl;
1604 cl->length = gfc_copy_expr (current_ts.cl->length);
1616 /* If this symbol has already shown up in a Cray Pointer declaration,
1617 then we want to set the type & bail out. */
1618 if (gfc_option.flag_cray_pointer)
1620 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1621 if (sym != NULL && sym->attr.cray_pointee)
1623 sym->ts.type = current_ts.type;
1624 sym->ts.kind = current_ts.kind;
1626 sym->ts.derived = current_ts.derived;
1627 sym->ts.is_c_interop = current_ts.is_c_interop;
1628 sym->ts.is_iso_c = current_ts.is_iso_c;
1631 /* Check to see if we have an array specification. */
1634 if (sym->as != NULL)
1636 gfc_error ("Duplicate array spec for Cray pointee at %C");
1637 gfc_free_array_spec (cp_as);
1643 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1644 gfc_internal_error ("Couldn't set pointee array spec.");
1646 /* Fix the array spec. */
1647 m = gfc_mod_pointee_as (sym->as);
1648 if (m == MATCH_ERROR)
1656 gfc_free_array_spec (cp_as);
1661 /* OK, we've successfully matched the declaration. Now put the
1662 symbol in the current namespace, because it might be used in the
1663 optional initialization expression for this symbol, e.g. this is
1666 integer, parameter :: i = huge(i)
1668 This is only true for parameters or variables of a basic type.
1669 For components of derived types, it is not true, so we don't
1670 create a symbol for those yet. If we fail to create the symbol,
1672 if (gfc_current_state () != COMP_DERIVED
1673 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1679 /* An interface body specifies all of the procedure's
1680 characteristics and these shall be consistent with those
1681 specified in the procedure definition, except that the interface
1682 may specify a procedure that is not pure if the procedure is
1683 defined to be pure(12.3.2). */
1684 if (current_ts.type == BT_DERIVED
1685 && gfc_current_ns->proc_name
1686 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1687 && current_ts.derived->ns != gfc_current_ns)
1690 st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
1691 if (!(current_ts.derived->attr.imported
1693 && st->n.sym == current_ts.derived)
1694 && !gfc_current_ns->has_import_set)
1696 gfc_error ("the type of '%s' at %C has not been declared within the "
1703 /* In functions that have a RESULT variable defined, the function
1704 name always refers to function calls. Therefore, the name is
1705 not allowed to appear in specification statements. */
1706 if (gfc_current_state () == COMP_FUNCTION
1707 && gfc_current_block () != NULL
1708 && gfc_current_block ()->result != NULL
1709 && gfc_current_block ()->result != gfc_current_block ()
1710 && strcmp (gfc_current_block ()->name, name) == 0)
1712 gfc_error ("Function name '%s' not allowed at %C", name);
1717 /* We allow old-style initializations of the form
1718 integer i /2/, j(4) /3*3, 1/
1719 (if no colon has been seen). These are different from data
1720 statements in that initializers are only allowed to apply to the
1721 variable immediately preceding, i.e.
1723 is not allowed. Therefore we have to do some work manually, that
1724 could otherwise be left to the matchers for DATA statements. */
1726 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1728 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1729 "initialization at %C") == FAILURE)
1732 return match_old_style_init (name);
1735 /* The double colon must be present in order to have initializers.
1736 Otherwise the statement is ambiguous with an assignment statement. */
1739 if (gfc_match (" =>") == MATCH_YES)
1741 if (!current_attr.pointer)
1743 gfc_error ("Initialization at %C isn't for a pointer variable");
1748 m = gfc_match_null (&initializer);
1751 gfc_error ("Pointer initialization requires a NULL() at %C");
1755 if (gfc_pure (NULL))
1757 gfc_error ("Initialization of pointer at %C is not allowed in "
1758 "a PURE procedure");
1766 else if (gfc_match_char ('=') == MATCH_YES)
1768 if (current_attr.pointer)
1770 gfc_error ("Pointer initialization at %C requires '=>', "
1776 m = gfc_match_init_expr (&initializer);
1779 gfc_error ("Expected an initialization expression at %C");
1783 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1785 gfc_error ("Initialization of variable at %C is not allowed in "
1786 "a PURE procedure");
1795 if (initializer != NULL && current_attr.allocatable
1796 && gfc_current_state () == COMP_DERIVED)
1798 gfc_error ("Initialization of allocatable component at %C is not "
1804 /* Add the initializer. Note that it is fine if initializer is
1805 NULL here, because we sometimes also need to check if a
1806 declaration *must* have an initialization expression. */
1807 if (gfc_current_state () != COMP_DERIVED)
1808 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1811 if (current_ts.type == BT_DERIVED
1812 && !current_attr.pointer && !initializer)
1813 initializer = gfc_default_initializer (¤t_ts);
1814 t = build_struct (name, cl, &initializer, &as);
1817 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1820 /* Free stuff up and return. */
1821 gfc_free_expr (initializer);
1822 gfc_free_array_spec (as);
1828 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1829 This assumes that the byte size is equal to the kind number for
1830 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1833 gfc_match_old_kind_spec (gfc_typespec *ts)
1838 if (gfc_match_char ('*') != MATCH_YES)
1841 m = gfc_match_small_literal_int (&ts->kind, NULL);
1845 original_kind = ts->kind;
1847 /* Massage the kind numbers for complex types. */
1848 if (ts->type == BT_COMPLEX)
1852 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1853 gfc_basic_typename (ts->type), original_kind);
1859 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1861 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1862 gfc_basic_typename (ts->type), original_kind);
1866 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1867 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1874 /* Match a kind specification. Since kinds are generally optional, we
1875 usually return MATCH_NO if something goes wrong. If a "kind="
1876 string is found, then we know we have an error. */
1879 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
1891 where = loc = gfc_current_locus;
1896 if (gfc_match_char ('(') == MATCH_NO)
1899 /* Also gobbles optional text. */
1900 if (gfc_match (" kind = ") == MATCH_YES)
1903 loc = gfc_current_locus;
1906 n = gfc_match_init_expr (&e);
1910 if (gfc_matching_function)
1912 /* The function kind expression might include use associated or
1913 imported parameters and try again after the specification
1915 if (gfc_match_char (')') != MATCH_YES)
1917 gfc_error ("Missing right parenthesis at %C");
1923 gfc_undo_symbols ();
1928 /* ....or else, the match is real. */
1930 gfc_error ("Expected initialization expression at %C");
1938 gfc_error ("Expected scalar initialization expression at %C");
1943 msg = gfc_extract_int (e, &ts->kind);
1952 /* Before throwing away the expression, let's see if we had a
1953 C interoperable kind (and store the fact). */
1954 if (e->ts.is_c_interop == 1)
1956 /* Mark this as c interoperable if being declared with one
1957 of the named constants from iso_c_binding. */
1958 ts->is_c_interop = e->ts.is_iso_c;
1959 ts->f90_type = e->ts.f90_type;
1965 /* Ignore errors to this point, if we've gotten here. This means
1966 we ignore the m=MATCH_ERROR from above. */
1967 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1969 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1970 gfc_basic_typename (ts->type));
1971 gfc_current_locus = where;
1975 gfc_gobble_whitespace ();
1976 if ((c = gfc_next_ascii_char ()) != ')'
1977 && (ts->type != BT_CHARACTER || c != ','))
1979 if (ts->type == BT_CHARACTER)
1980 gfc_error ("Missing right parenthesis or comma at %C");
1982 gfc_error ("Missing right parenthesis at %C");
1986 /* All tests passed. */
1989 if(m == MATCH_ERROR)
1990 gfc_current_locus = where;
1992 /* Return what we know from the test(s). */
1997 gfc_current_locus = where;
2003 match_char_kind (int * kind, int * is_iso_c)
2012 where = gfc_current_locus;
2014 n = gfc_match_init_expr (&e);
2016 if (n != MATCH_YES && gfc_matching_function)
2018 /* The expression might include use-associated or imported
2019 parameters and try again after the specification
2022 gfc_undo_symbols ();
2027 gfc_error ("Expected initialization expression at %C");
2033 gfc_error ("Expected scalar initialization expression at %C");
2038 msg = gfc_extract_int (e, kind);
2039 *is_iso_c = e->ts.is_iso_c;
2049 /* Ignore errors to this point, if we've gotten here. This means
2050 we ignore the m=MATCH_ERROR from above. */
2051 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2053 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2057 /* All tests passed. */
2060 if (m == MATCH_ERROR)
2061 gfc_current_locus = where;
2063 /* Return what we know from the test(s). */
2068 gfc_current_locus = where;
2072 /* Match the various kind/length specifications in a CHARACTER
2073 declaration. We don't return MATCH_NO. */
2076 match_char_spec (gfc_typespec *ts)
2078 int kind, seen_length, is_iso_c;
2088 /* Try the old-style specification first. */
2089 old_char_selector = 0;
2091 m = match_char_length (&len);
2095 old_char_selector = 1;
2100 m = gfc_match_char ('(');
2103 m = MATCH_YES; /* Character without length is a single char. */
2107 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2108 if (gfc_match (" kind =") == MATCH_YES)
2110 m = match_char_kind (&kind, &is_iso_c);
2112 if (m == MATCH_ERROR)
2117 if (gfc_match (" , len =") == MATCH_NO)
2120 m = char_len_param_value (&len);
2123 if (m == MATCH_ERROR)
2130 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2131 if (gfc_match (" len =") == MATCH_YES)
2133 m = char_len_param_value (&len);
2136 if (m == MATCH_ERROR)
2140 if (gfc_match_char (')') == MATCH_YES)
2143 if (gfc_match (" , kind =") != MATCH_YES)
2146 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2152 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2153 m = char_len_param_value (&len);
2156 if (m == MATCH_ERROR)
2160 m = gfc_match_char (')');
2164 if (gfc_match_char (',') != MATCH_YES)
2167 gfc_match (" kind ="); /* Gobble optional text. */
2169 m = match_char_kind (&kind, &is_iso_c);
2170 if (m == MATCH_ERROR)
2176 /* Require a right-paren at this point. */
2177 m = gfc_match_char (')');
2182 gfc_error ("Syntax error in CHARACTER declaration at %C");
2184 gfc_free_expr (len);
2188 /* Deal with character functions after USE and IMPORT statements. */
2189 if (gfc_matching_function)
2191 gfc_free_expr (len);
2192 gfc_undo_symbols ();
2198 gfc_free_expr (len);
2202 /* Do some final massaging of the length values. */
2203 cl = gfc_get_charlen ();
2204 cl->next = gfc_current_ns->cl_list;
2205 gfc_current_ns->cl_list = cl;
2207 if (seen_length == 0)
2208 cl->length = gfc_int_expr (1);
2213 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2215 /* We have to know if it was a c interoperable kind so we can
2216 do accurate type checking of bind(c) procs, etc. */
2218 /* Mark this as c interoperable if being declared with one
2219 of the named constants from iso_c_binding. */
2220 ts->is_c_interop = is_iso_c;
2221 else if (len != NULL)
2222 /* Here, we might have parsed something such as: character(c_char)
2223 In this case, the parsing code above grabs the c_char when
2224 looking for the length (line 1690, roughly). it's the last
2225 testcase for parsing the kind params of a character variable.
2226 However, it's not actually the length. this seems like it
2228 To see if the user used a C interop kind, test the expr
2229 of the so called length, and see if it's C interoperable. */
2230 ts->is_c_interop = len->ts.is_iso_c;
2236 /* Matches a type specification. If successful, sets the ts structure
2237 to the matched specification. This is necessary for FUNCTION and
2238 IMPLICIT statements.
2240 If implicit_flag is nonzero, then we don't check for the optional
2241 kind specification. Not doing so is needed for matching an IMPLICIT
2242 statement correctly. */
2245 gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
2247 char name[GFC_MAX_SYMBOL_LEN + 1];
2251 bool seen_deferred_kind;
2253 /* A belt and braces check that the typespec is correctly being treated
2254 as a deferred characteristic association. */
2255 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2256 && (gfc_current_block ()->result->ts.kind == -1)
2257 && (ts->kind == -1);
2259 if (seen_deferred_kind)
2262 /* Clear the current binding label, in case one is given. */
2263 curr_binding_label[0] = '\0';
2265 if (gfc_match (" byte") == MATCH_YES)
2267 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
2271 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2273 gfc_error ("BYTE type used at %C "
2274 "is not available on the target machine");
2278 ts->type = BT_INTEGER;
2283 if (gfc_match (" integer") == MATCH_YES)
2285 ts->type = BT_INTEGER;
2286 ts->kind = gfc_default_integer_kind;
2290 if (gfc_match (" character") == MATCH_YES)
2292 ts->type = BT_CHARACTER;
2293 if (implicit_flag == 0)
2294 return match_char_spec (ts);
2299 if (gfc_match (" real") == MATCH_YES)
2302 ts->kind = gfc_default_real_kind;
2306 if (gfc_match (" double precision") == MATCH_YES)
2309 ts->kind = gfc_default_double_kind;
2313 if (gfc_match (" complex") == MATCH_YES)
2315 ts->type = BT_COMPLEX;
2316 ts->kind = gfc_default_complex_kind;
2320 if (gfc_match (" double complex") == MATCH_YES)
2322 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2323 "conform to the Fortran 95 standard") == FAILURE)
2326 ts->type = BT_COMPLEX;
2327 ts->kind = gfc_default_double_kind;
2331 if (gfc_match (" logical") == MATCH_YES)
2333 ts->type = BT_LOGICAL;
2334 ts->kind = gfc_default_logical_kind;
2338 m = gfc_match (" type ( %n )", name);
2342 ts->type = BT_DERIVED;
2344 /* Defer association of the derived type until the end of the
2345 specification block. However, if the derived type can be
2346 found, add it to the typespec. */
2347 if (gfc_matching_function)
2350 if (gfc_current_state () != COMP_INTERFACE
2351 && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2356 /* Search for the name but allow the components to be defined later. If
2357 type = -1, this typespec has been seen in a function declaration but
2358 the type could not be accessed at that point. */
2360 if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2362 gfc_error ("Type name '%s' at %C is ambiguous", name);
2365 else if (ts->kind == -1)
2367 int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2368 || gfc_current_ns->has_import_set;
2369 if (gfc_find_symbol (name, NULL, iface, &sym))
2371 gfc_error ("Type name '%s' at %C is ambiguous", name);
2380 if (sym->attr.flavor != FL_DERIVED
2381 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2384 gfc_set_sym_referenced (sym);
2390 /* For all types except double, derived and character, look for an
2391 optional kind specifier. MATCH_NO is actually OK at this point. */
2392 if (implicit_flag == 1)
2395 if (gfc_current_form == FORM_FREE)
2397 c = gfc_peek_ascii_char();
2398 if (!gfc_is_whitespace(c) && c != '*' && c != '('
2399 && c != ':' && c != ',')
2403 m = gfc_match_kind_spec (ts, false);
2404 if (m == MATCH_NO && ts->type != BT_CHARACTER)
2405 m = gfc_match_old_kind_spec (ts);
2407 /* Defer association of the KIND expression of function results
2408 until after USE and IMPORT statements. */
2409 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2410 || gfc_matching_function)
2414 m = MATCH_YES; /* No kind specifier found. */
2420 /* Match an IMPLICIT NONE statement. Actually, this statement is
2421 already matched in parse.c, or we would not end up here in the
2422 first place. So the only thing we need to check, is if there is
2423 trailing garbage. If not, the match is successful. */
2426 gfc_match_implicit_none (void)
2428 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2432 /* Match the letter range(s) of an IMPLICIT statement. */
2435 match_implicit_range (void)
2441 cur_loc = gfc_current_locus;
2443 gfc_gobble_whitespace ();
2444 c = gfc_next_ascii_char ();
2447 gfc_error ("Missing character range in IMPLICIT at %C");
2454 gfc_gobble_whitespace ();
2455 c1 = gfc_next_ascii_char ();
2459 gfc_gobble_whitespace ();
2460 c = gfc_next_ascii_char ();
2465 inner = 0; /* Fall through. */
2472 gfc_gobble_whitespace ();
2473 c2 = gfc_next_ascii_char ();
2477 gfc_gobble_whitespace ();
2478 c = gfc_next_ascii_char ();
2480 if ((c != ',') && (c != ')'))
2493 gfc_error ("Letters must be in alphabetic order in "
2494 "IMPLICIT statement at %C");
2498 /* See if we can add the newly matched range to the pending
2499 implicits from this IMPLICIT statement. We do not check for
2500 conflicts with whatever earlier IMPLICIT statements may have
2501 set. This is done when we've successfully finished matching
2503 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2510 gfc_syntax_error (ST_IMPLICIT);
2512 gfc_current_locus = cur_loc;
2517 /* Match an IMPLICIT statement, storing the types for
2518 gfc_set_implicit() if the statement is accepted by the parser.
2519 There is a strange looking, but legal syntactic construction
2520 possible. It looks like:
2522 IMPLICIT INTEGER (a-b) (c-d)
2524 This is legal if "a-b" is a constant expression that happens to
2525 equal one of the legal kinds for integers. The real problem
2526 happens with an implicit specification that looks like:
2528 IMPLICIT INTEGER (a-b)
2530 In this case, a typespec matcher that is "greedy" (as most of the
2531 matchers are) gobbles the character range as a kindspec, leaving
2532 nothing left. We therefore have to go a bit more slowly in the
2533 matching process by inhibiting the kindspec checking during
2534 typespec matching and checking for a kind later. */
2537 gfc_match_implicit (void)
2546 /* We don't allow empty implicit statements. */
2547 if (gfc_match_eos () == MATCH_YES)
2549 gfc_error ("Empty IMPLICIT statement at %C");
2555 /* First cleanup. */
2556 gfc_clear_new_implicit ();
2558 /* A basic type is mandatory here. */
2559 m = gfc_match_type_spec (&ts, 1);
2560 if (m == MATCH_ERROR)
2565 cur_loc = gfc_current_locus;
2566 m = match_implicit_range ();
2570 /* We may have <TYPE> (<RANGE>). */
2571 gfc_gobble_whitespace ();
2572 c = gfc_next_ascii_char ();
2573 if ((c == '\n') || (c == ','))
2575 /* Check for CHARACTER with no length parameter. */
2576 if (ts.type == BT_CHARACTER && !ts.cl)
2578 ts.kind = gfc_default_character_kind;
2579 ts.cl = gfc_get_charlen ();
2580 ts.cl->next = gfc_current_ns->cl_list;
2581 gfc_current_ns->cl_list = ts.cl;
2582 ts.cl->length = gfc_int_expr (1);
2585 /* Record the Successful match. */
2586 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2591 gfc_current_locus = cur_loc;
2594 /* Discard the (incorrectly) matched range. */
2595 gfc_clear_new_implicit ();
2597 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2598 if (ts.type == BT_CHARACTER)
2599 m = match_char_spec (&ts);
2602 m = gfc_match_kind_spec (&ts, false);
2605 m = gfc_match_old_kind_spec (&ts);
2606 if (m == MATCH_ERROR)
2612 if (m == MATCH_ERROR)
2615 m = match_implicit_range ();
2616 if (m == MATCH_ERROR)
2621 gfc_gobble_whitespace ();
2622 c = gfc_next_ascii_char ();
2623 if ((c != '\n') && (c != ','))
2626 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2634 gfc_syntax_error (ST_IMPLICIT);
2642 gfc_match_import (void)
2644 char name[GFC_MAX_SYMBOL_LEN + 1];
2649 if (gfc_current_ns->proc_name == NULL
2650 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2652 gfc_error ("IMPORT statement at %C only permitted in "
2653 "an INTERFACE body");
2657 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2661 if (gfc_match_eos () == MATCH_YES)
2663 /* All host variables should be imported. */
2664 gfc_current_ns->has_import_set = 1;
2668 if (gfc_match (" ::") == MATCH_YES)
2670 if (gfc_match_eos () == MATCH_YES)
2672 gfc_error ("Expecting list of named entities at %C");
2679 m = gfc_match (" %n", name);
2683 if (gfc_current_ns->parent != NULL
2684 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2686 gfc_error ("Type name '%s' at %C is ambiguous", name);
2689 else if (gfc_current_ns->proc_name->ns->parent != NULL
2690 && gfc_find_symbol (name,
2691 gfc_current_ns->proc_name->ns->parent,
2694 gfc_error ("Type name '%s' at %C is ambiguous", name);
2700 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2701 "at %C - does not exist.", name);
2705 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2707 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2712 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2715 sym->attr.imported = 1;
2727 if (gfc_match_eos () == MATCH_YES)
2729 if (gfc_match_char (',') != MATCH_YES)
2736 gfc_error ("Syntax error in IMPORT statement at %C");
2741 /* A minimal implementation of gfc_match without whitespace, escape
2742 characters or variable arguments. Returns true if the next
2743 characters match the TARGET template exactly. */
2746 match_string_p (const char *target)
2750 for (p = target; *p; p++)
2751 if ((char) gfc_next_ascii_char () != *p)
2756 /* Matches an attribute specification including array specs. If
2757 successful, leaves the variables current_attr and current_as
2758 holding the specification. Also sets the colon_seen variable for
2759 later use by matchers associated with initializations.
2761 This subroutine is a little tricky in the sense that we don't know
2762 if we really have an attr-spec until we hit the double colon.
2763 Until that time, we can only return MATCH_NO. This forces us to
2764 check for duplicate specification at this level. */
2767 match_attr_spec (void)
2769 /* Modifiers that can exist in a type statement. */
2771 { GFC_DECL_BEGIN = 0,
2772 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2773 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2774 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2775 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2776 DECL_IS_BIND_C, DECL_NONE,
2777 GFC_DECL_END /* Sentinel */
2781 /* GFC_DECL_END is the sentinel, index starts at 0. */
2782 #define NUM_DECL GFC_DECL_END
2784 locus start, seen_at[NUM_DECL];
2791 gfc_clear_attr (¤t_attr);
2792 start = gfc_current_locus;
2797 /* See if we get all of the keywords up to the final double colon. */
2798 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2806 gfc_gobble_whitespace ();
2808 ch = gfc_next_ascii_char ();
2811 /* This is the successful exit condition for the loop. */
2812 if (gfc_next_ascii_char () == ':')
2817 gfc_gobble_whitespace ();
2818 switch (gfc_peek_ascii_char ())
2821 if (match_string_p ("allocatable"))
2822 d = DECL_ALLOCATABLE;
2826 /* Try and match the bind(c). */
2827 m = gfc_match_bind_c (NULL, true);
2830 else if (m == MATCH_ERROR)
2835 if (match_string_p ("dimension"))
2840 if (match_string_p ("external"))
2845 if (match_string_p ("int"))
2847 ch = gfc_next_ascii_char ();
2850 if (match_string_p ("nt"))
2852 /* Matched "intent". */
2853 /* TODO: Call match_intent_spec from here. */
2854 if (gfc_match (" ( in out )") == MATCH_YES)
2856 else if (gfc_match (" ( in )") == MATCH_YES)
2858 else if (gfc_match (" ( out )") == MATCH_YES)
2864 if (match_string_p ("insic"))
2866 /* Matched "intrinsic". */
2874 if (match_string_p ("optional"))
2879 gfc_next_ascii_char ();
2880 switch (gfc_next_ascii_char ())
2883 if (match_string_p ("rameter"))
2885 /* Matched "parameter". */
2891 if (match_string_p ("inter"))
2893 /* Matched "pointer". */
2899 ch = gfc_next_ascii_char ();
2902 if (match_string_p ("vate"))
2904 /* Matched "private". */
2910 if (match_string_p ("tected"))
2912 /* Matched "protected". */
2919 if (match_string_p ("blic"))
2921 /* Matched "public". */
2929 if (match_string_p ("save"))
2934 if (match_string_p ("target"))
2939 gfc_next_ascii_char ();
2940 ch = gfc_next_ascii_char ();
2943 if (match_string_p ("lue"))
2945 /* Matched "value". */
2951 if (match_string_p ("latile"))
2953 /* Matched "volatile". */
2961 /* No double colon and no recognizable decl_type, so assume that
2962 we've been looking at something else the whole time. */
2969 /* Check to make sure any parens are paired up correctly. */
2970 if (gfc_match_parens () == MATCH_ERROR)
2977 seen_at[d] = gfc_current_locus;
2979 if (d == DECL_DIMENSION)
2981 m = gfc_match_array_spec (¤t_as);
2985 gfc_error ("Missing dimension specification at %C");
2989 if (m == MATCH_ERROR)
2994 /* Since we've seen a double colon, we have to be looking at an
2995 attr-spec. This means that we can now issue errors. */
2996 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3001 case DECL_ALLOCATABLE:
3002 attr = "ALLOCATABLE";
3004 case DECL_DIMENSION:
3011 attr = "INTENT (IN)";
3014 attr = "INTENT (OUT)";
3017 attr = "INTENT (IN OUT)";
3019 case DECL_INTRINSIC:
3025 case DECL_PARAMETER:
3031 case DECL_PROTECTED:
3046 case DECL_IS_BIND_C:
3056 attr = NULL; /* This shouldn't happen. */
3059 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3064 /* Now that we've dealt with duplicate attributes, add the attributes
3065 to the current attribute. */
3066 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3071 if (gfc_current_state () == COMP_DERIVED
3072 && d != DECL_DIMENSION && d != DECL_POINTER
3073 && d != DECL_PRIVATE && d != DECL_PUBLIC
3076 if (d == DECL_ALLOCATABLE)
3078 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3079 "attribute at %C in a TYPE definition")
3088 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3095 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3096 && gfc_current_state () != COMP_MODULE)
3098 if (d == DECL_PRIVATE)
3102 if (gfc_current_state () == COMP_DERIVED
3103 && gfc_state_stack->previous
3104 && gfc_state_stack->previous->state == COMP_MODULE)
3106 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3107 "at %L in a TYPE definition", attr,
3117 gfc_error ("%s attribute at %L is not allowed outside of the "
3118 "specification part of a module", attr, &seen_at[d]);
3126 case DECL_ALLOCATABLE:
3127 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
3130 case DECL_DIMENSION:
3131 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
3135 t = gfc_add_external (¤t_attr, &seen_at[d]);
3139 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
3143 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
3147 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
3150 case DECL_INTRINSIC:
3151 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
3155 t = gfc_add_optional (¤t_attr, &seen_at[d]);
3158 case DECL_PARAMETER:
3159 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
3163 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
3166 case DECL_PROTECTED:
3167 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3169 gfc_error ("PROTECTED at %C only allowed in specification "
3170 "part of a module");
3175 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3180 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
3184 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
3189 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
3194 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
3198 t = gfc_add_target (¤t_attr, &seen_at[d]);
3201 case DECL_IS_BIND_C:
3202 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
3206 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3211 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
3215 if (gfc_notify_std (GFC_STD_F2003,
3216 "Fortran 2003: VOLATILE attribute at %C")
3220 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
3224 gfc_internal_error ("match_attr_spec(): Bad attribute");
3238 gfc_current_locus = start;
3239 gfc_free_array_spec (current_as);
3245 /* Set the binding label, dest_label, either with the binding label
3246 stored in the given gfc_typespec, ts, or if none was provided, it
3247 will be the symbol name in all lower case, as required by the draft
3248 (J3/04-007, section 15.4.1). If a binding label was given and
3249 there is more than one argument (num_idents), it is an error. */
3252 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3254 if (num_idents > 1 && has_name_equals)
3256 gfc_error ("Multiple identifiers provided with "
3257 "single NAME= specifier at %C");
3261 if (curr_binding_label[0] != '\0')
3263 /* Binding label given; store in temp holder til have sym. */
3264 strcpy (dest_label, curr_binding_label);
3268 /* No binding label given, and the NAME= specifier did not exist,
3269 which means there was no NAME="". */
3270 if (sym_name != NULL && has_name_equals == 0)
3271 strcpy (dest_label, sym_name);
3278 /* Set the status of the given common block as being BIND(C) or not,
3279 depending on the given parameter, is_bind_c. */
3282 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3284 com_block->is_bind_c = is_bind_c;
3289 /* Verify that the given gfc_typespec is for a C interoperable type. */
3292 verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
3296 /* Make sure the kind used is appropriate for the type.
3297 The f90_type is unknown if an integer constant was
3298 used (e.g., real(4), bind(c) :: myFloat). */
3299 if (ts->f90_type != BT_UNKNOWN)
3301 t = gfc_validate_c_kind (ts);
3304 /* Print an error, but continue parsing line. */
3305 gfc_error_now ("C kind parameter is for type %s but "
3306 "symbol '%s' at %L is of type %s",
3307 gfc_basic_typename (ts->f90_type),
3309 gfc_basic_typename (ts->type));
3313 /* Make sure the kind is C interoperable. This does not care about the
3314 possible error above. */
3315 if (ts->type == BT_DERIVED && ts->derived != NULL)
3316 return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
3317 else if (ts->is_c_interop != 1)
3324 /* Verify that the variables of a given common block, which has been
3325 defined with the attribute specifier bind(c), to be of a C
3326 interoperable type. Errors will be reported here, if
3330 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3332 gfc_symbol *curr_sym = NULL;
3333 try retval = SUCCESS;
3335 curr_sym = com_block->head;
3337 /* Make sure we have at least one symbol. */
3338 if (curr_sym == NULL)
3341 /* Here we know we have a symbol, so we'll execute this loop
3345 /* The second to last param, 1, says this is in a common block. */
3346 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3347 curr_sym = curr_sym->common_next;
3348 } while (curr_sym != NULL);
3354 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3355 an appropriate error message is reported. */
3358 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3359 int is_in_common, gfc_common_head *com_block)
3361 try retval = SUCCESS;
3363 if (tmp_sym->attr.function && tmp_sym->result != NULL)
3365 tmp_sym = tmp_sym->result;
3366 /* Make sure it wasn't an implicitly typed result. */
3367 if (tmp_sym->attr.implicit_type)
3369 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3370 "%L may not be C interoperable", tmp_sym->name,
3371 &tmp_sym->declared_at);
3372 tmp_sym->ts.f90_type = tmp_sym->ts.type;
3373 /* Mark it as C interoperable to prevent duplicate warnings. */
3374 tmp_sym->ts.is_c_interop = 1;
3375 tmp_sym->attr.is_c_interop = 1;
3379 /* Here, we know we have the bind(c) attribute, so if we have
3380 enough type info, then verify that it's a C interop kind.
3381 The info could be in the symbol already, or possibly still in
3382 the given ts (current_ts), so look in both. */
3383 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
3385 if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
3386 &(tmp_sym->declared_at)) != SUCCESS)
3388 /* See if we're dealing with a sym in a common block or not. */
3389 if (is_in_common == 1)
3391 gfc_warning ("Variable '%s' in common block '%s' at %L "
3392 "may not be a C interoperable "
3393 "kind though common block '%s' is BIND(C)",
3394 tmp_sym->name, com_block->name,
3395 &(tmp_sym->declared_at), com_block->name);
3399 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3400 gfc_error ("Type declaration '%s' at %L is not C "
3401 "interoperable but it is BIND(C)",
3402 tmp_sym->name, &(tmp_sym->declared_at));
3404 gfc_warning ("Variable '%s' at %L "
3405 "may not be a C interoperable "
3406 "kind but it is bind(c)",
3407 tmp_sym->name, &(tmp_sym->declared_at));
3411 /* Variables declared w/in a common block can't be bind(c)
3412 since there's no way for C to see these variables, so there's
3413 semantically no reason for the attribute. */
3414 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3416 gfc_error ("Variable '%s' in common block '%s' at "
3417 "%L cannot be declared with BIND(C) "
3418 "since it is not a global",
3419 tmp_sym->name, com_block->name,
3420 &(tmp_sym->declared_at));
3424 /* Scalar variables that are bind(c) can not have the pointer
3425 or allocatable attributes. */
3426 if (tmp_sym->attr.is_bind_c == 1)
3428 if (tmp_sym->attr.pointer == 1)
3430 gfc_error ("Variable '%s' at %L cannot have both the "
3431 "POINTER and BIND(C) attributes",
3432 tmp_sym->name, &(tmp_sym->declared_at));
3436 if (tmp_sym->attr.allocatable == 1)
3438 gfc_error ("Variable '%s' at %L cannot have both the "
3439 "ALLOCATABLE and BIND(C) attributes",
3440 tmp_sym->name, &(tmp_sym->declared_at));
3444 /* If it is a BIND(C) function, make sure the return value is a
3445 scalar value. The previous tests in this function made sure
3446 the type is interoperable. */
3447 if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3448 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3449 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3451 /* BIND(C) functions can not return a character string. */
3452 if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3453 if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3454 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3455 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3456 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3457 "be a character string", tmp_sym->name,
3458 &(tmp_sym->declared_at));
3462 /* See if the symbol has been marked as private. If it has, make sure
3463 there is no binding label and warn the user if there is one. */
3464 if (tmp_sym->attr.access == ACCESS_PRIVATE
3465 && tmp_sym->binding_label[0] != '\0')
3466 /* Use gfc_warning_now because we won't say that the symbol fails
3467 just because of this. */
3468 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3469 "given the binding label '%s'", tmp_sym->name,
3470 &(tmp_sym->declared_at), tmp_sym->binding_label);
3476 /* Set the appropriate fields for a symbol that's been declared as
3477 BIND(C) (the is_bind_c flag and the binding label), and verify that
3478 the type is C interoperable. Errors are reported by the functions
3479 used to set/test these fields. */
3482 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3484 try retval = SUCCESS;
3486 /* TODO: Do we need to make sure the vars aren't marked private? */
3488 /* Set the is_bind_c bit in symbol_attribute. */
3489 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3491 if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3492 num_idents) != SUCCESS)
3499 /* Set the fields marking the given common block as BIND(C), including
3500 a binding label, and report any errors encountered. */
3503 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3505 try retval = SUCCESS;
3507 /* destLabel, common name, typespec (which may have binding label). */
3508 if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3512 /* Set the given common block (com_block) to being bind(c) (1). */
3513 set_com_block_bind_c (com_block, 1);
3519 /* Retrieve the list of one or more identifiers that the given bind(c)
3520 attribute applies to. */
3523 get_bind_c_idents (void)
3525 char name[GFC_MAX_SYMBOL_LEN + 1];
3527 gfc_symbol *tmp_sym = NULL;
3529 gfc_common_head *com_block = NULL;
3531 if (gfc_match_name (name) == MATCH_YES)
3533 found_id = MATCH_YES;
3534 gfc_get_ha_symbol (name, &tmp_sym);
3536 else if (match_common_name (name) == MATCH_YES)
3538 found_id = MATCH_YES;
3539 com_block = gfc_get_common (name, 0);
3543 gfc_error ("Need either entity or common block name for "
3544 "attribute specification statement at %C");
3548 /* Save the current identifier and look for more. */
3551 /* Increment the number of identifiers found for this spec stmt. */
3554 /* Make sure we have a sym or com block, and verify that it can
3555 be bind(c). Set the appropriate field(s) and look for more
3557 if (tmp_sym != NULL || com_block != NULL)
3559 if (tmp_sym != NULL)
3561 if (set_verify_bind_c_sym (tmp_sym, num_idents)
3567 if (set_verify_bind_c_com_block(com_block, num_idents)
3572 /* Look to see if we have another identifier. */
3574 if (gfc_match_eos () == MATCH_YES)
3575 found_id = MATCH_NO;
3576 else if (gfc_match_char (',') != MATCH_YES)
3577 found_id = MATCH_NO;
3578 else if (gfc_match_name (name) == MATCH_YES)
3580 found_id = MATCH_YES;
3581 gfc_get_ha_symbol (name, &tmp_sym);
3583 else if (match_common_name (name) == MATCH_YES)
3585 found_id = MATCH_YES;
3586 com_block = gfc_get_common (name, 0);
3590 gfc_error ("Missing entity or common block name for "
3591 "attribute specification statement at %C");
3597 gfc_internal_error ("Missing symbol");
3599 } while (found_id == MATCH_YES);
3601 /* if we get here we were successful */
3606 /* Try and match a BIND(C) attribute specification statement. */
3609 gfc_match_bind_c_stmt (void)
3611 match found_match = MATCH_NO;
3616 /* This may not be necessary. */
3618 /* Clear the temporary binding label holder. */
3619 curr_binding_label[0] = '\0';
3621 /* Look for the bind(c). */
3622 found_match = gfc_match_bind_c (NULL, true);
3624 if (found_match == MATCH_YES)
3626 /* Look for the :: now, but it is not required. */
3629 /* Get the identifier(s) that needs to be updated. This may need to
3630 change to hand the flag(s) for the attr specified so all identifiers
3631 found can have all appropriate parts updated (assuming that the same
3632 spec stmt can have multiple attrs, such as both bind(c) and
3634 if (get_bind_c_idents () != SUCCESS)
3635 /* Error message should have printed already. */
3643 /* Match a data declaration statement. */
3646 gfc_match_data_decl (void)
3652 num_idents_on_line = 0;
3654 m = gfc_match_type_spec (¤t_ts, 0);
3658 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3660 sym = gfc_use_derived (current_ts.derived);
3668 current_ts.derived = sym;
3671 m = match_attr_spec ();
3672 if (m == MATCH_ERROR)
3678 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL
3679 && !current_ts.derived->attr.zero_comp)
3682 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3685 gfc_find_symbol (current_ts.derived->name,
3686 current_ts.derived->ns->parent, 1, &sym);
3688 /* Any symbol that we find had better be a type definition
3689 which has its components defined. */
3690 if (sym != NULL && sym->attr.flavor == FL_DERIVED
3691 && (current_ts.derived->components != NULL
3692 || current_ts.derived->attr.zero_comp))
3695 /* Now we have an error, which we signal, and then fix up
3696 because the knock-on is plain and simple confusing. */
3697 gfc_error_now ("Derived type at %C has not been previously defined "
3698 "and so cannot appear in a derived type definition");
3699 current_attr.pointer = 1;
3704 /* If we have an old-style character declaration, and no new-style
3705 attribute specifications, then there a comma is optional between
3706 the type specification and the variable list. */
3707 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3708 gfc_match_char (',');
3710 /* Give the types/attributes to symbols that follow. Give the element
3711 a number so that repeat character length expressions can be copied. */
3715 num_idents_on_line++;
3716 m = variable_decl (elem++);
3717 if (m == MATCH_ERROR)
3722 if (gfc_match_eos () == MATCH_YES)
3724 if (gfc_match_char (',') != MATCH_YES)
3728 if (gfc_error_flag_test () == 0)
3729 gfc_error ("Syntax error in data declaration at %C");
3732 gfc_free_data_all (gfc_current_ns);
3735 gfc_free_array_spec (current_as);
3741 /* Match a prefix associated with a function or subroutine
3742 declaration. If the typespec pointer is nonnull, then a typespec
3743 can be matched. Note that if nothing matches, MATCH_YES is
3744 returned (the null string was matched). */
3747 gfc_match_prefix (gfc_typespec *ts)
3751 gfc_clear_attr (¤t_attr);
3755 if (!seen_type && ts != NULL
3756 && gfc_match_type_spec (ts, 0) == MATCH_YES
3757 && gfc_match_space () == MATCH_YES)
3764 if (gfc_match ("elemental% ") == MATCH_YES)
3766 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
3772 if (gfc_match ("pure% ") == MATCH_YES)
3774 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
3780 if (gfc_match ("recursive% ") == MATCH_YES)
3782 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
3788 /* At this point, the next item is not a prefix. */
3793 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
3796 copy_prefix (symbol_attribute *dest, locus *where)
3798 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3801 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3804 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3811 /* Match a formal argument list. */
3814 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3816 gfc_formal_arglist *head, *tail, *p, *q;
3817 char name[GFC_MAX_SYMBOL_LEN + 1];
3823 if (gfc_match_char ('(') != MATCH_YES)
3830 if (gfc_match_char (')') == MATCH_YES)
3835 if (gfc_match_char ('*') == MATCH_YES)
3839 m = gfc_match_name (name);
3843 if (gfc_get_symbol (name, NULL, &sym))
3847 p = gfc_get_formal_arglist ();
3859 /* We don't add the VARIABLE flavor because the name could be a
3860 dummy procedure. We don't apply these attributes to formal
3861 arguments of statement functions. */
3862 if (sym != NULL && !st_flag
3863 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3864 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3870 /* The name of a program unit can be in a different namespace,
3871 so check for it explicitly. After the statement is accepted,
3872 the name is checked for especially in gfc_get_symbol(). */
3873 if (gfc_new_block != NULL && sym != NULL
3874 && strcmp (sym->name, gfc_new_block->name) == 0)
3876 gfc_error ("Name '%s' at %C is the name of the procedure",
3882 if (gfc_match_char (')') == MATCH_YES)
3885 m = gfc_match_char (',');
3888 gfc_error ("Unexpected junk in formal argument list at %C");
3894 /* Check for duplicate symbols in the formal argument list. */
3897 for (p = head; p->next; p = p->next)
3902 for (q = p->next; q; q = q->next)
3903 if (p->sym == q->sym)
3905 gfc_error ("Duplicate symbol '%s' in formal argument list "
3906 "at %C", p->sym->name);
3914 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3924 gfc_free_formal_arglist (head);
3929 /* Match a RESULT specification following a function declaration or
3930 ENTRY statement. Also matches the end-of-statement. */
3933 match_result (gfc_symbol *function, gfc_symbol **result)
3935 char name[GFC_MAX_SYMBOL_LEN + 1];
3939 if (gfc_match (" result (") != MATCH_YES)
3942 m = gfc_match_name (name);
3946 /* Get the right paren, and that's it because there could be the
3947 bind(c) attribute after the result clause. */
3948 if (gfc_match_char(')') != MATCH_YES)
3950 /* TODO: should report the missing right paren here. */
3954 if (strcmp (function->name, name) == 0)
3956 gfc_error ("RESULT variable at %C must be different than function name");
3960 if (gfc_get_symbol (name, NULL, &r))
3963 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3964 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3973 /* Match a function suffix, which could be a combination of a result
3974 clause and BIND(C), either one, or neither. The draft does not
3975 require them to come in a specific order. */
3978 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3980 match is_bind_c; /* Found bind(c). */
3981 match is_result; /* Found result clause. */
3982 match found_match; /* Status of whether we've found a good match. */
3983 char peek_char; /* Character we're going to peek at. */
3984 bool allow_binding_name;
3986 /* Initialize to having found nothing. */
3987 found_match = MATCH_NO;
3988 is_bind_c = MATCH_NO;
3989 is_result = MATCH_NO;
3991 /* Get the next char to narrow between result and bind(c). */
3992 gfc_gobble_whitespace ();
3993 peek_char = gfc_peek_ascii_char ();
3995 /* C binding names are not allowed for internal procedures. */
3996 if (gfc_current_state () == COMP_CONTAINS
3997 && sym->ns->proc_name->attr.flavor != FL_MODULE)
3998 allow_binding_name = false;
4000 allow_binding_name = true;
4005 /* Look for result clause. */
4006 is_result = match_result (sym, result);
4007 if (is_result == MATCH_YES)
4009 /* Now see if there is a bind(c) after it. */
4010 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
4011 /* We've found the result clause and possibly bind(c). */
4012 found_match = MATCH_YES;
4015 /* This should only be MATCH_ERROR. */
4016 found_match = is_result;
4019 /* Look for bind(c) first. */
4020 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
4021 if (is_bind_c == MATCH_YES)
4023 /* Now see if a result clause followed it. */
4024 is_result = match_result (sym, result);
4025 found_match = MATCH_YES;
4029 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
4030 found_match = MATCH_ERROR;
4034 gfc_error ("Unexpected junk after function declaration at %C");
4035 found_match = MATCH_ERROR;
4039 if (is_bind_c == MATCH_YES)
4041 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
4042 if (gfc_current_state () == COMP_CONTAINS
4043 && sym->ns->proc_name->attr.flavor != FL_MODULE
4044 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
4045 "at %L may not be specified for an internal "
4046 "procedure", &gfc_current_locus)
4050 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
4059 /* Match a PROCEDURE declaration (R1211). */
4062 match_procedure_decl (void)
4065 locus old_loc, entry_loc;
4066 gfc_symbol *sym, *proc_if = NULL;
4068 gfc_expr *initializer = NULL;
4070 old_loc = entry_loc = gfc_current_locus;
4072 gfc_clear_ts (¤t_ts);
4074 if (gfc_match (" (") != MATCH_YES)
4076 gfc_current_locus = entry_loc;
4080 /* Get the type spec. for the procedure interface. */
4081 old_loc = gfc_current_locus;
4082 m = gfc_match_type_spec (¤t_ts, 0);
4083 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
4086 if (m == MATCH_ERROR)
4089 gfc_current_locus = old_loc;
4091 /* Get the name of the procedure or abstract interface
4092 to inherit the interface from. */
4093 m = gfc_match_symbol (&proc_if, 1);
4097 else if (m == MATCH_ERROR)
4100 /* Various interface checks. */
4103 /* Resolve interface if possible. That way, attr.procedure is only set
4104 if it is declared by a later procedure-declaration-stmt, which is
4105 invalid per C1212. */
4106 while (proc_if->ts.interface)
4107 proc_if = proc_if->ts.interface;
4109 if (proc_if->generic)
4111 gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
4114 if (proc_if->attr.proc == PROC_ST_FUNCTION)
4116 gfc_error ("Interface '%s' at %C may not be a statement function",
4120 /* Handle intrinsic procedures. */
4121 if (!(proc_if->attr.external || proc_if->attr.use_assoc
4122 || proc_if->attr.if_source == IFSRC_IFBODY)
4123 && (gfc_intrinsic_name (proc_if->name, 0)
4124 || gfc_intrinsic_name (proc_if->name, 1)))
4125 proc_if->attr.intrinsic = 1;
4126 if (proc_if->attr.intrinsic
4127 && !gfc_intrinsic_actual_ok (proc_if->name, 0))
4129 gfc_error ("Intrinsic procedure '%s' not allowed "
4130 "in PROCEDURE statement at %C", proc_if->name);
4136 if (gfc_match (" )") != MATCH_YES)
4138 gfc_current_locus = entry_loc;
4142 /* Parse attributes. */
4143 m = match_attr_spec();
4144 if (m == MATCH_ERROR)
4147 /* Get procedure symbols. */
4150 m = gfc_match_symbol (&sym, 0);
4153 else if (m == MATCH_ERROR)
4156 /* Add current_attr to the symbol attributes. */
4157 if (gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
4160 if (sym->attr.is_bind_c)
4162 /* Check for C1218. */
4163 if (!proc_if || !proc_if->attr.is_bind_c)
4165 gfc_error ("BIND(C) attribute at %C requires "
4166 "an interface with BIND(C)");
4169 /* Check for C1217. */
4170 if (has_name_equals && sym->attr.pointer)
4172 gfc_error ("BIND(C) procedure with NAME may not have "
4173 "POINTER attribute at %C");
4176 if (has_name_equals && sym->attr.dummy)
4178 gfc_error ("Dummy procedure at %C may not have "
4179 "BIND(C) attribute with NAME");
4182 /* Set binding label for BIND(C). */
4183 if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
4187 if (gfc_add_external (&sym->attr, NULL) == FAILURE)
4189 if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
4192 /* Set interface. */
4193 if (proc_if != NULL)
4195 sym->ts.interface = proc_if;
4196 sym->attr.untyped = 1;
4198 else if (current_ts.type != BT_UNKNOWN)
4200 sym->ts = current_ts;
4201 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4202 sym->ts.interface->ts = current_ts;
4203 sym->ts.interface->attr.function = 1;
4204 sym->attr.function = sym->ts.interface->attr.function;
4207 if (gfc_match (" =>") == MATCH_YES)
4209 if (!current_attr.pointer)
4211 gfc_error ("Initialization at %C isn't for a pointer variable");
4216 m = gfc_match_null (&initializer);
4219 gfc_error ("Pointer initialization requires a NULL() at %C");
4223 if (gfc_pure (NULL))
4225 gfc_error ("Initialization of pointer at %C is not allowed in "
4226 "a PURE procedure");
4233 if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
4239 gfc_set_sym_referenced (sym);
4241 if (gfc_match_eos () == MATCH_YES)
4243 if (gfc_match_char (',') != MATCH_YES)
4248 gfc_error ("Syntax error in PROCEDURE statement at %C");
4252 /* Free stuff up and return. */
4253 gfc_free_expr (initializer);
4258 /* Match a PROCEDURE declaration inside an interface (R1206). */
4261 match_procedure_in_interface (void)
4265 char name[GFC_MAX_SYMBOL_LEN + 1];
4267 if (current_interface.type == INTERFACE_NAMELESS
4268 || current_interface.type == INTERFACE_ABSTRACT)
4270 gfc_error ("PROCEDURE at %C must be in a generic interface");
4276 m = gfc_match_name (name);
4279 else if (m == MATCH_ERROR)
4281 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4284 if (gfc_add_interface (sym) == FAILURE)
4287 if (gfc_match_eos () == MATCH_YES)
4289 if (gfc_match_char (',') != MATCH_YES)
4296 gfc_error ("Syntax error in PROCEDURE statement at %C");
4301 /* General matcher for PROCEDURE declarations. */
4304 gfc_match_procedure (void)
4308 switch (gfc_current_state ())
4313 case COMP_SUBROUTINE:
4315 m = match_procedure_decl ();
4317 case COMP_INTERFACE:
4318 m = match_procedure_in_interface ();
4321 gfc_error ("Fortran 2003: Procedure components at %C are "
4322 "not yet implemented in gfortran");
4331 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
4339 /* Match a function declaration. */
4342 gfc_match_function_decl (void)
4344 char name[GFC_MAX_SYMBOL_LEN + 1];
4345 gfc_symbol *sym, *result;
4349 match found_match; /* Status returned by match func. */
4351 if (gfc_current_state () != COMP_NONE
4352 && gfc_current_state () != COMP_INTERFACE
4353 && gfc_current_state () != COMP_CONTAINS)
4356 gfc_clear_ts (¤t_ts);
4358 old_loc = gfc_current_locus;
4360 m = gfc_match_prefix (¤t_ts);
4363 gfc_current_locus = old_loc;
4367 if (gfc_match ("function% %n", name) != MATCH_YES)
4369 gfc_current_locus = old_loc;
4372 if (get_proc_name (name, &sym, false))
4374 gfc_new_block = sym;
4376 m = gfc_match_formal_arglist (sym, 0, 0);
4379 gfc_error ("Expected formal argument list in function "
4380 "definition at %C");
4384 else if (m == MATCH_ERROR)
4389 /* According to the draft, the bind(c) and result clause can
4390 come in either order after the formal_arg_list (i.e., either
4391 can be first, both can exist together or by themselves or neither
4392 one). Therefore, the match_result can't match the end of the
4393 string, and check for the bind(c) or result clause in either order. */
4394 found_match = gfc_match_eos ();
4396 /* Make sure that it isn't already declared as BIND(C). If it is, it
4397 must have been marked BIND(C) with a BIND(C) attribute and that is
4398 not allowed for procedures. */
4399 if (sym->attr.is_bind_c == 1)
4401 sym->attr.is_bind_c = 0;
4402 if (sym->old_symbol != NULL)
4403 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4404 "variables or common blocks",
4405 &(sym->old_symbol->declared_at));
4407 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4408 "variables or common blocks", &gfc_current_locus);
4411 if (found_match != MATCH_YES)
4413 /* If we haven't found the end-of-statement, look for a suffix. */
4414 suffix_match = gfc_match_suffix (sym, &result);
4415 if (suffix_match == MATCH_YES)
4416 /* Need to get the eos now. */
4417 found_match = gfc_match_eos ();
4419 found_match = suffix_match;
4422 if(found_match != MATCH_YES)
4426 /* Make changes to the symbol. */
4429 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
4432 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
4433 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4436 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
4437 && !sym->attr.implicit_type)
4439 gfc_error ("Function '%s' at %C already has a type of %s", name,
4440 gfc_basic_typename (sym->ts.type));
4444 /* Delay matching the function characteristics until after the
4445 specification block by signalling kind=-1. */
4446 sym->declared_at = old_loc;
4447 if (current_ts.type != BT_UNKNOWN)
4448 current_ts.kind = -1;
4450 current_ts.kind = 0;
4454 sym->ts = current_ts;
4459 result->ts = current_ts;
4460 sym->result = result;
4467 gfc_current_locus = old_loc;
4472 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
4473 pass the name of the entry, rather than the gfc_current_block name, and
4474 to return false upon finding an existing global entry. */
4477 add_global_entry (const char *name, int sub)
4482 s = gfc_get_gsymbol(name);
4483 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4486 || (s->type != GSYM_UNKNOWN
4487 && s->type != type))
4488 gfc_global_used(s, NULL);
4492 s->where = gfc_current_locus;
4500 /* Match an ENTRY statement. */
4503 gfc_match_entry (void)
4508 char name[GFC_MAX_SYMBOL_LEN + 1];
4509 gfc_compile_state state;
4513 bool module_procedure;
4517 m = gfc_match_name (name);
4521 state = gfc_current_state ();
4522 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
4527 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
4530 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
4532 case COMP_BLOCK_DATA:
4533 gfc_error ("ENTRY statement at %C cannot appear within "
4536 case COMP_INTERFACE:
4537 gfc_error ("ENTRY statement at %C cannot appear within "
4541 gfc_error ("ENTRY statement at %C cannot appear within "
4542 "a DERIVED TYPE block");
4545 gfc_error ("ENTRY statement at %C cannot appear within "
4546 "an IF-THEN block");
4549 gfc_error ("ENTRY statement at %C cannot appear within "
4553 gfc_error ("ENTRY statement at %C cannot appear within "
4557 gfc_error ("ENTRY statement at %C cannot appear within "
4561 gfc_error ("ENTRY statement at %C cannot appear within "
4565 gfc_error ("ENTRY statement at %C cannot appear within "
4566 "a contained subprogram");
4569 gfc_internal_error ("gfc_match_entry(): Bad state");
4574 module_procedure = gfc_current_ns->parent != NULL
4575 && gfc_current_ns->parent->proc_name
4576 && gfc_current_ns->parent->proc_name->attr.flavor
4579 if (gfc_current_ns->parent != NULL
4580 && gfc_current_ns->parent->proc_name
4581 && !module_procedure)
4583 gfc_error("ENTRY statement at %C cannot appear in a "
4584 "contained procedure");
4588 /* Module function entries need special care in get_proc_name
4589 because previous references within the function will have
4590 created symbols attached to the current namespace. */
4591 if (get_proc_name (name, &entry,
4592 gfc_current_ns->parent != NULL
4594 && gfc_current_ns->proc_name->attr.function))
4597 proc = gfc_current_block ();
4599 /* Make sure that it isn't already declared as BIND(C). If it is, it
4600 must have been marked BIND(C) with a BIND(C) attribute and that is
4601 not allowed for procedures. */
4602 if (entry->attr.is_bind_c == 1)
4604 entry->attr.is_bind_c = 0;
4605 if (entry->old_symbol != NULL)
4606 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4607 "variables or common blocks",
4608 &(entry->old_symbol->declared_at));
4610 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4611 "variables or common blocks", &gfc_current_locus);
4614 /* Check what next non-whitespace character is so we can tell if there
4615 is the required parens if we have a BIND(C). */
4616 gfc_gobble_whitespace ();
4617 peek_char = gfc_peek_ascii_char ();
4619 if (state == COMP_SUBROUTINE)
4621 /* An entry in a subroutine. */
4622 if (!gfc_current_ns->parent && !add_global_entry (name, 1))
4625 m = gfc_match_formal_arglist (entry, 0, 1);
4629 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
4630 never be an internal procedure. */
4631 is_bind_c = gfc_match_bind_c (entry, true);
4632 if (is_bind_c == MATCH_ERROR)
4634 if (is_bind_c == MATCH_YES)
4636 if (peek_char != '(')
4638 gfc_error ("Missing required parentheses before BIND(C) at %C");
4641 if (gfc_add_is_bind_c (&(entry->attr), entry->name, &(entry->declared_at), 1)
4646 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4647 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4652 /* An entry in a function.
4653 We need to take special care because writing
4658 ENTRY f() RESULT (r)
4660 ENTRY f RESULT (r). */
4661 if (!gfc_current_ns->parent && !add_global_entry (name, 0))
4664 old_loc = gfc_current_locus;
4665 if (gfc_match_eos () == MATCH_YES)
4667 gfc_current_locus = old_loc;
4668 /* Match the empty argument list, and add the interface to
4670 m = gfc_match_formal_arglist (entry, 0, 1);
4673 m = gfc_match_formal_arglist (entry, 0, 0);
4680 if (gfc_match_eos () == MATCH_YES)
4682 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4683 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4686 entry->result = entry;
4690 m = gfc_match_suffix (entry, &result);
4692 gfc_syntax_error (ST_ENTRY);
4698 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
4699 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
4700 || gfc_add_function (&entry->attr, result->name, NULL)
4703 entry->result = result;
4707 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4708 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4710 entry->result = entry;
4715 if (gfc_match_eos () != MATCH_YES)
4717 gfc_syntax_error (ST_ENTRY);
4721 entry->attr.recursive = proc->attr.recursive;
4722 entry->attr.elemental = proc->attr.elemental;
4723 entry->attr.pure = proc->attr.pure;
4725 el = gfc_get_entry_list ();
4727 el->next = gfc_current_ns->entries;
4728 gfc_current_ns->entries = el;
4730 el->id = el->next->id + 1;
4734 new_st.op = EXEC_ENTRY;
4735 new_st.ext.entry = el;
4741 /* Match a subroutine statement, including optional prefixes. */
4744 gfc_match_subroutine (void)
4746 char name[GFC_MAX_SYMBOL_LEN + 1];
4751 bool allow_binding_name;
4753 if (gfc_current_state () != COMP_NONE
4754 && gfc_current_state () != COMP_INTERFACE
4755 && gfc_current_state () != COMP_CONTAINS)
4758 m = gfc_match_prefix (NULL);
4762 m = gfc_match ("subroutine% %n", name);
4766 if (get_proc_name (name, &sym, false))
4768 gfc_new_block = sym;
4770 /* Check what next non-whitespace character is so we can tell if there
4771 is the required parens if we have a BIND(C). */
4772 gfc_gobble_whitespace ();
4773 peek_char = gfc_peek_ascii_char ();
4775 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4778 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4781 /* Make sure that it isn't already declared as BIND(C). If it is, it
4782 must have been marked BIND(C) with a BIND(C) attribute and that is
4783 not allowed for procedures. */
4784 if (sym->attr.is_bind_c == 1)
4786 sym->attr.is_bind_c = 0;
4787 if (sym->old_symbol != NULL)
4788 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4789 "variables or common blocks",
4790 &(sym->old_symbol->declared_at));
4792 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4793 "variables or common blocks", &gfc_current_locus);
4796 /* C binding names are not allowed for internal procedures. */
4797 if (gfc_current_state () == COMP_CONTAINS
4798 && sym->ns->proc_name->attr.flavor != FL_MODULE)
4799 allow_binding_name = false;
4801 allow_binding_name = true;
4803 /* Here, we are just checking if it has the bind(c) attribute, and if
4804 so, then we need to make sure it's all correct. If it doesn't,
4805 we still need to continue matching the rest of the subroutine line. */
4806 is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
4807 if (is_bind_c == MATCH_ERROR)
4809 /* There was an attempt at the bind(c), but it was wrong. An
4810 error message should have been printed w/in the gfc_match_bind_c
4811 so here we'll just return the MATCH_ERROR. */
4815 if (is_bind_c == MATCH_YES)
4817 /* The following is allowed in the Fortran 2008 draft. */
4818 if (gfc_current_state () == COMP_CONTAINS
4819 && sym->ns->proc_name->attr.flavor != FL_MODULE
4820 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
4821 "at %L may not be specified for an internal "
4822 "procedure", &gfc_current_locus)
4826 if (peek_char != '(')
4828 gfc_error ("Missing required parentheses before BIND(C) at %C");
4831 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4836 if (gfc_match_eos () != MATCH_YES)
4838 gfc_syntax_error (ST_SUBROUTINE);
4842 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4849 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4850 given, and set the binding label in either the given symbol (if not
4851 NULL), or in the current_ts. The symbol may be NULL because we may
4852 encounter the BIND(C) before the declaration itself. Return
4853 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4854 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4855 or MATCH_YES if the specifier was correct and the binding label and
4856 bind(c) fields were set correctly for the given symbol or the
4857 current_ts. If allow_binding_name is false, no binding name may be
4861 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
4863 /* binding label, if exists */
4864 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4868 /* Initialize the flag that specifies whether we encountered a NAME=
4869 specifier or not. */
4870 has_name_equals = 0;
4872 /* Init the first char to nil so we can catch if we don't have
4873 the label (name attr) or the symbol name yet. */
4874 binding_label[0] = '\0';
4876 /* This much we have to be able to match, in this order, if
4877 there is a bind(c) label. */
4878 if (gfc_match (" bind ( c ") != MATCH_YES)
4881 /* Now see if there is a binding label, or if we've reached the
4882 end of the bind(c) attribute without one. */
4883 if (gfc_match_char (',') == MATCH_YES)
4885 if (gfc_match (" name = ") != MATCH_YES)
4887 gfc_error ("Syntax error in NAME= specifier for binding label "
4889 /* should give an error message here */
4893 has_name_equals = 1;
4895 /* Get the opening quote. */
4896 double_quote = MATCH_YES;
4897 single_quote = MATCH_YES;
4898 double_quote = gfc_match_char ('"');
4899 if (double_quote != MATCH_YES)
4900 single_quote = gfc_match_char ('\'');
4901 if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4903 gfc_error ("Syntax error in NAME= specifier for binding label "
4908 /* Grab the binding label, using functions that will not lower
4909 case the names automatically. */
4910 if (gfc_match_name_C (binding_label) != MATCH_YES)
4913 /* Get the closing quotation. */
4914 if (double_quote == MATCH_YES)
4916 if (gfc_match_char ('"') != MATCH_YES)
4918 gfc_error ("Missing closing quote '\"' for binding label at %C");
4919 /* User started string with '"' so looked to match it. */
4925 if (gfc_match_char ('\'') != MATCH_YES)
4927 gfc_error ("Missing closing quote '\'' for binding label at %C");
4928 /* User started string with "'" char. */
4934 /* Get the required right paren. */
4935 if (gfc_match_char (')') != MATCH_YES)
4937 gfc_error ("Missing closing paren for binding label at %C");
4941 if (has_name_equals && !allow_binding_name)
4943 gfc_error ("No binding name is allowed in BIND(C) at %C");
4947 if (has_name_equals && sym != NULL && sym->attr.dummy)
4949 gfc_error ("For dummy procedure %s, no binding name is "
4950 "allowed in BIND(C) at %C", sym->name);
4955 /* Save the binding label to the symbol. If sym is null, we're
4956 probably matching the typespec attributes of a declaration and
4957 haven't gotten the name yet, and therefore, no symbol yet. */
4958 if (binding_label[0] != '\0')
4962 strcpy (sym->binding_label, binding_label);
4965 strcpy (curr_binding_label, binding_label);
4967 else if (allow_binding_name)
4969 /* No binding label, but if symbol isn't null, we
4970 can set the label for it here.
4971 If name="" or allow_binding_name is false, no C binding name is
4973 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4974 strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4977 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
4978 && current_interface.type == INTERFACE_ABSTRACT)
4980 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4988 /* Return nonzero if we're currently compiling a contained procedure. */
4991 contained_procedure (void)
4993 gfc_state_data *s = gfc_state_stack;
4995 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4996 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
5002 /* Set the kind of each enumerator. The kind is selected such that it is
5003 interoperable with the corresponding C enumeration type, making
5004 sure that -fshort-enums is honored. */
5009 enumerator_history *current_history = NULL;
5013 if (max_enum == NULL || enum_history == NULL)
5016 if (!gfc_option.fshort_enums)
5022 kind = gfc_integer_kinds[i++].kind;
5024 while (kind < gfc_c_int_kind
5025 && gfc_check_integer_range (max_enum->initializer->value.integer,
5028 current_history = enum_history;
5029 while (current_history != NULL)
5031 current_history->sym->ts.kind = kind;
5032 current_history = current_history->next;
5037 /* Match any of the various end-block statements. Returns the type of
5038 END to the caller. The END INTERFACE, END IF, END DO and END
5039 SELECT statements cannot be replaced by a single END statement. */
5042 gfc_match_end (gfc_statement *st)
5044 char name[GFC_MAX_SYMBOL_LEN + 1];
5045 gfc_compile_state state;
5047 const char *block_name;
5052 old_loc = gfc_current_locus;
5053 if (gfc_match ("end") != MATCH_YES)
5056 state = gfc_current_state ();
5057 block_name = gfc_current_block () == NULL
5058 ? NULL : gfc_current_block ()->name;
5060 if (state == COMP_CONTAINS)
5062 state = gfc_state_stack->previous->state;
5063 block_name = gfc_state_stack->previous->sym == NULL
5064 ? NULL : gfc_state_stack->previous->sym->name;
5071 *st = ST_END_PROGRAM;
5072 target = " program";
5076 case COMP_SUBROUTINE:
5077 *st = ST_END_SUBROUTINE;
5078 target = " subroutine";
5079 eos_ok = !contained_procedure ();
5083 *st = ST_END_FUNCTION;
5084 target = " function";
5085 eos_ok = !contained_procedure ();
5088 case COMP_BLOCK_DATA:
5089 *st = ST_END_BLOCK_DATA;
5090 target = " block data";
5095 *st = ST_END_MODULE;
5100 case COMP_INTERFACE:
5101 *st = ST_END_INTERFACE;
5102 target = " interface";
5125 *st = ST_END_SELECT;
5131 *st = ST_END_FORALL;
5146 last_initializer = NULL;
5148 gfc_free_enum_history ();
5152 gfc_error ("Unexpected END statement at %C");
5156 if (gfc_match_eos () == MATCH_YES)
5160 /* We would have required END [something]. */
5161 gfc_error ("%s statement expected at %L",
5162 gfc_ascii_statement (*st), &old_loc);
5169 /* Verify that we've got the sort of end-block that we're expecting. */
5170 if (gfc_match (target) != MATCH_YES)
5172 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
5176 /* If we're at the end, make sure a block name wasn't required. */
5177 if (gfc_match_eos () == MATCH_YES)
5180 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
5181 && *st != ST_END_FORALL && *st != ST_END_WHERE)
5184 if (gfc_current_block () == NULL)
5187 gfc_error ("Expected block name of '%s' in %s statement at %C",
5188 block_name, gfc_ascii_statement (*st));
5193 /* END INTERFACE has a special handler for its several possible endings. */
5194 if (*st == ST_END_INTERFACE)
5195 return gfc_match_end_interface ();
5197 /* We haven't hit the end of statement, so what is left must be an
5199 m = gfc_match_space ();
5201 m = gfc_match_name (name);
5204 gfc_error ("Expected terminating name at %C");
5208 if (block_name == NULL)
5211 if (strcmp (name, block_name) != 0)
5213 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
5214 gfc_ascii_statement (*st));
5218 if (gfc_match_eos () == MATCH_YES)
5222 gfc_syntax_error (*st);
5225 gfc_current_locus = old_loc;
5231 /***************** Attribute declaration statements ****************/
5233 /* Set the attribute of a single variable. */
5238 char name[GFC_MAX_SYMBOL_LEN + 1];
5246 m = gfc_match_name (name);
5250 if (find_special (name, &sym))
5253 var_locus = gfc_current_locus;
5255 /* Deal with possible array specification for certain attributes. */
5256 if (current_attr.dimension
5257 || current_attr.allocatable
5258 || current_attr.pointer
5259 || current_attr.target)
5261 m = gfc_match_array_spec (&as);
5262 if (m == MATCH_ERROR)
5265 if (current_attr.dimension && m == MATCH_NO)
5267 gfc_error ("Missing array specification at %L in DIMENSION "
5268 "statement", &var_locus);
5273 if (current_attr.dimension && sym->value)
5275 gfc_error ("Dimensions specified for %s at %L after its "
5276 "initialisation", sym->name, &var_locus);
5281 if ((current_attr.allocatable || current_attr.pointer)
5282 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
5284 gfc_error ("Array specification must be deferred at %L", &var_locus);
5290 /* Update symbol table. DIMENSION attribute is set
5291 in gfc_set_array_spec(). */
5292 if (current_attr.dimension == 0
5293 && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
5299 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
5305 if (sym->attr.cray_pointee && sym->as != NULL)
5307 /* Fix the array spec. */
5308 m = gfc_mod_pointee_as (sym->as);
5309 if (m == MATCH_ERROR)
5313 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
5319 if ((current_attr.external || current_attr.intrinsic)
5320 && sym->attr.flavor != FL_PROCEDURE
5321 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
5330 gfc_free_array_spec (as);
5335 /* Generic attribute declaration subroutine. Used for attributes that
5336 just have a list of names. */
5343 /* Gobble the optional double colon, by simply ignoring the result
5353 if (gfc_match_eos () == MATCH_YES)
5359 if (gfc_match_char (',') != MATCH_YES)
5361 gfc_error ("Unexpected character in variable list at %C");
5371 /* This routine matches Cray Pointer declarations of the form:
5372 pointer ( <pointer>, <pointee> )
5374 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
5375 The pointer, if already declared, should be an integer. Otherwise, we
5376 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
5377 be either a scalar, or an array declaration. No space is allocated for
5378 the pointee. For the statement
5379 pointer (ipt, ar(10))
5380 any subsequent uses of ar will be translated (in C-notation) as
5381 ar(i) => ((<type> *) ipt)(i)
5382 After gimplification, pointee variable will disappear in the code. */
5385 cray_pointer_decl (void)
5389 gfc_symbol *cptr; /* Pointer symbol. */
5390 gfc_symbol *cpte; /* Pointee symbol. */
5396 if (gfc_match_char ('(') != MATCH_YES)
5398 gfc_error ("Expected '(' at %C");
5402 /* Match pointer. */
5403 var_locus = gfc_current_locus;
5404 gfc_clear_attr (¤t_attr);
5405 gfc_add_cray_pointer (¤t_attr, &var_locus);
5406 current_ts.type = BT_INTEGER;
5407 current_ts.kind = gfc_index_integer_kind;
5409 m = gfc_match_symbol (&cptr, 0);
5412 gfc_error ("Expected variable name at %C");
5416 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
5419 gfc_set_sym_referenced (cptr);
5421 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
5423 cptr->ts.type = BT_INTEGER;
5424 cptr->ts.kind = gfc_index_integer_kind;
5426 else if (cptr->ts.type != BT_INTEGER)
5428 gfc_error ("Cray pointer at %C must be an integer");
5431 else if (cptr->ts.kind < gfc_index_integer_kind)
5432 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
5433 " memory addresses require %d bytes",
5434 cptr->ts.kind, gfc_index_integer_kind);
5436 if (gfc_match_char (',') != MATCH_YES)
5438 gfc_error ("Expected \",\" at %C");
5442 /* Match Pointee. */
5443 var_locus = gfc_current_locus;
5444 gfc_clear_attr (¤t_attr);
5445 gfc_add_cray_pointee (¤t_attr, &var_locus);
5446 current_ts.type = BT_UNKNOWN;
5447 current_ts.kind = 0;
5449 m = gfc_match_symbol (&cpte, 0);
5452 gfc_error ("Expected variable name at %C");
5456 /* Check for an optional array spec. */
5457 m = gfc_match_array_spec (&as);
5458 if (m == MATCH_ERROR)
5460 gfc_free_array_spec (as);
5463 else if (m == MATCH_NO)
5465 gfc_free_array_spec (as);
5469 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
5472 gfc_set_sym_referenced (cpte);
5474 if (cpte->as == NULL)
5476 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
5477 gfc_internal_error ("Couldn't set Cray pointee array spec.");
5479 else if (as != NULL)
5481 gfc_error ("Duplicate array spec for Cray pointee at %C");
5482 gfc_free_array_spec (as);
5488 if (cpte->as != NULL)
5490 /* Fix array spec. */
5491 m = gfc_mod_pointee_as (cpte->as);
5492 if (m == MATCH_ERROR)
5496 /* Point the Pointee at the Pointer. */
5497 cpte->cp_pointer = cptr;
5499 if (gfc_match_char (')') != MATCH_YES)
5501 gfc_error ("Expected \")\" at %C");
5504 m = gfc_match_char (',');
5506 done = true; /* Stop searching for more declarations. */
5510 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
5511 || gfc_match_eos () != MATCH_YES)
5513 gfc_error ("Expected \",\" or end of statement at %C");
5521 gfc_match_external (void)
5524 gfc_clear_attr (¤t_attr);
5525 current_attr.external = 1;
5527 return attr_decl ();
5532 gfc_match_intent (void)
5536 intent = match_intent_spec ();
5537 if (intent == INTENT_UNKNOWN)
5540 gfc_clear_attr (¤t_attr);
5541 current_attr.intent = intent;
5543 return attr_decl ();
5548 gfc_match_intrinsic (void)
5551 gfc_clear_attr (¤t_attr);
5552 current_attr.intrinsic = 1;
5554 return attr_decl ();
5559 gfc_match_optional (void)
5562 gfc_clear_attr (¤t_attr);
5563 current_attr.optional = 1;
5565 return attr_decl ();
5570 gfc_match_pointer (void)
5572 gfc_gobble_whitespace ();
5573 if (gfc_peek_ascii_char () == '(')
5575 if (!gfc_option.flag_cray_pointer)
5577 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
5581 return cray_pointer_decl ();
5585 gfc_clear_attr (¤t_attr);
5586 current_attr.pointer = 1;
5588 return attr_decl ();
5594 gfc_match_allocatable (void)
5596 gfc_clear_attr (¤t_attr);
5597 current_attr.allocatable = 1;
5599 return attr_decl ();
5604 gfc_match_dimension (void)
5606 gfc_clear_attr (¤t_attr);
5607 current_attr.dimension = 1;
5609 return attr_decl ();
5614 gfc_match_target (void)
5616 gfc_clear_attr (¤t_attr);
5617 current_attr.target = 1;
5619 return attr_decl ();
5623 /* Match the list of entities being specified in a PUBLIC or PRIVATE
5627 access_attr_decl (gfc_statement st)
5629 char name[GFC_MAX_SYMBOL_LEN + 1];
5630 interface_type type;
5633 gfc_intrinsic_op operator;
5636 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5641 m = gfc_match_generic_spec (&type, name, &operator);
5644 if (m == MATCH_ERROR)
5649 case INTERFACE_NAMELESS:
5650 case INTERFACE_ABSTRACT:
5653 case INTERFACE_GENERIC:
5654 if (gfc_get_symbol (name, NULL, &sym))
5657 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
5658 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
5659 sym->name, NULL) == FAILURE)
5664 case INTERFACE_INTRINSIC_OP:
5665 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
5667 gfc_current_ns->operator_access[operator] =
5668 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5672 gfc_error ("Access specification of the %s operator at %C has "
5673 "already been specified", gfc_op2string (operator));
5679 case INTERFACE_USER_OP:
5680 uop = gfc_get_uop (name);
5682 if (uop->access == ACCESS_UNKNOWN)
5684 uop->access = (st == ST_PUBLIC)
5685 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5689 gfc_error ("Access specification of the .%s. operator at %C "
5690 "has already been specified", sym->name);
5697 if (gfc_match_char (',') == MATCH_NO)
5701 if (gfc_match_eos () != MATCH_YES)
5706 gfc_syntax_error (st);
5714 gfc_match_protected (void)
5719 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5721 gfc_error ("PROTECTED at %C only allowed in specification "
5722 "part of a module");
5727 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
5731 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5736 if (gfc_match_eos () == MATCH_YES)
5741 m = gfc_match_symbol (&sym, 0);
5745 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
5758 if (gfc_match_eos () == MATCH_YES)
5760 if (gfc_match_char (',') != MATCH_YES)
5767 gfc_error ("Syntax error in PROTECTED statement at %C");
5772 /* The PRIVATE statement is a bit weird in that it can be an attribute
5773 declaration, but also works as a standlone statement inside of a
5774 type declaration or a module. */
5777 gfc_match_private (gfc_statement *st)
5780 if (gfc_match ("private") != MATCH_YES)
5783 if (gfc_current_state () != COMP_MODULE
5784 && (gfc_current_state () != COMP_DERIVED
5785 || !gfc_state_stack->previous
5786 || gfc_state_stack->previous->state != COMP_MODULE))
5788 gfc_error ("PRIVATE statement at %C is only allowed in the "
5789 "specification part of a module");
5793 if (gfc_current_state () == COMP_DERIVED)
5795 if (gfc_match_eos () == MATCH_YES)
5801 gfc_syntax_error (ST_PRIVATE);
5805 if (gfc_match_eos () == MATCH_YES)
5812 return access_attr_decl (ST_PRIVATE);
5817 gfc_match_public (gfc_statement *st)
5820 if (gfc_match ("public") != MATCH_YES)
5823 if (gfc_current_state () != COMP_MODULE)
5825 gfc_error ("PUBLIC statement at %C is only allowed in the "
5826 "specification part of a module");
5830 if (gfc_match_eos () == MATCH_YES)
5837 return access_attr_decl (ST_PUBLIC);
5841 /* Workhorse for gfc_match_parameter. */
5850 m = gfc_match_symbol (&sym, 0);
5852 gfc_error ("Expected variable name at %C in PARAMETER statement");
5857 if (gfc_match_char ('=') == MATCH_NO)
5859 gfc_error ("Expected = sign in PARAMETER statement at %C");
5863 m = gfc_match_init_expr (&init);
5865 gfc_error ("Expected expression at %C in PARAMETER statement");
5869 if (sym->ts.type == BT_UNKNOWN
5870 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5876 if (gfc_check_assign_symbol (sym, init) == FAILURE
5877 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
5885 gfc_error ("Initializing already initialized variable at %C");
5890 if (sym->ts.type == BT_CHARACTER
5891 && sym->ts.cl != NULL
5892 && sym->ts.cl->length != NULL
5893 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5894 && init->expr_type == EXPR_CONSTANT
5895 && init->ts.type == BT_CHARACTER)
5896 gfc_set_constant_character_len (
5897 mpz_get_si (sym->ts.cl->length->value.integer), init, -1);
5898 else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL
5899 && sym->ts.cl->length == NULL)
5902 if (init->expr_type == EXPR_CONSTANT)
5904 clen = init->value.character.length;
5905 sym->ts.cl->length = gfc_int_expr (clen);
5907 else if (init->expr_type == EXPR_ARRAY)
5909 gfc_expr *p = init->value.constructor->expr;
5910 clen = p->value.character.length;
5911 sym->ts.cl->length = gfc_int_expr (clen);
5913 else if (init->ts.cl && init->ts.cl->length)
5914 sym->ts.cl->length = gfc_copy_expr (sym->value->ts.cl->length);
5921 gfc_free_expr (init);
5926 /* Match a parameter statement, with the weird syntax that these have. */
5929 gfc_match_parameter (void)
5933 if (gfc_match_char ('(') == MATCH_NO)
5942 if (gfc_match (" )%t") == MATCH_YES)
5945 if (gfc_match_char (',') != MATCH_YES)
5947 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5957 /* Save statements have a special syntax. */
5960 gfc_match_save (void)
5962 char n[GFC_MAX_SYMBOL_LEN+1];
5967 if (gfc_match_eos () == MATCH_YES)
5969 if (gfc_current_ns->seen_save)
5971 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5972 "follows previous SAVE statement")
5977 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5981 if (gfc_current_ns->save_all)
5983 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5984 "blanket SAVE statement")
5993 m = gfc_match_symbol (&sym, 0);
5997 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
6009 m = gfc_match (" / %n /", &n);
6010 if (m == MATCH_ERROR)
6015 c = gfc_get_common (n, 0);
6018 gfc_current_ns->seen_save = 1;
6021 if (gfc_match_eos () == MATCH_YES)
6023 if (gfc_match_char (',') != MATCH_YES)
6030 gfc_error ("Syntax error in SAVE statement at %C");
6036 gfc_match_value (void)
6041 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
6045 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
6050 if (gfc_match_eos () == MATCH_YES)
6055 m = gfc_match_symbol (&sym, 0);
6059 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
6072 if (gfc_match_eos () == MATCH_YES)
6074 if (gfc_match_char (',') != MATCH_YES)
6081 gfc_error ("Syntax error in VALUE statement at %C");
6087 gfc_match_volatile (void)
6092 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
6096 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
6101 if (gfc_match_eos () == MATCH_YES)
6106 /* VOLATILE is special because it can be added to host-associated
6108 m = gfc_match_symbol (&sym, 1);
6112 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
6125 if (gfc_match_eos () == MATCH_YES)
6127 if (gfc_match_char (',') != MATCH_YES)
6134 gfc_error ("Syntax error in VOLATILE statement at %C");
6139 /* Match a module procedure statement. Note that we have to modify
6140 symbols in the parent's namespace because the current one was there
6141 to receive symbols that are in an interface's formal argument list. */
6144 gfc_match_modproc (void)
6146 char name[GFC_MAX_SYMBOL_LEN + 1];
6149 gfc_namespace *module_ns;
6150 gfc_interface *old_interface_head, *interface;
6152 if (gfc_state_stack->state != COMP_INTERFACE
6153 || gfc_state_stack->previous == NULL
6154 || current_interface.type == INTERFACE_NAMELESS
6155 || current_interface.type == INTERFACE_ABSTRACT)
6157 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
6162 module_ns = gfc_current_ns->parent;
6163 for (; module_ns; module_ns = module_ns->parent)
6164 if (module_ns->proc_name->attr.flavor == FL_MODULE)
6167 if (module_ns == NULL)
6170 /* Store the current state of the interface. We will need it if we
6171 end up with a syntax error and need to recover. */
6172 old_interface_head = gfc_current_interface_head ();
6178 m = gfc_match_name (name);
6184 /* Check for syntax error before starting to add symbols to the
6185 current namespace. */
6186 if (gfc_match_eos () == MATCH_YES)
6188 if (!last && gfc_match_char (',') != MATCH_YES)
6191 /* Now we're sure the syntax is valid, we process this item
6193 if (gfc_get_symbol (name, module_ns, &sym))
6196 if (sym->attr.proc != PROC_MODULE
6197 && gfc_add_procedure (&sym->attr, PROC_MODULE,
6198 sym->name, NULL) == FAILURE)
6201 if (gfc_add_interface (sym) == FAILURE)
6204 sym->attr.mod_proc = 1;
6213 /* Restore the previous state of the interface. */
6214 interface = gfc_current_interface_head ();
6215 gfc_set_current_interface_head (old_interface_head);
6217 /* Free the new interfaces. */
6218 while (interface != old_interface_head)
6220 gfc_interface *i = interface->next;
6221 gfc_free (interface);
6225 /* And issue a syntax error. */
6226 gfc_syntax_error (ST_MODULE_PROC);
6231 /* Match the optional attribute specifiers for a type declaration.
6232 Return MATCH_ERROR if an error is encountered in one of the handled
6233 attributes (public, private, bind(c)), MATCH_NO if what's found is
6234 not a handled attribute, and MATCH_YES otherwise. TODO: More error
6235 checking on attribute conflicts needs to be done. */
6238 gfc_get_type_attr_spec (symbol_attribute *attr)
6240 /* See if the derived type is marked as private. */
6241 if (gfc_match (" , private") == MATCH_YES)
6243 if (gfc_current_state () != COMP_MODULE)
6245 gfc_error ("Derived type at %C can only be PRIVATE in the "
6246 "specification part of a module");
6250 if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
6253 else if (gfc_match (" , public") == MATCH_YES)
6255 if (gfc_current_state () != COMP_MODULE)
6257 gfc_error ("Derived type at %C can only be PUBLIC in the "
6258 "specification part of a module");
6262 if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
6265 else if (gfc_match(" , bind ( c )") == MATCH_YES)
6267 /* If the type is defined to be bind(c) it then needs to make
6268 sure that all fields are interoperable. This will
6269 need to be a semantic check on the finished derived type.
6270 See 15.2.3 (lines 9-12) of F2003 draft. */
6271 if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
6274 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
6279 /* If we get here, something matched. */
6284 /* Match the beginning of a derived type declaration. If a type name
6285 was the result of a function, then it is possible to have a symbol
6286 already to be known as a derived type yet have no components. */
6289 gfc_match_derived_decl (void)
6291 char name[GFC_MAX_SYMBOL_LEN + 1];
6292 symbol_attribute attr;
6295 match is_type_attr_spec = MATCH_NO;
6296 bool seen_attr = false;
6298 if (gfc_current_state () == COMP_DERIVED)
6301 gfc_clear_attr (&attr);
6305 is_type_attr_spec = gfc_get_type_attr_spec (&attr);
6306 if (is_type_attr_spec == MATCH_ERROR)
6308 if (is_type_attr_spec == MATCH_YES)
6310 } while (is_type_attr_spec == MATCH_YES);
6312 if (gfc_match (" ::") != MATCH_YES && seen_attr)
6314 gfc_error ("Expected :: in TYPE definition at %C");
6318 m = gfc_match (" %n%t", name);
6322 /* Make sure the name is not the name of an intrinsic type. */
6323 if (gfc_is_intrinsic_typename (name))
6325 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
6330 if (gfc_get_symbol (name, NULL, &sym))
6333 if (sym->ts.type != BT_UNKNOWN)
6335 gfc_error ("Derived type name '%s' at %C already has a basic type "
6336 "of %s", sym->name, gfc_typename (&sym->ts));
6340 /* The symbol may already have the derived attribute without the
6341 components. The ways this can happen is via a function
6342 definition, an INTRINSIC statement or a subtype in another
6343 derived type that is a pointer. The first part of the AND clause
6344 is true if a the symbol is not the return value of a function. */
6345 if (sym->attr.flavor != FL_DERIVED
6346 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
6349 if (sym->components != NULL || sym->attr.zero_comp)
6351 gfc_error ("Derived type definition of '%s' at %C has already been "
6352 "defined", sym->name);
6356 if (attr.access != ACCESS_UNKNOWN
6357 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
6360 /* See if the derived type was labeled as bind(c). */
6361 if (attr.is_bind_c != 0)
6362 sym->attr.is_bind_c = attr.is_bind_c;
6364 /* Construct the f2k_derived namespace if it is not yet there. */
6365 if (!sym->f2k_derived)
6366 sym->f2k_derived = gfc_get_namespace (NULL, 0);
6368 gfc_new_block = sym;
6374 /* Cray Pointees can be declared as:
6375 pointer (ipt, a (n,m,...,*))
6376 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
6377 cheat and set a constant bound of 1 for the last dimension, if this
6378 is the case. Since there is no bounds-checking for Cray Pointees,
6379 this will be okay. */
6382 gfc_mod_pointee_as (gfc_array_spec *as)
6384 as->cray_pointee = true; /* This will be useful to know later. */
6385 if (as->type == AS_ASSUMED_SIZE)
6387 as->type = AS_EXPLICIT;
6388 as->upper[as->rank - 1] = gfc_int_expr (1);
6389 as->cp_was_assumed = true;
6391 else if (as->type == AS_ASSUMED_SHAPE)
6393 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
6400 /* Match the enum definition statement, here we are trying to match
6401 the first line of enum definition statement.
6402 Returns MATCH_YES if match is found. */
6405 gfc_match_enum (void)
6409 m = gfc_match_eos ();
6413 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
6421 /* Match a variable name with an optional initializer. When this
6422 subroutine is called, a variable is expected to be parsed next.
6423 Depending on what is happening at the moment, updates either the
6424 symbol table or the current interface. */
6427 enumerator_decl (void)
6429 char name[GFC_MAX_SYMBOL_LEN + 1];
6430 gfc_expr *initializer;
6431 gfc_array_spec *as = NULL;
6439 old_locus = gfc_current_locus;
6441 /* When we get here, we've just matched a list of attributes and
6442 maybe a type and a double colon. The next thing we expect to see
6443 is the name of the symbol. */
6444 m = gfc_match_name (name);
6448 var_locus = gfc_current_locus;
6450 /* OK, we've successfully matched the declaration. Now put the
6451 symbol in the current namespace. If we fail to create the symbol,
6453 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
6459 /* The double colon must be present in order to have initializers.
6460 Otherwise the statement is ambiguous with an assignment statement. */
6463 if (gfc_match_char ('=') == MATCH_YES)
6465 m = gfc_match_init_expr (&initializer);
6468 gfc_error ("Expected an initialization expression at %C");
6477 /* If we do not have an initializer, the initialization value of the
6478 previous enumerator (stored in last_initializer) is incremented
6479 by 1 and is used to initialize the current enumerator. */
6480 if (initializer == NULL)
6481 initializer = gfc_enum_initializer (last_initializer, old_locus);
6483 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
6485 gfc_error("ENUMERATOR %L not initialized with integer expression",
6488 gfc_free_enum_history ();
6492 /* Store this current initializer, for the next enumerator variable
6493 to be parsed. add_init_expr_to_sym() zeros initializer, so we
6494 use last_initializer below. */
6495 last_initializer = initializer;
6496 t = add_init_expr_to_sym (name, &initializer, &var_locus);
6498 /* Maintain enumerator history. */
6499 gfc_find_symbol (name, NULL, 0, &sym);
6500 create_enum_history (sym, last_initializer);
6502 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
6505 /* Free stuff up and return. */
6506 gfc_free_expr (initializer);
6512 /* Match the enumerator definition statement. */
6515 gfc_match_enumerator_def (void)
6520 gfc_clear_ts (¤t_ts);
6522 m = gfc_match (" enumerator");
6526 m = gfc_match (" :: ");
6527 if (m == MATCH_ERROR)
6530 colon_seen = (m == MATCH_YES);
6532 if (gfc_current_state () != COMP_ENUM)
6534 gfc_error ("ENUM definition statement expected before %C");
6535 gfc_free_enum_history ();
6539 (¤t_ts)->type = BT_INTEGER;
6540 (¤t_ts)->kind = gfc_c_int_kind;
6542 gfc_clear_attr (¤t_attr);
6543 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
6552 m = enumerator_decl ();
6553 if (m == MATCH_ERROR)
6558 if (gfc_match_eos () == MATCH_YES)
6560 if (gfc_match_char (',') != MATCH_YES)
6564 if (gfc_current_state () == COMP_ENUM)
6566 gfc_free_enum_history ();
6567 gfc_error ("Syntax error in ENUMERATOR definition at %C");
6572 gfc_free_array_spec (current_as);
6578 /* Match a FINAL declaration inside a derived type. */
6581 gfc_match_final_decl (void)
6583 char name[GFC_MAX_SYMBOL_LEN + 1];
6586 gfc_namespace* module_ns;
6589 if (gfc_state_stack->state != COMP_DERIVED)
6591 gfc_error ("FINAL declaration at %C must be inside a derived type "
6596 gcc_assert (gfc_current_block ());
6598 if (!gfc_state_stack->previous
6599 || gfc_state_stack->previous->state != COMP_MODULE)
6601 gfc_error ("Derived type declaration with FINAL at %C must be in the"
6602 " specification part of a MODULE");
6606 module_ns = gfc_current_ns;
6607 gcc_assert (module_ns);
6608 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
6610 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
6611 if (gfc_match (" ::") == MATCH_ERROR)
6614 /* Match the sequence of procedure names. */
6621 if (first && gfc_match_eos () == MATCH_YES)
6623 gfc_error ("Empty FINAL at %C");
6627 m = gfc_match_name (name);
6630 gfc_error ("Expected module procedure name at %C");
6633 else if (m != MATCH_YES)
6636 if (gfc_match_eos () == MATCH_YES)
6638 if (!last && gfc_match_char (',') != MATCH_YES)
6640 gfc_error ("Expected ',' at %C");
6644 if (gfc_get_symbol (name, module_ns, &sym))
6646 gfc_error ("Unknown procedure name \"%s\" at %C", name);
6650 /* Mark the symbol as module procedure. */
6651 if (sym->attr.proc != PROC_MODULE
6652 && gfc_add_procedure (&sym->attr, PROC_MODULE,
6653 sym->name, NULL) == FAILURE)
6656 /* Check if we already have this symbol in the list, this is an error. */
6657 for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
6658 if (f->procedure == sym)
6660 gfc_error ("'%s' at %C is already defined as FINAL procedure!",
6665 /* Add this symbol to the list of finalizers. */
6666 gcc_assert (gfc_current_block ()->f2k_derived);
6668 f = XCNEW (gfc_finalizer);
6670 f->where = gfc_current_locus;
6671 f->next = gfc_current_block ()->f2k_derived->finalizers;
6672 gfc_current_block ()->f2k_derived->finalizers = f;