1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006, 2007
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() gfc_getmem (sizeof (gfc_data_variable))
32 #define gfc_get_data_value() gfc_getmem (sizeof (gfc_data_value))
33 #define gfc_get_data() gfc_getmem( sizeof (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 locus gfc_function_kind_locus;
90 locus gfc_function_type_locus;
93 /********************* DATA statement subroutines *********************/
95 static bool in_match_data = false;
98 gfc_in_match_data (void)
100 return in_match_data;
104 set_in_match_data (bool set_value)
106 in_match_data = set_value;
109 /* Free a gfc_data_variable structure and everything beneath it. */
112 free_variable (gfc_data_variable *p)
114 gfc_data_variable *q;
119 gfc_free_expr (p->expr);
120 gfc_free_iterator (&p->iter, 0);
121 free_variable (p->list);
127 /* Free a gfc_data_value structure and everything beneath it. */
130 free_value (gfc_data_value *p)
137 gfc_free_expr (p->expr);
143 /* Free a list of gfc_data structures. */
146 gfc_free_data (gfc_data *p)
153 free_variable (p->var);
154 free_value (p->value);
160 /* Free all data in a namespace. */
163 gfc_free_data_all (gfc_namespace *ns)
176 static match var_element (gfc_data_variable *);
178 /* Match a list of variables terminated by an iterator and a right
182 var_list (gfc_data_variable *parent)
184 gfc_data_variable *tail, var;
187 m = var_element (&var);
188 if (m == MATCH_ERROR)
193 tail = gfc_get_data_variable ();
200 if (gfc_match_char (',') != MATCH_YES)
203 m = gfc_match_iterator (&parent->iter, 1);
206 if (m == MATCH_ERROR)
209 m = var_element (&var);
210 if (m == MATCH_ERROR)
215 tail->next = gfc_get_data_variable ();
221 if (gfc_match_char (')') != MATCH_YES)
226 gfc_syntax_error (ST_DATA);
231 /* Match a single element in a data variable list, which can be a
232 variable-iterator list. */
235 var_element (gfc_data_variable *new)
240 memset (new, 0, sizeof (gfc_data_variable));
242 if (gfc_match_char ('(') == MATCH_YES)
243 return var_list (new);
245 m = gfc_match_variable (&new->expr, 0);
249 sym = new->expr->symtree->n.sym;
251 if (!sym->attr.function && gfc_current_ns->parent
252 && gfc_current_ns->parent == sym->ns)
254 gfc_error ("Host associated variable '%s' may not be in the DATA "
255 "statement at %C", sym->name);
259 if (gfc_current_state () != COMP_BLOCK_DATA
260 && sym->attr.in_common
261 && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
262 "common block variable '%s' in DATA statement at %C",
263 sym->name) == FAILURE)
266 if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
273 /* Match the top-level list of data variables. */
276 top_var_list (gfc_data *d)
278 gfc_data_variable var, *tail, *new;
285 m = var_element (&var);
288 if (m == MATCH_ERROR)
291 new = gfc_get_data_variable ();
301 if (gfc_match_char ('/') == MATCH_YES)
303 if (gfc_match_char (',') != MATCH_YES)
310 gfc_syntax_error (ST_DATA);
311 gfc_free_data_all (gfc_current_ns);
317 match_data_constant (gfc_expr **result)
319 char name[GFC_MAX_SYMBOL_LEN + 1];
325 m = gfc_match_literal_constant (&expr, 1);
332 if (m == MATCH_ERROR)
335 m = gfc_match_null (result);
339 old_loc = gfc_current_locus;
341 /* Should this be a structure component, try to match it
342 before matching a name. */
343 m = gfc_match_rvalue (result);
344 if (m == MATCH_ERROR)
347 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
349 if (gfc_simplify_expr (*result, 0) == FAILURE)
354 gfc_current_locus = old_loc;
356 m = gfc_match_name (name);
360 if (gfc_find_symbol (name, NULL, 1, &sym))
364 || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
366 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
370 else if (sym->attr.flavor == FL_DERIVED)
371 return gfc_match_structure_constructor (sym, result);
373 *result = gfc_copy_expr (sym->value);
378 /* Match a list of values in a DATA statement. The leading '/' has
379 already been seen at this point. */
382 top_val_list (gfc_data *data)
384 gfc_data_value *new, *tail;
392 m = match_data_constant (&expr);
395 if (m == MATCH_ERROR)
398 new = gfc_get_data_value ();
399 mpz_init (new->repeat);
408 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
411 mpz_set_ui (tail->repeat, 1);
415 if (expr->ts.type == BT_INTEGER)
416 mpz_set (tail->repeat, expr->value.integer);
417 gfc_free_expr (expr);
419 m = match_data_constant (&tail->expr);
422 if (m == MATCH_ERROR)
426 if (gfc_match_char ('/') == MATCH_YES)
428 if (gfc_match_char (',') == MATCH_NO)
435 gfc_syntax_error (ST_DATA);
436 gfc_free_data_all (gfc_current_ns);
441 /* Matches an old style initialization. */
444 match_old_style_init (const char *name)
451 /* Set up data structure to hold initializers. */
452 gfc_find_sym_tree (name, NULL, 0, &st);
455 newdata = gfc_get_data ();
456 newdata->var = gfc_get_data_variable ();
457 newdata->var->expr = gfc_get_variable_expr (st);
458 newdata->where = gfc_current_locus;
460 /* Match initial value list. This also eats the terminal '/'. */
461 m = top_val_list (newdata);
470 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
475 /* Mark the variable as having appeared in a data statement. */
476 if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
482 /* Chain in namespace list of DATA initializers. */
483 newdata->next = gfc_current_ns->data;
484 gfc_current_ns->data = newdata;
490 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
491 we are matching a DATA statement and are therefore issuing an error
492 if we encounter something unexpected, if not, we're trying to match
493 an old-style initialization expression of the form INTEGER I /2/. */
496 gfc_match_data (void)
501 set_in_match_data (true);
505 new = gfc_get_data ();
506 new->where = gfc_current_locus;
508 m = top_var_list (new);
512 m = top_val_list (new);
516 new->next = gfc_current_ns->data;
517 gfc_current_ns->data = new;
519 if (gfc_match_eos () == MATCH_YES)
522 gfc_match_char (','); /* Optional comma */
525 set_in_match_data (false);
529 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
536 set_in_match_data (false);
542 /************************ Declaration statements *********************/
544 /* Match an intent specification. Since this can only happen after an
545 INTENT word, a legal intent-spec must follow. */
548 match_intent_spec (void)
551 if (gfc_match (" ( in out )") == MATCH_YES)
553 if (gfc_match (" ( in )") == MATCH_YES)
555 if (gfc_match (" ( out )") == MATCH_YES)
558 gfc_error ("Bad INTENT specification at %C");
559 return INTENT_UNKNOWN;
563 /* Matches a character length specification, which is either a
564 specification expression or a '*'. */
567 char_len_param_value (gfc_expr **expr)
569 if (gfc_match_char ('*') == MATCH_YES)
575 return gfc_match_expr (expr);
579 /* A character length is a '*' followed by a literal integer or a
580 char_len_param_value in parenthesis. */
583 match_char_length (gfc_expr **expr)
588 m = gfc_match_char ('*');
592 m = gfc_match_small_literal_int (&length, NULL);
593 if (m == MATCH_ERROR)
598 *expr = gfc_int_expr (length);
602 if (gfc_match_char ('(') == MATCH_NO)
605 m = char_len_param_value (expr);
606 if (m == MATCH_ERROR)
611 if (gfc_match_char (')') == MATCH_NO)
613 gfc_free_expr (*expr);
621 gfc_error ("Syntax error in character length specification at %C");
626 /* Special subroutine for finding a symbol. Check if the name is found
627 in the current name space. If not, and we're compiling a function or
628 subroutine and the parent compilation unit is an interface, then check
629 to see if the name we've been given is the name of the interface
630 (located in another namespace). */
633 find_special (const char *name, gfc_symbol **result)
638 i = gfc_get_symbol (name, NULL, result);
642 if (gfc_current_state () != COMP_SUBROUTINE
643 && gfc_current_state () != COMP_FUNCTION)
646 s = gfc_state_stack->previous;
650 if (s->state != COMP_INTERFACE)
653 goto end; /* Nameless interface. */
655 if (strcmp (name, s->sym->name) == 0)
666 /* Special subroutine for getting a symbol node associated with a
667 procedure name, used in SUBROUTINE and FUNCTION statements. The
668 symbol is created in the parent using with symtree node in the
669 child unit pointing to the symbol. If the current namespace has no
670 parent, then the symbol is just created in the current unit. */
673 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
679 /* Module functions have to be left in their own namespace because
680 they have potentially (almost certainly!) already been referenced.
681 In this sense, they are rather like external functions. This is
682 fixed up in resolve.c(resolve_entries), where the symbol name-
683 space is set to point to the master function, so that the fake
684 result mechanism can work. */
685 if (module_fcn_entry)
687 /* Present if entry is declared to be a module procedure. */
688 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
691 rc = gfc_get_symbol (name, NULL, result);
692 else if (gfc_get_symbol (name, NULL, &sym) == 0
694 && sym->ts.type != BT_UNKNOWN
695 && (*result)->ts.type == BT_UNKNOWN
696 && sym->attr.flavor == FL_UNKNOWN)
697 /* Pick up the typespec for the entry, if declared in the function
698 body. Note that this symbol is FL_UNKNOWN because it will
699 only have appeared in a type declaration. The local symtree
700 is set to point to the module symbol and a unique symtree
701 to the local version. This latter ensures a correct clearing
704 (*result)->ts = sym->ts;
705 gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
707 st = gfc_get_unique_symtree (gfc_current_ns);
712 rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
718 gfc_current_ns->refs++;
720 if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
722 /* Trap another encompassed procedure with the same name. All
723 these conditions are necessary to avoid picking up an entry
724 whose name clashes with that of the encompassing procedure;
725 this is handled using gsymbols to register unique,globally
727 if (sym->attr.flavor != 0
728 && sym->attr.proc != 0
729 && (sym->attr.subroutine || sym->attr.function)
730 && sym->attr.if_source != IFSRC_UNKNOWN)
731 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
732 name, &sym->declared_at);
734 /* Trap a procedure with a name the same as interface in the
735 encompassing scope. */
736 if (sym->attr.generic != 0
737 && (sym->attr.subroutine || sym->attr.function)
738 && !sym->attr.mod_proc)
739 gfc_error_now ("Name '%s' at %C is already defined"
740 " as a generic interface at %L",
741 name, &sym->declared_at);
743 /* Trap declarations of attributes in encompassing scope. The
744 signature for this is that ts.kind is set. Legitimate
745 references only set ts.type. */
746 if (sym->ts.kind != 0
747 && !sym->attr.implicit_type
748 && sym->attr.proc == 0
749 && gfc_current_ns->parent != NULL
750 && sym->attr.access == 0
751 && !module_fcn_entry)
752 gfc_error_now ("Procedure '%s' at %C has an explicit interface "
753 "and must not have attributes declared at %L",
754 name, &sym->declared_at);
757 if (gfc_current_ns->parent == NULL || *result == NULL)
760 /* Module function entries will already have a symtree in
761 the current namespace but will need one at module level. */
762 if (module_fcn_entry)
764 /* Present if entry is declared to be a module procedure. */
765 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
767 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
770 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
775 /* See if the procedure should be a module procedure. */
777 if (((sym->ns->proc_name != NULL
778 && sym->ns->proc_name->attr.flavor == FL_MODULE
779 && sym->attr.proc != PROC_MODULE)
780 || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
781 && gfc_add_procedure (&sym->attr, PROC_MODULE,
782 sym->name, NULL) == FAILURE)
789 /* Verify that the given symbol representing a parameter is C
790 interoperable, by checking to see if it was marked as such after
791 its declaration. If the given symbol is not interoperable, a
792 warning is reported, thus removing the need to return the status to
793 the calling function. The standard does not require the user use
794 one of the iso_c_binding named constants to declare an
795 interoperable parameter, but we can't be sure if the param is C
796 interop or not if the user doesn't. For example, integer(4) may be
797 legal Fortran, but doesn't have meaning in C. It may interop with
798 a number of the C types, which causes a problem because the
799 compiler can't know which one. This code is almost certainly not
800 portable, and the user will get what they deserve if the C type
801 across platforms isn't always interoperable with integer(4). If
802 the user had used something like integer(c_int) or integer(c_long),
803 the compiler could have automatically handled the varying sizes
807 verify_c_interop_param (gfc_symbol *sym)
809 int is_c_interop = 0;
810 try retval = SUCCESS;
812 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
813 Don't repeat the checks here. */
814 if (sym->attr.implicit_type)
817 /* For subroutines or functions that are passed to a BIND(C) procedure,
818 they're interoperable if they're BIND(C) and their params are all
820 if (sym->attr.flavor == FL_PROCEDURE)
822 if (sym->attr.is_bind_c == 0)
824 gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
825 "attribute to be C interoperable", sym->name,
826 &(sym->declared_at));
832 if (sym->attr.is_c_interop == 1)
833 /* We've already checked this procedure; don't check it again. */
836 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
841 /* See if we've stored a reference to a procedure that owns sym. */
842 if (sym->ns != NULL && sym->ns->proc_name != NULL)
844 if (sym->ns->proc_name->attr.is_bind_c == 1)
847 (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
850 if (is_c_interop != 1)
852 /* Make personalized messages to give better feedback. */
853 if (sym->ts.type == BT_DERIVED)
854 gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
855 " procedure '%s' but is not C interoperable "
856 "because derived type '%s' is not C interoperable",
857 sym->name, &(sym->declared_at),
858 sym->ns->proc_name->name,
859 sym->ts.derived->name);
861 gfc_warning ("Variable '%s' at %L is a parameter to the "
862 "BIND(C) procedure '%s' but may not be C "
864 sym->name, &(sym->declared_at),
865 sym->ns->proc_name->name);
868 /* Character strings are only C interoperable if they have a
870 if (sym->ts.type == BT_CHARACTER)
872 gfc_charlen *cl = sym->ts.cl;
873 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
874 || mpz_cmp_si (cl->length->value.integer, 1) != 0)
876 gfc_error ("Character argument '%s' at %L "
877 "must be length 1 because "
878 "procedure '%s' is BIND(C)",
879 sym->name, &sym->declared_at,
880 sym->ns->proc_name->name);
885 /* We have to make sure that any param to a bind(c) routine does
886 not have the allocatable, pointer, or optional attributes,
887 according to J3/04-007, section 5.1. */
888 if (sym->attr.allocatable == 1)
890 gfc_error ("Variable '%s' at %L cannot have the "
891 "ALLOCATABLE attribute because procedure '%s'"
892 " is BIND(C)", sym->name, &(sym->declared_at),
893 sym->ns->proc_name->name);
897 if (sym->attr.pointer == 1)
899 gfc_error ("Variable '%s' at %L cannot have the "
900 "POINTER attribute because procedure '%s'"
901 " is BIND(C)", sym->name, &(sym->declared_at),
902 sym->ns->proc_name->name);
906 if (sym->attr.optional == 1)
908 gfc_error ("Variable '%s' at %L cannot have the "
909 "OPTIONAL attribute because procedure '%s'"
910 " is BIND(C)", sym->name, &(sym->declared_at),
911 sym->ns->proc_name->name);
915 /* Make sure that if it has the dimension attribute, that it is
916 either assumed size or explicit shape. */
919 if (sym->as->type == AS_ASSUMED_SHAPE)
921 gfc_error ("Assumed-shape array '%s' at %L cannot be an "
922 "argument to the procedure '%s' at %L because "
923 "the procedure is BIND(C)", sym->name,
924 &(sym->declared_at), sym->ns->proc_name->name,
925 &(sym->ns->proc_name->declared_at));
929 if (sym->as->type == AS_DEFERRED)
931 gfc_error ("Deferred-shape array '%s' at %L cannot be an "
932 "argument to the procedure '%s' at %L because "
933 "the procedure is BIND(C)", sym->name,
934 &(sym->declared_at), sym->ns->proc_name->name,
935 &(sym->ns->proc_name->declared_at));
946 /* Function called by variable_decl() that adds a name to the symbol table. */
949 build_sym (const char *name, gfc_charlen *cl,
950 gfc_array_spec **as, locus *var_locus)
952 symbol_attribute attr;
955 if (gfc_get_symbol (name, NULL, &sym))
958 /* Start updating the symbol table. Add basic type attribute if present. */
959 if (current_ts.type != BT_UNKNOWN
960 && (sym->attr.implicit_type == 0
961 || !gfc_compare_types (&sym->ts, ¤t_ts))
962 && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
965 if (sym->ts.type == BT_CHARACTER)
968 /* Add dimension attribute if present. */
969 if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
973 /* Add attribute to symbol. The copy is so that we can reset the
974 dimension attribute. */
978 if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
981 /* Finish any work that may need to be done for the binding label,
982 if it's a bind(c). The bind(c) attr is found before the symbol
983 is made, and before the symbol name (for data decls), so the
984 current_ts is holding the binding label, or nothing if the
985 name= attr wasn't given. Therefore, test here if we're dealing
986 with a bind(c) and make sure the binding label is set correctly. */
987 if (sym->attr.is_bind_c == 1)
989 if (sym->binding_label[0] == '\0')
991 /* Set the binding label and verify that if a NAME= was specified
992 then only one identifier was in the entity-decl-list. */
993 if (set_binding_label (sym->binding_label, sym->name,
994 num_idents_on_line) == FAILURE)
999 /* See if we know we're in a common block, and if it's a bind(c)
1000 common then we need to make sure we're an interoperable type. */
1001 if (sym->attr.in_common == 1)
1003 /* Test the common block object. */
1004 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1005 && sym->ts.is_c_interop != 1)
1007 gfc_error_now ("Variable '%s' in common block '%s' at %C "
1008 "must be declared with a C interoperable "
1009 "kind since common block '%s' is BIND(C)",
1010 sym->name, sym->common_block->name,
1011 sym->common_block->name);
1016 sym->attr.implied_index = 0;
1022 /* Set character constant to the given length. The constant will be padded or
1026 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
1031 gcc_assert (expr->expr_type == EXPR_CONSTANT);
1032 gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
1034 slen = expr->value.character.length;
1037 s = gfc_getmem (len + 1);
1038 memcpy (s, expr->value.character.string, MIN (len, slen));
1040 memset (&s[slen], ' ', len - slen);
1042 if (gfc_option.warn_character_truncation && slen > len)
1043 gfc_warning_now ("CHARACTER expression at %L is being truncated "
1044 "(%d/%d)", &expr->where, slen, len);
1046 /* Apply the standard by 'hand' otherwise it gets cleared for
1048 if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
1049 gfc_error_now ("The CHARACTER elements of the array constructor "
1050 "at %L must have the same length (%d/%d)",
1051 &expr->where, slen, len);
1054 gfc_free (expr->value.character.string);
1055 expr->value.character.string = s;
1056 expr->value.character.length = len;
1061 /* Function to create and update the enumerator history
1062 using the information passed as arguments.
1063 Pointer "max_enum" is also updated, to point to
1064 enum history node containing largest initializer.
1066 SYM points to the symbol node of enumerator.
1067 INIT points to its enumerator value. */
1070 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1072 enumerator_history *new_enum_history;
1073 gcc_assert (sym != NULL && init != NULL);
1075 new_enum_history = gfc_getmem (sizeof (enumerator_history));
1077 new_enum_history->sym = sym;
1078 new_enum_history->initializer = init;
1079 new_enum_history->next = NULL;
1081 if (enum_history == NULL)
1083 enum_history = new_enum_history;
1084 max_enum = enum_history;
1088 new_enum_history->next = enum_history;
1089 enum_history = new_enum_history;
1091 if (mpz_cmp (max_enum->initializer->value.integer,
1092 new_enum_history->initializer->value.integer) < 0)
1093 max_enum = new_enum_history;
1098 /* Function to free enum kind history. */
1101 gfc_free_enum_history (void)
1103 enumerator_history *current = enum_history;
1104 enumerator_history *next;
1106 while (current != NULL)
1108 next = current->next;
1113 enum_history = NULL;
1117 /* Function called by variable_decl() that adds an initialization
1118 expression to a symbol. */
1121 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1123 symbol_attribute attr;
1128 if (find_special (name, &sym))
1133 /* If this symbol is confirming an implicit parameter type,
1134 then an initialization expression is not allowed. */
1135 if (attr.flavor == FL_PARAMETER
1136 && sym->value != NULL
1139 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1148 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
1155 /* An initializer is required for PARAMETER declarations. */
1156 if (attr.flavor == FL_PARAMETER)
1158 gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1164 /* If a variable appears in a DATA block, it cannot have an
1168 gfc_error ("Variable '%s' at %C with an initializer already "
1169 "appears in a DATA statement", sym->name);
1173 /* Check if the assignment can happen. This has to be put off
1174 until later for a derived type variable. */
1175 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1176 && gfc_check_assign_symbol (sym, init) == FAILURE)
1179 if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
1181 /* Update symbol character length according initializer. */
1182 if (sym->ts.cl->length == NULL)
1185 /* If there are multiple CHARACTER variables declared on the
1186 same line, we don't want them to share the same length. */
1187 sym->ts.cl = gfc_get_charlen ();
1188 sym->ts.cl->next = gfc_current_ns->cl_list;
1189 gfc_current_ns->cl_list = sym->ts.cl;
1191 if (sym->attr.flavor == FL_PARAMETER)
1193 if (init->expr_type == EXPR_CONSTANT)
1195 clen = init->value.character.length;
1196 sym->ts.cl->length = gfc_int_expr (clen);
1198 else if (init->expr_type == EXPR_ARRAY)
1200 gfc_expr *p = init->value.constructor->expr;
1201 clen = p->value.character.length;
1202 sym->ts.cl->length = gfc_int_expr (clen);
1204 else if (init->ts.cl && init->ts.cl->length)
1205 sym->ts.cl->length =
1206 gfc_copy_expr (sym->value->ts.cl->length);
1209 /* Update initializer character length according symbol. */
1210 else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1212 int len = mpz_get_si (sym->ts.cl->length->value.integer);
1213 gfc_constructor * p;
1215 if (init->expr_type == EXPR_CONSTANT)
1216 gfc_set_constant_character_len (len, init, false);
1217 else if (init->expr_type == EXPR_ARRAY)
1219 /* Build a new charlen to prevent simplification from
1220 deleting the length before it is resolved. */
1221 init->ts.cl = gfc_get_charlen ();
1222 init->ts.cl->next = gfc_current_ns->cl_list;
1223 gfc_current_ns->cl_list = sym->ts.cl;
1224 init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
1226 for (p = init->value.constructor; p; p = p->next)
1227 gfc_set_constant_character_len (len, p->expr, false);
1232 /* Need to check if the expression we initialized this
1233 to was one of the iso_c_binding named constants. If so,
1234 and we're a parameter (constant), let it be iso_c.
1236 integer(c_int), parameter :: my_int = c_int
1237 integer(my_int) :: my_int_2
1238 If we mark my_int as iso_c (since we can see it's value
1239 is equal to one of the named constants), then my_int_2
1240 will be considered C interoperable. */
1241 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1243 sym->ts.is_iso_c |= init->ts.is_iso_c;
1244 sym->ts.is_c_interop |= init->ts.is_c_interop;
1245 /* attr bits needed for module files. */
1246 sym->attr.is_iso_c |= init->ts.is_iso_c;
1247 sym->attr.is_c_interop |= init->ts.is_c_interop;
1248 if (init->ts.is_iso_c)
1249 sym->ts.f90_type = init->ts.f90_type;
1252 /* Add initializer. Make sure we keep the ranks sane. */
1253 if (sym->attr.dimension && init->rank == 0)
1259 if (sym->attr.flavor == FL_PARAMETER
1260 && init->expr_type == EXPR_CONSTANT
1261 && spec_size (sym->as, &size) == SUCCESS
1262 && mpz_cmp_si (size, 0) > 0)
1264 array = gfc_start_constructor (init->ts.type, init->ts.kind,
1267 array->value.constructor = c = NULL;
1268 for (n = 0; n < (int)mpz_get_si (size); n++)
1270 if (array->value.constructor == NULL)
1272 array->value.constructor = c = gfc_get_constructor ();
1277 c->next = gfc_get_constructor ();
1279 c->expr = gfc_copy_expr (init);
1283 array->shape = gfc_get_shape (sym->as->rank);
1284 for (n = 0; n < sym->as->rank; n++)
1285 spec_dimen_size (sym->as, n, &array->shape[n]);
1290 init->rank = sym->as->rank;
1294 if (sym->attr.save == SAVE_NONE)
1295 sym->attr.save = SAVE_IMPLICIT;
1303 /* Function called by variable_decl() that adds a name to a structure
1307 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1308 gfc_array_spec **as)
1312 /* If the current symbol is of the same derived type that we're
1313 constructing, it must have the pointer attribute. */
1314 if (current_ts.type == BT_DERIVED
1315 && current_ts.derived == gfc_current_block ()
1316 && current_attr.pointer == 0)
1318 gfc_error ("Component at %C must have the POINTER attribute");
1322 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1324 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1326 gfc_error ("Array component of structure at %C must have explicit "
1327 "or deferred shape");
1332 if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1337 gfc_set_component_attr (c, ¤t_attr);
1339 c->initializer = *init;
1347 /* Check array components. */
1352 gfc_error ("Allocatable component at %C must be an array");
1361 if (c->as->type != AS_DEFERRED)
1363 gfc_error ("Pointer array component of structure at %C must have a "
1368 else if (c->allocatable)
1370 if (c->as->type != AS_DEFERRED)
1372 gfc_error ("Allocatable component of structure at %C must have a "
1379 if (c->as->type != AS_EXPLICIT)
1381 gfc_error ("Array component of structure at %C must have an "
1391 /* Match a 'NULL()', and possibly take care of some side effects. */
1394 gfc_match_null (gfc_expr **result)
1400 m = gfc_match (" null ( )");
1404 /* The NULL symbol now has to be/become an intrinsic function. */
1405 if (gfc_get_symbol ("null", NULL, &sym))
1407 gfc_error ("NULL() initialization at %C is ambiguous");
1411 gfc_intrinsic_symbol (sym);
1413 if (sym->attr.proc != PROC_INTRINSIC
1414 && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1415 sym->name, NULL) == FAILURE
1416 || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1419 e = gfc_get_expr ();
1420 e->where = gfc_current_locus;
1421 e->expr_type = EXPR_NULL;
1422 e->ts.type = BT_UNKNOWN;
1430 /* Match a variable name with an optional initializer. When this
1431 subroutine is called, a variable is expected to be parsed next.
1432 Depending on what is happening at the moment, updates either the
1433 symbol table or the current interface. */
1436 variable_decl (int elem)
1438 char name[GFC_MAX_SYMBOL_LEN + 1];
1439 gfc_expr *initializer, *char_len;
1441 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
1452 old_locus = gfc_current_locus;
1454 /* When we get here, we've just matched a list of attributes and
1455 maybe a type and a double colon. The next thing we expect to see
1456 is the name of the symbol. */
1457 m = gfc_match_name (name);
1461 var_locus = gfc_current_locus;
1463 /* Now we could see the optional array spec. or character length. */
1464 m = gfc_match_array_spec (&as);
1465 if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1466 cp_as = gfc_copy_array_spec (as);
1467 else if (m == MATCH_ERROR)
1471 as = gfc_copy_array_spec (current_as);
1476 if (current_ts.type == BT_CHARACTER)
1478 switch (match_char_length (&char_len))
1481 cl = gfc_get_charlen ();
1482 cl->next = gfc_current_ns->cl_list;
1483 gfc_current_ns->cl_list = cl;
1485 cl->length = char_len;
1488 /* Non-constant lengths need to be copied after the first
1489 element. Also copy assumed lengths. */
1492 && (current_ts.cl->length == NULL
1493 || current_ts.cl->length->expr_type != EXPR_CONSTANT))
1495 cl = gfc_get_charlen ();
1496 cl->next = gfc_current_ns->cl_list;
1497 gfc_current_ns->cl_list = cl;
1498 cl->length = gfc_copy_expr (current_ts.cl->length);
1510 /* If this symbol has already shown up in a Cray Pointer declaration,
1511 then we want to set the type & bail out. */
1512 if (gfc_option.flag_cray_pointer)
1514 gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1515 if (sym != NULL && sym->attr.cray_pointee)
1517 sym->ts.type = current_ts.type;
1518 sym->ts.kind = current_ts.kind;
1520 sym->ts.derived = current_ts.derived;
1521 sym->ts.is_c_interop = current_ts.is_c_interop;
1522 sym->ts.is_iso_c = current_ts.is_iso_c;
1525 /* Check to see if we have an array specification. */
1528 if (sym->as != NULL)
1530 gfc_error ("Duplicate array spec for Cray pointee at %C");
1531 gfc_free_array_spec (cp_as);
1537 if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1538 gfc_internal_error ("Couldn't set pointee array spec.");
1540 /* Fix the array spec. */
1541 m = gfc_mod_pointee_as (sym->as);
1542 if (m == MATCH_ERROR)
1550 gfc_free_array_spec (cp_as);
1555 /* OK, we've successfully matched the declaration. Now put the
1556 symbol in the current namespace, because it might be used in the
1557 optional initialization expression for this symbol, e.g. this is
1560 integer, parameter :: i = huge(i)
1562 This is only true for parameters or variables of a basic type.
1563 For components of derived types, it is not true, so we don't
1564 create a symbol for those yet. If we fail to create the symbol,
1566 if (gfc_current_state () != COMP_DERIVED
1567 && build_sym (name, cl, &as, &var_locus) == FAILURE)
1573 /* An interface body specifies all of the procedure's
1574 characteristics and these shall be consistent with those
1575 specified in the procedure definition, except that the interface
1576 may specify a procedure that is not pure if the procedure is
1577 defined to be pure(12.3.2). */
1578 if (current_ts.type == BT_DERIVED
1579 && gfc_current_ns->proc_name
1580 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1581 && current_ts.derived->ns != gfc_current_ns)
1584 st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.derived->name);
1585 if (!(current_ts.derived->attr.imported
1587 && st->n.sym == current_ts.derived)
1588 && !gfc_current_ns->has_import_set)
1590 gfc_error ("the type of '%s' at %C has not been declared within the "
1597 /* In functions that have a RESULT variable defined, the function
1598 name always refers to function calls. Therefore, the name is
1599 not allowed to appear in specification statements. */
1600 if (gfc_current_state () == COMP_FUNCTION
1601 && gfc_current_block () != NULL
1602 && gfc_current_block ()->result != NULL
1603 && gfc_current_block ()->result != gfc_current_block ()
1604 && strcmp (gfc_current_block ()->name, name) == 0)
1606 gfc_error ("Function name '%s' not allowed at %C", name);
1611 /* We allow old-style initializations of the form
1612 integer i /2/, j(4) /3*3, 1/
1613 (if no colon has been seen). These are different from data
1614 statements in that initializers are only allowed to apply to the
1615 variable immediately preceding, i.e.
1617 is not allowed. Therefore we have to do some work manually, that
1618 could otherwise be left to the matchers for DATA statements. */
1620 if (!colon_seen && gfc_match (" /") == MATCH_YES)
1622 if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1623 "initialization at %C") == FAILURE)
1626 return match_old_style_init (name);
1629 /* The double colon must be present in order to have initializers.
1630 Otherwise the statement is ambiguous with an assignment statement. */
1633 if (gfc_match (" =>") == MATCH_YES)
1635 if (!current_attr.pointer)
1637 gfc_error ("Initialization at %C isn't for a pointer variable");
1642 m = gfc_match_null (&initializer);
1645 gfc_error ("Pointer initialization requires a NULL() at %C");
1649 if (gfc_pure (NULL))
1651 gfc_error ("Initialization of pointer at %C is not allowed in "
1652 "a PURE procedure");
1660 else if (gfc_match_char ('=') == MATCH_YES)
1662 if (current_attr.pointer)
1664 gfc_error ("Pointer initialization at %C requires '=>', "
1670 m = gfc_match_init_expr (&initializer);
1673 gfc_error ("Expected an initialization expression at %C");
1677 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1679 gfc_error ("Initialization of variable at %C is not allowed in "
1680 "a PURE procedure");
1689 if (initializer != NULL && current_attr.allocatable
1690 && gfc_current_state () == COMP_DERIVED)
1692 gfc_error ("Initialization of allocatable component at %C is not "
1698 /* Add the initializer. Note that it is fine if initializer is
1699 NULL here, because we sometimes also need to check if a
1700 declaration *must* have an initialization expression. */
1701 if (gfc_current_state () != COMP_DERIVED)
1702 t = add_init_expr_to_sym (name, &initializer, &var_locus);
1705 if (current_ts.type == BT_DERIVED
1706 && !current_attr.pointer && !initializer)
1707 initializer = gfc_default_initializer (¤t_ts);
1708 t = build_struct (name, cl, &initializer, &as);
1711 m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1714 /* Free stuff up and return. */
1715 gfc_free_expr (initializer);
1716 gfc_free_array_spec (as);
1722 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1723 This assumes that the byte size is equal to the kind number for
1724 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
1727 gfc_match_old_kind_spec (gfc_typespec *ts)
1732 if (gfc_match_char ('*') != MATCH_YES)
1735 m = gfc_match_small_literal_int (&ts->kind, NULL);
1739 original_kind = ts->kind;
1741 /* Massage the kind numbers for complex types. */
1742 if (ts->type == BT_COMPLEX)
1746 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1747 gfc_basic_typename (ts->type), original_kind);
1753 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1755 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1756 gfc_basic_typename (ts->type), original_kind);
1760 if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1761 gfc_basic_typename (ts->type), original_kind) == FAILURE)
1768 /* Match a kind specification. Since kinds are generally optional, we
1769 usually return MATCH_NO if something goes wrong. If a "kind="
1770 string is found, then we know we have an error. */
1773 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
1784 where = loc = gfc_current_locus;
1789 if (gfc_match_char ('(') == MATCH_NO)
1792 /* Also gobbles optional text. */
1793 if (gfc_match (" kind = ") == MATCH_YES)
1796 loc = gfc_current_locus;
1799 n = gfc_match_init_expr (&e);
1803 if (gfc_current_state () == COMP_INTERFACE
1804 || gfc_current_state () == COMP_NONE
1805 || gfc_current_state () == COMP_CONTAINS)
1807 /* Signal using kind = -1 that the expression might include
1808 use associated or imported parameters and try again after
1809 the specification expressions..... */
1810 if (gfc_match_char (')') != MATCH_YES)
1812 gfc_error ("Missing right parenthesis at %C");
1819 gfc_function_kind_locus = loc;
1820 gfc_undo_symbols ();
1825 /* ....or else, the match is real. */
1827 gfc_error ("Expected initialization expression at %C");
1835 gfc_error ("Expected scalar initialization expression at %C");
1840 msg = gfc_extract_int (e, &ts->kind);
1848 /* Before throwing away the expression, let's see if we had a
1849 C interoperable kind (and store the fact). */
1850 if (e->ts.is_c_interop == 1)
1852 /* Mark this as c interoperable if being declared with one
1853 of the named constants from iso_c_binding. */
1854 ts->is_c_interop = e->ts.is_iso_c;
1855 ts->f90_type = e->ts.f90_type;
1861 /* Ignore errors to this point, if we've gotten here. This means
1862 we ignore the m=MATCH_ERROR from above. */
1863 if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1865 gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1866 gfc_basic_typename (ts->type));
1869 else if (gfc_match_char (')') != MATCH_YES)
1871 gfc_error ("Missing right parenthesis at %C");
1875 /* All tests passed. */
1878 if(m == MATCH_ERROR)
1879 gfc_current_locus = where;
1881 /* Return what we know from the test(s). */
1886 gfc_current_locus = where;
1892 match_char_kind (int * kind, int * is_iso_c)
1901 where = gfc_current_locus;
1903 n = gfc_match_init_expr (&e);
1905 gfc_error ("Expected initialization expression at %C");
1911 gfc_error ("Expected scalar initialization expression at %C");
1916 msg = gfc_extract_int (e, kind);
1917 *is_iso_c = e->ts.is_iso_c;
1927 /* Ignore errors to this point, if we've gotten here. This means
1928 we ignore the m=MATCH_ERROR from above. */
1929 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
1931 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
1935 /* All tests passed. */
1938 if (m == MATCH_ERROR)
1939 gfc_current_locus = where;
1941 /* Return what we know from the test(s). */
1946 gfc_current_locus = where;
1950 /* Match the various kind/length specifications in a CHARACTER
1951 declaration. We don't return MATCH_NO. */
1954 match_char_spec (gfc_typespec *ts)
1956 int kind, seen_length, is_iso_c;
1966 /* Try the old-style specification first. */
1967 old_char_selector = 0;
1969 m = match_char_length (&len);
1973 old_char_selector = 1;
1978 m = gfc_match_char ('(');
1981 m = MATCH_YES; /* Character without length is a single char. */
1985 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
1986 if (gfc_match (" kind =") == MATCH_YES)
1988 m = match_char_kind (&kind, &is_iso_c);
1990 if (m == MATCH_ERROR)
1995 if (gfc_match (" , len =") == MATCH_NO)
1998 m = char_len_param_value (&len);
2001 if (m == MATCH_ERROR)
2008 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2009 if (gfc_match (" len =") == MATCH_YES)
2011 m = char_len_param_value (&len);
2014 if (m == MATCH_ERROR)
2018 if (gfc_match_char (')') == MATCH_YES)
2021 if (gfc_match (" , kind =") != MATCH_YES)
2024 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2030 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2031 m = char_len_param_value (&len);
2034 if (m == MATCH_ERROR)
2038 m = gfc_match_char (')');
2042 if (gfc_match_char (',') != MATCH_YES)
2045 gfc_match (" kind ="); /* Gobble optional text. */
2047 m = match_char_kind (&kind, &is_iso_c);
2048 if (m == MATCH_ERROR)
2054 /* Require a right-paren at this point. */
2055 m = gfc_match_char (')');
2060 gfc_error ("Syntax error in CHARACTER declaration at %C");
2062 gfc_free_expr (len);
2068 gfc_free_expr (len);
2072 /* Do some final massaging of the length values. */
2073 cl = gfc_get_charlen ();
2074 cl->next = gfc_current_ns->cl_list;
2075 gfc_current_ns->cl_list = cl;
2077 if (seen_length == 0)
2078 cl->length = gfc_int_expr (1);
2083 ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2085 /* We have to know if it was a c interoperable kind so we can
2086 do accurate type checking of bind(c) procs, etc. */
2088 /* Mark this as c interoperable if being declared with one
2089 of the named constants from iso_c_binding. */
2090 ts->is_c_interop = is_iso_c;
2091 else if (len != NULL)
2092 /* Here, we might have parsed something such as: character(c_char)
2093 In this case, the parsing code above grabs the c_char when
2094 looking for the length (line 1690, roughly). it's the last
2095 testcase for parsing the kind params of a character variable.
2096 However, it's not actually the length. this seems like it
2098 To see if the user used a C interop kind, test the expr
2099 of the so called length, and see if it's C interoperable. */
2100 ts->is_c_interop = len->ts.is_iso_c;
2106 /* Matches a type specification. If successful, sets the ts structure
2107 to the matched specification. This is necessary for FUNCTION and
2108 IMPLICIT statements.
2110 If implicit_flag is nonzero, then we don't check for the optional
2111 kind specification. Not doing so is needed for matching an IMPLICIT
2112 statement correctly. */
2115 gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
2117 char name[GFC_MAX_SYMBOL_LEN + 1];
2121 locus loc = gfc_current_locus;
2125 /* Clear the current binding label, in case one is given. */
2126 curr_binding_label[0] = '\0';
2128 if (gfc_match (" byte") == MATCH_YES)
2130 if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
2134 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2136 gfc_error ("BYTE type used at %C "
2137 "is not available on the target machine");
2141 ts->type = BT_INTEGER;
2146 if (gfc_match (" integer") == MATCH_YES)
2148 ts->type = BT_INTEGER;
2149 ts->kind = gfc_default_integer_kind;
2153 if (gfc_match (" character") == MATCH_YES)
2155 ts->type = BT_CHARACTER;
2156 if (implicit_flag == 0)
2157 return match_char_spec (ts);
2162 if (gfc_match (" real") == MATCH_YES)
2165 ts->kind = gfc_default_real_kind;
2169 if (gfc_match (" double precision") == MATCH_YES)
2172 ts->kind = gfc_default_double_kind;
2176 if (gfc_match (" complex") == MATCH_YES)
2178 ts->type = BT_COMPLEX;
2179 ts->kind = gfc_default_complex_kind;
2183 if (gfc_match (" double complex") == MATCH_YES)
2185 if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2186 "conform to the Fortran 95 standard") == FAILURE)
2189 ts->type = BT_COMPLEX;
2190 ts->kind = gfc_default_double_kind;
2194 if (gfc_match (" logical") == MATCH_YES)
2196 ts->type = BT_LOGICAL;
2197 ts->kind = gfc_default_logical_kind;
2201 m = gfc_match (" type ( %n )", name);
2205 if (gfc_current_state () == COMP_INTERFACE
2206 || gfc_current_state () == COMP_NONE)
2208 gfc_function_type_locus = loc;
2209 ts->type = BT_UNKNOWN;
2214 /* Search for the name but allow the components to be defined later. If
2215 type = -1, this typespec has been seen in a function declaration but
2216 the type could not legally be accessed at that point. */
2217 if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2219 gfc_error ("Type name '%s' at %C is ambiguous", name);
2222 else if (ts->kind == -1)
2224 if (gfc_find_symbol (name, NULL, 0, &sym))
2226 gfc_error ("Type name '%s' at %C is ambiguous", name);
2234 if (sym->attr.flavor != FL_DERIVED
2235 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2238 ts->type = BT_DERIVED;
2245 /* For all types except double, derived and character, look for an
2246 optional kind specifier. MATCH_NO is actually OK at this point. */
2247 if (implicit_flag == 1)
2250 if (gfc_current_form == FORM_FREE)
2252 c = gfc_peek_char();
2253 if (!gfc_is_whitespace(c) && c != '*' && c != '('
2254 && c != ':' && c != ',')
2258 m = gfc_match_kind_spec (ts, false);
2259 if (m == MATCH_NO && ts->type != BT_CHARACTER)
2260 m = gfc_match_old_kind_spec (ts);
2263 m = MATCH_YES; /* No kind specifier found. */
2269 /* Match an IMPLICIT NONE statement. Actually, this statement is
2270 already matched in parse.c, or we would not end up here in the
2271 first place. So the only thing we need to check, is if there is
2272 trailing garbage. If not, the match is successful. */
2275 gfc_match_implicit_none (void)
2277 return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2281 /* Match the letter range(s) of an IMPLICIT statement. */
2284 match_implicit_range (void)
2286 int c, c1, c2, inner;
2289 cur_loc = gfc_current_locus;
2291 gfc_gobble_whitespace ();
2292 c = gfc_next_char ();
2295 gfc_error ("Missing character range in IMPLICIT at %C");
2302 gfc_gobble_whitespace ();
2303 c1 = gfc_next_char ();
2307 gfc_gobble_whitespace ();
2308 c = gfc_next_char ();
2313 inner = 0; /* Fall through. */
2320 gfc_gobble_whitespace ();
2321 c2 = gfc_next_char ();
2325 gfc_gobble_whitespace ();
2326 c = gfc_next_char ();
2328 if ((c != ',') && (c != ')'))
2341 gfc_error ("Letters must be in alphabetic order in "
2342 "IMPLICIT statement at %C");
2346 /* See if we can add the newly matched range to the pending
2347 implicits from this IMPLICIT statement. We do not check for
2348 conflicts with whatever earlier IMPLICIT statements may have
2349 set. This is done when we've successfully finished matching
2351 if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2358 gfc_syntax_error (ST_IMPLICIT);
2360 gfc_current_locus = cur_loc;
2365 /* Match an IMPLICIT statement, storing the types for
2366 gfc_set_implicit() if the statement is accepted by the parser.
2367 There is a strange looking, but legal syntactic construction
2368 possible. It looks like:
2370 IMPLICIT INTEGER (a-b) (c-d)
2372 This is legal if "a-b" is a constant expression that happens to
2373 equal one of the legal kinds for integers. The real problem
2374 happens with an implicit specification that looks like:
2376 IMPLICIT INTEGER (a-b)
2378 In this case, a typespec matcher that is "greedy" (as most of the
2379 matchers are) gobbles the character range as a kindspec, leaving
2380 nothing left. We therefore have to go a bit more slowly in the
2381 matching process by inhibiting the kindspec checking during
2382 typespec matching and checking for a kind later. */
2385 gfc_match_implicit (void)
2392 /* We don't allow empty implicit statements. */
2393 if (gfc_match_eos () == MATCH_YES)
2395 gfc_error ("Empty IMPLICIT statement at %C");
2401 /* First cleanup. */
2402 gfc_clear_new_implicit ();
2404 /* A basic type is mandatory here. */
2405 m = gfc_match_type_spec (&ts, 1);
2406 if (m == MATCH_ERROR)
2411 cur_loc = gfc_current_locus;
2412 m = match_implicit_range ();
2416 /* We may have <TYPE> (<RANGE>). */
2417 gfc_gobble_whitespace ();
2418 c = gfc_next_char ();
2419 if ((c == '\n') || (c == ','))
2421 /* Check for CHARACTER with no length parameter. */
2422 if (ts.type == BT_CHARACTER && !ts.cl)
2424 ts.kind = gfc_default_character_kind;
2425 ts.cl = gfc_get_charlen ();
2426 ts.cl->next = gfc_current_ns->cl_list;
2427 gfc_current_ns->cl_list = ts.cl;
2428 ts.cl->length = gfc_int_expr (1);
2431 /* Record the Successful match. */
2432 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2437 gfc_current_locus = cur_loc;
2440 /* Discard the (incorrectly) matched range. */
2441 gfc_clear_new_implicit ();
2443 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
2444 if (ts.type == BT_CHARACTER)
2445 m = match_char_spec (&ts);
2448 m = gfc_match_kind_spec (&ts, false);
2451 m = gfc_match_old_kind_spec (&ts);
2452 if (m == MATCH_ERROR)
2458 if (m == MATCH_ERROR)
2461 m = match_implicit_range ();
2462 if (m == MATCH_ERROR)
2467 gfc_gobble_whitespace ();
2468 c = gfc_next_char ();
2469 if ((c != '\n') && (c != ','))
2472 if (gfc_merge_new_implicit (&ts) != SUCCESS)
2480 gfc_syntax_error (ST_IMPLICIT);
2488 gfc_match_import (void)
2490 char name[GFC_MAX_SYMBOL_LEN + 1];
2495 if (gfc_current_ns->proc_name == NULL
2496 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2498 gfc_error ("IMPORT statement at %C only permitted in "
2499 "an INTERFACE body");
2503 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2507 if (gfc_match_eos () == MATCH_YES)
2509 /* All host variables should be imported. */
2510 gfc_current_ns->has_import_set = 1;
2514 if (gfc_match (" ::") == MATCH_YES)
2516 if (gfc_match_eos () == MATCH_YES)
2518 gfc_error ("Expecting list of named entities at %C");
2525 m = gfc_match (" %n", name);
2529 if (gfc_current_ns->parent != NULL
2530 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2532 gfc_error ("Type name '%s' at %C is ambiguous", name);
2535 else if (gfc_current_ns->proc_name->ns->parent != NULL
2536 && gfc_find_symbol (name,
2537 gfc_current_ns->proc_name->ns->parent,
2540 gfc_error ("Type name '%s' at %C is ambiguous", name);
2546 gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2547 "at %C - does not exist.", name);
2551 if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2553 gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2558 st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2561 sym->attr.imported = 1;
2573 if (gfc_match_eos () == MATCH_YES)
2575 if (gfc_match_char (',') != MATCH_YES)
2582 gfc_error ("Syntax error in IMPORT statement at %C");
2587 /* A minimal implementation of gfc_match without whitespace, escape
2588 characters or variable arguments. Returns true if the next
2589 characters match the TARGET template exactly. */
2592 match_string_p (const char *target)
2596 for (p = target; *p; p++)
2597 if (gfc_next_char () != *p)
2602 /* Matches an attribute specification including array specs. If
2603 successful, leaves the variables current_attr and current_as
2604 holding the specification. Also sets the colon_seen variable for
2605 later use by matchers associated with initializations.
2607 This subroutine is a little tricky in the sense that we don't know
2608 if we really have an attr-spec until we hit the double colon.
2609 Until that time, we can only return MATCH_NO. This forces us to
2610 check for duplicate specification at this level. */
2613 match_attr_spec (void)
2615 /* Modifiers that can exist in a type statement. */
2617 { GFC_DECL_BEGIN = 0,
2618 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2619 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2620 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2621 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2622 DECL_IS_BIND_C, DECL_NONE,
2623 GFC_DECL_END /* Sentinel */
2627 /* GFC_DECL_END is the sentinel, index starts at 0. */
2628 #define NUM_DECL GFC_DECL_END
2630 locus start, seen_at[NUM_DECL];
2637 gfc_clear_attr (¤t_attr);
2638 start = gfc_current_locus;
2643 /* See if we get all of the keywords up to the final double colon. */
2644 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2652 gfc_gobble_whitespace ();
2654 ch = gfc_next_char ();
2657 /* This is the successful exit condition for the loop. */
2658 if (gfc_next_char () == ':')
2663 gfc_gobble_whitespace ();
2664 switch (gfc_peek_char ())
2667 if (match_string_p ("allocatable"))
2668 d = DECL_ALLOCATABLE;
2672 /* Try and match the bind(c). */
2673 m = gfc_match_bind_c (NULL);
2676 else if (m == MATCH_ERROR)
2681 if (match_string_p ("dimension"))
2686 if (match_string_p ("external"))
2691 if (match_string_p ("int"))
2693 ch = gfc_next_char ();
2696 if (match_string_p ("nt"))
2698 /* Matched "intent". */
2699 /* TODO: Call match_intent_spec from here. */
2700 if (gfc_match (" ( in out )") == MATCH_YES)
2702 else if (gfc_match (" ( in )") == MATCH_YES)
2704 else if (gfc_match (" ( out )") == MATCH_YES)
2710 if (match_string_p ("insic"))
2712 /* Matched "intrinsic". */
2720 if (match_string_p ("optional"))
2726 switch (gfc_next_char ())
2729 if (match_string_p ("rameter"))
2731 /* Matched "parameter". */
2737 if (match_string_p ("inter"))
2739 /* Matched "pointer". */
2745 ch = gfc_next_char ();
2748 if (match_string_p ("vate"))
2750 /* Matched "private". */
2756 if (match_string_p ("tected"))
2758 /* Matched "protected". */
2765 if (match_string_p ("blic"))
2767 /* Matched "public". */
2775 if (match_string_p ("save"))
2780 if (match_string_p ("target"))
2786 ch = gfc_next_char ();
2789 if (match_string_p ("lue"))
2791 /* Matched "value". */
2797 if (match_string_p ("latile"))
2799 /* Matched "volatile". */
2807 /* No double colon and no recognizable decl_type, so assume that
2808 we've been looking at something else the whole time. */
2816 seen_at[d] = gfc_current_locus;
2818 if (d == DECL_DIMENSION)
2820 m = gfc_match_array_spec (¤t_as);
2824 gfc_error ("Missing dimension specification at %C");
2828 if (m == MATCH_ERROR)
2833 /* Since we've seen a double colon, we have to be looking at an
2834 attr-spec. This means that we can now issue errors. */
2835 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2840 case DECL_ALLOCATABLE:
2841 attr = "ALLOCATABLE";
2843 case DECL_DIMENSION:
2850 attr = "INTENT (IN)";
2853 attr = "INTENT (OUT)";
2856 attr = "INTENT (IN OUT)";
2858 case DECL_INTRINSIC:
2864 case DECL_PARAMETER:
2870 case DECL_PROTECTED:
2885 case DECL_IS_BIND_C:
2895 attr = NULL; /* This shouldn't happen. */
2898 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2903 /* Now that we've dealt with duplicate attributes, add the attributes
2904 to the current attribute. */
2905 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2910 if (gfc_current_state () == COMP_DERIVED
2911 && d != DECL_DIMENSION && d != DECL_POINTER
2912 && d != DECL_PRIVATE && d != DECL_PUBLIC
2915 if (d == DECL_ALLOCATABLE)
2917 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2918 "attribute at %C in a TYPE definition")
2927 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2934 if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2935 && gfc_current_state () != COMP_MODULE)
2937 if (d == DECL_PRIVATE)
2941 if (gfc_current_state () == COMP_DERIVED
2942 && gfc_state_stack->previous
2943 && gfc_state_stack->previous->state == COMP_MODULE)
2945 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2946 "at %L in a TYPE definition", attr,
2956 gfc_error ("%s attribute at %L is not allowed outside of the "
2957 "specification part of a module", attr, &seen_at[d]);
2965 case DECL_ALLOCATABLE:
2966 t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
2969 case DECL_DIMENSION:
2970 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
2974 t = gfc_add_external (¤t_attr, &seen_at[d]);
2978 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
2982 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
2986 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
2989 case DECL_INTRINSIC:
2990 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
2994 t = gfc_add_optional (¤t_attr, &seen_at[d]);
2997 case DECL_PARAMETER:
2998 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
3002 t = gfc_add_pointer (¤t_attr, &seen_at[d]);
3005 case DECL_PROTECTED:
3006 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3008 gfc_error ("PROTECTED at %C only allowed in specification "
3009 "part of a module");
3014 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3019 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
3023 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
3028 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
3033 t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
3037 t = gfc_add_target (¤t_attr, &seen_at[d]);
3040 case DECL_IS_BIND_C:
3041 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
3045 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3050 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
3054 if (gfc_notify_std (GFC_STD_F2003,
3055 "Fortran 2003: VOLATILE attribute at %C")
3059 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
3063 gfc_internal_error ("match_attr_spec(): Bad attribute");
3077 gfc_current_locus = start;
3078 gfc_free_array_spec (current_as);
3084 /* Set the binding label, dest_label, either with the binding label
3085 stored in the given gfc_typespec, ts, or if none was provided, it
3086 will be the symbol name in all lower case, as required by the draft
3087 (J3/04-007, section 15.4.1). If a binding label was given and
3088 there is more than one argument (num_idents), it is an error. */
3091 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3093 if (num_idents > 1 && has_name_equals)
3095 gfc_error ("Multiple identifiers provided with "
3096 "single NAME= specifier at %C");
3100 if (curr_binding_label[0] != '\0')
3102 /* Binding label given; store in temp holder til have sym. */
3103 strncpy (dest_label, curr_binding_label,
3104 strlen (curr_binding_label) + 1);
3108 /* No binding label given, and the NAME= specifier did not exist,
3109 which means there was no NAME="". */
3110 if (sym_name != NULL && has_name_equals == 0)
3111 strncpy (dest_label, sym_name, strlen (sym_name) + 1);
3118 /* Set the status of the given common block as being BIND(C) or not,
3119 depending on the given parameter, is_bind_c. */
3122 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3124 com_block->is_bind_c = is_bind_c;
3129 /* Verify that the given gfc_typespec is for a C interoperable type. */
3132 verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
3136 /* Make sure the kind used is appropriate for the type.
3137 The f90_type is unknown if an integer constant was
3138 used (e.g., real(4), bind(c) :: myFloat). */
3139 if (ts->f90_type != BT_UNKNOWN)
3141 t = gfc_validate_c_kind (ts);
3144 /* Print an error, but continue parsing line. */
3145 gfc_error_now ("C kind parameter is for type %s but "
3146 "symbol '%s' at %L is of type %s",
3147 gfc_basic_typename (ts->f90_type),
3149 gfc_basic_typename (ts->type));
3153 /* Make sure the kind is C interoperable. This does not care about the
3154 possible error above. */
3155 if (ts->type == BT_DERIVED && ts->derived != NULL)
3156 return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
3157 else if (ts->is_c_interop != 1)
3164 /* Verify that the variables of a given common block, which has been
3165 defined with the attribute specifier bind(c), to be of a C
3166 interoperable type. Errors will be reported here, if
3170 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3172 gfc_symbol *curr_sym = NULL;
3173 try retval = SUCCESS;
3175 curr_sym = com_block->head;
3177 /* Make sure we have at least one symbol. */
3178 if (curr_sym == NULL)
3181 /* Here we know we have a symbol, so we'll execute this loop
3185 /* The second to last param, 1, says this is in a common block. */
3186 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3187 curr_sym = curr_sym->common_next;
3188 } while (curr_sym != NULL);
3194 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
3195 an appropriate error message is reported. */
3198 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3199 int is_in_common, gfc_common_head *com_block)
3201 try retval = SUCCESS;
3203 if (tmp_sym->attr.function && tmp_sym->result != NULL)
3205 tmp_sym = tmp_sym->result;
3206 /* Make sure it wasn't an implicitly typed result. */
3207 if (tmp_sym->attr.implicit_type)
3209 gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3210 "%L may not be C interoperable", tmp_sym->name,
3211 &tmp_sym->declared_at);
3212 tmp_sym->ts.f90_type = tmp_sym->ts.type;
3213 /* Mark it as C interoperable to prevent duplicate warnings. */
3214 tmp_sym->ts.is_c_interop = 1;
3215 tmp_sym->attr.is_c_interop = 1;
3219 /* Here, we know we have the bind(c) attribute, so if we have
3220 enough type info, then verify that it's a C interop kind.
3221 The info could be in the symbol already, or possibly still in
3222 the given ts (current_ts), so look in both. */
3223 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
3225 if (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
3226 &(tmp_sym->declared_at)) != SUCCESS)
3228 /* See if we're dealing with a sym in a common block or not. */
3229 if (is_in_common == 1)
3231 gfc_warning ("Variable '%s' in common block '%s' at %L "
3232 "may not be a C interoperable "
3233 "kind though common block '%s' is BIND(C)",
3234 tmp_sym->name, com_block->name,
3235 &(tmp_sym->declared_at), com_block->name);
3239 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3240 gfc_error ("Type declaration '%s' at %L is not C "
3241 "interoperable but it is BIND(C)",
3242 tmp_sym->name, &(tmp_sym->declared_at));
3244 gfc_warning ("Variable '%s' at %L "
3245 "may not be a C interoperable "
3246 "kind but it is bind(c)",
3247 tmp_sym->name, &(tmp_sym->declared_at));
3251 /* Variables declared w/in a common block can't be bind(c)
3252 since there's no way for C to see these variables, so there's
3253 semantically no reason for the attribute. */
3254 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3256 gfc_error ("Variable '%s' in common block '%s' at "
3257 "%L cannot be declared with BIND(C) "
3258 "since it is not a global",
3259 tmp_sym->name, com_block->name,
3260 &(tmp_sym->declared_at));
3264 /* Scalar variables that are bind(c) can not have the pointer
3265 or allocatable attributes. */
3266 if (tmp_sym->attr.is_bind_c == 1)
3268 if (tmp_sym->attr.pointer == 1)
3270 gfc_error ("Variable '%s' at %L cannot have both the "
3271 "POINTER and BIND(C) attributes",
3272 tmp_sym->name, &(tmp_sym->declared_at));
3276 if (tmp_sym->attr.allocatable == 1)
3278 gfc_error ("Variable '%s' at %L cannot have both the "
3279 "ALLOCATABLE and BIND(C) attributes",
3280 tmp_sym->name, &(tmp_sym->declared_at));
3284 /* If it is a BIND(C) function, make sure the return value is a
3285 scalar value. The previous tests in this function made sure
3286 the type is interoperable. */
3287 if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
3288 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3289 "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3291 /* BIND(C) functions can not return a character string. */
3292 if (tmp_sym->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
3293 if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
3294 || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
3295 || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
3296 gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3297 "be a character string", tmp_sym->name,
3298 &(tmp_sym->declared_at));
3302 /* See if the symbol has been marked as private. If it has, make sure
3303 there is no binding label and warn the user if there is one. */
3304 if (tmp_sym->attr.access == ACCESS_PRIVATE
3305 && tmp_sym->binding_label[0] != '\0')
3306 /* Use gfc_warning_now because we won't say that the symbol fails
3307 just because of this. */
3308 gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3309 "given the binding label '%s'", tmp_sym->name,
3310 &(tmp_sym->declared_at), tmp_sym->binding_label);
3316 /* Set the appropriate fields for a symbol that's been declared as
3317 BIND(C) (the is_bind_c flag and the binding label), and verify that
3318 the type is C interoperable. Errors are reported by the functions
3319 used to set/test these fields. */
3322 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3324 try retval = SUCCESS;
3326 /* TODO: Do we need to make sure the vars aren't marked private? */
3328 /* Set the is_bind_c bit in symbol_attribute. */
3329 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3331 if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
3332 num_idents) != SUCCESS)
3339 /* Set the fields marking the given common block as BIND(C), including
3340 a binding label, and report any errors encountered. */
3343 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3345 try retval = SUCCESS;
3347 /* destLabel, common name, typespec (which may have binding label). */
3348 if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3352 /* Set the given common block (com_block) to being bind(c) (1). */
3353 set_com_block_bind_c (com_block, 1);
3359 /* Retrieve the list of one or more identifiers that the given bind(c)
3360 attribute applies to. */
3363 get_bind_c_idents (void)
3365 char name[GFC_MAX_SYMBOL_LEN + 1];
3367 gfc_symbol *tmp_sym = NULL;
3369 gfc_common_head *com_block = NULL;
3371 if (gfc_match_name (name) == MATCH_YES)
3373 found_id = MATCH_YES;
3374 gfc_get_ha_symbol (name, &tmp_sym);
3376 else if (match_common_name (name) == MATCH_YES)
3378 found_id = MATCH_YES;
3379 com_block = gfc_get_common (name, 0);
3383 gfc_error ("Need either entity or common block name for "
3384 "attribute specification statement at %C");
3388 /* Save the current identifier and look for more. */
3391 /* Increment the number of identifiers found for this spec stmt. */
3394 /* Make sure we have a sym or com block, and verify that it can
3395 be bind(c). Set the appropriate field(s) and look for more
3397 if (tmp_sym != NULL || com_block != NULL)
3399 if (tmp_sym != NULL)
3401 if (set_verify_bind_c_sym (tmp_sym, num_idents)
3407 if (set_verify_bind_c_com_block(com_block, num_idents)
3412 /* Look to see if we have another identifier. */
3414 if (gfc_match_eos () == MATCH_YES)
3415 found_id = MATCH_NO;
3416 else if (gfc_match_char (',') != MATCH_YES)
3417 found_id = MATCH_NO;
3418 else if (gfc_match_name (name) == MATCH_YES)
3420 found_id = MATCH_YES;
3421 gfc_get_ha_symbol (name, &tmp_sym);
3423 else if (match_common_name (name) == MATCH_YES)
3425 found_id = MATCH_YES;
3426 com_block = gfc_get_common (name, 0);
3430 gfc_error ("Missing entity or common block name for "
3431 "attribute specification statement at %C");
3437 gfc_internal_error ("Missing symbol");
3439 } while (found_id == MATCH_YES);
3441 /* if we get here we were successful */
3446 /* Try and match a BIND(C) attribute specification statement. */
3449 gfc_match_bind_c_stmt (void)
3451 match found_match = MATCH_NO;
3456 /* This may not be necessary. */
3458 /* Clear the temporary binding label holder. */
3459 curr_binding_label[0] = '\0';
3461 /* Look for the bind(c). */
3462 found_match = gfc_match_bind_c (NULL);
3464 if (found_match == MATCH_YES)
3466 /* Look for the :: now, but it is not required. */
3469 /* Get the identifier(s) that needs to be updated. This may need to
3470 change to hand the flag(s) for the attr specified so all identifiers
3471 found can have all appropriate parts updated (assuming that the same
3472 spec stmt can have multiple attrs, such as both bind(c) and
3474 if (get_bind_c_idents () != SUCCESS)
3475 /* Error message should have printed already. */
3483 /* Match a data declaration statement. */
3486 gfc_match_data_decl (void)
3492 num_idents_on_line = 0;
3494 m = gfc_match_type_spec (¤t_ts, 0);
3498 if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3500 sym = gfc_use_derived (current_ts.derived);
3508 current_ts.derived = sym;
3511 m = match_attr_spec ();
3512 if (m == MATCH_ERROR)
3518 if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL
3519 && !current_ts.derived->attr.zero_comp)
3522 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3525 gfc_find_symbol (current_ts.derived->name,
3526 current_ts.derived->ns->parent, 1, &sym);
3528 /* Any symbol that we find had better be a type definition
3529 which has its components defined. */
3530 if (sym != NULL && sym->attr.flavor == FL_DERIVED
3531 && (current_ts.derived->components != NULL
3532 || current_ts.derived->attr.zero_comp))
3535 /* Now we have an error, which we signal, and then fix up
3536 because the knock-on is plain and simple confusing. */
3537 gfc_error_now ("Derived type at %C has not been previously defined "
3538 "and so cannot appear in a derived type definition");
3539 current_attr.pointer = 1;
3544 /* If we have an old-style character declaration, and no new-style
3545 attribute specifications, then there a comma is optional between
3546 the type specification and the variable list. */
3547 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3548 gfc_match_char (',');
3550 /* Give the types/attributes to symbols that follow. Give the element
3551 a number so that repeat character length expressions can be copied. */
3555 num_idents_on_line++;
3556 m = variable_decl (elem++);
3557 if (m == MATCH_ERROR)
3562 if (gfc_match_eos () == MATCH_YES)
3564 if (gfc_match_char (',') != MATCH_YES)
3568 if (gfc_error_flag_test () == 0)
3569 gfc_error ("Syntax error in data declaration at %C");
3572 gfc_free_data_all (gfc_current_ns);
3575 gfc_free_array_spec (current_as);
3581 /* Match a prefix associated with a function or subroutine
3582 declaration. If the typespec pointer is nonnull, then a typespec
3583 can be matched. Note that if nothing matches, MATCH_YES is
3584 returned (the null string was matched). */
3587 match_prefix (gfc_typespec *ts)
3591 gfc_clear_attr (¤t_attr);
3595 if (!seen_type && ts != NULL
3596 && gfc_match_type_spec (ts, 0) == MATCH_YES
3597 && gfc_match_space () == MATCH_YES)
3604 if (gfc_match ("elemental% ") == MATCH_YES)
3606 if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
3612 if (gfc_match ("pure% ") == MATCH_YES)
3614 if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
3620 if (gfc_match ("recursive% ") == MATCH_YES)
3622 if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
3628 /* At this point, the next item is not a prefix. */
3633 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
3636 copy_prefix (symbol_attribute *dest, locus *where)
3638 if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3641 if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3644 if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3651 /* Match a formal argument list. */
3654 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3656 gfc_formal_arglist *head, *tail, *p, *q;
3657 char name[GFC_MAX_SYMBOL_LEN + 1];
3663 if (gfc_match_char ('(') != MATCH_YES)
3670 if (gfc_match_char (')') == MATCH_YES)
3675 if (gfc_match_char ('*') == MATCH_YES)
3679 m = gfc_match_name (name);
3683 if (gfc_get_symbol (name, NULL, &sym))
3687 p = gfc_get_formal_arglist ();
3699 /* We don't add the VARIABLE flavor because the name could be a
3700 dummy procedure. We don't apply these attributes to formal
3701 arguments of statement functions. */
3702 if (sym != NULL && !st_flag
3703 && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3704 || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3710 /* The name of a program unit can be in a different namespace,
3711 so check for it explicitly. After the statement is accepted,
3712 the name is checked for especially in gfc_get_symbol(). */
3713 if (gfc_new_block != NULL && sym != NULL
3714 && strcmp (sym->name, gfc_new_block->name) == 0)
3716 gfc_error ("Name '%s' at %C is the name of the procedure",
3722 if (gfc_match_char (')') == MATCH_YES)
3725 m = gfc_match_char (',');
3728 gfc_error ("Unexpected junk in formal argument list at %C");
3734 /* Check for duplicate symbols in the formal argument list. */
3737 for (p = head; p->next; p = p->next)
3742 for (q = p->next; q; q = q->next)
3743 if (p->sym == q->sym)
3745 gfc_error ("Duplicate symbol '%s' in formal argument list "
3746 "at %C", p->sym->name);
3754 if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3764 gfc_free_formal_arglist (head);
3769 /* Match a RESULT specification following a function declaration or
3770 ENTRY statement. Also matches the end-of-statement. */
3773 match_result (gfc_symbol *function, gfc_symbol **result)
3775 char name[GFC_MAX_SYMBOL_LEN + 1];
3779 if (gfc_match (" result (") != MATCH_YES)
3782 m = gfc_match_name (name);
3786 /* Get the right paren, and that's it because there could be the
3787 bind(c) attribute after the result clause. */
3788 if (gfc_match_char(')') != MATCH_YES)
3790 /* TODO: should report the missing right paren here. */
3794 if (strcmp (function->name, name) == 0)
3796 gfc_error ("RESULT variable at %C must be different than function name");
3800 if (gfc_get_symbol (name, NULL, &r))
3803 if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
3804 || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3813 /* Match a function suffix, which could be a combination of a result
3814 clause and BIND(C), either one, or neither. The draft does not
3815 require them to come in a specific order. */
3818 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
3820 match is_bind_c; /* Found bind(c). */
3821 match is_result; /* Found result clause. */
3822 match found_match; /* Status of whether we've found a good match. */
3823 int peek_char; /* Character we're going to peek at. */
3825 /* Initialize to having found nothing. */
3826 found_match = MATCH_NO;
3827 is_bind_c = MATCH_NO;
3828 is_result = MATCH_NO;
3830 /* Get the next char to narrow between result and bind(c). */
3831 gfc_gobble_whitespace ();
3832 peek_char = gfc_peek_char ();
3837 /* Look for result clause. */
3838 is_result = match_result (sym, result);
3839 if (is_result == MATCH_YES)
3841 /* Now see if there is a bind(c) after it. */
3842 is_bind_c = gfc_match_bind_c (sym);
3843 /* We've found the result clause and possibly bind(c). */
3844 found_match = MATCH_YES;
3847 /* This should only be MATCH_ERROR. */
3848 found_match = is_result;
3851 /* Look for bind(c) first. */
3852 is_bind_c = gfc_match_bind_c (sym);
3853 if (is_bind_c == MATCH_YES)
3855 /* Now see if a result clause followed it. */
3856 is_result = match_result (sym, result);
3857 found_match = MATCH_YES;
3861 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
3862 found_match = MATCH_ERROR;
3866 gfc_error ("Unexpected junk after function declaration at %C");
3867 found_match = MATCH_ERROR;
3871 if (is_bind_c == MATCH_YES)
3872 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
3880 /* Match a PROCEDURE declaration (R1211). */
3883 match_procedure_decl (void)
3886 locus old_loc, entry_loc;
3887 gfc_symbol *sym, *proc_if = NULL;
3890 old_loc = entry_loc = gfc_current_locus;
3892 gfc_clear_ts (¤t_ts);
3894 if (gfc_match (" (") != MATCH_YES)
3896 gfc_current_locus = entry_loc;
3900 /* Get the type spec. for the procedure interface. */
3901 old_loc = gfc_current_locus;
3902 m = gfc_match_type_spec (¤t_ts, 0);
3903 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
3906 if (m == MATCH_ERROR)
3909 gfc_current_locus = old_loc;
3911 /* Get the name of the procedure or abstract interface
3912 to inherit the interface from. */
3913 m = gfc_match_symbol (&proc_if, 1);
3917 else if (m == MATCH_ERROR)
3920 /* Various interface checks. */
3923 if (proc_if->generic)
3925 gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
3928 if (proc_if->attr.proc == PROC_ST_FUNCTION)
3930 gfc_error ("Interface '%s' at %C may not be a statement function",
3934 /* Handle intrinsic procedures. */
3935 if (gfc_intrinsic_name (proc_if->name, 0)
3936 || gfc_intrinsic_name (proc_if->name, 1))
3937 proc_if->attr.intrinsic = 1;
3938 if (proc_if->attr.intrinsic
3939 && !gfc_intrinsic_actual_ok (proc_if->name, 0))
3941 gfc_error ("Intrinsic procedure '%s' not allowed "
3942 "in PROCEDURE statement at %C", proc_if->name);
3945 /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok
3946 (proc_if->name, 0) after PR33162 is fixed. */
3947 if (proc_if->attr.intrinsic)
3949 gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' "
3950 "in PROCEDURE statement at %C not yet implemented "
3951 "in gfortran", proc_if->name);
3958 if (gfc_match (" )") != MATCH_YES)
3960 gfc_current_locus = entry_loc;
3964 /* Parse attributes. */
3965 m = match_attr_spec();
3966 if (m == MATCH_ERROR)
3969 /* Get procedure symbols. */
3973 m = gfc_match_symbol (&sym, 0);
3976 else if (m == MATCH_ERROR)
3979 /* Add current_attr to the symbol attributes. */
3980 if (gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
3983 if (sym->attr.is_bind_c)
3985 /* Check for C1218. */
3986 if (!proc_if || !proc_if->attr.is_bind_c)
3988 gfc_error ("BIND(C) attribute at %C requires "
3989 "an interface with BIND(C)");
3992 /* Check for C1217. */
3993 if (has_name_equals && sym->attr.pointer)
3995 gfc_error ("BIND(C) procedure with NAME may not have "
3996 "POINTER attribute at %C");
3999 if (has_name_equals && sym->attr.dummy)
4001 gfc_error ("Dummy procedure at %C may not have "
4002 "BIND(C) attribute with NAME");
4005 /* Set binding label for BIND(C). */
4006 if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
4010 if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
4012 if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
4015 /* Set interface. */
4016 if (proc_if != NULL)
4017 sym->interface = proc_if;
4018 else if (current_ts.type != BT_UNKNOWN)
4020 sym->interface = gfc_new_symbol ("", gfc_current_ns);
4021 sym->interface->ts = current_ts;
4022 sym->interface->attr.function = 1;
4023 sym->ts = sym->interface->ts;
4024 sym->attr.function = sym->interface->attr.function;
4027 if (gfc_match_eos () == MATCH_YES)
4029 if (gfc_match_char (',') != MATCH_YES)
4034 gfc_error ("Syntax error in PROCEDURE statement at %C");
4039 /* Match a PROCEDURE declaration inside an interface (R1206). */
4042 match_procedure_in_interface (void)
4046 char name[GFC_MAX_SYMBOL_LEN + 1];
4048 if (current_interface.type == INTERFACE_NAMELESS
4049 || current_interface.type == INTERFACE_ABSTRACT)
4051 gfc_error ("PROCEDURE at %C must be in a generic interface");
4057 m = gfc_match_name (name);
4060 else if (m == MATCH_ERROR)
4062 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
4065 if (gfc_add_interface (sym) == FAILURE)
4068 sym->attr.procedure = 1;
4070 if (gfc_match_eos () == MATCH_YES)
4072 if (gfc_match_char (',') != MATCH_YES)
4079 gfc_error ("Syntax error in PROCEDURE statement at %C");
4084 /* General matcher for PROCEDURE declarations. */
4087 gfc_match_procedure (void)
4091 switch (gfc_current_state ())
4096 case COMP_SUBROUTINE:
4098 m = match_procedure_decl ();
4100 case COMP_INTERFACE:
4101 m = match_procedure_in_interface ();
4104 gfc_error ("Fortran 2003: Procedure components at %C are "
4105 "not yet implemented in gfortran");
4114 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
4122 /* Match a function declaration. */
4125 gfc_match_function_decl (void)
4127 char name[GFC_MAX_SYMBOL_LEN + 1];
4128 gfc_symbol *sym, *result;
4132 match found_match; /* Status returned by match func. */
4134 if (gfc_current_state () != COMP_NONE
4135 && gfc_current_state () != COMP_INTERFACE
4136 && gfc_current_state () != COMP_CONTAINS)
4139 gfc_clear_ts (¤t_ts);
4141 old_loc = gfc_current_locus;
4143 m = match_prefix (¤t_ts);
4146 gfc_current_locus = old_loc;
4150 if (gfc_match ("function% %n", name) != MATCH_YES)
4152 gfc_current_locus = old_loc;
4155 if (get_proc_name (name, &sym, false))
4157 gfc_new_block = sym;
4159 m = gfc_match_formal_arglist (sym, 0, 0);
4162 gfc_error ("Expected formal argument list in function "
4163 "definition at %C");
4167 else if (m == MATCH_ERROR)
4172 /* According to the draft, the bind(c) and result clause can
4173 come in either order after the formal_arg_list (i.e., either
4174 can be first, both can exist together or by themselves or neither
4175 one). Therefore, the match_result can't match the end of the
4176 string, and check for the bind(c) or result clause in either order. */
4177 found_match = gfc_match_eos ();
4179 /* Make sure that it isn't already declared as BIND(C). If it is, it
4180 must have been marked BIND(C) with a BIND(C) attribute and that is
4181 not allowed for procedures. */
4182 if (sym->attr.is_bind_c == 1)
4184 sym->attr.is_bind_c = 0;
4185 if (sym->old_symbol != NULL)
4186 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4187 "variables or common blocks",
4188 &(sym->old_symbol->declared_at));
4190 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4191 "variables or common blocks", &gfc_current_locus);
4194 if (found_match != MATCH_YES)
4196 /* If we haven't found the end-of-statement, look for a suffix. */
4197 suffix_match = gfc_match_suffix (sym, &result);
4198 if (suffix_match == MATCH_YES)
4199 /* Need to get the eos now. */
4200 found_match = gfc_match_eos ();
4202 found_match = suffix_match;
4205 if(found_match != MATCH_YES)
4209 /* Make changes to the symbol. */
4212 if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
4215 if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
4216 || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4219 if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
4220 && !sym->attr.implicit_type)
4222 gfc_error ("Function '%s' at %C already has a type of %s", name,
4223 gfc_basic_typename (sym->ts.type));
4229 sym->ts = current_ts;
4234 result->ts = current_ts;
4235 sym->result = result;
4242 gfc_current_locus = old_loc;
4247 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
4248 pass the name of the entry, rather than the gfc_current_block name, and
4249 to return false upon finding an existing global entry. */
4252 add_global_entry (const char *name, int sub)
4256 s = gfc_get_gsymbol(name);
4259 || (s->type != GSYM_UNKNOWN
4260 && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4261 gfc_global_used(s, NULL);
4264 s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4265 s->where = gfc_current_locus;
4273 /* Match an ENTRY statement. */
4276 gfc_match_entry (void)
4281 char name[GFC_MAX_SYMBOL_LEN + 1];
4282 gfc_compile_state state;
4286 bool module_procedure;
4288 m = gfc_match_name (name);
4292 state = gfc_current_state ();
4293 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
4298 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
4301 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
4303 case COMP_BLOCK_DATA:
4304 gfc_error ("ENTRY statement at %C cannot appear within "
4307 case COMP_INTERFACE:
4308 gfc_error ("ENTRY statement at %C cannot appear within "
4312 gfc_error ("ENTRY statement at %C cannot appear within "
4313 "a DERIVED TYPE block");
4316 gfc_error ("ENTRY statement at %C cannot appear within "
4317 "an IF-THEN block");
4320 gfc_error ("ENTRY statement at %C cannot appear within "
4324 gfc_error ("ENTRY statement at %C cannot appear within "
4328 gfc_error ("ENTRY statement at %C cannot appear within "
4332 gfc_error ("ENTRY statement at %C cannot appear within "
4336 gfc_error ("ENTRY statement at %C cannot appear within "
4337 "a contained subprogram");
4340 gfc_internal_error ("gfc_match_entry(): Bad state");
4345 module_procedure = gfc_current_ns->parent != NULL
4346 && gfc_current_ns->parent->proc_name
4347 && gfc_current_ns->parent->proc_name->attr.flavor
4350 if (gfc_current_ns->parent != NULL
4351 && gfc_current_ns->parent->proc_name
4352 && !module_procedure)
4354 gfc_error("ENTRY statement at %C cannot appear in a "
4355 "contained procedure");
4359 /* Module function entries need special care in get_proc_name
4360 because previous references within the function will have
4361 created symbols attached to the current namespace. */
4362 if (get_proc_name (name, &entry,
4363 gfc_current_ns->parent != NULL
4365 && gfc_current_ns->proc_name->attr.function))
4368 proc = gfc_current_block ();
4370 if (state == COMP_SUBROUTINE)
4372 /* An entry in a subroutine. */
4373 if (!add_global_entry (name, 1))
4376 m = gfc_match_formal_arglist (entry, 0, 1);
4380 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4381 || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
4386 /* An entry in a function.
4387 We need to take special care because writing
4392 ENTRY f() RESULT (r)
4394 ENTRY f RESULT (r). */
4395 if (!add_global_entry (name, 0))
4398 old_loc = gfc_current_locus;
4399 if (gfc_match_eos () == MATCH_YES)
4401 gfc_current_locus = old_loc;
4402 /* Match the empty argument list, and add the interface to
4404 m = gfc_match_formal_arglist (entry, 0, 1);
4407 m = gfc_match_formal_arglist (entry, 0, 0);
4414 if (gfc_match_eos () == MATCH_YES)
4416 if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
4417 || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
4420 entry->result = entry;
4424 m = match_result (proc, &result);
4426 gfc_syntax_error (ST_ENTRY);
4430 if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
4431 || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
4432 || gfc_add_function (&entry->attr, result->name, NULL)
4436 entry->result = result;
4440 if (gfc_match_eos () != MATCH_YES)
4442 gfc_syntax_error (ST_ENTRY);
4446 entry->attr.recursive = proc->attr.recursive;
4447 entry->attr.elemental = proc->attr.elemental;
4448 entry->attr.pure = proc->attr.pure;
4450 el = gfc_get_entry_list ();
4452 el->next = gfc_current_ns->entries;
4453 gfc_current_ns->entries = el;
4455 el->id = el->next->id + 1;
4459 new_st.op = EXEC_ENTRY;
4460 new_st.ext.entry = el;
4466 /* Match a subroutine statement, including optional prefixes. */
4469 gfc_match_subroutine (void)
4471 char name[GFC_MAX_SYMBOL_LEN + 1];
4477 if (gfc_current_state () != COMP_NONE
4478 && gfc_current_state () != COMP_INTERFACE
4479 && gfc_current_state () != COMP_CONTAINS)
4482 m = match_prefix (NULL);
4486 m = gfc_match ("subroutine% %n", name);
4490 if (get_proc_name (name, &sym, false))
4492 gfc_new_block = sym;
4494 /* Check what next non-whitespace character is so we can tell if there
4495 where the required parens if we have a BIND(C). */
4496 gfc_gobble_whitespace ();
4497 peek_char = gfc_peek_char ();
4499 if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
4502 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
4505 /* Make sure that it isn't already declared as BIND(C). If it is, it
4506 must have been marked BIND(C) with a BIND(C) attribute and that is
4507 not allowed for procedures. */
4508 if (sym->attr.is_bind_c == 1)
4510 sym->attr.is_bind_c = 0;
4511 if (sym->old_symbol != NULL)
4512 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4513 "variables or common blocks",
4514 &(sym->old_symbol->declared_at));
4516 gfc_error_now ("BIND(C) attribute at %L can only be used for "
4517 "variables or common blocks", &gfc_current_locus);
4520 /* Here, we are just checking if it has the bind(c) attribute, and if
4521 so, then we need to make sure it's all correct. If it doesn't,
4522 we still need to continue matching the rest of the subroutine line. */
4523 is_bind_c = gfc_match_bind_c (sym);
4524 if (is_bind_c == MATCH_ERROR)
4526 /* There was an attempt at the bind(c), but it was wrong. An
4527 error message should have been printed w/in the gfc_match_bind_c
4528 so here we'll just return the MATCH_ERROR. */
4532 if (is_bind_c == MATCH_YES)
4534 if (peek_char != '(')
4536 gfc_error ("Missing required parentheses before BIND(C) at %C");
4539 if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
4544 if (gfc_match_eos () != MATCH_YES)
4546 gfc_syntax_error (ST_SUBROUTINE);
4550 if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
4557 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
4558 given, and set the binding label in either the given symbol (if not
4559 NULL), or in the current_ts. The symbol may be NULL because we may
4560 encounter the BIND(C) before the declaration itself. Return
4561 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
4562 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
4563 or MATCH_YES if the specifier was correct and the binding label and
4564 bind(c) fields were set correctly for the given symbol or the
4568 gfc_match_bind_c (gfc_symbol *sym)
4570 /* binding label, if exists */
4571 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
4575 /* Initialize the flag that specifies whether we encountered a NAME=
4576 specifier or not. */
4577 has_name_equals = 0;
4579 /* Init the first char to nil so we can catch if we don't have
4580 the label (name attr) or the symbol name yet. */
4581 binding_label[0] = '\0';
4583 /* This much we have to be able to match, in this order, if
4584 there is a bind(c) label. */
4585 if (gfc_match (" bind ( c ") != MATCH_YES)
4588 /* Now see if there is a binding label, or if we've reached the
4589 end of the bind(c) attribute without one. */
4590 if (gfc_match_char (',') == MATCH_YES)
4592 if (gfc_match (" name = ") != MATCH_YES)
4594 gfc_error ("Syntax error in NAME= specifier for binding label "
4596 /* should give an error message here */
4600 has_name_equals = 1;
4602 /* Get the opening quote. */
4603 double_quote = MATCH_YES;
4604 single_quote = MATCH_YES;
4605 double_quote = gfc_match_char ('"');
4606 if (double_quote != MATCH_YES)
4607 single_quote = gfc_match_char ('\'');
4608 if (double_quote != MATCH_YES && single_quote != MATCH_YES)
4610 gfc_error ("Syntax error in NAME= specifier for binding label "
4615 /* Grab the binding label, using functions that will not lower
4616 case the names automatically. */
4617 if (gfc_match_name_C (binding_label) != MATCH_YES)
4620 /* Get the closing quotation. */
4621 if (double_quote == MATCH_YES)
4623 if (gfc_match_char ('"') != MATCH_YES)
4625 gfc_error ("Missing closing quote '\"' for binding label at %C");
4626 /* User started string with '"' so looked to match it. */
4632 if (gfc_match_char ('\'') != MATCH_YES)
4634 gfc_error ("Missing closing quote '\'' for binding label at %C");
4635 /* User started string with "'" char. */
4641 /* Get the required right paren. */
4642 if (gfc_match_char (')') != MATCH_YES)
4644 gfc_error ("Missing closing paren for binding label at %C");
4648 /* Save the binding label to the symbol. If sym is null, we're
4649 probably matching the typespec attributes of a declaration and
4650 haven't gotten the name yet, and therefore, no symbol yet. */
4651 if (binding_label[0] != '\0')
4655 strncpy (sym->binding_label, binding_label,
4656 strlen (binding_label)+1);
4659 strncpy (curr_binding_label, binding_label,
4660 strlen (binding_label) + 1);
4664 /* No binding label, but if symbol isn't null, we
4665 can set the label for it here. */
4666 /* TODO: If the name= was given and no binding label (name=""), we simply
4667 will let fortran mangle the symbol name as it usually would.
4668 However, this could still let C call it if the user looked up the
4669 symbol in the object file. Should the name set during mangling in
4670 trans-decl.c be marked with characters that are invalid for C to
4672 if (sym != NULL && sym->name != NULL && has_name_equals == 0)
4673 strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
4676 if (has_name_equals && gfc_current_state () == COMP_INTERFACE
4677 && current_interface.type == INTERFACE_ABSTRACT)
4679 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
4687 /* Return nonzero if we're currently compiling a contained procedure. */
4690 contained_procedure (void)
4694 for (s=gfc_state_stack; s; s=s->previous)
4695 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
4696 && s->previous != NULL && s->previous->state == COMP_CONTAINS)
4702 /* Set the kind of each enumerator. The kind is selected such that it is
4703 interoperable with the corresponding C enumeration type, making
4704 sure that -fshort-enums is honored. */
4709 enumerator_history *current_history = NULL;
4713 if (max_enum == NULL || enum_history == NULL)
4716 if (!gfc_option.fshort_enums)
4722 kind = gfc_integer_kinds[i++].kind;
4724 while (kind < gfc_c_int_kind
4725 && gfc_check_integer_range (max_enum->initializer->value.integer,
4728 current_history = enum_history;
4729 while (current_history != NULL)
4731 current_history->sym->ts.kind = kind;
4732 current_history = current_history->next;
4737 /* Match any of the various end-block statements. Returns the type of
4738 END to the caller. The END INTERFACE, END IF, END DO and END
4739 SELECT statements cannot be replaced by a single END statement. */
4742 gfc_match_end (gfc_statement *st)
4744 char name[GFC_MAX_SYMBOL_LEN + 1];
4745 gfc_compile_state state;
4747 const char *block_name;
4752 old_loc = gfc_current_locus;
4753 if (gfc_match ("end") != MATCH_YES)
4756 state = gfc_current_state ();
4757 block_name = gfc_current_block () == NULL
4758 ? NULL : gfc_current_block ()->name;
4760 if (state == COMP_CONTAINS)
4762 state = gfc_state_stack->previous->state;
4763 block_name = gfc_state_stack->previous->sym == NULL
4764 ? NULL : gfc_state_stack->previous->sym->name;
4771 *st = ST_END_PROGRAM;
4772 target = " program";
4776 case COMP_SUBROUTINE:
4777 *st = ST_END_SUBROUTINE;
4778 target = " subroutine";
4779 eos_ok = !contained_procedure ();
4783 *st = ST_END_FUNCTION;
4784 target = " function";
4785 eos_ok = !contained_procedure ();
4788 case COMP_BLOCK_DATA:
4789 *st = ST_END_BLOCK_DATA;
4790 target = " block data";
4795 *st = ST_END_MODULE;
4800 case COMP_INTERFACE:
4801 *st = ST_END_INTERFACE;
4802 target = " interface";
4825 *st = ST_END_SELECT;
4831 *st = ST_END_FORALL;
4846 last_initializer = NULL;
4848 gfc_free_enum_history ();
4852 gfc_error ("Unexpected END statement at %C");
4856 if (gfc_match_eos () == MATCH_YES)
4860 /* We would have required END [something]. */
4861 gfc_error ("%s statement expected at %L",
4862 gfc_ascii_statement (*st), &old_loc);
4869 /* Verify that we've got the sort of end-block that we're expecting. */
4870 if (gfc_match (target) != MATCH_YES)
4872 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
4876 /* If we're at the end, make sure a block name wasn't required. */
4877 if (gfc_match_eos () == MATCH_YES)
4880 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
4881 && *st != ST_END_FORALL && *st != ST_END_WHERE)
4884 if (gfc_current_block () == NULL)
4887 gfc_error ("Expected block name of '%s' in %s statement at %C",
4888 block_name, gfc_ascii_statement (*st));
4893 /* END INTERFACE has a special handler for its several possible endings. */
4894 if (*st == ST_END_INTERFACE)
4895 return gfc_match_end_interface ();
4897 /* We haven't hit the end of statement, so what is left must be an
4899 m = gfc_match_space ();
4901 m = gfc_match_name (name);
4904 gfc_error ("Expected terminating name at %C");
4908 if (block_name == NULL)
4911 if (strcmp (name, block_name) != 0)
4913 gfc_error ("Expected label '%s' for %s statement at %C", block_name,
4914 gfc_ascii_statement (*st));
4918 if (gfc_match_eos () == MATCH_YES)
4922 gfc_syntax_error (*st);
4925 gfc_current_locus = old_loc;
4931 /***************** Attribute declaration statements ****************/
4933 /* Set the attribute of a single variable. */
4938 char name[GFC_MAX_SYMBOL_LEN + 1];
4946 m = gfc_match_name (name);
4950 if (find_special (name, &sym))
4953 var_locus = gfc_current_locus;
4955 /* Deal with possible array specification for certain attributes. */
4956 if (current_attr.dimension
4957 || current_attr.allocatable
4958 || current_attr.pointer
4959 || current_attr.target)
4961 m = gfc_match_array_spec (&as);
4962 if (m == MATCH_ERROR)
4965 if (current_attr.dimension && m == MATCH_NO)
4967 gfc_error ("Missing array specification at %L in DIMENSION "
4968 "statement", &var_locus);
4973 if ((current_attr.allocatable || current_attr.pointer)
4974 && (m == MATCH_YES) && (as->type != AS_DEFERRED))
4976 gfc_error ("Array specification must be deferred at %L", &var_locus);
4982 /* Update symbol table. DIMENSION attribute is set
4983 in gfc_set_array_spec(). */
4984 if (current_attr.dimension == 0
4985 && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
4991 if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
4997 if (sym->attr.cray_pointee && sym->as != NULL)
4999 /* Fix the array spec. */
5000 m = gfc_mod_pointee_as (sym->as);
5001 if (m == MATCH_ERROR)
5005 if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
5011 if ((current_attr.external || current_attr.intrinsic)
5012 && sym->attr.flavor != FL_PROCEDURE
5013 && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
5022 gfc_free_array_spec (as);
5027 /* Generic attribute declaration subroutine. Used for attributes that
5028 just have a list of names. */
5035 /* Gobble the optional double colon, by simply ignoring the result
5045 if (gfc_match_eos () == MATCH_YES)
5051 if (gfc_match_char (',') != MATCH_YES)
5053 gfc_error ("Unexpected character in variable list at %C");
5063 /* This routine matches Cray Pointer declarations of the form:
5064 pointer ( <pointer>, <pointee> )
5066 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
5067 The pointer, if already declared, should be an integer. Otherwise, we
5068 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
5069 be either a scalar, or an array declaration. No space is allocated for
5070 the pointee. For the statement
5071 pointer (ipt, ar(10))
5072 any subsequent uses of ar will be translated (in C-notation) as
5073 ar(i) => ((<type> *) ipt)(i)
5074 After gimplification, pointee variable will disappear in the code. */
5077 cray_pointer_decl (void)
5081 gfc_symbol *cptr; /* Pointer symbol. */
5082 gfc_symbol *cpte; /* Pointee symbol. */
5088 if (gfc_match_char ('(') != MATCH_YES)
5090 gfc_error ("Expected '(' at %C");
5094 /* Match pointer. */
5095 var_locus = gfc_current_locus;
5096 gfc_clear_attr (¤t_attr);
5097 gfc_add_cray_pointer (¤t_attr, &var_locus);
5098 current_ts.type = BT_INTEGER;
5099 current_ts.kind = gfc_index_integer_kind;
5101 m = gfc_match_symbol (&cptr, 0);
5104 gfc_error ("Expected variable name at %C");
5108 if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
5111 gfc_set_sym_referenced (cptr);
5113 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
5115 cptr->ts.type = BT_INTEGER;
5116 cptr->ts.kind = gfc_index_integer_kind;
5118 else if (cptr->ts.type != BT_INTEGER)
5120 gfc_error ("Cray pointer at %C must be an integer");
5123 else if (cptr->ts.kind < gfc_index_integer_kind)
5124 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
5125 " memory addresses require %d bytes",
5126 cptr->ts.kind, gfc_index_integer_kind);
5128 if (gfc_match_char (',') != MATCH_YES)
5130 gfc_error ("Expected \",\" at %C");
5134 /* Match Pointee. */
5135 var_locus = gfc_current_locus;
5136 gfc_clear_attr (¤t_attr);
5137 gfc_add_cray_pointee (¤t_attr, &var_locus);
5138 current_ts.type = BT_UNKNOWN;
5139 current_ts.kind = 0;
5141 m = gfc_match_symbol (&cpte, 0);
5144 gfc_error ("Expected variable name at %C");
5148 /* Check for an optional array spec. */
5149 m = gfc_match_array_spec (&as);
5150 if (m == MATCH_ERROR)
5152 gfc_free_array_spec (as);
5155 else if (m == MATCH_NO)
5157 gfc_free_array_spec (as);
5161 if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
5164 gfc_set_sym_referenced (cpte);
5166 if (cpte->as == NULL)
5168 if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
5169 gfc_internal_error ("Couldn't set Cray pointee array spec.");
5171 else if (as != NULL)
5173 gfc_error ("Duplicate array spec for Cray pointee at %C");
5174 gfc_free_array_spec (as);
5180 if (cpte->as != NULL)
5182 /* Fix array spec. */
5183 m = gfc_mod_pointee_as (cpte->as);
5184 if (m == MATCH_ERROR)
5188 /* Point the Pointee at the Pointer. */
5189 cpte->cp_pointer = cptr;
5191 if (gfc_match_char (')') != MATCH_YES)
5193 gfc_error ("Expected \")\" at %C");
5196 m = gfc_match_char (',');
5198 done = true; /* Stop searching for more declarations. */
5202 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
5203 || gfc_match_eos () != MATCH_YES)
5205 gfc_error ("Expected \",\" or end of statement at %C");
5213 gfc_match_external (void)
5216 gfc_clear_attr (¤t_attr);
5217 current_attr.external = 1;
5219 return attr_decl ();
5224 gfc_match_intent (void)
5228 intent = match_intent_spec ();
5229 if (intent == INTENT_UNKNOWN)
5232 gfc_clear_attr (¤t_attr);
5233 current_attr.intent = intent;
5235 return attr_decl ();
5240 gfc_match_intrinsic (void)
5243 gfc_clear_attr (¤t_attr);
5244 current_attr.intrinsic = 1;
5246 return attr_decl ();
5251 gfc_match_optional (void)
5254 gfc_clear_attr (¤t_attr);
5255 current_attr.optional = 1;
5257 return attr_decl ();
5262 gfc_match_pointer (void)
5264 gfc_gobble_whitespace ();
5265 if (gfc_peek_char () == '(')
5267 if (!gfc_option.flag_cray_pointer)
5269 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
5273 return cray_pointer_decl ();
5277 gfc_clear_attr (¤t_attr);
5278 current_attr.pointer = 1;
5280 return attr_decl ();
5286 gfc_match_allocatable (void)
5288 gfc_clear_attr (¤t_attr);
5289 current_attr.allocatable = 1;
5291 return attr_decl ();
5296 gfc_match_dimension (void)
5298 gfc_clear_attr (¤t_attr);
5299 current_attr.dimension = 1;
5301 return attr_decl ();
5306 gfc_match_target (void)
5308 gfc_clear_attr (¤t_attr);
5309 current_attr.target = 1;
5311 return attr_decl ();
5315 /* Match the list of entities being specified in a PUBLIC or PRIVATE
5319 access_attr_decl (gfc_statement st)
5321 char name[GFC_MAX_SYMBOL_LEN + 1];
5322 interface_type type;
5325 gfc_intrinsic_op operator;
5328 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5333 m = gfc_match_generic_spec (&type, name, &operator);
5336 if (m == MATCH_ERROR)
5341 case INTERFACE_NAMELESS:
5342 case INTERFACE_ABSTRACT:
5345 case INTERFACE_GENERIC:
5346 if (gfc_get_symbol (name, NULL, &sym))
5349 if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
5350 ? ACCESS_PUBLIC : ACCESS_PRIVATE,
5351 sym->name, NULL) == FAILURE)
5356 case INTERFACE_INTRINSIC_OP:
5357 if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
5359 gfc_current_ns->operator_access[operator] =
5360 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5364 gfc_error ("Access specification of the %s operator at %C has "
5365 "already been specified", gfc_op2string (operator));
5371 case INTERFACE_USER_OP:
5372 uop = gfc_get_uop (name);
5374 if (uop->access == ACCESS_UNKNOWN)
5376 uop->access = (st == ST_PUBLIC)
5377 ? ACCESS_PUBLIC : ACCESS_PRIVATE;
5381 gfc_error ("Access specification of the .%s. operator at %C "
5382 "has already been specified", sym->name);
5389 if (gfc_match_char (',') == MATCH_NO)
5393 if (gfc_match_eos () != MATCH_YES)
5398 gfc_syntax_error (st);
5406 gfc_match_protected (void)
5411 if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
5413 gfc_error ("PROTECTED at %C only allowed in specification "
5414 "part of a module");
5419 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
5423 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5428 if (gfc_match_eos () == MATCH_YES)
5433 m = gfc_match_symbol (&sym, 0);
5437 if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
5450 if (gfc_match_eos () == MATCH_YES)
5452 if (gfc_match_char (',') != MATCH_YES)
5459 gfc_error ("Syntax error in PROTECTED statement at %C");
5464 /* The PRIVATE statement is a bit weird in that it can be an attribute
5465 declaration, but also works as a standlone statement inside of a
5466 type declaration or a module. */
5469 gfc_match_private (gfc_statement *st)
5472 if (gfc_match ("private") != MATCH_YES)
5475 if (gfc_current_state () != COMP_MODULE
5476 && (gfc_current_state () != COMP_DERIVED
5477 || !gfc_state_stack->previous
5478 || gfc_state_stack->previous->state != COMP_MODULE))
5480 gfc_error ("PRIVATE statement at %C is only allowed in the "
5481 "specification part of a module");
5485 if (gfc_current_state () == COMP_DERIVED)
5487 if (gfc_match_eos () == MATCH_YES)
5493 gfc_syntax_error (ST_PRIVATE);
5497 if (gfc_match_eos () == MATCH_YES)
5504 return access_attr_decl (ST_PRIVATE);
5509 gfc_match_public (gfc_statement *st)
5512 if (gfc_match ("public") != MATCH_YES)
5515 if (gfc_current_state () != COMP_MODULE)
5517 gfc_error ("PUBLIC statement at %C is only allowed in the "
5518 "specification part of a module");
5522 if (gfc_match_eos () == MATCH_YES)
5529 return access_attr_decl (ST_PUBLIC);
5533 /* Workhorse for gfc_match_parameter. */
5542 m = gfc_match_symbol (&sym, 0);
5544 gfc_error ("Expected variable name at %C in PARAMETER statement");
5549 if (gfc_match_char ('=') == MATCH_NO)
5551 gfc_error ("Expected = sign in PARAMETER statement at %C");
5555 m = gfc_match_init_expr (&init);
5557 gfc_error ("Expected expression at %C in PARAMETER statement");
5561 if (sym->ts.type == BT_UNKNOWN
5562 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
5568 if (gfc_check_assign_symbol (sym, init) == FAILURE
5569 || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
5575 if (sym->ts.type == BT_CHARACTER
5576 && sym->ts.cl != NULL
5577 && sym->ts.cl->length != NULL
5578 && sym->ts.cl->length->expr_type == EXPR_CONSTANT
5579 && init->expr_type == EXPR_CONSTANT
5580 && init->ts.type == BT_CHARACTER
5581 && init->ts.kind == 1)
5582 gfc_set_constant_character_len (
5583 mpz_get_si (sym->ts.cl->length->value.integer), init, false);
5589 gfc_free_expr (init);
5594 /* Match a parameter statement, with the weird syntax that these have. */
5597 gfc_match_parameter (void)
5601 if (gfc_match_char ('(') == MATCH_NO)
5610 if (gfc_match (" )%t") == MATCH_YES)
5613 if (gfc_match_char (',') != MATCH_YES)
5615 gfc_error ("Unexpected characters in PARAMETER statement at %C");
5625 /* Save statements have a special syntax. */
5628 gfc_match_save (void)
5630 char n[GFC_MAX_SYMBOL_LEN+1];
5635 if (gfc_match_eos () == MATCH_YES)
5637 if (gfc_current_ns->seen_save)
5639 if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
5640 "follows previous SAVE statement")
5645 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
5649 if (gfc_current_ns->save_all)
5651 if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
5652 "blanket SAVE statement")
5661 m = gfc_match_symbol (&sym, 0);
5665 if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
5677 m = gfc_match (" / %n /", &n);
5678 if (m == MATCH_ERROR)
5683 c = gfc_get_common (n, 0);
5686 gfc_current_ns->seen_save = 1;
5689 if (gfc_match_eos () == MATCH_YES)
5691 if (gfc_match_char (',') != MATCH_YES)
5698 gfc_error ("Syntax error in SAVE statement at %C");
5704 gfc_match_value (void)
5709 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
5713 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5718 if (gfc_match_eos () == MATCH_YES)
5723 m = gfc_match_symbol (&sym, 0);
5727 if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
5740 if (gfc_match_eos () == MATCH_YES)
5742 if (gfc_match_char (',') != MATCH_YES)
5749 gfc_error ("Syntax error in VALUE statement at %C");
5755 gfc_match_volatile (void)
5760 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
5764 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
5769 if (gfc_match_eos () == MATCH_YES)
5774 /* VOLATILE is special because it can be added to host-associated
5776 m = gfc_match_symbol (&sym, 1);
5780 if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
5793 if (gfc_match_eos () == MATCH_YES)
5795 if (gfc_match_char (',') != MATCH_YES)
5802 gfc_error ("Syntax error in VOLATILE statement at %C");
5807 /* Match a module procedure statement. Note that we have to modify
5808 symbols in the parent's namespace because the current one was there
5809 to receive symbols that are in an interface's formal argument list. */
5812 gfc_match_modproc (void)
5814 char name[GFC_MAX_SYMBOL_LEN + 1];
5817 gfc_namespace *module_ns;
5819 if (gfc_state_stack->state != COMP_INTERFACE
5820 || gfc_state_stack->previous == NULL
5821 || current_interface.type == INTERFACE_NAMELESS
5822 || current_interface.type == INTERFACE_ABSTRACT)
5824 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
5829 module_ns = gfc_current_ns->parent;
5830 for (; module_ns; module_ns = module_ns->parent)
5831 if (module_ns->proc_name->attr.flavor == FL_MODULE)
5834 if (module_ns == NULL)
5839 m = gfc_match_name (name);
5845 if (gfc_get_symbol (name, module_ns, &sym))
5848 if (sym->attr.proc != PROC_MODULE
5849 && gfc_add_procedure (&sym->attr, PROC_MODULE,
5850 sym->name, NULL) == FAILURE)
5853 if (gfc_add_interface (sym) == FAILURE)
5856 sym->attr.mod_proc = 1;
5858 if (gfc_match_eos () == MATCH_YES)
5860 if (gfc_match_char (',') != MATCH_YES)
5867 gfc_syntax_error (ST_MODULE_PROC);
5872 /* Match the optional attribute specifiers for a type declaration.
5873 Return MATCH_ERROR if an error is encountered in one of the handled
5874 attributes (public, private, bind(c)), MATCH_NO if what's found is
5875 not a handled attribute, and MATCH_YES otherwise. TODO: More error
5876 checking on attribute conflicts needs to be done. */
5879 gfc_get_type_attr_spec (symbol_attribute *attr)
5881 /* See if the derived type is marked as private. */
5882 if (gfc_match (" , private") == MATCH_YES)
5884 if (gfc_current_state () != COMP_MODULE)
5886 gfc_error ("Derived type at %C can only be PRIVATE in the "
5887 "specification part of a module");
5891 if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
5894 else if (gfc_match (" , public") == MATCH_YES)
5896 if (gfc_current_state () != COMP_MODULE)
5898 gfc_error ("Derived type at %C can only be PUBLIC in the "
5899 "specification part of a module");
5903 if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
5906 else if (gfc_match(" , bind ( c )") == MATCH_YES)
5908 /* If the type is defined to be bind(c) it then needs to make
5909 sure that all fields are interoperable. This will
5910 need to be a semantic check on the finished derived type.
5911 See 15.2.3 (lines 9-12) of F2003 draft. */
5912 if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
5915 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
5920 /* If we get here, something matched. */
5925 /* Match the beginning of a derived type declaration. If a type name
5926 was the result of a function, then it is possible to have a symbol
5927 already to be known as a derived type yet have no components. */
5930 gfc_match_derived_decl (void)
5932 char name[GFC_MAX_SYMBOL_LEN + 1];
5933 symbol_attribute attr;
5936 match is_type_attr_spec = MATCH_NO;
5937 bool seen_attr = false;
5939 if (gfc_current_state () == COMP_DERIVED)
5942 gfc_clear_attr (&attr);
5946 is_type_attr_spec = gfc_get_type_attr_spec (&attr);
5947 if (is_type_attr_spec == MATCH_ERROR)
5949 if (is_type_attr_spec == MATCH_YES)
5951 } while (is_type_attr_spec == MATCH_YES);
5953 if (gfc_match (" ::") != MATCH_YES && seen_attr)
5955 gfc_error ("Expected :: in TYPE definition at %C");
5959 m = gfc_match (" %n%t", name);
5963 /* Make sure the name is not the name of an intrinsic type. */
5964 if (gfc_is_intrinsic_typename (name))
5966 gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
5971 if (gfc_get_symbol (name, NULL, &sym))
5974 if (sym->ts.type != BT_UNKNOWN)
5976 gfc_error ("Derived type name '%s' at %C already has a basic type "
5977 "of %s", sym->name, gfc_typename (&sym->ts));
5981 /* The symbol may already have the derived attribute without the
5982 components. The ways this can happen is via a function
5983 definition, an INTRINSIC statement or a subtype in another
5984 derived type that is a pointer. The first part of the AND clause
5985 is true if a the symbol is not the return value of a function. */
5986 if (sym->attr.flavor != FL_DERIVED
5987 && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
5990 if (sym->components != NULL || sym->attr.zero_comp)
5992 gfc_error ("Derived type definition of '%s' at %C has already been "
5993 "defined", sym->name);
5997 if (attr.access != ACCESS_UNKNOWN
5998 && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
6001 /* See if the derived type was labeled as bind(c). */
6002 if (attr.is_bind_c != 0)
6003 sym->attr.is_bind_c = attr.is_bind_c;
6005 gfc_new_block = sym;
6011 /* Cray Pointees can be declared as:
6012 pointer (ipt, a (n,m,...,*))
6013 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
6014 cheat and set a constant bound of 1 for the last dimension, if this
6015 is the case. Since there is no bounds-checking for Cray Pointees,
6016 this will be okay. */
6019 gfc_mod_pointee_as (gfc_array_spec *as)
6021 as->cray_pointee = true; /* This will be useful to know later. */
6022 if (as->type == AS_ASSUMED_SIZE)
6024 as->type = AS_EXPLICIT;
6025 as->upper[as->rank - 1] = gfc_int_expr (1);
6026 as->cp_was_assumed = true;
6028 else if (as->type == AS_ASSUMED_SHAPE)
6030 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
6037 /* Match the enum definition statement, here we are trying to match
6038 the first line of enum definition statement.
6039 Returns MATCH_YES if match is found. */
6042 gfc_match_enum (void)
6046 m = gfc_match_eos ();
6050 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
6058 /* Match a variable name with an optional initializer. When this
6059 subroutine is called, a variable is expected to be parsed next.
6060 Depending on what is happening at the moment, updates either the
6061 symbol table or the current interface. */
6064 enumerator_decl (void)
6066 char name[GFC_MAX_SYMBOL_LEN + 1];
6067 gfc_expr *initializer;
6068 gfc_array_spec *as = NULL;
6076 old_locus = gfc_current_locus;
6078 /* When we get here, we've just matched a list of attributes and
6079 maybe a type and a double colon. The next thing we expect to see
6080 is the name of the symbol. */
6081 m = gfc_match_name (name);
6085 var_locus = gfc_current_locus;
6087 /* OK, we've successfully matched the declaration. Now put the
6088 symbol in the current namespace. If we fail to create the symbol,
6090 if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
6096 /* The double colon must be present in order to have initializers.
6097 Otherwise the statement is ambiguous with an assignment statement. */
6100 if (gfc_match_char ('=') == MATCH_YES)
6102 m = gfc_match_init_expr (&initializer);
6105 gfc_error ("Expected an initialization expression at %C");
6114 /* If we do not have an initializer, the initialization value of the
6115 previous enumerator (stored in last_initializer) is incremented
6116 by 1 and is used to initialize the current enumerator. */
6117 if (initializer == NULL)
6118 initializer = gfc_enum_initializer (last_initializer, old_locus);
6120 if (initializer == NULL || initializer->ts.type != BT_INTEGER)
6122 gfc_error("ENUMERATOR %L not initialized with integer expression",
6125 gfc_free_enum_history ();
6129 /* Store this current initializer, for the next enumerator variable
6130 to be parsed. add_init_expr_to_sym() zeros initializer, so we
6131 use last_initializer below. */
6132 last_initializer = initializer;
6133 t = add_init_expr_to_sym (name, &initializer, &var_locus);
6135 /* Maintain enumerator history. */
6136 gfc_find_symbol (name, NULL, 0, &sym);
6137 create_enum_history (sym, last_initializer);
6139 return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
6142 /* Free stuff up and return. */
6143 gfc_free_expr (initializer);
6149 /* Match the enumerator definition statement. */
6152 gfc_match_enumerator_def (void)
6157 gfc_clear_ts (¤t_ts);
6159 m = gfc_match (" enumerator");
6163 m = gfc_match (" :: ");
6164 if (m == MATCH_ERROR)
6167 colon_seen = (m == MATCH_YES);
6169 if (gfc_current_state () != COMP_ENUM)
6171 gfc_error ("ENUM definition statement expected before %C");
6172 gfc_free_enum_history ();
6176 (¤t_ts)->type = BT_INTEGER;
6177 (¤t_ts)->kind = gfc_c_int_kind;
6179 gfc_clear_attr (¤t_attr);
6180 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
6189 m = enumerator_decl ();
6190 if (m == MATCH_ERROR)
6195 if (gfc_match_eos () == MATCH_YES)
6197 if (gfc_match_char (',') != MATCH_YES)
6201 if (gfc_current_state () == COMP_ENUM)
6203 gfc_free_enum_history ();
6204 gfc_error ("Syntax error in ENUMERATOR definition at %C");
6209 gfc_free_array_spec (current_as);