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 /* gfc_new_block points to the symbol of a newly matched block. */
48 gfc_symbol
*gfc_new_block
;
51 /********************* DATA statement subroutines *********************/
53 /* Free a gfc_data_variable structure and everything beneath it. */
56 free_variable (gfc_data_variable
* p
)
63 gfc_free_expr (p
->expr
);
64 gfc_free_iterator (&p
->iter
, 0);
65 free_variable (p
->list
);
72 /* Free a gfc_data_value structure and everything beneath it. */
75 free_value (gfc_data_value
* p
)
82 gfc_free_expr (p
->expr
);
88 /* Free a list of gfc_data structures. */
91 gfc_free_data (gfc_data
* p
)
99 free_variable (p
->var
);
100 free_value (p
->value
);
107 static match
var_element (gfc_data_variable
*);
109 /* Match a list of variables terminated by an iterator and a right
113 var_list (gfc_data_variable
* parent
)
115 gfc_data_variable
*tail
, var
;
118 m
= var_element (&var
);
119 if (m
== MATCH_ERROR
)
124 tail
= gfc_get_data_variable ();
131 if (gfc_match_char (',') != MATCH_YES
)
134 m
= gfc_match_iterator (&parent
->iter
, 1);
137 if (m
== MATCH_ERROR
)
140 m
= var_element (&var
);
141 if (m
== MATCH_ERROR
)
146 tail
->next
= gfc_get_data_variable ();
152 if (gfc_match_char (')') != MATCH_YES
)
157 gfc_syntax_error (ST_DATA
);
162 /* Match a single element in a data variable list, which can be a
163 variable-iterator list. */
166 var_element (gfc_data_variable
* new)
171 memset (new, 0, sizeof (gfc_data_variable
));
173 if (gfc_match_char ('(') == MATCH_YES
)
174 return var_list (new);
176 m
= gfc_match_variable (&new->expr
, 0);
180 sym
= new->expr
->symtree
->n
.sym
;
182 if(sym
->value
!= NULL
)
184 gfc_error ("Variable '%s' at %C already has an initialization",
189 #if 0 /* TODO: Find out where to move this message */
190 if (sym
->attr
.in_common
)
191 /* See if sym is in the blank common block. */
192 for (t
= &sym
->ns
->blank_common
; t
; t
= t
->common_next
)
195 gfc_error ("DATA statement at %C may not initialize variable "
196 "'%s' from blank COMMON", sym
->name
);
201 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
208 /* Match the top-level list of data variables. */
211 top_var_list (gfc_data
* d
)
213 gfc_data_variable var
, *tail
, *new;
220 m
= var_element (&var
);
223 if (m
== MATCH_ERROR
)
226 new = gfc_get_data_variable ();
236 if (gfc_match_char ('/') == MATCH_YES
)
238 if (gfc_match_char (',') != MATCH_YES
)
245 gfc_syntax_error (ST_DATA
);
251 match_data_constant (gfc_expr
** result
)
253 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
258 m
= gfc_match_literal_constant (&expr
, 1);
265 if (m
== MATCH_ERROR
)
268 m
= gfc_match_null (result
);
272 m
= gfc_match_name (name
);
276 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
280 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
282 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
286 else if (sym
->attr
.flavor
== FL_DERIVED
)
287 return gfc_match_structure_constructor (sym
, result
);
289 *result
= gfc_copy_expr (sym
->value
);
294 /* Match a list of values in a DATA statement. The leading '/' has
295 already been seen at this point. */
298 top_val_list (gfc_data
* data
)
300 gfc_data_value
*new, *tail
;
309 m
= match_data_constant (&expr
);
312 if (m
== MATCH_ERROR
)
315 new = gfc_get_data_value ();
324 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
332 msg
= gfc_extract_int (expr
, &tmp
);
333 gfc_free_expr (expr
);
341 m
= match_data_constant (&tail
->expr
);
344 if (m
== MATCH_ERROR
)
348 if (gfc_match_char ('/') == MATCH_YES
)
350 if (gfc_match_char (',') == MATCH_NO
)
357 gfc_syntax_error (ST_DATA
);
362 /* Matches an old style initialization. */
365 match_old_style_init (const char *name
)
371 /* Set up data structure to hold initializers. */
372 gfc_find_sym_tree (name
, NULL
, 0, &st
);
374 newdata
= gfc_get_data ();
375 newdata
->var
= gfc_get_data_variable ();
376 newdata
->var
->expr
= gfc_get_variable_expr (st
);
378 /* Match initial value list. This also eats the terminal
380 m
= top_val_list (newdata
);
389 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
394 /* Chain in namespace list of DATA initializers. */
395 newdata
->next
= gfc_current_ns
->data
;
396 gfc_current_ns
->data
= newdata
;
401 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
402 we are matching a DATA statement and are therefore issuing an error
403 if we encounter something unexpected, if not, we're trying to match
404 an old-style initialization expression of the form INTEGER I /2/. */
407 gfc_match_data (void)
414 new = gfc_get_data ();
415 new->where
= gfc_current_locus
;
417 m
= top_var_list (new);
421 m
= top_val_list (new);
425 new->next
= gfc_current_ns
->data
;
426 gfc_current_ns
->data
= new;
428 if (gfc_match_eos () == MATCH_YES
)
431 gfc_match_char (','); /* Optional comma */
436 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
448 /************************ Declaration statements *********************/
450 /* Match an intent specification. Since this can only happen after an
451 INTENT word, a legal intent-spec must follow. */
454 match_intent_spec (void)
457 if (gfc_match (" ( in out )") == MATCH_YES
)
459 if (gfc_match (" ( in )") == MATCH_YES
)
461 if (gfc_match (" ( out )") == MATCH_YES
)
464 gfc_error ("Bad INTENT specification at %C");
465 return INTENT_UNKNOWN
;
469 /* Matches a character length specification, which is either a
470 specification expression or a '*'. */
473 char_len_param_value (gfc_expr
** expr
)
476 if (gfc_match_char ('*') == MATCH_YES
)
482 return gfc_match_expr (expr
);
486 /* A character length is a '*' followed by a literal integer or a
487 char_len_param_value in parenthesis. */
490 match_char_length (gfc_expr
** expr
)
495 m
= gfc_match_char ('*');
499 m
= gfc_match_small_literal_int (&length
);
500 if (m
== MATCH_ERROR
)
505 *expr
= gfc_int_expr (length
);
509 if (gfc_match_char ('(') == MATCH_NO
)
512 m
= char_len_param_value (expr
);
513 if (m
== MATCH_ERROR
)
518 if (gfc_match_char (')') == MATCH_NO
)
520 gfc_free_expr (*expr
);
528 gfc_error ("Syntax error in character length specification at %C");
533 /* Special subroutine for finding a symbol. Check if the name is found
534 in the current name space. If not, and we're compiling a function or
535 subroutine and the parent compilation unit is an interface, then check
536 to see if the name we've been given is the name of the interface
537 (located in another namespace). */
540 find_special (const char *name
, gfc_symbol
** result
)
545 i
= gfc_get_symbol (name
, NULL
, result
);
549 if (gfc_current_state () != COMP_SUBROUTINE
550 && gfc_current_state () != COMP_FUNCTION
)
553 s
= gfc_state_stack
->previous
;
557 if (s
->state
!= COMP_INTERFACE
)
560 goto end
; /* Nameless interface */
562 if (strcmp (name
, s
->sym
->name
) == 0)
573 /* Special subroutine for getting a symbol node associated with a
574 procedure name, used in SUBROUTINE and FUNCTION statements. The
575 symbol is created in the parent using with symtree node in the
576 child unit pointing to the symbol. If the current namespace has no
577 parent, then the symbol is just created in the current unit. */
580 get_proc_name (const char *name
, gfc_symbol
** result
)
586 if (gfc_current_ns
->parent
== NULL
)
587 return gfc_get_symbol (name
, NULL
, result
);
589 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
593 /* ??? Deal with ENTRY problem */
595 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
601 /* See if the procedure should be a module procedure */
603 if (sym
->ns
->proc_name
!= NULL
604 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
605 && sym
->attr
.proc
!= PROC_MODULE
606 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
607 sym
->name
, NULL
) == FAILURE
)
614 /* Function called by variable_decl() that adds a name to the symbol
618 build_sym (const char *name
, gfc_charlen
* cl
,
619 gfc_array_spec
** as
, locus
* var_locus
)
621 symbol_attribute attr
;
624 /* if (find_special (name, &sym)) */
625 if (gfc_get_symbol (name
, NULL
, &sym
))
628 /* Start updating the symbol table. Add basic type attribute
630 if (current_ts
.type
!= BT_UNKNOWN
631 &&(sym
->attr
.implicit_type
== 0
632 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
633 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
636 if (sym
->ts
.type
== BT_CHARACTER
)
639 /* Add dimension attribute if present. */
640 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
644 /* Add attribute to symbol. The copy is so that we can reset the
645 dimension attribute. */
649 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
655 /* Set character constant to the given length. The constant will be padded or
659 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
664 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
665 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
667 slen
= expr
->value
.character
.length
;
670 s
= gfc_getmem (len
);
671 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
673 memset (&s
[slen
], ' ', len
- slen
);
674 gfc_free (expr
->value
.character
.string
);
675 expr
->value
.character
.string
= s
;
676 expr
->value
.character
.length
= len
;
680 /* Function called by variable_decl() that adds an initialization
681 expression to a symbol. */
684 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
687 symbol_attribute attr
;
692 if (find_special (name
, &sym
))
697 /* If this symbol is confirming an implicit parameter type,
698 then an initialization expression is not allowed. */
699 if (attr
.flavor
== FL_PARAMETER
700 && sym
->value
!= NULL
703 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
712 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
719 /* An initializer is required for PARAMETER declarations. */
720 if (attr
.flavor
== FL_PARAMETER
)
722 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
728 /* If a variable appears in a DATA block, it cannot have an
733 ("Variable '%s' at %C with an initializer already appears "
734 "in a DATA statement", sym
->name
);
738 /* Check if the assignment can happen. This has to be put off
739 until later for a derived type variable. */
740 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
741 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
744 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
746 /* Update symbol character length according initializer. */
747 if (sym
->ts
.cl
->length
== NULL
)
749 /* If there are multiple CHARACTER variables declared on
750 the same line, we don't want them to share the same
752 sym
->ts
.cl
= gfc_get_charlen ();
753 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
754 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
756 if (init
->expr_type
== EXPR_CONSTANT
)
758 gfc_int_expr (init
->value
.character
.length
);
759 else if (init
->expr_type
== EXPR_ARRAY
)
760 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
762 /* Update initializer character length according symbol. */
763 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
765 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
768 if (init
->expr_type
== EXPR_CONSTANT
)
769 gfc_set_constant_character_len (len
, init
);
770 else if (init
->expr_type
== EXPR_ARRAY
)
772 gfc_free_expr (init
->ts
.cl
->length
);
773 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
774 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
775 gfc_set_constant_character_len (len
, p
->expr
);
780 /* Add initializer. Make sure we keep the ranks sane. */
781 if (sym
->attr
.dimension
&& init
->rank
== 0)
782 init
->rank
= sym
->as
->rank
;
792 /* Function called by variable_decl() that adds a name to a structure
796 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
797 gfc_array_spec
** as
)
801 /* If the current symbol is of the same derived type that we're
802 constructing, it must have the pointer attribute. */
803 if (current_ts
.type
== BT_DERIVED
804 && current_ts
.derived
== gfc_current_block ()
805 && current_attr
.pointer
== 0)
807 gfc_error ("Component at %C must have the POINTER attribute");
811 if (gfc_current_block ()->attr
.pointer
814 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
816 gfc_error ("Array component of structure at %C must have explicit "
817 "or deferred shape");
822 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
827 gfc_set_component_attr (c
, ¤t_attr
);
829 c
->initializer
= *init
;
837 /* Check array components. */
843 if (c
->as
->type
!= AS_DEFERRED
)
845 gfc_error ("Pointer array component of structure at %C "
846 "must have a deferred shape");
852 if (c
->as
->type
!= AS_EXPLICIT
)
855 ("Array component of structure at %C must have an explicit "
865 /* Match a 'NULL()', and possibly take care of some side effects. */
868 gfc_match_null (gfc_expr
** result
)
874 m
= gfc_match (" null ( )");
878 /* The NULL symbol now has to be/become an intrinsic function. */
879 if (gfc_get_symbol ("null", NULL
, &sym
))
881 gfc_error ("NULL() initialization at %C is ambiguous");
885 gfc_intrinsic_symbol (sym
);
887 if (sym
->attr
.proc
!= PROC_INTRINSIC
888 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
889 sym
->name
, NULL
) == FAILURE
890 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
894 e
->where
= gfc_current_locus
;
895 e
->expr_type
= EXPR_NULL
;
896 e
->ts
.type
= BT_UNKNOWN
;
904 /* Match a variable name with an optional initializer. When this
905 subroutine is called, a variable is expected to be parsed next.
906 Depending on what is happening at the moment, updates either the
907 symbol table or the current interface. */
910 variable_decl (int elem
)
912 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
913 gfc_expr
*initializer
, *char_len
;
923 /* When we get here, we've just matched a list of attributes and
924 maybe a type and a double colon. The next thing we expect to see
925 is the name of the symbol. */
926 m
= gfc_match_name (name
);
930 var_locus
= gfc_current_locus
;
932 /* Now we could see the optional array spec. or character length. */
933 m
= gfc_match_array_spec (&as
);
934 if (m
== MATCH_ERROR
)
937 as
= gfc_copy_array_spec (current_as
);
942 if (current_ts
.type
== BT_CHARACTER
)
944 switch (match_char_length (&char_len
))
947 cl
= gfc_get_charlen ();
948 cl
->next
= gfc_current_ns
->cl_list
;
949 gfc_current_ns
->cl_list
= cl
;
951 cl
->length
= char_len
;
954 /* Non-constant lengths need to be copied after the first
957 if (elem
> 1 && current_ts
.cl
->length
958 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
960 cl
= gfc_get_charlen ();
961 cl
->next
= gfc_current_ns
->cl_list
;
962 gfc_current_ns
->cl_list
= cl
;
963 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
975 /* OK, we've successfully matched the declaration. Now put the
976 symbol in the current namespace, because it might be used in the
977 optional initialization expression for this symbol, e.g. this is
980 integer, parameter :: i = huge(i)
982 This is only true for parameters or variables of a basic type.
983 For components of derived types, it is not true, so we don't
984 create a symbol for those yet. If we fail to create the symbol,
986 if (gfc_current_state () != COMP_DERIVED
987 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
993 /* In functions that have a RESULT variable defined, the function
994 name always refers to function calls. Therefore, the name is
995 not allowed to appear in specification statements. */
996 if (gfc_current_state () == COMP_FUNCTION
997 && gfc_current_block () != NULL
998 && gfc_current_block ()->result
!= NULL
999 && gfc_current_block ()->result
!= gfc_current_block ()
1000 && strcmp (gfc_current_block ()->name
, name
) == 0)
1002 gfc_error ("Function name '%s' not allowed at %C", name
);
1007 /* We allow old-style initializations of the form
1008 integer i /2/, j(4) /3*3, 1/
1009 (if no colon has been seen). These are different from data
1010 statements in that initializers are only allowed to apply to the
1011 variable immediately preceding, i.e.
1013 is not allowed. Therefore we have to do some work manually, that
1014 could otherwise be left to the matchers for DATA statements. */
1016 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1018 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1019 "initialization at %C") == FAILURE
)
1022 return match_old_style_init (name
);
1025 /* The double colon must be present in order to have initializers.
1026 Otherwise the statement is ambiguous with an assignment statement. */
1029 if (gfc_match (" =>") == MATCH_YES
)
1032 if (!current_attr
.pointer
)
1034 gfc_error ("Initialization at %C isn't for a pointer variable");
1039 m
= gfc_match_null (&initializer
);
1042 gfc_error ("Pointer initialization requires a NULL at %C");
1046 if (gfc_pure (NULL
))
1049 ("Initialization of pointer at %C is not allowed in a "
1057 initializer
->ts
= current_ts
;
1060 else if (gfc_match_char ('=') == MATCH_YES
)
1062 if (current_attr
.pointer
)
1065 ("Pointer initialization at %C requires '=>', not '='");
1070 m
= gfc_match_init_expr (&initializer
);
1073 gfc_error ("Expected an initialization expression at %C");
1077 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1080 ("Initialization of variable at %C is not allowed in a "
1090 /* Add the initializer. Note that it is fine if initializer is
1091 NULL here, because we sometimes also need to check if a
1092 declaration *must* have an initialization expression. */
1093 if (gfc_current_state () != COMP_DERIVED
)
1094 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1097 if (current_ts
.type
== BT_DERIVED
&& !current_attr
.pointer
&& !initializer
)
1098 initializer
= gfc_default_initializer (¤t_ts
);
1099 t
= build_struct (name
, cl
, &initializer
, &as
);
1102 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1105 /* Free stuff up and return. */
1106 gfc_free_expr (initializer
);
1107 gfc_free_array_spec (as
);
1113 /* Match an extended-f77 kind specification. */
1116 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1120 if (gfc_match_char ('*') != MATCH_YES
)
1123 m
= gfc_match_small_literal_int (&ts
->kind
);
1127 /* Massage the kind numbers for complex types. */
1128 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1130 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1133 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1135 gfc_error ("Old-style kind %d not supported for type %s at %C",
1136 ts
->kind
, gfc_basic_typename (ts
->type
));
1145 /* Match a kind specification. Since kinds are generally optional, we
1146 usually return MATCH_NO if something goes wrong. If a "kind="
1147 string is found, then we know we have an error. */
1150 gfc_match_kind_spec (gfc_typespec
* ts
)
1160 where
= gfc_current_locus
;
1162 if (gfc_match_char ('(') == MATCH_NO
)
1165 /* Also gobbles optional text. */
1166 if (gfc_match (" kind = ") == MATCH_YES
)
1169 n
= gfc_match_init_expr (&e
);
1171 gfc_error ("Expected initialization expression at %C");
1177 gfc_error ("Expected scalar initialization expression at %C");
1182 msg
= gfc_extract_int (e
, &ts
->kind
);
1193 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1195 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1196 gfc_basic_typename (ts
->type
));
1202 if (gfc_match_char (')') != MATCH_YES
)
1204 gfc_error ("Missing right paren at %C");
1212 gfc_current_locus
= where
;
1217 /* Match the various kind/length specifications in a CHARACTER
1218 declaration. We don't return MATCH_NO. */
1221 match_char_spec (gfc_typespec
* ts
)
1223 int i
, kind
, seen_length
;
1228 kind
= gfc_default_character_kind
;
1232 /* Try the old-style specification first. */
1233 old_char_selector
= 0;
1235 m
= match_char_length (&len
);
1239 old_char_selector
= 1;
1244 m
= gfc_match_char ('(');
1247 m
= MATCH_YES
; /* character without length is a single char */
1251 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1252 if (gfc_match (" kind =") == MATCH_YES
)
1254 m
= gfc_match_small_int (&kind
);
1255 if (m
== MATCH_ERROR
)
1260 if (gfc_match (" , len =") == MATCH_NO
)
1263 m
= char_len_param_value (&len
);
1266 if (m
== MATCH_ERROR
)
1273 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1274 if (gfc_match (" len =") == MATCH_YES
)
1276 m
= char_len_param_value (&len
);
1279 if (m
== MATCH_ERROR
)
1283 if (gfc_match_char (')') == MATCH_YES
)
1286 if (gfc_match (" , kind =") != MATCH_YES
)
1289 gfc_match_small_int (&kind
);
1291 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1293 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1300 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1301 m
= char_len_param_value (&len
);
1304 if (m
== MATCH_ERROR
)
1308 m
= gfc_match_char (')');
1312 if (gfc_match_char (',') != MATCH_YES
)
1315 gfc_match (" kind ="); /* Gobble optional text */
1317 m
= gfc_match_small_int (&kind
);
1318 if (m
== MATCH_ERROR
)
1324 /* Require a right-paren at this point. */
1325 m
= gfc_match_char (')');
1330 gfc_error ("Syntax error in CHARACTER declaration at %C");
1334 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1336 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1342 gfc_free_expr (len
);
1346 /* Do some final massaging of the length values. */
1347 cl
= gfc_get_charlen ();
1348 cl
->next
= gfc_current_ns
->cl_list
;
1349 gfc_current_ns
->cl_list
= cl
;
1351 if (seen_length
== 0)
1352 cl
->length
= gfc_int_expr (1);
1355 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1359 gfc_free_expr (len
);
1360 cl
->length
= gfc_int_expr (0);
1371 /* Matches a type specification. If successful, sets the ts structure
1372 to the matched specification. This is necessary for FUNCTION and
1373 IMPLICIT statements.
1375 If implicit_flag is nonzero, then we don't check for the optional
1376 kind specification. Not doing so is needed for matching an IMPLICIT
1377 statement correctly. */
1380 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1382 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1389 if (gfc_match (" byte") == MATCH_YES
)
1391 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1395 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1397 gfc_error ("BYTE type used at %C "
1398 "is not available on the target machine");
1402 ts
->type
= BT_INTEGER
;
1407 if (gfc_match (" integer") == MATCH_YES
)
1409 ts
->type
= BT_INTEGER
;
1410 ts
->kind
= gfc_default_integer_kind
;
1414 if (gfc_match (" character") == MATCH_YES
)
1416 ts
->type
= BT_CHARACTER
;
1417 if (implicit_flag
== 0)
1418 return match_char_spec (ts
);
1423 if (gfc_match (" real") == MATCH_YES
)
1426 ts
->kind
= gfc_default_real_kind
;
1430 if (gfc_match (" double precision") == MATCH_YES
)
1433 ts
->kind
= gfc_default_double_kind
;
1437 if (gfc_match (" complex") == MATCH_YES
)
1439 ts
->type
= BT_COMPLEX
;
1440 ts
->kind
= gfc_default_complex_kind
;
1444 if (gfc_match (" double complex") == MATCH_YES
)
1446 ts
->type
= BT_COMPLEX
;
1447 ts
->kind
= gfc_default_double_kind
;
1451 if (gfc_match (" logical") == MATCH_YES
)
1453 ts
->type
= BT_LOGICAL
;
1454 ts
->kind
= gfc_default_logical_kind
;
1458 m
= gfc_match (" type ( %n )", name
);
1462 /* Search for the name but allow the components to be defined later. */
1463 if (gfc_get_ha_symbol (name
, &sym
))
1465 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1469 if (sym
->attr
.flavor
!= FL_DERIVED
1470 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1473 ts
->type
= BT_DERIVED
;
1480 /* For all types except double, derived and character, look for an
1481 optional kind specifier. MATCH_NO is actually OK at this point. */
1482 if (implicit_flag
== 1)
1485 if (gfc_current_form
== FORM_FREE
)
1487 c
= gfc_peek_char();
1488 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1489 && c
!= ':' && c
!= ',')
1493 m
= gfc_match_kind_spec (ts
);
1494 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1495 m
= gfc_match_old_kind_spec (ts
);
1498 m
= MATCH_YES
; /* No kind specifier found. */
1504 /* Match an IMPLICIT NONE statement. Actually, this statement is
1505 already matched in parse.c, or we would not end up here in the
1506 first place. So the only thing we need to check, is if there is
1507 trailing garbage. If not, the match is successful. */
1510 gfc_match_implicit_none (void)
1513 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1517 /* Match the letter range(s) of an IMPLICIT statement. */
1520 match_implicit_range (void)
1522 int c
, c1
, c2
, inner
;
1525 cur_loc
= gfc_current_locus
;
1527 gfc_gobble_whitespace ();
1528 c
= gfc_next_char ();
1531 gfc_error ("Missing character range in IMPLICIT at %C");
1538 gfc_gobble_whitespace ();
1539 c1
= gfc_next_char ();
1543 gfc_gobble_whitespace ();
1544 c
= gfc_next_char ();
1549 inner
= 0; /* Fall through */
1556 gfc_gobble_whitespace ();
1557 c2
= gfc_next_char ();
1561 gfc_gobble_whitespace ();
1562 c
= gfc_next_char ();
1564 if ((c
!= ',') && (c
!= ')'))
1577 gfc_error ("Letters must be in alphabetic order in "
1578 "IMPLICIT statement at %C");
1582 /* See if we can add the newly matched range to the pending
1583 implicits from this IMPLICIT statement. We do not check for
1584 conflicts with whatever earlier IMPLICIT statements may have
1585 set. This is done when we've successfully finished matching
1587 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1594 gfc_syntax_error (ST_IMPLICIT
);
1596 gfc_current_locus
= cur_loc
;
1601 /* Match an IMPLICIT statement, storing the types for
1602 gfc_set_implicit() if the statement is accepted by the parser.
1603 There is a strange looking, but legal syntactic construction
1604 possible. It looks like:
1606 IMPLICIT INTEGER (a-b) (c-d)
1608 This is legal if "a-b" is a constant expression that happens to
1609 equal one of the legal kinds for integers. The real problem
1610 happens with an implicit specification that looks like:
1612 IMPLICIT INTEGER (a-b)
1614 In this case, a typespec matcher that is "greedy" (as most of the
1615 matchers are) gobbles the character range as a kindspec, leaving
1616 nothing left. We therefore have to go a bit more slowly in the
1617 matching process by inhibiting the kindspec checking during
1618 typespec matching and checking for a kind later. */
1621 gfc_match_implicit (void)
1628 /* We don't allow empty implicit statements. */
1629 if (gfc_match_eos () == MATCH_YES
)
1631 gfc_error ("Empty IMPLICIT statement at %C");
1637 /* First cleanup. */
1638 gfc_clear_new_implicit ();
1640 /* A basic type is mandatory here. */
1641 m
= match_type_spec (&ts
, 1);
1642 if (m
== MATCH_ERROR
)
1647 cur_loc
= gfc_current_locus
;
1648 m
= match_implicit_range ();
1652 /* We may have <TYPE> (<RANGE>). */
1653 gfc_gobble_whitespace ();
1654 c
= gfc_next_char ();
1655 if ((c
== '\n') || (c
== ','))
1657 /* Check for CHARACTER with no length parameter. */
1658 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1660 ts
.kind
= gfc_default_character_kind
;
1661 ts
.cl
= gfc_get_charlen ();
1662 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1663 gfc_current_ns
->cl_list
= ts
.cl
;
1664 ts
.cl
->length
= gfc_int_expr (1);
1667 /* Record the Successful match. */
1668 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1673 gfc_current_locus
= cur_loc
;
1676 /* Discard the (incorrectly) matched range. */
1677 gfc_clear_new_implicit ();
1679 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1680 if (ts
.type
== BT_CHARACTER
)
1681 m
= match_char_spec (&ts
);
1684 m
= gfc_match_kind_spec (&ts
);
1687 m
= gfc_match_old_kind_spec (&ts
);
1688 if (m
== MATCH_ERROR
)
1694 if (m
== MATCH_ERROR
)
1697 m
= match_implicit_range ();
1698 if (m
== MATCH_ERROR
)
1703 gfc_gobble_whitespace ();
1704 c
= gfc_next_char ();
1705 if ((c
!= '\n') && (c
!= ','))
1708 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1716 gfc_syntax_error (ST_IMPLICIT
);
1723 /* Matches an attribute specification including array specs. If
1724 successful, leaves the variables current_attr and current_as
1725 holding the specification. Also sets the colon_seen variable for
1726 later use by matchers associated with initializations.
1728 This subroutine is a little tricky in the sense that we don't know
1729 if we really have an attr-spec until we hit the double colon.
1730 Until that time, we can only return MATCH_NO. This forces us to
1731 check for duplicate specification at this level. */
1734 match_attr_spec (void)
1737 /* Modifiers that can exist in a type statement. */
1739 { GFC_DECL_BEGIN
= 0,
1740 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1741 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1742 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1743 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1744 GFC_DECL_END
/* Sentinel */
1748 /* GFC_DECL_END is the sentinel, index starts at 0. */
1749 #define NUM_DECL GFC_DECL_END
1751 static mstring decls
[] = {
1752 minit (", allocatable", DECL_ALLOCATABLE
),
1753 minit (", dimension", DECL_DIMENSION
),
1754 minit (", external", DECL_EXTERNAL
),
1755 minit (", intent ( in )", DECL_IN
),
1756 minit (", intent ( out )", DECL_OUT
),
1757 minit (", intent ( in out )", DECL_INOUT
),
1758 minit (", intrinsic", DECL_INTRINSIC
),
1759 minit (", optional", DECL_OPTIONAL
),
1760 minit (", parameter", DECL_PARAMETER
),
1761 minit (", pointer", DECL_POINTER
),
1762 minit (", private", DECL_PRIVATE
),
1763 minit (", public", DECL_PUBLIC
),
1764 minit (", save", DECL_SAVE
),
1765 minit (", target", DECL_TARGET
),
1766 minit ("::", DECL_COLON
),
1767 minit (NULL
, DECL_NONE
)
1770 locus start
, seen_at
[NUM_DECL
];
1777 gfc_clear_attr (¤t_attr
);
1778 start
= gfc_current_locus
;
1783 /* See if we get all of the keywords up to the final double colon. */
1784 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1789 d
= (decl_types
) gfc_match_strings (decls
);
1790 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1794 seen_at
[d
] = gfc_current_locus
;
1796 if (d
== DECL_DIMENSION
)
1798 m
= gfc_match_array_spec (¤t_as
);
1802 gfc_error ("Missing dimension specification at %C");
1806 if (m
== MATCH_ERROR
)
1811 /* No double colon, so assume that we've been looking at something
1812 else the whole time. */
1819 /* Since we've seen a double colon, we have to be looking at an
1820 attr-spec. This means that we can now issue errors. */
1821 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1826 case DECL_ALLOCATABLE
:
1827 attr
= "ALLOCATABLE";
1829 case DECL_DIMENSION
:
1836 attr
= "INTENT (IN)";
1839 attr
= "INTENT (OUT)";
1842 attr
= "INTENT (IN OUT)";
1844 case DECL_INTRINSIC
:
1850 case DECL_PARAMETER
:
1869 attr
= NULL
; /* This shouldn't happen */
1872 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1877 /* Now that we've dealt with duplicate attributes, add the attributes
1878 to the current attribute. */
1879 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1884 if (gfc_current_state () == COMP_DERIVED
1885 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1886 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1889 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1895 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
1896 && gfc_current_state () != COMP_MODULE
)
1898 if (d
== DECL_PRIVATE
)
1903 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
1911 case DECL_ALLOCATABLE
:
1912 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1915 case DECL_DIMENSION
:
1916 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
1920 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1924 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1928 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1932 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1935 case DECL_INTRINSIC
:
1936 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1940 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1943 case DECL_PARAMETER
:
1944 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
1948 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1952 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
1957 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
1962 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
1966 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1970 gfc_internal_error ("match_attr_spec(): Bad attribute");
1984 gfc_current_locus
= start
;
1985 gfc_free_array_spec (current_as
);
1991 /* Match a data declaration statement. */
1994 gfc_match_data_decl (void)
2000 m
= match_type_spec (¤t_ts
, 0);
2004 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2006 sym
= gfc_use_derived (current_ts
.derived
);
2014 current_ts
.derived
= sym
;
2017 m
= match_attr_spec ();
2018 if (m
== MATCH_ERROR
)
2024 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2027 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2030 if (gfc_find_symbol (current_ts
.derived
->name
,
2031 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
2034 /* Hope that an ambiguous symbol is itself masked by a type definition. */
2035 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
2038 gfc_error ("Derived type at %C has not been previously defined");
2044 /* If we have an old-style character declaration, and no new-style
2045 attribute specifications, then there a comma is optional between
2046 the type specification and the variable list. */
2047 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2048 gfc_match_char (',');
2050 /* Give the types/attributes to symbols that follow. Give the element
2051 a number so that repeat character length expressions can be copied. */
2055 m
= variable_decl (elem
++);
2056 if (m
== MATCH_ERROR
)
2061 if (gfc_match_eos () == MATCH_YES
)
2063 if (gfc_match_char (',') != MATCH_YES
)
2067 gfc_error ("Syntax error in data declaration at %C");
2071 gfc_free_array_spec (current_as
);
2077 /* Match a prefix associated with a function or subroutine
2078 declaration. If the typespec pointer is nonnull, then a typespec
2079 can be matched. Note that if nothing matches, MATCH_YES is
2080 returned (the null string was matched). */
2083 match_prefix (gfc_typespec
* ts
)
2087 gfc_clear_attr (¤t_attr
);
2091 if (!seen_type
&& ts
!= NULL
2092 && match_type_spec (ts
, 0) == MATCH_YES
2093 && gfc_match_space () == MATCH_YES
)
2100 if (gfc_match ("elemental% ") == MATCH_YES
)
2102 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2108 if (gfc_match ("pure% ") == MATCH_YES
)
2110 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2116 if (gfc_match ("recursive% ") == MATCH_YES
)
2118 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2124 /* At this point, the next item is not a prefix. */
2129 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2132 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2135 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2138 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2141 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2148 /* Match a formal argument list. */
2151 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2153 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2154 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2160 if (gfc_match_char ('(') != MATCH_YES
)
2167 if (gfc_match_char (')') == MATCH_YES
)
2172 if (gfc_match_char ('*') == MATCH_YES
)
2176 m
= gfc_match_name (name
);
2180 if (gfc_get_symbol (name
, NULL
, &sym
))
2184 p
= gfc_get_formal_arglist ();
2196 /* We don't add the VARIABLE flavor because the name could be a
2197 dummy procedure. We don't apply these attributes to formal
2198 arguments of statement functions. */
2199 if (sym
!= NULL
&& !st_flag
2200 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2201 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2207 /* The name of a program unit can be in a different namespace,
2208 so check for it explicitly. After the statement is accepted,
2209 the name is checked for especially in gfc_get_symbol(). */
2210 if (gfc_new_block
!= NULL
&& sym
!= NULL
2211 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2213 gfc_error ("Name '%s' at %C is the name of the procedure",
2219 if (gfc_match_char (')') == MATCH_YES
)
2222 m
= gfc_match_char (',');
2225 gfc_error ("Unexpected junk in formal argument list at %C");
2231 /* Check for duplicate symbols in the formal argument list. */
2234 for (p
= head
; p
->next
; p
= p
->next
)
2239 for (q
= p
->next
; q
; q
= q
->next
)
2240 if (p
->sym
== q
->sym
)
2243 ("Duplicate symbol '%s' in formal argument list at %C",
2252 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2262 gfc_free_formal_arglist (head
);
2267 /* Match a RESULT specification following a function declaration or
2268 ENTRY statement. Also matches the end-of-statement. */
2271 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2273 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2277 if (gfc_match (" result (") != MATCH_YES
)
2280 m
= gfc_match_name (name
);
2284 if (gfc_match (" )%t") != MATCH_YES
)
2286 gfc_error ("Unexpected junk following RESULT variable at %C");
2290 if (strcmp (function
->name
, name
) == 0)
2293 ("RESULT variable at %C must be different than function name");
2297 if (gfc_get_symbol (name
, NULL
, &r
))
2300 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2301 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2310 /* Match a function declaration. */
2313 gfc_match_function_decl (void)
2315 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2316 gfc_symbol
*sym
, *result
;
2320 if (gfc_current_state () != COMP_NONE
2321 && gfc_current_state () != COMP_INTERFACE
2322 && gfc_current_state () != COMP_CONTAINS
)
2325 gfc_clear_ts (¤t_ts
);
2327 old_loc
= gfc_current_locus
;
2329 m
= match_prefix (¤t_ts
);
2332 gfc_current_locus
= old_loc
;
2336 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2338 gfc_current_locus
= old_loc
;
2342 if (get_proc_name (name
, &sym
))
2344 gfc_new_block
= sym
;
2346 m
= gfc_match_formal_arglist (sym
, 0, 0);
2348 gfc_error ("Expected formal argument list in function definition at %C");
2349 else if (m
== MATCH_ERROR
)
2354 if (gfc_match_eos () != MATCH_YES
)
2356 /* See if a result variable is present. */
2357 m
= match_result (sym
, &result
);
2359 gfc_error ("Unexpected junk after function declaration at %C");
2368 /* Make changes to the symbol. */
2371 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2374 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2375 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2378 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2380 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2381 gfc_basic_typename (sym
->ts
.type
));
2387 sym
->ts
= current_ts
;
2392 result
->ts
= current_ts
;
2393 sym
->result
= result
;
2399 gfc_current_locus
= old_loc
;
2404 /* Match an ENTRY statement. */
2407 gfc_match_entry (void)
2412 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2413 gfc_compile_state state
;
2417 m
= gfc_match_name (name
);
2421 state
= gfc_current_state ();
2422 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2427 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2430 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2432 case COMP_BLOCK_DATA
:
2434 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2436 case COMP_INTERFACE
:
2438 ("ENTRY statement at %C cannot appear within an INTERFACE");
2442 ("ENTRY statement at %C cannot appear "
2443 "within a DERIVED TYPE block");
2447 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2451 ("ENTRY statement at %C cannot appear within a DO block");
2455 ("ENTRY statement at %C cannot appear within a SELECT block");
2459 ("ENTRY statement at %C cannot appear within a FORALL block");
2463 ("ENTRY statement at %C cannot appear within a WHERE block");
2467 ("ENTRY statement at %C cannot appear "
2468 "within a contained subprogram");
2471 gfc_internal_error ("gfc_match_entry(): Bad state");
2476 if (gfc_current_ns
->parent
!= NULL
2477 && gfc_current_ns
->parent
->proc_name
2478 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2480 gfc_error("ENTRY statement at %C cannot appear in a "
2481 "contained procedure");
2485 if (get_proc_name (name
, &entry
))
2488 proc
= gfc_current_block ();
2490 if (state
== COMP_SUBROUTINE
)
2492 /* An entry in a subroutine. */
2493 m
= gfc_match_formal_arglist (entry
, 0, 1);
2497 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2498 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2503 /* An entry in a function. */
2504 m
= gfc_match_formal_arglist (entry
, 0, 1);
2510 if (gfc_match_eos () == MATCH_YES
)
2512 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2513 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2516 entry
->result
= entry
;
2520 m
= match_result (proc
, &result
);
2522 gfc_syntax_error (ST_ENTRY
);
2526 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2527 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2528 || gfc_add_function (&entry
->attr
, result
->name
,
2532 entry
->result
= result
;
2535 if (proc
->attr
.recursive
&& result
== NULL
)
2537 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2542 if (gfc_match_eos () != MATCH_YES
)
2544 gfc_syntax_error (ST_ENTRY
);
2548 entry
->attr
.recursive
= proc
->attr
.recursive
;
2549 entry
->attr
.elemental
= proc
->attr
.elemental
;
2550 entry
->attr
.pure
= proc
->attr
.pure
;
2552 el
= gfc_get_entry_list ();
2554 el
->next
= gfc_current_ns
->entries
;
2555 gfc_current_ns
->entries
= el
;
2557 el
->id
= el
->next
->id
+ 1;
2561 new_st
.op
= EXEC_ENTRY
;
2562 new_st
.ext
.entry
= el
;
2568 /* Match a subroutine statement, including optional prefixes. */
2571 gfc_match_subroutine (void)
2573 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2577 if (gfc_current_state () != COMP_NONE
2578 && gfc_current_state () != COMP_INTERFACE
2579 && gfc_current_state () != COMP_CONTAINS
)
2582 m
= match_prefix (NULL
);
2586 m
= gfc_match ("subroutine% %n", name
);
2590 if (get_proc_name (name
, &sym
))
2592 gfc_new_block
= sym
;
2594 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2597 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2600 if (gfc_match_eos () != MATCH_YES
)
2602 gfc_syntax_error (ST_SUBROUTINE
);
2606 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2613 /* Return nonzero if we're currently compiling a contained procedure. */
2616 contained_procedure (void)
2620 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2621 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2622 && s
->previous
!= NULL
2623 && s
->previous
->state
== COMP_CONTAINS
)
2629 /* Match any of the various end-block statements. Returns the type of
2630 END to the caller. The END INTERFACE, END IF, END DO and END
2631 SELECT statements cannot be replaced by a single END statement. */
2634 gfc_match_end (gfc_statement
* st
)
2636 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2637 gfc_compile_state state
;
2639 const char *block_name
;
2644 old_loc
= gfc_current_locus
;
2645 if (gfc_match ("end") != MATCH_YES
)
2648 state
= gfc_current_state ();
2650 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2652 if (state
== COMP_CONTAINS
)
2654 state
= gfc_state_stack
->previous
->state
;
2655 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2656 : gfc_state_stack
->previous
->sym
->name
;
2663 *st
= ST_END_PROGRAM
;
2664 target
= " program";
2668 case COMP_SUBROUTINE
:
2669 *st
= ST_END_SUBROUTINE
;
2670 target
= " subroutine";
2671 eos_ok
= !contained_procedure ();
2675 *st
= ST_END_FUNCTION
;
2676 target
= " function";
2677 eos_ok
= !contained_procedure ();
2680 case COMP_BLOCK_DATA
:
2681 *st
= ST_END_BLOCK_DATA
;
2682 target
= " block data";
2687 *st
= ST_END_MODULE
;
2692 case COMP_INTERFACE
:
2693 *st
= ST_END_INTERFACE
;
2694 target
= " interface";
2717 *st
= ST_END_SELECT
;
2723 *st
= ST_END_FORALL
;
2735 gfc_error ("Unexpected END statement at %C");
2739 if (gfc_match_eos () == MATCH_YES
)
2743 /* We would have required END [something] */
2744 gfc_error ("%s statement expected at %L",
2745 gfc_ascii_statement (*st
), &old_loc
);
2752 /* Verify that we've got the sort of end-block that we're expecting. */
2753 if (gfc_match (target
) != MATCH_YES
)
2755 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2759 /* If we're at the end, make sure a block name wasn't required. */
2760 if (gfc_match_eos () == MATCH_YES
)
2763 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2766 if (gfc_current_block () == NULL
)
2769 gfc_error ("Expected block name of '%s' in %s statement at %C",
2770 block_name
, gfc_ascii_statement (*st
));
2775 /* END INTERFACE has a special handler for its several possible endings. */
2776 if (*st
== ST_END_INTERFACE
)
2777 return gfc_match_end_interface ();
2779 /* We haven't hit the end of statement, so what is left must be an end-name. */
2780 m
= gfc_match_space ();
2782 m
= gfc_match_name (name
);
2785 gfc_error ("Expected terminating name at %C");
2789 if (block_name
== NULL
)
2792 if (strcmp (name
, block_name
) != 0)
2794 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2795 gfc_ascii_statement (*st
));
2799 if (gfc_match_eos () == MATCH_YES
)
2803 gfc_syntax_error (*st
);
2806 gfc_current_locus
= old_loc
;
2812 /***************** Attribute declaration statements ****************/
2814 /* Set the attribute of a single variable. */
2819 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2827 m
= gfc_match_name (name
);
2831 if (find_special (name
, &sym
))
2834 var_locus
= gfc_current_locus
;
2836 /* Deal with possible array specification for certain attributes. */
2837 if (current_attr
.dimension
2838 || current_attr
.allocatable
2839 || current_attr
.pointer
2840 || current_attr
.target
)
2842 m
= gfc_match_array_spec (&as
);
2843 if (m
== MATCH_ERROR
)
2846 if (current_attr
.dimension
&& m
== MATCH_NO
)
2849 ("Missing array specification at %L in DIMENSION statement",
2855 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2856 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2858 gfc_error ("Array specification must be deferred at %L",
2865 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2866 if (current_attr
.dimension
== 0
2867 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2873 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2879 if ((current_attr
.external
|| current_attr
.intrinsic
)
2880 && sym
->attr
.flavor
!= FL_PROCEDURE
2881 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
2890 gfc_free_array_spec (as
);
2895 /* Generic attribute declaration subroutine. Used for attributes that
2896 just have a list of names. */
2903 /* Gobble the optional double colon, by simply ignoring the result
2913 if (gfc_match_eos () == MATCH_YES
)
2919 if (gfc_match_char (',') != MATCH_YES
)
2921 gfc_error ("Unexpected character in variable list at %C");
2932 gfc_match_external (void)
2935 gfc_clear_attr (¤t_attr
);
2936 gfc_add_external (¤t_attr
, NULL
);
2938 return attr_decl ();
2944 gfc_match_intent (void)
2948 intent
= match_intent_spec ();
2949 if (intent
== INTENT_UNKNOWN
)
2952 gfc_clear_attr (¤t_attr
);
2953 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2955 return attr_decl ();
2960 gfc_match_intrinsic (void)
2963 gfc_clear_attr (¤t_attr
);
2964 gfc_add_intrinsic (¤t_attr
, NULL
);
2966 return attr_decl ();
2971 gfc_match_optional (void)
2974 gfc_clear_attr (¤t_attr
);
2975 gfc_add_optional (¤t_attr
, NULL
);
2977 return attr_decl ();
2982 gfc_match_pointer (void)
2985 gfc_clear_attr (¤t_attr
);
2986 gfc_add_pointer (¤t_attr
, NULL
);
2988 return attr_decl ();
2993 gfc_match_allocatable (void)
2996 gfc_clear_attr (¤t_attr
);
2997 gfc_add_allocatable (¤t_attr
, NULL
);
2999 return attr_decl ();
3004 gfc_match_dimension (void)
3007 gfc_clear_attr (¤t_attr
);
3008 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
3010 return attr_decl ();
3015 gfc_match_target (void)
3018 gfc_clear_attr (¤t_attr
);
3019 gfc_add_target (¤t_attr
, NULL
);
3021 return attr_decl ();
3025 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3029 access_attr_decl (gfc_statement st
)
3031 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3032 interface_type type
;
3035 gfc_intrinsic_op
operator;
3038 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3043 m
= gfc_match_generic_spec (&type
, name
, &operator);
3046 if (m
== MATCH_ERROR
)
3051 case INTERFACE_NAMELESS
:
3054 case INTERFACE_GENERIC
:
3055 if (gfc_get_symbol (name
, NULL
, &sym
))
3058 if (gfc_add_access (&sym
->attr
,
3060 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3061 sym
->name
, NULL
) == FAILURE
)
3066 case INTERFACE_INTRINSIC_OP
:
3067 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3069 gfc_current_ns
->operator_access
[operator] =
3070 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3074 gfc_error ("Access specification of the %s operator at %C has "
3075 "already been specified", gfc_op2string (operator));
3081 case INTERFACE_USER_OP
:
3082 uop
= gfc_get_uop (name
);
3084 if (uop
->access
== ACCESS_UNKNOWN
)
3087 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3092 ("Access specification of the .%s. operator at %C has "
3093 "already been specified", sym
->name
);
3100 if (gfc_match_char (',') == MATCH_NO
)
3104 if (gfc_match_eos () != MATCH_YES
)
3109 gfc_syntax_error (st
);
3116 /* The PRIVATE statement is a bit weird in that it can be a attribute
3117 declaration, but also works as a standlone statement inside of a
3118 type declaration or a module. */
3121 gfc_match_private (gfc_statement
* st
)
3124 if (gfc_match ("private") != MATCH_YES
)
3127 if (gfc_current_state () == COMP_DERIVED
)
3129 if (gfc_match_eos () == MATCH_YES
)
3135 gfc_syntax_error (ST_PRIVATE
);
3139 if (gfc_match_eos () == MATCH_YES
)
3146 return access_attr_decl (ST_PRIVATE
);
3151 gfc_match_public (gfc_statement
* st
)
3154 if (gfc_match ("public") != MATCH_YES
)
3157 if (gfc_match_eos () == MATCH_YES
)
3164 return access_attr_decl (ST_PUBLIC
);
3168 /* Workhorse for gfc_match_parameter. */
3177 m
= gfc_match_symbol (&sym
, 0);
3179 gfc_error ("Expected variable name at %C in PARAMETER statement");
3184 if (gfc_match_char ('=') == MATCH_NO
)
3186 gfc_error ("Expected = sign in PARAMETER statement at %C");
3190 m
= gfc_match_init_expr (&init
);
3192 gfc_error ("Expected expression at %C in PARAMETER statement");
3196 if (sym
->ts
.type
== BT_UNKNOWN
3197 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3203 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3204 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3210 if (sym
->ts
.type
== BT_CHARACTER
3211 && sym
->ts
.cl
!= NULL
3212 && sym
->ts
.cl
->length
!= NULL
3213 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3214 && init
->expr_type
== EXPR_CONSTANT
3215 && init
->ts
.type
== BT_CHARACTER
3216 && init
->ts
.kind
== 1)
3217 gfc_set_constant_character_len (
3218 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3224 gfc_free_expr (init
);
3229 /* Match a parameter statement, with the weird syntax that these have. */
3232 gfc_match_parameter (void)
3236 if (gfc_match_char ('(') == MATCH_NO
)
3245 if (gfc_match (" )%t") == MATCH_YES
)
3248 if (gfc_match_char (',') != MATCH_YES
)
3250 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3260 /* Save statements have a special syntax. */
3263 gfc_match_save (void)
3265 char n
[GFC_MAX_SYMBOL_LEN
+1];
3270 if (gfc_match_eos () == MATCH_YES
)
3272 if (gfc_current_ns
->seen_save
)
3274 if (gfc_notify_std (GFC_STD_LEGACY
,
3275 "Blanket SAVE statement at %C follows previous "
3281 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3285 if (gfc_current_ns
->save_all
)
3287 if (gfc_notify_std (GFC_STD_LEGACY
,
3288 "SAVE statement at %C follows blanket SAVE statement")
3297 m
= gfc_match_symbol (&sym
, 0);
3301 if (gfc_add_save (&sym
->attr
, sym
->name
,
3302 &gfc_current_locus
) == FAILURE
)
3313 m
= gfc_match (" / %n /", &n
);
3314 if (m
== MATCH_ERROR
)
3319 c
= gfc_get_common (n
, 0);
3322 gfc_current_ns
->seen_save
= 1;
3325 if (gfc_match_eos () == MATCH_YES
)
3327 if (gfc_match_char (',') != MATCH_YES
)
3334 gfc_error ("Syntax error in SAVE statement at %C");
3339 /* Match a module procedure statement. Note that we have to modify
3340 symbols in the parent's namespace because the current one was there
3341 to receive symbols that are in an interface's formal argument list. */
3344 gfc_match_modproc (void)
3346 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3350 if (gfc_state_stack
->state
!= COMP_INTERFACE
3351 || gfc_state_stack
->previous
== NULL
3352 || current_interface
.type
== INTERFACE_NAMELESS
)
3355 ("MODULE PROCEDURE at %C must be in a generic module interface");
3361 m
= gfc_match_name (name
);
3367 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3370 if (sym
->attr
.proc
!= PROC_MODULE
3371 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3372 sym
->name
, NULL
) == FAILURE
)
3375 if (gfc_add_interface (sym
) == FAILURE
)
3378 if (gfc_match_eos () == MATCH_YES
)
3380 if (gfc_match_char (',') != MATCH_YES
)
3387 gfc_syntax_error (ST_MODULE_PROC
);
3392 /* Match the beginning of a derived type declaration. If a type name
3393 was the result of a function, then it is possible to have a symbol
3394 already to be known as a derived type yet have no components. */
3397 gfc_match_derived_decl (void)
3399 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3400 symbol_attribute attr
;
3404 if (gfc_current_state () == COMP_DERIVED
)
3407 gfc_clear_attr (&attr
);
3410 if (gfc_match (" , private") == MATCH_YES
)
3412 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3415 ("Derived type at %C can only be PRIVATE within a MODULE");
3419 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3424 if (gfc_match (" , public") == MATCH_YES
)
3426 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3428 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3432 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3437 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3439 gfc_error ("Expected :: in TYPE definition at %C");
3443 m
= gfc_match (" %n%t", name
);
3447 /* Make sure the name isn't the name of an intrinsic type. The
3448 'double precision' type doesn't get past the name matcher. */
3449 if (strcmp (name
, "integer") == 0
3450 || strcmp (name
, "real") == 0
3451 || strcmp (name
, "character") == 0
3452 || strcmp (name
, "logical") == 0
3453 || strcmp (name
, "complex") == 0)
3456 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3461 if (gfc_get_symbol (name
, NULL
, &sym
))
3464 if (sym
->ts
.type
!= BT_UNKNOWN
)
3466 gfc_error ("Derived type name '%s' at %C already has a basic type "
3467 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3471 /* The symbol may already have the derived attribute without the
3472 components. The ways this can happen is via a function
3473 definition, an INTRINSIC statement or a subtype in another
3474 derived type that is a pointer. The first part of the AND clause
3475 is true if a the symbol is not the return value of a function. */
3476 if (sym
->attr
.flavor
!= FL_DERIVED
3477 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3480 if (sym
->components
!= NULL
)
3483 ("Derived type definition of '%s' at %C has already been defined",
3488 if (attr
.access
!= ACCESS_UNKNOWN
3489 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3492 gfc_new_block
= sym
;