1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* This flag is set if an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector
;
35 /* When variables acquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts
;
42 static symbol_attribute current_attr
;
43 static gfc_array_spec
*current_as
;
44 static int colon_seen
;
46 /* Initializer of the previous enumerator. */
48 static gfc_expr
*last_initializer
;
50 /* History of all the enumerators is maintained, so that
51 kind values of all the enumerators could be updated depending
52 upon the maximum initialized value. */
54 typedef struct enumerator_history
57 gfc_expr
*initializer
;
58 struct enumerator_history
*next
;
62 /* Header of enum history chain. */
64 static enumerator_history
*enum_history
= NULL
;
66 /* Pointer of enum history node containing largest initializer. */
68 static enumerator_history
*max_enum
= NULL
;
70 /* gfc_new_block points to the symbol of a newly matched block. */
72 gfc_symbol
*gfc_new_block
;
75 /********************* DATA statement subroutines *********************/
77 /* Free a gfc_data_variable structure and everything beneath it. */
80 free_variable (gfc_data_variable
* p
)
87 gfc_free_expr (p
->expr
);
88 gfc_free_iterator (&p
->iter
, 0);
89 free_variable (p
->list
);
96 /* Free a gfc_data_value structure and everything beneath it. */
99 free_value (gfc_data_value
* p
)
106 gfc_free_expr (p
->expr
);
112 /* Free a list of gfc_data structures. */
115 gfc_free_data (gfc_data
* p
)
123 free_variable (p
->var
);
124 free_value (p
->value
);
131 static match
var_element (gfc_data_variable
*);
133 /* Match a list of variables terminated by an iterator and a right
137 var_list (gfc_data_variable
* parent
)
139 gfc_data_variable
*tail
, var
;
142 m
= var_element (&var
);
143 if (m
== MATCH_ERROR
)
148 tail
= gfc_get_data_variable ();
155 if (gfc_match_char (',') != MATCH_YES
)
158 m
= gfc_match_iterator (&parent
->iter
, 1);
161 if (m
== MATCH_ERROR
)
164 m
= var_element (&var
);
165 if (m
== MATCH_ERROR
)
170 tail
->next
= gfc_get_data_variable ();
176 if (gfc_match_char (')') != MATCH_YES
)
181 gfc_syntax_error (ST_DATA
);
186 /* Match a single element in a data variable list, which can be a
187 variable-iterator list. */
190 var_element (gfc_data_variable
* new)
195 memset (new, 0, sizeof (gfc_data_variable
));
197 if (gfc_match_char ('(') == MATCH_YES
)
198 return var_list (new);
200 m
= gfc_match_variable (&new->expr
, 0);
204 sym
= new->expr
->symtree
->n
.sym
;
206 if(sym
->value
!= NULL
)
208 gfc_error ("Variable '%s' at %C already has an initialization",
213 #if 0 /* TODO: Find out where to move this message */
214 if (sym
->attr
.in_common
)
215 /* See if sym is in the blank common block. */
216 for (t
= &sym
->ns
->blank_common
; t
; t
= t
->common_next
)
219 gfc_error ("DATA statement at %C may not initialize variable "
220 "'%s' from blank COMMON", sym
->name
);
225 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
232 /* Match the top-level list of data variables. */
235 top_var_list (gfc_data
* d
)
237 gfc_data_variable var
, *tail
, *new;
244 m
= var_element (&var
);
247 if (m
== MATCH_ERROR
)
250 new = gfc_get_data_variable ();
260 if (gfc_match_char ('/') == MATCH_YES
)
262 if (gfc_match_char (',') != MATCH_YES
)
269 gfc_syntax_error (ST_DATA
);
275 match_data_constant (gfc_expr
** result
)
277 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 m
= gfc_match_literal_constant (&expr
, 1);
289 if (m
== MATCH_ERROR
)
292 m
= gfc_match_null (result
);
296 m
= gfc_match_name (name
);
300 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
304 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
306 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
310 else if (sym
->attr
.flavor
== FL_DERIVED
)
311 return gfc_match_structure_constructor (sym
, result
);
313 *result
= gfc_copy_expr (sym
->value
);
318 /* Match a list of values in a DATA statement. The leading '/' has
319 already been seen at this point. */
322 top_val_list (gfc_data
* data
)
324 gfc_data_value
*new, *tail
;
333 m
= match_data_constant (&expr
);
336 if (m
== MATCH_ERROR
)
339 new = gfc_get_data_value ();
348 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
356 msg
= gfc_extract_int (expr
, &tmp
);
357 gfc_free_expr (expr
);
365 m
= match_data_constant (&tail
->expr
);
368 if (m
== MATCH_ERROR
)
372 if (gfc_match_char ('/') == MATCH_YES
)
374 if (gfc_match_char (',') == MATCH_NO
)
381 gfc_syntax_error (ST_DATA
);
386 /* Matches an old style initialization. */
389 match_old_style_init (const char *name
)
395 /* Set up data structure to hold initializers. */
396 gfc_find_sym_tree (name
, NULL
, 0, &st
);
398 newdata
= gfc_get_data ();
399 newdata
->var
= gfc_get_data_variable ();
400 newdata
->var
->expr
= gfc_get_variable_expr (st
);
402 /* Match initial value list. This also eats the terminal
404 m
= top_val_list (newdata
);
413 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
418 /* Chain in namespace list of DATA initializers. */
419 newdata
->next
= gfc_current_ns
->data
;
420 gfc_current_ns
->data
= newdata
;
425 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
426 we are matching a DATA statement and are therefore issuing an error
427 if we encounter something unexpected, if not, we're trying to match
428 an old-style initialization expression of the form INTEGER I /2/. */
431 gfc_match_data (void)
438 new = gfc_get_data ();
439 new->where
= gfc_current_locus
;
441 m
= top_var_list (new);
445 m
= top_val_list (new);
449 new->next
= gfc_current_ns
->data
;
450 gfc_current_ns
->data
= new;
452 if (gfc_match_eos () == MATCH_YES
)
455 gfc_match_char (','); /* Optional comma */
460 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
472 /************************ Declaration statements *********************/
474 /* Match an intent specification. Since this can only happen after an
475 INTENT word, a legal intent-spec must follow. */
478 match_intent_spec (void)
481 if (gfc_match (" ( in out )") == MATCH_YES
)
483 if (gfc_match (" ( in )") == MATCH_YES
)
485 if (gfc_match (" ( out )") == MATCH_YES
)
488 gfc_error ("Bad INTENT specification at %C");
489 return INTENT_UNKNOWN
;
493 /* Matches a character length specification, which is either a
494 specification expression or a '*'. */
497 char_len_param_value (gfc_expr
** expr
)
500 if (gfc_match_char ('*') == MATCH_YES
)
506 return gfc_match_expr (expr
);
510 /* A character length is a '*' followed by a literal integer or a
511 char_len_param_value in parenthesis. */
514 match_char_length (gfc_expr
** expr
)
519 m
= gfc_match_char ('*');
523 m
= gfc_match_small_literal_int (&length
);
524 if (m
== MATCH_ERROR
)
529 *expr
= gfc_int_expr (length
);
533 if (gfc_match_char ('(') == MATCH_NO
)
536 m
= char_len_param_value (expr
);
537 if (m
== MATCH_ERROR
)
542 if (gfc_match_char (')') == MATCH_NO
)
544 gfc_free_expr (*expr
);
552 gfc_error ("Syntax error in character length specification at %C");
557 /* Special subroutine for finding a symbol. Check if the name is found
558 in the current name space. If not, and we're compiling a function or
559 subroutine and the parent compilation unit is an interface, then check
560 to see if the name we've been given is the name of the interface
561 (located in another namespace). */
564 find_special (const char *name
, gfc_symbol
** result
)
569 i
= gfc_get_symbol (name
, NULL
, result
);
573 if (gfc_current_state () != COMP_SUBROUTINE
574 && gfc_current_state () != COMP_FUNCTION
)
577 s
= gfc_state_stack
->previous
;
581 if (s
->state
!= COMP_INTERFACE
)
584 goto end
; /* Nameless interface */
586 if (strcmp (name
, s
->sym
->name
) == 0)
597 /* Special subroutine for getting a symbol node associated with a
598 procedure name, used in SUBROUTINE and FUNCTION statements. The
599 symbol is created in the parent using with symtree node in the
600 child unit pointing to the symbol. If the current namespace has no
601 parent, then the symbol is just created in the current unit. */
604 get_proc_name (const char *name
, gfc_symbol
** result
)
610 if (gfc_current_ns
->parent
== NULL
)
611 return gfc_get_symbol (name
, NULL
, result
);
613 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
617 /* ??? Deal with ENTRY problem */
619 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
625 /* See if the procedure should be a module procedure */
627 if (sym
->ns
->proc_name
!= NULL
628 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
629 && sym
->attr
.proc
!= PROC_MODULE
630 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
631 sym
->name
, NULL
) == FAILURE
)
638 /* Function called by variable_decl() that adds a name to the symbol
642 build_sym (const char *name
, gfc_charlen
* cl
,
643 gfc_array_spec
** as
, locus
* var_locus
)
645 symbol_attribute attr
;
648 /* if (find_special (name, &sym)) */
649 if (gfc_get_symbol (name
, NULL
, &sym
))
652 /* Start updating the symbol table. Add basic type attribute
654 if (current_ts
.type
!= BT_UNKNOWN
655 &&(sym
->attr
.implicit_type
== 0
656 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
657 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
660 if (sym
->ts
.type
== BT_CHARACTER
)
663 /* Add dimension attribute if present. */
664 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
668 /* Add attribute to symbol. The copy is so that we can reset the
669 dimension attribute. */
673 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
679 /* Set character constant to the given length. The constant will be padded or
683 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
688 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
689 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
691 slen
= expr
->value
.character
.length
;
694 s
= gfc_getmem (len
);
695 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
697 memset (&s
[slen
], ' ', len
- slen
);
698 gfc_free (expr
->value
.character
.string
);
699 expr
->value
.character
.string
= s
;
700 expr
->value
.character
.length
= len
;
705 /* Function to create and update the enumumerator history
706 using the information passed as arguments.
707 Pointer "max_enum" is also updated, to point to
708 enum history node containing largest initializer.
710 SYM points to the symbol node of enumerator.
711 INIT points to its enumerator value. */
714 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
716 enumerator_history
*new_enum_history
;
717 gcc_assert (sym
!= NULL
&& init
!= NULL
);
719 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
721 new_enum_history
->sym
= sym
;
722 new_enum_history
->initializer
= init
;
723 new_enum_history
->next
= NULL
;
725 if (enum_history
== NULL
)
727 enum_history
= new_enum_history
;
728 max_enum
= enum_history
;
732 new_enum_history
->next
= enum_history
;
733 enum_history
= new_enum_history
;
735 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
736 new_enum_history
->initializer
->value
.integer
) < 0)
737 max_enum
= new_enum_history
;
742 /* Function to free enum kind history. */
745 gfc_free_enum_history(void)
747 enumerator_history
*current
= enum_history
;
748 enumerator_history
*next
;
750 while (current
!= NULL
)
752 next
= current
->next
;
761 /* Function called by variable_decl() that adds an initialization
762 expression to a symbol. */
765 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
768 symbol_attribute attr
;
773 if (find_special (name
, &sym
))
778 /* If this symbol is confirming an implicit parameter type,
779 then an initialization expression is not allowed. */
780 if (attr
.flavor
== FL_PARAMETER
781 && sym
->value
!= NULL
784 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
793 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
800 /* An initializer is required for PARAMETER declarations. */
801 if (attr
.flavor
== FL_PARAMETER
)
803 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
809 /* If a variable appears in a DATA block, it cannot have an
814 ("Variable '%s' at %C with an initializer already appears "
815 "in a DATA statement", sym
->name
);
819 /* Check if the assignment can happen. This has to be put off
820 until later for a derived type variable. */
821 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
822 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
825 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
827 /* Update symbol character length according initializer. */
828 if (sym
->ts
.cl
->length
== NULL
)
830 /* If there are multiple CHARACTER variables declared on
831 the same line, we don't want them to share the same
833 sym
->ts
.cl
= gfc_get_charlen ();
834 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
835 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
837 if (init
->expr_type
== EXPR_CONSTANT
)
839 gfc_int_expr (init
->value
.character
.length
);
840 else if (init
->expr_type
== EXPR_ARRAY
)
841 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
843 /* Update initializer character length according symbol. */
844 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
846 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
849 if (init
->expr_type
== EXPR_CONSTANT
)
850 gfc_set_constant_character_len (len
, init
);
851 else if (init
->expr_type
== EXPR_ARRAY
)
853 gfc_free_expr (init
->ts
.cl
->length
);
854 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
855 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
856 gfc_set_constant_character_len (len
, p
->expr
);
861 /* Add initializer. Make sure we keep the ranks sane. */
862 if (sym
->attr
.dimension
&& init
->rank
== 0)
863 init
->rank
= sym
->as
->rank
;
869 /* Maintain enumerator history. */
870 if (gfc_current_state () == COMP_ENUM
)
871 create_enum_history (sym
, init
);
877 /* Function called by variable_decl() that adds a name to a structure
881 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
882 gfc_array_spec
** as
)
886 /* If the current symbol is of the same derived type that we're
887 constructing, it must have the pointer attribute. */
888 if (current_ts
.type
== BT_DERIVED
889 && current_ts
.derived
== gfc_current_block ()
890 && current_attr
.pointer
== 0)
892 gfc_error ("Component at %C must have the POINTER attribute");
896 if (gfc_current_block ()->attr
.pointer
899 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
901 gfc_error ("Array component of structure at %C must have explicit "
902 "or deferred shape");
907 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
912 gfc_set_component_attr (c
, ¤t_attr
);
914 c
->initializer
= *init
;
922 /* Check array components. */
928 if (c
->as
->type
!= AS_DEFERRED
)
930 gfc_error ("Pointer array component of structure at %C "
931 "must have a deferred shape");
937 if (c
->as
->type
!= AS_EXPLICIT
)
940 ("Array component of structure at %C must have an explicit "
950 /* Match a 'NULL()', and possibly take care of some side effects. */
953 gfc_match_null (gfc_expr
** result
)
959 m
= gfc_match (" null ( )");
963 /* The NULL symbol now has to be/become an intrinsic function. */
964 if (gfc_get_symbol ("null", NULL
, &sym
))
966 gfc_error ("NULL() initialization at %C is ambiguous");
970 gfc_intrinsic_symbol (sym
);
972 if (sym
->attr
.proc
!= PROC_INTRINSIC
973 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
974 sym
->name
, NULL
) == FAILURE
975 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
979 e
->where
= gfc_current_locus
;
980 e
->expr_type
= EXPR_NULL
;
981 e
->ts
.type
= BT_UNKNOWN
;
989 /* Match a variable name with an optional initializer. When this
990 subroutine is called, a variable is expected to be parsed next.
991 Depending on what is happening at the moment, updates either the
992 symbol table or the current interface. */
995 variable_decl (int elem
)
997 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
998 gfc_expr
*initializer
, *char_len
;
1000 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1011 old_locus
= gfc_current_locus
;
1013 /* When we get here, we've just matched a list of attributes and
1014 maybe a type and a double colon. The next thing we expect to see
1015 is the name of the symbol. */
1016 m
= gfc_match_name (name
);
1020 var_locus
= gfc_current_locus
;
1022 /* Now we could see the optional array spec. or character length. */
1023 m
= gfc_match_array_spec (&as
);
1024 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1025 cp_as
= gfc_copy_array_spec (as
);
1026 else if (m
== MATCH_ERROR
)
1030 as
= gfc_copy_array_spec (current_as
);
1031 else if (gfc_current_state () == COMP_ENUM
)
1033 gfc_error ("Enumerator cannot be array at %C");
1034 gfc_free_enum_history ();
1043 if (current_ts
.type
== BT_CHARACTER
)
1045 switch (match_char_length (&char_len
))
1048 cl
= gfc_get_charlen ();
1049 cl
->next
= gfc_current_ns
->cl_list
;
1050 gfc_current_ns
->cl_list
= cl
;
1052 cl
->length
= char_len
;
1055 /* Non-constant lengths need to be copied after the first
1058 if (elem
> 1 && current_ts
.cl
->length
1059 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1061 cl
= gfc_get_charlen ();
1062 cl
->next
= gfc_current_ns
->cl_list
;
1063 gfc_current_ns
->cl_list
= cl
;
1064 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1076 /* If this symbol has already shown up in a Cray Pointer declaration,
1077 then we want to set the type & bail out. */
1078 if (gfc_option
.flag_cray_pointer
)
1080 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1081 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1083 sym
->ts
.type
= current_ts
.type
;
1084 sym
->ts
.kind
= current_ts
.kind
;
1086 sym
->ts
.derived
= current_ts
.derived
;
1089 /* Check to see if we have an array specification. */
1092 if (sym
->as
!= NULL
)
1094 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1095 gfc_free_array_spec (cp_as
);
1101 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1102 gfc_internal_error ("Couldn't set pointee array spec.");
1104 /* Fix the array spec. */
1105 m
= gfc_mod_pointee_as (sym
->as
);
1106 if (m
== MATCH_ERROR
)
1114 gfc_free_array_spec (cp_as
);
1119 /* OK, we've successfully matched the declaration. Now put the
1120 symbol in the current namespace, because it might be used in the
1121 optional initialization expression for this symbol, e.g. this is
1124 integer, parameter :: i = huge(i)
1126 This is only true for parameters or variables of a basic type.
1127 For components of derived types, it is not true, so we don't
1128 create a symbol for those yet. If we fail to create the symbol,
1130 if (gfc_current_state () != COMP_DERIVED
1131 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1137 /* In functions that have a RESULT variable defined, the function
1138 name always refers to function calls. Therefore, the name is
1139 not allowed to appear in specification statements. */
1140 if (gfc_current_state () == COMP_FUNCTION
1141 && gfc_current_block () != NULL
1142 && gfc_current_block ()->result
!= NULL
1143 && gfc_current_block ()->result
!= gfc_current_block ()
1144 && strcmp (gfc_current_block ()->name
, name
) == 0)
1146 gfc_error ("Function name '%s' not allowed at %C", name
);
1151 /* We allow old-style initializations of the form
1152 integer i /2/, j(4) /3*3, 1/
1153 (if no colon has been seen). These are different from data
1154 statements in that initializers are only allowed to apply to the
1155 variable immediately preceding, i.e.
1157 is not allowed. Therefore we have to do some work manually, that
1158 could otherwise be left to the matchers for DATA statements. */
1160 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1162 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1163 "initialization at %C") == FAILURE
)
1166 return match_old_style_init (name
);
1169 /* The double colon must be present in order to have initializers.
1170 Otherwise the statement is ambiguous with an assignment statement. */
1173 if (gfc_match (" =>") == MATCH_YES
)
1176 if (!current_attr
.pointer
)
1178 gfc_error ("Initialization at %C isn't for a pointer variable");
1183 m
= gfc_match_null (&initializer
);
1186 gfc_error ("Pointer initialization requires a NULL at %C");
1190 if (gfc_pure (NULL
))
1193 ("Initialization of pointer at %C is not allowed in a "
1201 initializer
->ts
= current_ts
;
1204 else if (gfc_match_char ('=') == MATCH_YES
)
1206 if (current_attr
.pointer
)
1209 ("Pointer initialization at %C requires '=>', not '='");
1214 m
= gfc_match_init_expr (&initializer
);
1217 gfc_error ("Expected an initialization expression at %C");
1221 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1224 ("Initialization of variable at %C is not allowed in a "
1234 /* Check if we are parsing an enumeration and if the current enumerator
1235 variable has an initializer or not. If it does not have an
1236 initializer, the initialization value of the previous enumerator
1237 (stored in last_initializer) is incremented by 1 and is used to
1238 initialize the current enumerator. */
1239 if (gfc_current_state () == COMP_ENUM
)
1241 if (initializer
== NULL
)
1242 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1244 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1246 gfc_error("ENUMERATOR %L not initialized with integer expression",
1249 gfc_free_enum_history ();
1253 /* Store this current initializer, for the next enumerator
1254 variable to be parsed. */
1255 last_initializer
= initializer
;
1258 /* Add the initializer. Note that it is fine if initializer is
1259 NULL here, because we sometimes also need to check if a
1260 declaration *must* have an initialization expression. */
1261 if (gfc_current_state () != COMP_DERIVED
)
1262 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1265 if (current_ts
.type
== BT_DERIVED
&& !current_attr
.pointer
&& !initializer
)
1266 initializer
= gfc_default_initializer (¤t_ts
);
1267 t
= build_struct (name
, cl
, &initializer
, &as
);
1270 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1273 /* Free stuff up and return. */
1274 gfc_free_expr (initializer
);
1275 gfc_free_array_spec (as
);
1281 /* Match an extended-f77 kind specification. */
1284 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1288 if (gfc_match_char ('*') != MATCH_YES
)
1291 m
= gfc_match_small_literal_int (&ts
->kind
);
1295 /* Massage the kind numbers for complex types. */
1296 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1298 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1301 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1303 gfc_error ("Old-style kind %d not supported for type %s at %C",
1304 ts
->kind
, gfc_basic_typename (ts
->type
));
1313 /* Match a kind specification. Since kinds are generally optional, we
1314 usually return MATCH_NO if something goes wrong. If a "kind="
1315 string is found, then we know we have an error. */
1318 gfc_match_kind_spec (gfc_typespec
* ts
)
1328 where
= gfc_current_locus
;
1330 if (gfc_match_char ('(') == MATCH_NO
)
1333 /* Also gobbles optional text. */
1334 if (gfc_match (" kind = ") == MATCH_YES
)
1337 n
= gfc_match_init_expr (&e
);
1339 gfc_error ("Expected initialization expression at %C");
1345 gfc_error ("Expected scalar initialization expression at %C");
1350 msg
= gfc_extract_int (e
, &ts
->kind
);
1361 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1363 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1364 gfc_basic_typename (ts
->type
));
1370 if (gfc_match_char (')') != MATCH_YES
)
1372 gfc_error ("Missing right paren at %C");
1380 gfc_current_locus
= where
;
1385 /* Match the various kind/length specifications in a CHARACTER
1386 declaration. We don't return MATCH_NO. */
1389 match_char_spec (gfc_typespec
* ts
)
1391 int i
, kind
, seen_length
;
1396 kind
= gfc_default_character_kind
;
1400 /* Try the old-style specification first. */
1401 old_char_selector
= 0;
1403 m
= match_char_length (&len
);
1407 old_char_selector
= 1;
1412 m
= gfc_match_char ('(');
1415 m
= MATCH_YES
; /* character without length is a single char */
1419 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1420 if (gfc_match (" kind =") == MATCH_YES
)
1422 m
= gfc_match_small_int (&kind
);
1423 if (m
== MATCH_ERROR
)
1428 if (gfc_match (" , len =") == MATCH_NO
)
1431 m
= char_len_param_value (&len
);
1434 if (m
== MATCH_ERROR
)
1441 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1442 if (gfc_match (" len =") == MATCH_YES
)
1444 m
= char_len_param_value (&len
);
1447 if (m
== MATCH_ERROR
)
1451 if (gfc_match_char (')') == MATCH_YES
)
1454 if (gfc_match (" , kind =") != MATCH_YES
)
1457 gfc_match_small_int (&kind
);
1459 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1461 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1468 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1469 m
= char_len_param_value (&len
);
1472 if (m
== MATCH_ERROR
)
1476 m
= gfc_match_char (')');
1480 if (gfc_match_char (',') != MATCH_YES
)
1483 gfc_match (" kind ="); /* Gobble optional text */
1485 m
= gfc_match_small_int (&kind
);
1486 if (m
== MATCH_ERROR
)
1492 /* Require a right-paren at this point. */
1493 m
= gfc_match_char (')');
1498 gfc_error ("Syntax error in CHARACTER declaration at %C");
1502 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1504 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1510 gfc_free_expr (len
);
1514 /* Do some final massaging of the length values. */
1515 cl
= gfc_get_charlen ();
1516 cl
->next
= gfc_current_ns
->cl_list
;
1517 gfc_current_ns
->cl_list
= cl
;
1519 if (seen_length
== 0)
1520 cl
->length
= gfc_int_expr (1);
1523 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1527 gfc_free_expr (len
);
1528 cl
->length
= gfc_int_expr (0);
1539 /* Matches a type specification. If successful, sets the ts structure
1540 to the matched specification. This is necessary for FUNCTION and
1541 IMPLICIT statements.
1543 If implicit_flag is nonzero, then we don't check for the optional
1544 kind specification. Not doing so is needed for matching an IMPLICIT
1545 statement correctly. */
1548 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1550 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1557 if (gfc_match (" byte") == MATCH_YES
)
1559 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1563 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1565 gfc_error ("BYTE type used at %C "
1566 "is not available on the target machine");
1570 ts
->type
= BT_INTEGER
;
1575 if (gfc_match (" integer") == MATCH_YES
)
1577 ts
->type
= BT_INTEGER
;
1578 ts
->kind
= gfc_default_integer_kind
;
1582 if (gfc_match (" character") == MATCH_YES
)
1584 ts
->type
= BT_CHARACTER
;
1585 if (implicit_flag
== 0)
1586 return match_char_spec (ts
);
1591 if (gfc_match (" real") == MATCH_YES
)
1594 ts
->kind
= gfc_default_real_kind
;
1598 if (gfc_match (" double precision") == MATCH_YES
)
1601 ts
->kind
= gfc_default_double_kind
;
1605 if (gfc_match (" complex") == MATCH_YES
)
1607 ts
->type
= BT_COMPLEX
;
1608 ts
->kind
= gfc_default_complex_kind
;
1612 if (gfc_match (" double complex") == MATCH_YES
)
1614 ts
->type
= BT_COMPLEX
;
1615 ts
->kind
= gfc_default_double_kind
;
1619 if (gfc_match (" logical") == MATCH_YES
)
1621 ts
->type
= BT_LOGICAL
;
1622 ts
->kind
= gfc_default_logical_kind
;
1626 m
= gfc_match (" type ( %n )", name
);
1630 /* Search for the name but allow the components to be defined later. */
1631 if (gfc_get_ha_symbol (name
, &sym
))
1633 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1637 if (sym
->attr
.flavor
!= FL_DERIVED
1638 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1641 ts
->type
= BT_DERIVED
;
1648 /* For all types except double, derived and character, look for an
1649 optional kind specifier. MATCH_NO is actually OK at this point. */
1650 if (implicit_flag
== 1)
1653 if (gfc_current_form
== FORM_FREE
)
1655 c
= gfc_peek_char();
1656 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1657 && c
!= ':' && c
!= ',')
1661 m
= gfc_match_kind_spec (ts
);
1662 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1663 m
= gfc_match_old_kind_spec (ts
);
1666 m
= MATCH_YES
; /* No kind specifier found. */
1672 /* Match an IMPLICIT NONE statement. Actually, this statement is
1673 already matched in parse.c, or we would not end up here in the
1674 first place. So the only thing we need to check, is if there is
1675 trailing garbage. If not, the match is successful. */
1678 gfc_match_implicit_none (void)
1681 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1685 /* Match the letter range(s) of an IMPLICIT statement. */
1688 match_implicit_range (void)
1690 int c
, c1
, c2
, inner
;
1693 cur_loc
= gfc_current_locus
;
1695 gfc_gobble_whitespace ();
1696 c
= gfc_next_char ();
1699 gfc_error ("Missing character range in IMPLICIT at %C");
1706 gfc_gobble_whitespace ();
1707 c1
= gfc_next_char ();
1711 gfc_gobble_whitespace ();
1712 c
= gfc_next_char ();
1717 inner
= 0; /* Fall through */
1724 gfc_gobble_whitespace ();
1725 c2
= gfc_next_char ();
1729 gfc_gobble_whitespace ();
1730 c
= gfc_next_char ();
1732 if ((c
!= ',') && (c
!= ')'))
1745 gfc_error ("Letters must be in alphabetic order in "
1746 "IMPLICIT statement at %C");
1750 /* See if we can add the newly matched range to the pending
1751 implicits from this IMPLICIT statement. We do not check for
1752 conflicts with whatever earlier IMPLICIT statements may have
1753 set. This is done when we've successfully finished matching
1755 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1762 gfc_syntax_error (ST_IMPLICIT
);
1764 gfc_current_locus
= cur_loc
;
1769 /* Match an IMPLICIT statement, storing the types for
1770 gfc_set_implicit() if the statement is accepted by the parser.
1771 There is a strange looking, but legal syntactic construction
1772 possible. It looks like:
1774 IMPLICIT INTEGER (a-b) (c-d)
1776 This is legal if "a-b" is a constant expression that happens to
1777 equal one of the legal kinds for integers. The real problem
1778 happens with an implicit specification that looks like:
1780 IMPLICIT INTEGER (a-b)
1782 In this case, a typespec matcher that is "greedy" (as most of the
1783 matchers are) gobbles the character range as a kindspec, leaving
1784 nothing left. We therefore have to go a bit more slowly in the
1785 matching process by inhibiting the kindspec checking during
1786 typespec matching and checking for a kind later. */
1789 gfc_match_implicit (void)
1796 /* We don't allow empty implicit statements. */
1797 if (gfc_match_eos () == MATCH_YES
)
1799 gfc_error ("Empty IMPLICIT statement at %C");
1805 /* First cleanup. */
1806 gfc_clear_new_implicit ();
1808 /* A basic type is mandatory here. */
1809 m
= match_type_spec (&ts
, 1);
1810 if (m
== MATCH_ERROR
)
1815 cur_loc
= gfc_current_locus
;
1816 m
= match_implicit_range ();
1820 /* We may have <TYPE> (<RANGE>). */
1821 gfc_gobble_whitespace ();
1822 c
= gfc_next_char ();
1823 if ((c
== '\n') || (c
== ','))
1825 /* Check for CHARACTER with no length parameter. */
1826 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1828 ts
.kind
= gfc_default_character_kind
;
1829 ts
.cl
= gfc_get_charlen ();
1830 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1831 gfc_current_ns
->cl_list
= ts
.cl
;
1832 ts
.cl
->length
= gfc_int_expr (1);
1835 /* Record the Successful match. */
1836 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1841 gfc_current_locus
= cur_loc
;
1844 /* Discard the (incorrectly) matched range. */
1845 gfc_clear_new_implicit ();
1847 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1848 if (ts
.type
== BT_CHARACTER
)
1849 m
= match_char_spec (&ts
);
1852 m
= gfc_match_kind_spec (&ts
);
1855 m
= gfc_match_old_kind_spec (&ts
);
1856 if (m
== MATCH_ERROR
)
1862 if (m
== MATCH_ERROR
)
1865 m
= match_implicit_range ();
1866 if (m
== MATCH_ERROR
)
1871 gfc_gobble_whitespace ();
1872 c
= gfc_next_char ();
1873 if ((c
!= '\n') && (c
!= ','))
1876 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1884 gfc_syntax_error (ST_IMPLICIT
);
1891 /* Matches an attribute specification including array specs. If
1892 successful, leaves the variables current_attr and current_as
1893 holding the specification. Also sets the colon_seen variable for
1894 later use by matchers associated with initializations.
1896 This subroutine is a little tricky in the sense that we don't know
1897 if we really have an attr-spec until we hit the double colon.
1898 Until that time, we can only return MATCH_NO. This forces us to
1899 check for duplicate specification at this level. */
1902 match_attr_spec (void)
1905 /* Modifiers that can exist in a type statement. */
1907 { GFC_DECL_BEGIN
= 0,
1908 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1909 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1910 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1911 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1912 GFC_DECL_END
/* Sentinel */
1916 /* GFC_DECL_END is the sentinel, index starts at 0. */
1917 #define NUM_DECL GFC_DECL_END
1919 static mstring decls
[] = {
1920 minit (", allocatable", DECL_ALLOCATABLE
),
1921 minit (", dimension", DECL_DIMENSION
),
1922 minit (", external", DECL_EXTERNAL
),
1923 minit (", intent ( in )", DECL_IN
),
1924 minit (", intent ( out )", DECL_OUT
),
1925 minit (", intent ( in out )", DECL_INOUT
),
1926 minit (", intrinsic", DECL_INTRINSIC
),
1927 minit (", optional", DECL_OPTIONAL
),
1928 minit (", parameter", DECL_PARAMETER
),
1929 minit (", pointer", DECL_POINTER
),
1930 minit (", private", DECL_PRIVATE
),
1931 minit (", public", DECL_PUBLIC
),
1932 minit (", save", DECL_SAVE
),
1933 minit (", target", DECL_TARGET
),
1934 minit ("::", DECL_COLON
),
1935 minit (NULL
, DECL_NONE
)
1938 locus start
, seen_at
[NUM_DECL
];
1945 gfc_clear_attr (¤t_attr
);
1946 start
= gfc_current_locus
;
1951 /* See if we get all of the keywords up to the final double colon. */
1952 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1957 d
= (decl_types
) gfc_match_strings (decls
);
1958 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1961 if (gfc_current_state () == COMP_ENUM
)
1963 gfc_error ("Enumerator cannot have attributes %C");
1968 seen_at
[d
] = gfc_current_locus
;
1970 if (d
== DECL_DIMENSION
)
1972 m
= gfc_match_array_spec (¤t_as
);
1976 gfc_error ("Missing dimension specification at %C");
1980 if (m
== MATCH_ERROR
)
1985 /* If we are parsing an enumeration and have enusured that no other
1986 attributes are present we can now set the parameter attribute. */
1987 if (gfc_current_state () == COMP_ENUM
)
1989 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
1997 /* No double colon, so assume that we've been looking at something
1998 else the whole time. */
2005 /* Since we've seen a double colon, we have to be looking at an
2006 attr-spec. This means that we can now issue errors. */
2007 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2012 case DECL_ALLOCATABLE
:
2013 attr
= "ALLOCATABLE";
2015 case DECL_DIMENSION
:
2022 attr
= "INTENT (IN)";
2025 attr
= "INTENT (OUT)";
2028 attr
= "INTENT (IN OUT)";
2030 case DECL_INTRINSIC
:
2036 case DECL_PARAMETER
:
2055 attr
= NULL
; /* This shouldn't happen */
2058 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2063 /* Now that we've dealt with duplicate attributes, add the attributes
2064 to the current attribute. */
2065 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2070 if (gfc_current_state () == COMP_DERIVED
2071 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2072 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2075 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2081 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2082 && gfc_current_state () != COMP_MODULE
)
2084 if (d
== DECL_PRIVATE
)
2089 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2097 case DECL_ALLOCATABLE
:
2098 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2101 case DECL_DIMENSION
:
2102 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2106 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2110 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2114 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2118 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2121 case DECL_INTRINSIC
:
2122 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2126 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2129 case DECL_PARAMETER
:
2130 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2134 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2138 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2143 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2148 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2152 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2156 gfc_internal_error ("match_attr_spec(): Bad attribute");
2170 gfc_current_locus
= start
;
2171 gfc_free_array_spec (current_as
);
2177 /* Match a data declaration statement. */
2180 gfc_match_data_decl (void)
2186 m
= match_type_spec (¤t_ts
, 0);
2190 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2192 sym
= gfc_use_derived (current_ts
.derived
);
2200 current_ts
.derived
= sym
;
2203 m
= match_attr_spec ();
2204 if (m
== MATCH_ERROR
)
2210 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2213 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2216 gfc_find_symbol (current_ts
.derived
->name
,
2217 current_ts
.derived
->ns
->parent
, 1, &sym
);
2219 /* Any symbol that we find had better be a type definition
2220 which has its components defined. */
2221 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2222 && current_ts
.derived
->components
!= NULL
)
2225 /* Now we have an error, which we signal, and then fix up
2226 because the knock-on is plain and simple confusing. */
2227 gfc_error_now ("Derived type at %C has not been previously defined "
2228 "and so cannot appear in a derived type definition.");
2229 current_attr
.pointer
= 1;
2234 /* If we have an old-style character declaration, and no new-style
2235 attribute specifications, then there a comma is optional between
2236 the type specification and the variable list. */
2237 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2238 gfc_match_char (',');
2240 /* Give the types/attributes to symbols that follow. Give the element
2241 a number so that repeat character length expressions can be copied. */
2245 m
= variable_decl (elem
++);
2246 if (m
== MATCH_ERROR
)
2251 if (gfc_match_eos () == MATCH_YES
)
2253 if (gfc_match_char (',') != MATCH_YES
)
2257 gfc_error ("Syntax error in data declaration at %C");
2261 gfc_free_array_spec (current_as
);
2267 /* Match a prefix associated with a function or subroutine
2268 declaration. If the typespec pointer is nonnull, then a typespec
2269 can be matched. Note that if nothing matches, MATCH_YES is
2270 returned (the null string was matched). */
2273 match_prefix (gfc_typespec
* ts
)
2277 gfc_clear_attr (¤t_attr
);
2281 if (!seen_type
&& ts
!= NULL
2282 && match_type_spec (ts
, 0) == MATCH_YES
2283 && gfc_match_space () == MATCH_YES
)
2290 if (gfc_match ("elemental% ") == MATCH_YES
)
2292 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2298 if (gfc_match ("pure% ") == MATCH_YES
)
2300 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2306 if (gfc_match ("recursive% ") == MATCH_YES
)
2308 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2314 /* At this point, the next item is not a prefix. */
2319 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2322 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2325 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2328 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2331 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2338 /* Match a formal argument list. */
2341 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2343 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2344 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2350 if (gfc_match_char ('(') != MATCH_YES
)
2357 if (gfc_match_char (')') == MATCH_YES
)
2362 if (gfc_match_char ('*') == MATCH_YES
)
2366 m
= gfc_match_name (name
);
2370 if (gfc_get_symbol (name
, NULL
, &sym
))
2374 p
= gfc_get_formal_arglist ();
2386 /* We don't add the VARIABLE flavor because the name could be a
2387 dummy procedure. We don't apply these attributes to formal
2388 arguments of statement functions. */
2389 if (sym
!= NULL
&& !st_flag
2390 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2391 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2397 /* The name of a program unit can be in a different namespace,
2398 so check for it explicitly. After the statement is accepted,
2399 the name is checked for especially in gfc_get_symbol(). */
2400 if (gfc_new_block
!= NULL
&& sym
!= NULL
2401 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2403 gfc_error ("Name '%s' at %C is the name of the procedure",
2409 if (gfc_match_char (')') == MATCH_YES
)
2412 m
= gfc_match_char (',');
2415 gfc_error ("Unexpected junk in formal argument list at %C");
2421 /* Check for duplicate symbols in the formal argument list. */
2424 for (p
= head
; p
->next
; p
= p
->next
)
2429 for (q
= p
->next
; q
; q
= q
->next
)
2430 if (p
->sym
== q
->sym
)
2433 ("Duplicate symbol '%s' in formal argument list at %C",
2442 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2452 gfc_free_formal_arglist (head
);
2457 /* Match a RESULT specification following a function declaration or
2458 ENTRY statement. Also matches the end-of-statement. */
2461 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2467 if (gfc_match (" result (") != MATCH_YES
)
2470 m
= gfc_match_name (name
);
2474 if (gfc_match (" )%t") != MATCH_YES
)
2476 gfc_error ("Unexpected junk following RESULT variable at %C");
2480 if (strcmp (function
->name
, name
) == 0)
2483 ("RESULT variable at %C must be different than function name");
2487 if (gfc_get_symbol (name
, NULL
, &r
))
2490 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2491 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2500 /* Match a function declaration. */
2503 gfc_match_function_decl (void)
2505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2506 gfc_symbol
*sym
, *result
;
2510 if (gfc_current_state () != COMP_NONE
2511 && gfc_current_state () != COMP_INTERFACE
2512 && gfc_current_state () != COMP_CONTAINS
)
2515 gfc_clear_ts (¤t_ts
);
2517 old_loc
= gfc_current_locus
;
2519 m
= match_prefix (¤t_ts
);
2522 gfc_current_locus
= old_loc
;
2526 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2528 gfc_current_locus
= old_loc
;
2532 if (get_proc_name (name
, &sym
))
2534 gfc_new_block
= sym
;
2536 m
= gfc_match_formal_arglist (sym
, 0, 0);
2538 gfc_error ("Expected formal argument list in function definition at %C");
2539 else if (m
== MATCH_ERROR
)
2544 if (gfc_match_eos () != MATCH_YES
)
2546 /* See if a result variable is present. */
2547 m
= match_result (sym
, &result
);
2549 gfc_error ("Unexpected junk after function declaration at %C");
2558 /* Make changes to the symbol. */
2561 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2564 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2565 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2568 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2570 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2571 gfc_basic_typename (sym
->ts
.type
));
2577 sym
->ts
= current_ts
;
2582 result
->ts
= current_ts
;
2583 sym
->result
= result
;
2589 gfc_current_locus
= old_loc
;
2594 /* Match an ENTRY statement. */
2597 gfc_match_entry (void)
2602 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2603 gfc_compile_state state
;
2607 m
= gfc_match_name (name
);
2611 state
= gfc_current_state ();
2612 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2617 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2620 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2622 case COMP_BLOCK_DATA
:
2624 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2626 case COMP_INTERFACE
:
2628 ("ENTRY statement at %C cannot appear within an INTERFACE");
2632 ("ENTRY statement at %C cannot appear "
2633 "within a DERIVED TYPE block");
2637 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2641 ("ENTRY statement at %C cannot appear within a DO block");
2645 ("ENTRY statement at %C cannot appear within a SELECT block");
2649 ("ENTRY statement at %C cannot appear within a FORALL block");
2653 ("ENTRY statement at %C cannot appear within a WHERE block");
2657 ("ENTRY statement at %C cannot appear "
2658 "within a contained subprogram");
2661 gfc_internal_error ("gfc_match_entry(): Bad state");
2666 if (gfc_current_ns
->parent
!= NULL
2667 && gfc_current_ns
->parent
->proc_name
2668 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2670 gfc_error("ENTRY statement at %C cannot appear in a "
2671 "contained procedure");
2675 if (get_proc_name (name
, &entry
))
2678 proc
= gfc_current_block ();
2680 if (state
== COMP_SUBROUTINE
)
2682 /* An entry in a subroutine. */
2683 m
= gfc_match_formal_arglist (entry
, 0, 1);
2687 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2688 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2693 /* An entry in a function. */
2694 m
= gfc_match_formal_arglist (entry
, 0, 1);
2700 if (gfc_match_eos () == MATCH_YES
)
2702 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2703 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2706 entry
->result
= entry
;
2710 m
= match_result (proc
, &result
);
2712 gfc_syntax_error (ST_ENTRY
);
2716 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2717 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2718 || gfc_add_function (&entry
->attr
, result
->name
,
2722 entry
->result
= result
;
2725 if (proc
->attr
.recursive
&& result
== NULL
)
2727 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2732 if (gfc_match_eos () != MATCH_YES
)
2734 gfc_syntax_error (ST_ENTRY
);
2738 entry
->attr
.recursive
= proc
->attr
.recursive
;
2739 entry
->attr
.elemental
= proc
->attr
.elemental
;
2740 entry
->attr
.pure
= proc
->attr
.pure
;
2742 el
= gfc_get_entry_list ();
2744 el
->next
= gfc_current_ns
->entries
;
2745 gfc_current_ns
->entries
= el
;
2747 el
->id
= el
->next
->id
+ 1;
2751 new_st
.op
= EXEC_ENTRY
;
2752 new_st
.ext
.entry
= el
;
2758 /* Match a subroutine statement, including optional prefixes. */
2761 gfc_match_subroutine (void)
2763 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2767 if (gfc_current_state () != COMP_NONE
2768 && gfc_current_state () != COMP_INTERFACE
2769 && gfc_current_state () != COMP_CONTAINS
)
2772 m
= match_prefix (NULL
);
2776 m
= gfc_match ("subroutine% %n", name
);
2780 if (get_proc_name (name
, &sym
))
2782 gfc_new_block
= sym
;
2784 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2787 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2790 if (gfc_match_eos () != MATCH_YES
)
2792 gfc_syntax_error (ST_SUBROUTINE
);
2796 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2803 /* Return nonzero if we're currently compiling a contained procedure. */
2806 contained_procedure (void)
2810 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2811 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2812 && s
->previous
!= NULL
2813 && s
->previous
->state
== COMP_CONTAINS
)
2819 /* Set the kind of each enumerator. The kind is selected such that it is
2820 interoperable with the corresponding C enumeration type, making
2821 sure that -fshort-enums is honored. */
2826 enumerator_history
*current_history
= NULL
;
2830 if (max_enum
== NULL
|| enum_history
== NULL
)
2833 if (!gfc_option
.fshort_enums
)
2839 kind
= gfc_integer_kinds
[i
++].kind
;
2841 while (kind
< gfc_c_int_kind
2842 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
2845 current_history
= enum_history
;
2846 while (current_history
!= NULL
)
2848 current_history
->sym
->ts
.kind
= kind
;
2849 current_history
= current_history
->next
;
2853 /* Match any of the various end-block statements. Returns the type of
2854 END to the caller. The END INTERFACE, END IF, END DO and END
2855 SELECT statements cannot be replaced by a single END statement. */
2858 gfc_match_end (gfc_statement
* st
)
2860 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2861 gfc_compile_state state
;
2863 const char *block_name
;
2868 old_loc
= gfc_current_locus
;
2869 if (gfc_match ("end") != MATCH_YES
)
2872 state
= gfc_current_state ();
2874 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2876 if (state
== COMP_CONTAINS
)
2878 state
= gfc_state_stack
->previous
->state
;
2879 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2880 : gfc_state_stack
->previous
->sym
->name
;
2887 *st
= ST_END_PROGRAM
;
2888 target
= " program";
2892 case COMP_SUBROUTINE
:
2893 *st
= ST_END_SUBROUTINE
;
2894 target
= " subroutine";
2895 eos_ok
= !contained_procedure ();
2899 *st
= ST_END_FUNCTION
;
2900 target
= " function";
2901 eos_ok
= !contained_procedure ();
2904 case COMP_BLOCK_DATA
:
2905 *st
= ST_END_BLOCK_DATA
;
2906 target
= " block data";
2911 *st
= ST_END_MODULE
;
2916 case COMP_INTERFACE
:
2917 *st
= ST_END_INTERFACE
;
2918 target
= " interface";
2941 *st
= ST_END_SELECT
;
2947 *st
= ST_END_FORALL
;
2962 last_initializer
= NULL
;
2964 gfc_free_enum_history ();
2968 gfc_error ("Unexpected END statement at %C");
2972 if (gfc_match_eos () == MATCH_YES
)
2976 /* We would have required END [something] */
2977 gfc_error ("%s statement expected at %L",
2978 gfc_ascii_statement (*st
), &old_loc
);
2985 /* Verify that we've got the sort of end-block that we're expecting. */
2986 if (gfc_match (target
) != MATCH_YES
)
2988 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2992 /* If we're at the end, make sure a block name wasn't required. */
2993 if (gfc_match_eos () == MATCH_YES
)
2996 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2999 if (gfc_current_block () == NULL
)
3002 gfc_error ("Expected block name of '%s' in %s statement at %C",
3003 block_name
, gfc_ascii_statement (*st
));
3008 /* END INTERFACE has a special handler for its several possible endings. */
3009 if (*st
== ST_END_INTERFACE
)
3010 return gfc_match_end_interface ();
3012 /* We haven't hit the end of statement, so what is left must be an end-name. */
3013 m
= gfc_match_space ();
3015 m
= gfc_match_name (name
);
3018 gfc_error ("Expected terminating name at %C");
3022 if (block_name
== NULL
)
3025 if (strcmp (name
, block_name
) != 0)
3027 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3028 gfc_ascii_statement (*st
));
3032 if (gfc_match_eos () == MATCH_YES
)
3036 gfc_syntax_error (*st
);
3039 gfc_current_locus
= old_loc
;
3045 /***************** Attribute declaration statements ****************/
3047 /* Set the attribute of a single variable. */
3052 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3060 m
= gfc_match_name (name
);
3064 if (find_special (name
, &sym
))
3067 var_locus
= gfc_current_locus
;
3069 /* Deal with possible array specification for certain attributes. */
3070 if (current_attr
.dimension
3071 || current_attr
.allocatable
3072 || current_attr
.pointer
3073 || current_attr
.target
)
3075 m
= gfc_match_array_spec (&as
);
3076 if (m
== MATCH_ERROR
)
3079 if (current_attr
.dimension
&& m
== MATCH_NO
)
3082 ("Missing array specification at %L in DIMENSION statement",
3088 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3089 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3091 gfc_error ("Array specification must be deferred at %L",
3098 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3099 if (current_attr
.dimension
== 0
3100 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3106 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3112 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3114 /* Fix the array spec. */
3115 m
= gfc_mod_pointee_as (sym
->as
);
3116 if (m
== MATCH_ERROR
)
3120 if ((current_attr
.external
|| current_attr
.intrinsic
)
3121 && sym
->attr
.flavor
!= FL_PROCEDURE
3122 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3131 gfc_free_array_spec (as
);
3136 /* Generic attribute declaration subroutine. Used for attributes that
3137 just have a list of names. */
3144 /* Gobble the optional double colon, by simply ignoring the result
3154 if (gfc_match_eos () == MATCH_YES
)
3160 if (gfc_match_char (',') != MATCH_YES
)
3162 gfc_error ("Unexpected character in variable list at %C");
3172 /* This routine matches Cray Pointer declarations of the form:
3173 pointer ( <pointer>, <pointee> )
3175 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3176 The pointer, if already declared, should be an integer. Otherwise, we
3177 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3178 be either a scalar, or an array declaration. No space is allocated for
3179 the pointee. For the statement
3180 pointer (ipt, ar(10))
3181 any subsequent uses of ar will be translated (in C-notation) as
3182 ar(i) => ((<type> *) ipt)(i)
3183 After gimplification, pointee variable will disappear in the code. */
3186 cray_pointer_decl (void)
3190 gfc_symbol
*cptr
; /* Pointer symbol. */
3191 gfc_symbol
*cpte
; /* Pointee symbol. */
3197 if (gfc_match_char ('(') != MATCH_YES
)
3199 gfc_error ("Expected '(' at %C");
3203 /* Match pointer. */
3204 var_locus
= gfc_current_locus
;
3205 gfc_clear_attr (¤t_attr
);
3206 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3207 current_ts
.type
= BT_INTEGER
;
3208 current_ts
.kind
= gfc_index_integer_kind
;
3210 m
= gfc_match_symbol (&cptr
, 0);
3213 gfc_error ("Expected variable name at %C");
3217 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3220 gfc_set_sym_referenced (cptr
);
3222 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3224 cptr
->ts
.type
= BT_INTEGER
;
3225 cptr
->ts
.kind
= gfc_index_integer_kind
;
3227 else if (cptr
->ts
.type
!= BT_INTEGER
)
3229 gfc_error ("Cray pointer at %C must be an integer.");
3232 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3233 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3234 " memory addresses require %d bytes.",
3236 gfc_index_integer_kind
);
3238 if (gfc_match_char (',') != MATCH_YES
)
3240 gfc_error ("Expected \",\" at %C");
3244 /* Match Pointee. */
3245 var_locus
= gfc_current_locus
;
3246 gfc_clear_attr (¤t_attr
);
3247 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3248 current_ts
.type
= BT_UNKNOWN
;
3249 current_ts
.kind
= 0;
3251 m
= gfc_match_symbol (&cpte
, 0);
3254 gfc_error ("Expected variable name at %C");
3258 /* Check for an optional array spec. */
3259 m
= gfc_match_array_spec (&as
);
3260 if (m
== MATCH_ERROR
)
3262 gfc_free_array_spec (as
);
3265 else if (m
== MATCH_NO
)
3267 gfc_free_array_spec (as
);
3271 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3274 gfc_set_sym_referenced (cpte
);
3276 if (cpte
->as
== NULL
)
3278 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3279 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3281 else if (as
!= NULL
)
3283 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3284 gfc_free_array_spec (as
);
3290 if (cpte
->as
!= NULL
)
3292 /* Fix array spec. */
3293 m
= gfc_mod_pointee_as (cpte
->as
);
3294 if (m
== MATCH_ERROR
)
3298 /* Point the Pointee at the Pointer. */
3299 cpte
->cp_pointer
= cptr
;
3301 if (gfc_match_char (')') != MATCH_YES
)
3303 gfc_error ("Expected \")\" at %C");
3306 m
= gfc_match_char (',');
3308 done
= true; /* Stop searching for more declarations. */
3312 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3313 || gfc_match_eos () != MATCH_YES
)
3315 gfc_error ("Expected \",\" or end of statement at %C");
3323 gfc_match_external (void)
3326 gfc_clear_attr (¤t_attr
);
3327 gfc_add_external (¤t_attr
, NULL
);
3329 return attr_decl ();
3335 gfc_match_intent (void)
3339 intent
= match_intent_spec ();
3340 if (intent
== INTENT_UNKNOWN
)
3343 gfc_clear_attr (¤t_attr
);
3344 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
3346 return attr_decl ();
3351 gfc_match_intrinsic (void)
3354 gfc_clear_attr (¤t_attr
);
3355 gfc_add_intrinsic (¤t_attr
, NULL
);
3357 return attr_decl ();
3362 gfc_match_optional (void)
3365 gfc_clear_attr (¤t_attr
);
3366 gfc_add_optional (¤t_attr
, NULL
);
3368 return attr_decl ();
3373 gfc_match_pointer (void)
3375 gfc_gobble_whitespace ();
3376 if (gfc_peek_char () == '(')
3378 if (!gfc_option
.flag_cray_pointer
)
3380 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3384 return cray_pointer_decl ();
3388 gfc_clear_attr (¤t_attr
);
3389 gfc_add_pointer (¤t_attr
, NULL
);
3391 return attr_decl ();
3397 gfc_match_allocatable (void)
3400 gfc_clear_attr (¤t_attr
);
3401 gfc_add_allocatable (¤t_attr
, NULL
);
3403 return attr_decl ();
3408 gfc_match_dimension (void)
3411 gfc_clear_attr (¤t_attr
);
3412 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
3414 return attr_decl ();
3419 gfc_match_target (void)
3422 gfc_clear_attr (¤t_attr
);
3423 gfc_add_target (¤t_attr
, NULL
);
3425 return attr_decl ();
3429 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3433 access_attr_decl (gfc_statement st
)
3435 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3436 interface_type type
;
3439 gfc_intrinsic_op
operator;
3442 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3447 m
= gfc_match_generic_spec (&type
, name
, &operator);
3450 if (m
== MATCH_ERROR
)
3455 case INTERFACE_NAMELESS
:
3458 case INTERFACE_GENERIC
:
3459 if (gfc_get_symbol (name
, NULL
, &sym
))
3462 if (gfc_add_access (&sym
->attr
,
3464 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3465 sym
->name
, NULL
) == FAILURE
)
3470 case INTERFACE_INTRINSIC_OP
:
3471 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3473 gfc_current_ns
->operator_access
[operator] =
3474 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3478 gfc_error ("Access specification of the %s operator at %C has "
3479 "already been specified", gfc_op2string (operator));
3485 case INTERFACE_USER_OP
:
3486 uop
= gfc_get_uop (name
);
3488 if (uop
->access
== ACCESS_UNKNOWN
)
3491 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3496 ("Access specification of the .%s. operator at %C has "
3497 "already been specified", sym
->name
);
3504 if (gfc_match_char (',') == MATCH_NO
)
3508 if (gfc_match_eos () != MATCH_YES
)
3513 gfc_syntax_error (st
);
3520 /* The PRIVATE statement is a bit weird in that it can be a attribute
3521 declaration, but also works as a standlone statement inside of a
3522 type declaration or a module. */
3525 gfc_match_private (gfc_statement
* st
)
3528 if (gfc_match ("private") != MATCH_YES
)
3531 if (gfc_current_state () == COMP_DERIVED
)
3533 if (gfc_match_eos () == MATCH_YES
)
3539 gfc_syntax_error (ST_PRIVATE
);
3543 if (gfc_match_eos () == MATCH_YES
)
3550 return access_attr_decl (ST_PRIVATE
);
3555 gfc_match_public (gfc_statement
* st
)
3558 if (gfc_match ("public") != MATCH_YES
)
3561 if (gfc_match_eos () == MATCH_YES
)
3568 return access_attr_decl (ST_PUBLIC
);
3572 /* Workhorse for gfc_match_parameter. */
3581 m
= gfc_match_symbol (&sym
, 0);
3583 gfc_error ("Expected variable name at %C in PARAMETER statement");
3588 if (gfc_match_char ('=') == MATCH_NO
)
3590 gfc_error ("Expected = sign in PARAMETER statement at %C");
3594 m
= gfc_match_init_expr (&init
);
3596 gfc_error ("Expected expression at %C in PARAMETER statement");
3600 if (sym
->ts
.type
== BT_UNKNOWN
3601 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3607 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3608 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3614 if (sym
->ts
.type
== BT_CHARACTER
3615 && sym
->ts
.cl
!= NULL
3616 && sym
->ts
.cl
->length
!= NULL
3617 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3618 && init
->expr_type
== EXPR_CONSTANT
3619 && init
->ts
.type
== BT_CHARACTER
3620 && init
->ts
.kind
== 1)
3621 gfc_set_constant_character_len (
3622 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3628 gfc_free_expr (init
);
3633 /* Match a parameter statement, with the weird syntax that these have. */
3636 gfc_match_parameter (void)
3640 if (gfc_match_char ('(') == MATCH_NO
)
3649 if (gfc_match (" )%t") == MATCH_YES
)
3652 if (gfc_match_char (',') != MATCH_YES
)
3654 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3664 /* Save statements have a special syntax. */
3667 gfc_match_save (void)
3669 char n
[GFC_MAX_SYMBOL_LEN
+1];
3674 if (gfc_match_eos () == MATCH_YES
)
3676 if (gfc_current_ns
->seen_save
)
3678 if (gfc_notify_std (GFC_STD_LEGACY
,
3679 "Blanket SAVE statement at %C follows previous "
3685 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3689 if (gfc_current_ns
->save_all
)
3691 if (gfc_notify_std (GFC_STD_LEGACY
,
3692 "SAVE statement at %C follows blanket SAVE statement")
3701 m
= gfc_match_symbol (&sym
, 0);
3705 if (gfc_add_save (&sym
->attr
, sym
->name
,
3706 &gfc_current_locus
) == FAILURE
)
3717 m
= gfc_match (" / %n /", &n
);
3718 if (m
== MATCH_ERROR
)
3723 c
= gfc_get_common (n
, 0);
3726 gfc_current_ns
->seen_save
= 1;
3729 if (gfc_match_eos () == MATCH_YES
)
3731 if (gfc_match_char (',') != MATCH_YES
)
3738 gfc_error ("Syntax error in SAVE statement at %C");
3743 /* Match a module procedure statement. Note that we have to modify
3744 symbols in the parent's namespace because the current one was there
3745 to receive symbols that are in an interface's formal argument list. */
3748 gfc_match_modproc (void)
3750 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3754 if (gfc_state_stack
->state
!= COMP_INTERFACE
3755 || gfc_state_stack
->previous
== NULL
3756 || current_interface
.type
== INTERFACE_NAMELESS
)
3759 ("MODULE PROCEDURE at %C must be in a generic module interface");
3765 m
= gfc_match_name (name
);
3771 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3774 if (sym
->attr
.proc
!= PROC_MODULE
3775 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3776 sym
->name
, NULL
) == FAILURE
)
3779 if (gfc_add_interface (sym
) == FAILURE
)
3782 if (gfc_match_eos () == MATCH_YES
)
3784 if (gfc_match_char (',') != MATCH_YES
)
3791 gfc_syntax_error (ST_MODULE_PROC
);
3796 /* Match the beginning of a derived type declaration. If a type name
3797 was the result of a function, then it is possible to have a symbol
3798 already to be known as a derived type yet have no components. */
3801 gfc_match_derived_decl (void)
3803 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3804 symbol_attribute attr
;
3808 if (gfc_current_state () == COMP_DERIVED
)
3811 gfc_clear_attr (&attr
);
3814 if (gfc_match (" , private") == MATCH_YES
)
3816 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3819 ("Derived type at %C can only be PRIVATE within a MODULE");
3823 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3828 if (gfc_match (" , public") == MATCH_YES
)
3830 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3832 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3836 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3841 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3843 gfc_error ("Expected :: in TYPE definition at %C");
3847 m
= gfc_match (" %n%t", name
);
3851 /* Make sure the name isn't the name of an intrinsic type. The
3852 'double precision' type doesn't get past the name matcher. */
3853 if (strcmp (name
, "integer") == 0
3854 || strcmp (name
, "real") == 0
3855 || strcmp (name
, "character") == 0
3856 || strcmp (name
, "logical") == 0
3857 || strcmp (name
, "complex") == 0)
3860 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3865 if (gfc_get_symbol (name
, NULL
, &sym
))
3868 if (sym
->ts
.type
!= BT_UNKNOWN
)
3870 gfc_error ("Derived type name '%s' at %C already has a basic type "
3871 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3875 /* The symbol may already have the derived attribute without the
3876 components. The ways this can happen is via a function
3877 definition, an INTRINSIC statement or a subtype in another
3878 derived type that is a pointer. The first part of the AND clause
3879 is true if a the symbol is not the return value of a function. */
3880 if (sym
->attr
.flavor
!= FL_DERIVED
3881 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3884 if (sym
->components
!= NULL
)
3887 ("Derived type definition of '%s' at %C has already been defined",
3892 if (attr
.access
!= ACCESS_UNKNOWN
3893 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3896 gfc_new_block
= sym
;
3902 /* Cray Pointees can be declared as:
3903 pointer (ipt, a (n,m,...,*))
3904 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
3905 cheat and set a constant bound of 1 for the last dimension, if this
3906 is the case. Since there is no bounds-checking for Cray Pointees,
3907 this will be okay. */
3910 gfc_mod_pointee_as (gfc_array_spec
*as
)
3912 as
->cray_pointee
= true; /* This will be useful to know later. */
3913 if (as
->type
== AS_ASSUMED_SIZE
)
3915 as
->type
= AS_EXPLICIT
;
3916 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
3917 as
->cp_was_assumed
= true;
3919 else if (as
->type
== AS_ASSUMED_SHAPE
)
3921 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
3928 /* Match the enum definition statement, here we are trying to match
3929 the first line of enum definition statement.
3930 Returns MATCH_YES if match is found. */
3933 gfc_match_enum (void)
3937 m
= gfc_match_eos ();
3941 if (gfc_notify_std (GFC_STD_F2003
,
3942 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
3950 /* Match the enumerator definition statement. */
3953 gfc_match_enumerator_def (void)
3958 gfc_clear_ts (¤t_ts
);
3960 m
= gfc_match (" enumerator");
3964 if (gfc_current_state () != COMP_ENUM
)
3966 gfc_error ("ENUM definition statement expected before %C");
3967 gfc_free_enum_history ();
3971 (¤t_ts
)->type
= BT_INTEGER
;
3972 (¤t_ts
)->kind
= gfc_c_int_kind
;
3974 m
= match_attr_spec ();
3975 if (m
== MATCH_ERROR
)
3984 m
= variable_decl (elem
++);
3985 if (m
== MATCH_ERROR
)
3990 if (gfc_match_eos () == MATCH_YES
)
3992 if (gfc_match_char (',') != MATCH_YES
)
3996 if (gfc_current_state () == COMP_ENUM
)
3998 gfc_free_enum_history ();
3999 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4004 gfc_free_array_spec (current_as
);