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 (init
->expr_type
== EXPR_CONSTANT
)
751 gfc_int_expr (init
->value
.character
.length
);
752 else if (init
->expr_type
== EXPR_ARRAY
)
753 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
755 /* Update initializer character length according symbol. */
756 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
758 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
761 if (init
->expr_type
== EXPR_CONSTANT
)
762 gfc_set_constant_character_len (len
, init
);
763 else if (init
->expr_type
== EXPR_ARRAY
)
765 gfc_free_expr (init
->ts
.cl
->length
);
766 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
767 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
768 gfc_set_constant_character_len (len
, p
->expr
);
773 /* Add initializer. Make sure we keep the ranks sane. */
774 if (sym
->attr
.dimension
&& init
->rank
== 0)
775 init
->rank
= sym
->as
->rank
;
785 /* Function called by variable_decl() that adds a name to a structure
789 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
790 gfc_array_spec
** as
)
794 /* If the current symbol is of the same derived type that we're
795 constructing, it must have the pointer attribute. */
796 if (current_ts
.type
== BT_DERIVED
797 && current_ts
.derived
== gfc_current_block ()
798 && current_attr
.pointer
== 0)
800 gfc_error ("Component at %C must have the POINTER attribute");
804 if (gfc_current_block ()->attr
.pointer
807 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
809 gfc_error ("Array component of structure at %C must have explicit "
810 "or deferred shape");
815 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
820 gfc_set_component_attr (c
, ¤t_attr
);
822 c
->initializer
= *init
;
830 /* Check array components. */
836 if (c
->as
->type
!= AS_DEFERRED
)
838 gfc_error ("Pointer array component of structure at %C "
839 "must have a deferred shape");
845 if (c
->as
->type
!= AS_EXPLICIT
)
848 ("Array component of structure at %C must have an explicit "
858 /* Match a 'NULL()', and possibly take care of some side effects. */
861 gfc_match_null (gfc_expr
** result
)
867 m
= gfc_match (" null ( )");
871 /* The NULL symbol now has to be/become an intrinsic function. */
872 if (gfc_get_symbol ("null", NULL
, &sym
))
874 gfc_error ("NULL() initialization at %C is ambiguous");
878 gfc_intrinsic_symbol (sym
);
880 if (sym
->attr
.proc
!= PROC_INTRINSIC
881 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
882 sym
->name
, NULL
) == FAILURE
883 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
887 e
->where
= gfc_current_locus
;
888 e
->expr_type
= EXPR_NULL
;
889 e
->ts
.type
= BT_UNKNOWN
;
897 /* Match a variable name with an optional initializer. When this
898 subroutine is called, a variable is expected to be parsed next.
899 Depending on what is happening at the moment, updates either the
900 symbol table or the current interface. */
903 variable_decl (int elem
)
905 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
906 gfc_expr
*initializer
, *char_len
;
916 /* When we get here, we've just matched a list of attributes and
917 maybe a type and a double colon. The next thing we expect to see
918 is the name of the symbol. */
919 m
= gfc_match_name (name
);
923 var_locus
= gfc_current_locus
;
925 /* Now we could see the optional array spec. or character length. */
926 m
= gfc_match_array_spec (&as
);
927 if (m
== MATCH_ERROR
)
930 as
= gfc_copy_array_spec (current_as
);
935 if (current_ts
.type
== BT_CHARACTER
)
937 switch (match_char_length (&char_len
))
940 cl
= gfc_get_charlen ();
941 cl
->next
= gfc_current_ns
->cl_list
;
942 gfc_current_ns
->cl_list
= cl
;
944 cl
->length
= char_len
;
947 /* Non-constant lengths need to be copied after the first
950 if (elem
> 1 && current_ts
.cl
->length
951 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
953 cl
= gfc_get_charlen ();
954 cl
->next
= gfc_current_ns
->cl_list
;
955 gfc_current_ns
->cl_list
= cl
;
956 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
968 /* OK, we've successfully matched the declaration. Now put the
969 symbol in the current namespace, because it might be used in the
970 optional initialization expression for this symbol, e.g. this is
973 integer, parameter :: i = huge(i)
975 This is only true for parameters or variables of a basic type.
976 For components of derived types, it is not true, so we don't
977 create a symbol for those yet. If we fail to create the symbol,
979 if (gfc_current_state () != COMP_DERIVED
980 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
986 /* In functions that have a RESULT variable defined, the function
987 name always refers to function calls. Therefore, the name is
988 not allowed to appear in specification statements. */
989 if (gfc_current_state () == COMP_FUNCTION
990 && gfc_current_block () != NULL
991 && gfc_current_block ()->result
!= NULL
992 && gfc_current_block ()->result
!= gfc_current_block ()
993 && strcmp (gfc_current_block ()->name
, name
) == 0)
995 gfc_error ("Function name '%s' not allowed at %C", name
);
1000 /* We allow old-style initializations of the form
1001 integer i /2/, j(4) /3*3, 1/
1002 (if no colon has been seen). These are different from data
1003 statements in that initializers are only allowed to apply to the
1004 variable immediately preceding, i.e.
1006 is not allowed. Therefore we have to do some work manually, that
1007 could otherwise be left to the matchers for DATA statements. */
1009 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1011 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1012 "initialization at %C") == FAILURE
)
1015 return match_old_style_init (name
);
1018 /* The double colon must be present in order to have initializers.
1019 Otherwise the statement is ambiguous with an assignment statement. */
1022 if (gfc_match (" =>") == MATCH_YES
)
1025 if (!current_attr
.pointer
)
1027 gfc_error ("Initialization at %C isn't for a pointer variable");
1032 m
= gfc_match_null (&initializer
);
1035 gfc_error ("Pointer initialization requires a NULL at %C");
1039 if (gfc_pure (NULL
))
1042 ("Initialization of pointer at %C is not allowed in a "
1050 initializer
->ts
= current_ts
;
1053 else if (gfc_match_char ('=') == MATCH_YES
)
1055 if (current_attr
.pointer
)
1058 ("Pointer initialization at %C requires '=>', not '='");
1063 m
= gfc_match_init_expr (&initializer
);
1066 gfc_error ("Expected an initialization expression at %C");
1070 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1073 ("Initialization of variable at %C is not allowed in a "
1083 /* Add the initializer. Note that it is fine if initializer is
1084 NULL here, because we sometimes also need to check if a
1085 declaration *must* have an initialization expression. */
1086 if (gfc_current_state () != COMP_DERIVED
)
1087 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1090 if (current_ts
.type
== BT_DERIVED
&& !initializer
)
1091 initializer
= gfc_default_initializer (¤t_ts
);
1092 t
= build_struct (name
, cl
, &initializer
, &as
);
1095 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1098 /* Free stuff up and return. */
1099 gfc_free_expr (initializer
);
1100 gfc_free_array_spec (as
);
1106 /* Match an extended-f77 kind specification. */
1109 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1113 if (gfc_match_char ('*') != MATCH_YES
)
1116 m
= gfc_match_small_literal_int (&ts
->kind
);
1120 /* Massage the kind numbers for complex types. */
1121 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1123 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1126 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1128 gfc_error ("Old-style kind %d not supported for type %s at %C",
1129 ts
->kind
, gfc_basic_typename (ts
->type
));
1138 /* Match a kind specification. Since kinds are generally optional, we
1139 usually return MATCH_NO if something goes wrong. If a "kind="
1140 string is found, then we know we have an error. */
1143 gfc_match_kind_spec (gfc_typespec
* ts
)
1153 where
= gfc_current_locus
;
1155 if (gfc_match_char ('(') == MATCH_NO
)
1158 /* Also gobbles optional text. */
1159 if (gfc_match (" kind = ") == MATCH_YES
)
1162 n
= gfc_match_init_expr (&e
);
1164 gfc_error ("Expected initialization expression at %C");
1170 gfc_error ("Expected scalar initialization expression at %C");
1175 msg
= gfc_extract_int (e
, &ts
->kind
);
1186 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1188 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1189 gfc_basic_typename (ts
->type
));
1195 if (gfc_match_char (')') != MATCH_YES
)
1197 gfc_error ("Missing right paren at %C");
1205 gfc_current_locus
= where
;
1210 /* Match the various kind/length specifications in a CHARACTER
1211 declaration. We don't return MATCH_NO. */
1214 match_char_spec (gfc_typespec
* ts
)
1216 int i
, kind
, seen_length
;
1221 kind
= gfc_default_character_kind
;
1225 /* Try the old-style specification first. */
1226 old_char_selector
= 0;
1228 m
= match_char_length (&len
);
1232 old_char_selector
= 1;
1237 m
= gfc_match_char ('(');
1240 m
= MATCH_YES
; /* character without length is a single char */
1244 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1245 if (gfc_match (" kind =") == MATCH_YES
)
1247 m
= gfc_match_small_int (&kind
);
1248 if (m
== MATCH_ERROR
)
1253 if (gfc_match (" , len =") == MATCH_NO
)
1256 m
= char_len_param_value (&len
);
1259 if (m
== MATCH_ERROR
)
1266 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1267 if (gfc_match (" len =") == MATCH_YES
)
1269 m
= char_len_param_value (&len
);
1272 if (m
== MATCH_ERROR
)
1276 if (gfc_match_char (')') == MATCH_YES
)
1279 if (gfc_match (" , kind =") != MATCH_YES
)
1282 gfc_match_small_int (&kind
);
1284 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1286 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1293 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1294 m
= char_len_param_value (&len
);
1297 if (m
== MATCH_ERROR
)
1301 m
= gfc_match_char (')');
1305 if (gfc_match_char (',') != MATCH_YES
)
1308 gfc_match (" kind ="); /* Gobble optional text */
1310 m
= gfc_match_small_int (&kind
);
1311 if (m
== MATCH_ERROR
)
1317 /* Require a right-paren at this point. */
1318 m
= gfc_match_char (')');
1323 gfc_error ("Syntax error in CHARACTER declaration at %C");
1327 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1329 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1335 gfc_free_expr (len
);
1339 /* Do some final massaging of the length values. */
1340 cl
= gfc_get_charlen ();
1341 cl
->next
= gfc_current_ns
->cl_list
;
1342 gfc_current_ns
->cl_list
= cl
;
1344 if (seen_length
== 0)
1345 cl
->length
= gfc_int_expr (1);
1348 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1352 gfc_free_expr (len
);
1353 cl
->length
= gfc_int_expr (0);
1364 /* Matches a type specification. If successful, sets the ts structure
1365 to the matched specification. This is necessary for FUNCTION and
1366 IMPLICIT statements.
1368 If implicit_flag is nonzero, then we don't check for the optional
1369 kind specification. Not doing so is needed for matching an IMPLICIT
1370 statement correctly. */
1373 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1375 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1382 if (gfc_match (" integer") == MATCH_YES
)
1384 ts
->type
= BT_INTEGER
;
1385 ts
->kind
= gfc_default_integer_kind
;
1389 if (gfc_match (" character") == MATCH_YES
)
1391 ts
->type
= BT_CHARACTER
;
1392 if (implicit_flag
== 0)
1393 return match_char_spec (ts
);
1398 if (gfc_match (" real") == MATCH_YES
)
1401 ts
->kind
= gfc_default_real_kind
;
1405 if (gfc_match (" double precision") == MATCH_YES
)
1408 ts
->kind
= gfc_default_double_kind
;
1412 if (gfc_match (" complex") == MATCH_YES
)
1414 ts
->type
= BT_COMPLEX
;
1415 ts
->kind
= gfc_default_complex_kind
;
1419 if (gfc_match (" double complex") == MATCH_YES
)
1421 ts
->type
= BT_COMPLEX
;
1422 ts
->kind
= gfc_default_double_kind
;
1426 if (gfc_match (" logical") == MATCH_YES
)
1428 ts
->type
= BT_LOGICAL
;
1429 ts
->kind
= gfc_default_logical_kind
;
1433 m
= gfc_match (" type ( %n )", name
);
1437 /* Search for the name but allow the components to be defined later. */
1438 if (gfc_get_ha_symbol (name
, &sym
))
1440 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1444 if (sym
->attr
.flavor
!= FL_DERIVED
1445 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1448 ts
->type
= BT_DERIVED
;
1455 /* For all types except double, derived and character, look for an
1456 optional kind specifier. MATCH_NO is actually OK at this point. */
1457 if (implicit_flag
== 1)
1460 if (gfc_current_form
== FORM_FREE
)
1462 c
= gfc_peek_char();
1463 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1464 && c
!= ':' && c
!= ',')
1468 m
= gfc_match_kind_spec (ts
);
1469 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1470 m
= gfc_match_old_kind_spec (ts
);
1473 m
= MATCH_YES
; /* No kind specifier found. */
1479 /* Match an IMPLICIT NONE statement. Actually, this statement is
1480 already matched in parse.c, or we would not end up here in the
1481 first place. So the only thing we need to check, is if there is
1482 trailing garbage. If not, the match is successful. */
1485 gfc_match_implicit_none (void)
1488 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1492 /* Match the letter range(s) of an IMPLICIT statement. */
1495 match_implicit_range (void)
1497 int c
, c1
, c2
, inner
;
1500 cur_loc
= gfc_current_locus
;
1502 gfc_gobble_whitespace ();
1503 c
= gfc_next_char ();
1506 gfc_error ("Missing character range in IMPLICIT at %C");
1513 gfc_gobble_whitespace ();
1514 c1
= gfc_next_char ();
1518 gfc_gobble_whitespace ();
1519 c
= gfc_next_char ();
1524 inner
= 0; /* Fall through */
1531 gfc_gobble_whitespace ();
1532 c2
= gfc_next_char ();
1536 gfc_gobble_whitespace ();
1537 c
= gfc_next_char ();
1539 if ((c
!= ',') && (c
!= ')'))
1552 gfc_error ("Letters must be in alphabetic order in "
1553 "IMPLICIT statement at %C");
1557 /* See if we can add the newly matched range to the pending
1558 implicits from this IMPLICIT statement. We do not check for
1559 conflicts with whatever earlier IMPLICIT statements may have
1560 set. This is done when we've successfully finished matching
1562 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1569 gfc_syntax_error (ST_IMPLICIT
);
1571 gfc_current_locus
= cur_loc
;
1576 /* Match an IMPLICIT statement, storing the types for
1577 gfc_set_implicit() if the statement is accepted by the parser.
1578 There is a strange looking, but legal syntactic construction
1579 possible. It looks like:
1581 IMPLICIT INTEGER (a-b) (c-d)
1583 This is legal if "a-b" is a constant expression that happens to
1584 equal one of the legal kinds for integers. The real problem
1585 happens with an implicit specification that looks like:
1587 IMPLICIT INTEGER (a-b)
1589 In this case, a typespec matcher that is "greedy" (as most of the
1590 matchers are) gobbles the character range as a kindspec, leaving
1591 nothing left. We therefore have to go a bit more slowly in the
1592 matching process by inhibiting the kindspec checking during
1593 typespec matching and checking for a kind later. */
1596 gfc_match_implicit (void)
1603 /* We don't allow empty implicit statements. */
1604 if (gfc_match_eos () == MATCH_YES
)
1606 gfc_error ("Empty IMPLICIT statement at %C");
1612 /* First cleanup. */
1613 gfc_clear_new_implicit ();
1615 /* A basic type is mandatory here. */
1616 m
= match_type_spec (&ts
, 1);
1617 if (m
== MATCH_ERROR
)
1622 cur_loc
= gfc_current_locus
;
1623 m
= match_implicit_range ();
1627 /* We may have <TYPE> (<RANGE>). */
1628 gfc_gobble_whitespace ();
1629 c
= gfc_next_char ();
1630 if ((c
== '\n') || (c
== ','))
1632 /* Check for CHARACTER with no length parameter. */
1633 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1635 ts
.kind
= gfc_default_character_kind
;
1636 ts
.cl
= gfc_get_charlen ();
1637 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1638 gfc_current_ns
->cl_list
= ts
.cl
;
1639 ts
.cl
->length
= gfc_int_expr (1);
1642 /* Record the Successful match. */
1643 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1648 gfc_current_locus
= cur_loc
;
1651 /* Discard the (incorrectly) matched range. */
1652 gfc_clear_new_implicit ();
1654 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1655 if (ts
.type
== BT_CHARACTER
)
1656 m
= match_char_spec (&ts
);
1659 m
= gfc_match_kind_spec (&ts
);
1662 m
= gfc_match_old_kind_spec (&ts
);
1663 if (m
== MATCH_ERROR
)
1669 if (m
== MATCH_ERROR
)
1672 m
= match_implicit_range ();
1673 if (m
== MATCH_ERROR
)
1678 gfc_gobble_whitespace ();
1679 c
= gfc_next_char ();
1680 if ((c
!= '\n') && (c
!= ','))
1683 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1691 gfc_syntax_error (ST_IMPLICIT
);
1698 /* Matches an attribute specification including array specs. If
1699 successful, leaves the variables current_attr and current_as
1700 holding the specification. Also sets the colon_seen variable for
1701 later use by matchers associated with initializations.
1703 This subroutine is a little tricky in the sense that we don't know
1704 if we really have an attr-spec until we hit the double colon.
1705 Until that time, we can only return MATCH_NO. This forces us to
1706 check for duplicate specification at this level. */
1709 match_attr_spec (void)
1712 /* Modifiers that can exist in a type statement. */
1714 { GFC_DECL_BEGIN
= 0,
1715 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1716 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1717 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1718 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1719 GFC_DECL_END
/* Sentinel */
1723 /* GFC_DECL_END is the sentinel, index starts at 0. */
1724 #define NUM_DECL GFC_DECL_END
1726 static mstring decls
[] = {
1727 minit (", allocatable", DECL_ALLOCATABLE
),
1728 minit (", dimension", DECL_DIMENSION
),
1729 minit (", external", DECL_EXTERNAL
),
1730 minit (", intent ( in )", DECL_IN
),
1731 minit (", intent ( out )", DECL_OUT
),
1732 minit (", intent ( in out )", DECL_INOUT
),
1733 minit (", intrinsic", DECL_INTRINSIC
),
1734 minit (", optional", DECL_OPTIONAL
),
1735 minit (", parameter", DECL_PARAMETER
),
1736 minit (", pointer", DECL_POINTER
),
1737 minit (", private", DECL_PRIVATE
),
1738 minit (", public", DECL_PUBLIC
),
1739 minit (", save", DECL_SAVE
),
1740 minit (", target", DECL_TARGET
),
1741 minit ("::", DECL_COLON
),
1742 minit (NULL
, DECL_NONE
)
1745 locus start
, seen_at
[NUM_DECL
];
1752 gfc_clear_attr (¤t_attr
);
1753 start
= gfc_current_locus
;
1758 /* See if we get all of the keywords up to the final double colon. */
1759 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1764 d
= (decl_types
) gfc_match_strings (decls
);
1765 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1769 seen_at
[d
] = gfc_current_locus
;
1771 if (d
== DECL_DIMENSION
)
1773 m
= gfc_match_array_spec (¤t_as
);
1777 gfc_error ("Missing dimension specification at %C");
1781 if (m
== MATCH_ERROR
)
1786 /* No double colon, so assume that we've been looking at something
1787 else the whole time. */
1794 /* Since we've seen a double colon, we have to be looking at an
1795 attr-spec. This means that we can now issue errors. */
1796 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1801 case DECL_ALLOCATABLE
:
1802 attr
= "ALLOCATABLE";
1804 case DECL_DIMENSION
:
1811 attr
= "INTENT (IN)";
1814 attr
= "INTENT (OUT)";
1817 attr
= "INTENT (IN OUT)";
1819 case DECL_INTRINSIC
:
1825 case DECL_PARAMETER
:
1844 attr
= NULL
; /* This shouldn't happen */
1847 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1852 /* Now that we've dealt with duplicate attributes, add the attributes
1853 to the current attribute. */
1854 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1859 if (gfc_current_state () == COMP_DERIVED
1860 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1861 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1864 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1872 case DECL_ALLOCATABLE
:
1873 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1876 case DECL_DIMENSION
:
1877 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
1881 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1885 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1889 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1893 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1896 case DECL_INTRINSIC
:
1897 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1901 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1904 case DECL_PARAMETER
:
1905 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
1909 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1913 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
1918 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
1923 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
1927 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1931 gfc_internal_error ("match_attr_spec(): Bad attribute");
1945 gfc_current_locus
= start
;
1946 gfc_free_array_spec (current_as
);
1952 /* Match a data declaration statement. */
1955 gfc_match_data_decl (void)
1961 m
= match_type_spec (¤t_ts
, 0);
1965 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1967 sym
= gfc_use_derived (current_ts
.derived
);
1975 current_ts
.derived
= sym
;
1978 m
= match_attr_spec ();
1979 if (m
== MATCH_ERROR
)
1985 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1988 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1991 if (gfc_find_symbol (current_ts
.derived
->name
,
1992 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1995 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1996 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1999 gfc_error ("Derived type at %C has not been previously defined");
2005 /* If we have an old-style character declaration, and no new-style
2006 attribute specifications, then there a comma is optional between
2007 the type specification and the variable list. */
2008 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2009 gfc_match_char (',');
2011 /* Give the types/attributes to symbols that follow. Give the element
2012 a number so that repeat character length expressions can be copied. */
2016 m
= variable_decl (elem
++);
2017 if (m
== MATCH_ERROR
)
2022 if (gfc_match_eos () == MATCH_YES
)
2024 if (gfc_match_char (',') != MATCH_YES
)
2028 gfc_error ("Syntax error in data declaration at %C");
2032 gfc_free_array_spec (current_as
);
2038 /* Match a prefix associated with a function or subroutine
2039 declaration. If the typespec pointer is nonnull, then a typespec
2040 can be matched. Note that if nothing matches, MATCH_YES is
2041 returned (the null string was matched). */
2044 match_prefix (gfc_typespec
* ts
)
2048 gfc_clear_attr (¤t_attr
);
2052 if (!seen_type
&& ts
!= NULL
2053 && match_type_spec (ts
, 0) == MATCH_YES
2054 && gfc_match_space () == MATCH_YES
)
2061 if (gfc_match ("elemental% ") == MATCH_YES
)
2063 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2069 if (gfc_match ("pure% ") == MATCH_YES
)
2071 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2077 if (gfc_match ("recursive% ") == MATCH_YES
)
2079 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2085 /* At this point, the next item is not a prefix. */
2090 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2093 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2096 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2099 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2102 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2109 /* Match a formal argument list. */
2112 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2114 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2115 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2121 if (gfc_match_char ('(') != MATCH_YES
)
2128 if (gfc_match_char (')') == MATCH_YES
)
2133 if (gfc_match_char ('*') == MATCH_YES
)
2137 m
= gfc_match_name (name
);
2141 if (gfc_get_symbol (name
, NULL
, &sym
))
2145 p
= gfc_get_formal_arglist ();
2157 /* We don't add the VARIABLE flavor because the name could be a
2158 dummy procedure. We don't apply these attributes to formal
2159 arguments of statement functions. */
2160 if (sym
!= NULL
&& !st_flag
2161 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2162 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2168 /* The name of a program unit can be in a different namespace,
2169 so check for it explicitly. After the statement is accepted,
2170 the name is checked for especially in gfc_get_symbol(). */
2171 if (gfc_new_block
!= NULL
&& sym
!= NULL
2172 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2174 gfc_error ("Name '%s' at %C is the name of the procedure",
2180 if (gfc_match_char (')') == MATCH_YES
)
2183 m
= gfc_match_char (',');
2186 gfc_error ("Unexpected junk in formal argument list at %C");
2192 /* Check for duplicate symbols in the formal argument list. */
2195 for (p
= head
; p
->next
; p
= p
->next
)
2200 for (q
= p
->next
; q
; q
= q
->next
)
2201 if (p
->sym
== q
->sym
)
2204 ("Duplicate symbol '%s' in formal argument list at %C",
2213 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2223 gfc_free_formal_arglist (head
);
2228 /* Match a RESULT specification following a function declaration or
2229 ENTRY statement. Also matches the end-of-statement. */
2232 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2234 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2238 if (gfc_match (" result (") != MATCH_YES
)
2241 m
= gfc_match_name (name
);
2245 if (gfc_match (" )%t") != MATCH_YES
)
2247 gfc_error ("Unexpected junk following RESULT variable at %C");
2251 if (strcmp (function
->name
, name
) == 0)
2254 ("RESULT variable at %C must be different than function name");
2258 if (gfc_get_symbol (name
, NULL
, &r
))
2261 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2262 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2271 /* Match a function declaration. */
2274 gfc_match_function_decl (void)
2276 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2277 gfc_symbol
*sym
, *result
;
2281 if (gfc_current_state () != COMP_NONE
2282 && gfc_current_state () != COMP_INTERFACE
2283 && gfc_current_state () != COMP_CONTAINS
)
2286 gfc_clear_ts (¤t_ts
);
2288 old_loc
= gfc_current_locus
;
2290 m
= match_prefix (¤t_ts
);
2293 gfc_current_locus
= old_loc
;
2297 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2299 gfc_current_locus
= old_loc
;
2303 if (get_proc_name (name
, &sym
))
2305 gfc_new_block
= sym
;
2307 m
= gfc_match_formal_arglist (sym
, 0, 0);
2309 gfc_error ("Expected formal argument list in function definition at %C");
2310 else if (m
== MATCH_ERROR
)
2315 if (gfc_match_eos () != MATCH_YES
)
2317 /* See if a result variable is present. */
2318 m
= match_result (sym
, &result
);
2320 gfc_error ("Unexpected junk after function declaration at %C");
2329 /* Make changes to the symbol. */
2332 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2335 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2336 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2339 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2341 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2342 gfc_basic_typename (sym
->ts
.type
));
2348 sym
->ts
= current_ts
;
2353 result
->ts
= current_ts
;
2354 sym
->result
= result
;
2360 gfc_current_locus
= old_loc
;
2365 /* Match an ENTRY statement. */
2368 gfc_match_entry (void)
2373 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2374 gfc_compile_state state
;
2378 m
= gfc_match_name (name
);
2382 state
= gfc_current_state ();
2383 if (state
!= COMP_SUBROUTINE
2384 && state
!= COMP_FUNCTION
)
2386 gfc_error ("ENTRY statement at %C cannot appear within %s",
2387 gfc_state_name (gfc_current_state ()));
2391 if (gfc_current_ns
->parent
!= NULL
2392 && gfc_current_ns
->parent
->proc_name
2393 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2395 gfc_error("ENTRY statement at %C cannot appear in a "
2396 "contained procedure");
2400 if (get_proc_name (name
, &entry
))
2403 proc
= gfc_current_block ();
2405 if (state
== COMP_SUBROUTINE
)
2407 /* An entry in a subroutine. */
2408 m
= gfc_match_formal_arglist (entry
, 0, 1);
2412 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2413 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2418 /* An entry in a function. */
2419 m
= gfc_match_formal_arglist (entry
, 0, 1);
2425 if (gfc_match_eos () == MATCH_YES
)
2427 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2428 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2431 entry
->result
= entry
;
2435 m
= match_result (proc
, &result
);
2437 gfc_syntax_error (ST_ENTRY
);
2441 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2442 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2443 || gfc_add_function (&entry
->attr
, result
->name
,
2447 entry
->result
= result
;
2450 if (proc
->attr
.recursive
&& result
== NULL
)
2452 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2457 if (gfc_match_eos () != MATCH_YES
)
2459 gfc_syntax_error (ST_ENTRY
);
2463 entry
->attr
.recursive
= proc
->attr
.recursive
;
2464 entry
->attr
.elemental
= proc
->attr
.elemental
;
2465 entry
->attr
.pure
= proc
->attr
.pure
;
2467 el
= gfc_get_entry_list ();
2469 el
->next
= gfc_current_ns
->entries
;
2470 gfc_current_ns
->entries
= el
;
2472 el
->id
= el
->next
->id
+ 1;
2476 new_st
.op
= EXEC_ENTRY
;
2477 new_st
.ext
.entry
= el
;
2483 /* Match a subroutine statement, including optional prefixes. */
2486 gfc_match_subroutine (void)
2488 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2492 if (gfc_current_state () != COMP_NONE
2493 && gfc_current_state () != COMP_INTERFACE
2494 && gfc_current_state () != COMP_CONTAINS
)
2497 m
= match_prefix (NULL
);
2501 m
= gfc_match ("subroutine% %n", name
);
2505 if (get_proc_name (name
, &sym
))
2507 gfc_new_block
= sym
;
2509 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2512 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2515 if (gfc_match_eos () != MATCH_YES
)
2517 gfc_syntax_error (ST_SUBROUTINE
);
2521 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2528 /* Return nonzero if we're currently compiling a contained procedure. */
2531 contained_procedure (void)
2535 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2536 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2537 && s
->previous
!= NULL
2538 && s
->previous
->state
== COMP_CONTAINS
)
2544 /* Match any of the various end-block statements. Returns the type of
2545 END to the caller. The END INTERFACE, END IF, END DO and END
2546 SELECT statements cannot be replaced by a single END statement. */
2549 gfc_match_end (gfc_statement
* st
)
2551 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2552 gfc_compile_state state
;
2554 const char *block_name
;
2559 old_loc
= gfc_current_locus
;
2560 if (gfc_match ("end") != MATCH_YES
)
2563 state
= gfc_current_state ();
2565 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2567 if (state
== COMP_CONTAINS
)
2569 state
= gfc_state_stack
->previous
->state
;
2570 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2571 : gfc_state_stack
->previous
->sym
->name
;
2578 *st
= ST_END_PROGRAM
;
2579 target
= " program";
2583 case COMP_SUBROUTINE
:
2584 *st
= ST_END_SUBROUTINE
;
2585 target
= " subroutine";
2586 eos_ok
= !contained_procedure ();
2590 *st
= ST_END_FUNCTION
;
2591 target
= " function";
2592 eos_ok
= !contained_procedure ();
2595 case COMP_BLOCK_DATA
:
2596 *st
= ST_END_BLOCK_DATA
;
2597 target
= " block data";
2602 *st
= ST_END_MODULE
;
2607 case COMP_INTERFACE
:
2608 *st
= ST_END_INTERFACE
;
2609 target
= " interface";
2632 *st
= ST_END_SELECT
;
2638 *st
= ST_END_FORALL
;
2650 gfc_error ("Unexpected END statement at %C");
2654 if (gfc_match_eos () == MATCH_YES
)
2658 /* We would have required END [something] */
2659 gfc_error ("%s statement expected at %L",
2660 gfc_ascii_statement (*st
), &old_loc
);
2667 /* Verify that we've got the sort of end-block that we're expecting. */
2668 if (gfc_match (target
) != MATCH_YES
)
2670 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2674 /* If we're at the end, make sure a block name wasn't required. */
2675 if (gfc_match_eos () == MATCH_YES
)
2678 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2681 if (gfc_current_block () == NULL
)
2684 gfc_error ("Expected block name of '%s' in %s statement at %C",
2685 block_name
, gfc_ascii_statement (*st
));
2690 /* END INTERFACE has a special handler for its several possible endings. */
2691 if (*st
== ST_END_INTERFACE
)
2692 return gfc_match_end_interface ();
2694 /* We haven't hit the end of statement, so what is left must be an end-name. */
2695 m
= gfc_match_space ();
2697 m
= gfc_match_name (name
);
2700 gfc_error ("Expected terminating name at %C");
2704 if (block_name
== NULL
)
2707 if (strcmp (name
, block_name
) != 0)
2709 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2710 gfc_ascii_statement (*st
));
2714 if (gfc_match_eos () == MATCH_YES
)
2718 gfc_syntax_error (*st
);
2721 gfc_current_locus
= old_loc
;
2727 /***************** Attribute declaration statements ****************/
2729 /* Set the attribute of a single variable. */
2734 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2742 m
= gfc_match_name (name
);
2746 if (find_special (name
, &sym
))
2749 var_locus
= gfc_current_locus
;
2751 /* Deal with possible array specification for certain attributes. */
2752 if (current_attr
.dimension
2753 || current_attr
.allocatable
2754 || current_attr
.pointer
2755 || current_attr
.target
)
2757 m
= gfc_match_array_spec (&as
);
2758 if (m
== MATCH_ERROR
)
2761 if (current_attr
.dimension
&& m
== MATCH_NO
)
2764 ("Missing array specification at %L in DIMENSION statement",
2770 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2771 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2773 gfc_error ("Array specification must be deferred at %L",
2780 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2781 if (current_attr
.dimension
== 0
2782 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2788 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2794 if ((current_attr
.external
|| current_attr
.intrinsic
)
2795 && sym
->attr
.flavor
!= FL_PROCEDURE
2796 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
2805 gfc_free_array_spec (as
);
2810 /* Generic attribute declaration subroutine. Used for attributes that
2811 just have a list of names. */
2818 /* Gobble the optional double colon, by simply ignoring the result
2828 if (gfc_match_eos () == MATCH_YES
)
2834 if (gfc_match_char (',') != MATCH_YES
)
2836 gfc_error ("Unexpected character in variable list at %C");
2847 gfc_match_external (void)
2850 gfc_clear_attr (¤t_attr
);
2851 gfc_add_external (¤t_attr
, NULL
);
2853 return attr_decl ();
2859 gfc_match_intent (void)
2863 intent
= match_intent_spec ();
2864 if (intent
== INTENT_UNKNOWN
)
2867 gfc_clear_attr (¤t_attr
);
2868 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2870 return attr_decl ();
2875 gfc_match_intrinsic (void)
2878 gfc_clear_attr (¤t_attr
);
2879 gfc_add_intrinsic (¤t_attr
, NULL
);
2881 return attr_decl ();
2886 gfc_match_optional (void)
2889 gfc_clear_attr (¤t_attr
);
2890 gfc_add_optional (¤t_attr
, NULL
);
2892 return attr_decl ();
2897 gfc_match_pointer (void)
2900 gfc_clear_attr (¤t_attr
);
2901 gfc_add_pointer (¤t_attr
, NULL
);
2903 return attr_decl ();
2908 gfc_match_allocatable (void)
2911 gfc_clear_attr (¤t_attr
);
2912 gfc_add_allocatable (¤t_attr
, NULL
);
2914 return attr_decl ();
2919 gfc_match_dimension (void)
2922 gfc_clear_attr (¤t_attr
);
2923 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
2925 return attr_decl ();
2930 gfc_match_target (void)
2933 gfc_clear_attr (¤t_attr
);
2934 gfc_add_target (¤t_attr
, NULL
);
2936 return attr_decl ();
2940 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2944 access_attr_decl (gfc_statement st
)
2946 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2947 interface_type type
;
2950 gfc_intrinsic_op
operator;
2953 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2958 m
= gfc_match_generic_spec (&type
, name
, &operator);
2961 if (m
== MATCH_ERROR
)
2966 case INTERFACE_NAMELESS
:
2969 case INTERFACE_GENERIC
:
2970 if (gfc_get_symbol (name
, NULL
, &sym
))
2973 if (gfc_add_access (&sym
->attr
,
2975 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2976 sym
->name
, NULL
) == FAILURE
)
2981 case INTERFACE_INTRINSIC_OP
:
2982 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2984 gfc_current_ns
->operator_access
[operator] =
2985 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2989 gfc_error ("Access specification of the %s operator at %C has "
2990 "already been specified", gfc_op2string (operator));
2996 case INTERFACE_USER_OP
:
2997 uop
= gfc_get_uop (name
);
2999 if (uop
->access
== ACCESS_UNKNOWN
)
3002 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3007 ("Access specification of the .%s. operator at %C has "
3008 "already been specified", sym
->name
);
3015 if (gfc_match_char (',') == MATCH_NO
)
3019 if (gfc_match_eos () != MATCH_YES
)
3024 gfc_syntax_error (st
);
3031 /* The PRIVATE statement is a bit weird in that it can be a attribute
3032 declaration, but also works as a standlone statement inside of a
3033 type declaration or a module. */
3036 gfc_match_private (gfc_statement
* st
)
3039 if (gfc_match ("private") != MATCH_YES
)
3042 if (gfc_current_state () == COMP_DERIVED
)
3044 if (gfc_match_eos () == MATCH_YES
)
3050 gfc_syntax_error (ST_PRIVATE
);
3054 if (gfc_match_eos () == MATCH_YES
)
3061 return access_attr_decl (ST_PRIVATE
);
3066 gfc_match_public (gfc_statement
* st
)
3069 if (gfc_match ("public") != MATCH_YES
)
3072 if (gfc_match_eos () == MATCH_YES
)
3079 return access_attr_decl (ST_PUBLIC
);
3083 /* Workhorse for gfc_match_parameter. */
3092 m
= gfc_match_symbol (&sym
, 0);
3094 gfc_error ("Expected variable name at %C in PARAMETER statement");
3099 if (gfc_match_char ('=') == MATCH_NO
)
3101 gfc_error ("Expected = sign in PARAMETER statement at %C");
3105 m
= gfc_match_init_expr (&init
);
3107 gfc_error ("Expected expression at %C in PARAMETER statement");
3111 if (sym
->ts
.type
== BT_UNKNOWN
3112 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3118 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3119 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3125 if (sym
->ts
.type
== BT_CHARACTER
3126 && sym
->ts
.cl
!= NULL
3127 && sym
->ts
.cl
->length
!= NULL
3128 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3129 && init
->expr_type
== EXPR_CONSTANT
3130 && init
->ts
.type
== BT_CHARACTER
3131 && init
->ts
.kind
== 1)
3132 gfc_set_constant_character_len (
3133 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3139 gfc_free_expr (init
);
3144 /* Match a parameter statement, with the weird syntax that these have. */
3147 gfc_match_parameter (void)
3151 if (gfc_match_char ('(') == MATCH_NO
)
3160 if (gfc_match (" )%t") == MATCH_YES
)
3163 if (gfc_match_char (',') != MATCH_YES
)
3165 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3175 /* Save statements have a special syntax. */
3178 gfc_match_save (void)
3180 char n
[GFC_MAX_SYMBOL_LEN
+1];
3185 if (gfc_match_eos () == MATCH_YES
)
3187 if (gfc_current_ns
->seen_save
)
3189 gfc_error ("Blanket SAVE statement at %C follows previous "
3195 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3199 if (gfc_current_ns
->save_all
)
3201 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3209 m
= gfc_match_symbol (&sym
, 0);
3213 if (gfc_add_save (&sym
->attr
, sym
->name
,
3214 &gfc_current_locus
) == FAILURE
)
3225 m
= gfc_match (" / %n /", &n
);
3226 if (m
== MATCH_ERROR
)
3231 c
= gfc_get_common (n
, 0);
3234 gfc_current_ns
->seen_save
= 1;
3237 if (gfc_match_eos () == MATCH_YES
)
3239 if (gfc_match_char (',') != MATCH_YES
)
3246 gfc_error ("Syntax error in SAVE statement at %C");
3251 /* Match a module procedure statement. Note that we have to modify
3252 symbols in the parent's namespace because the current one was there
3253 to receive symbols that are in an interface's formal argument list. */
3256 gfc_match_modproc (void)
3258 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3262 if (gfc_state_stack
->state
!= COMP_INTERFACE
3263 || gfc_state_stack
->previous
== NULL
3264 || current_interface
.type
== INTERFACE_NAMELESS
)
3267 ("MODULE PROCEDURE at %C must be in a generic module interface");
3273 m
= gfc_match_name (name
);
3279 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3282 if (sym
->attr
.proc
!= PROC_MODULE
3283 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3284 sym
->name
, NULL
) == FAILURE
)
3287 if (gfc_add_interface (sym
) == FAILURE
)
3290 if (gfc_match_eos () == MATCH_YES
)
3292 if (gfc_match_char (',') != MATCH_YES
)
3299 gfc_syntax_error (ST_MODULE_PROC
);
3304 /* Match the beginning of a derived type declaration. If a type name
3305 was the result of a function, then it is possible to have a symbol
3306 already to be known as a derived type yet have no components. */
3309 gfc_match_derived_decl (void)
3311 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3312 symbol_attribute attr
;
3316 if (gfc_current_state () == COMP_DERIVED
)
3319 gfc_clear_attr (&attr
);
3322 if (gfc_match (" , private") == MATCH_YES
)
3324 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3327 ("Derived type at %C can only be PRIVATE within a MODULE");
3331 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3336 if (gfc_match (" , public") == MATCH_YES
)
3338 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3340 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3344 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3349 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3351 gfc_error ("Expected :: in TYPE definition at %C");
3355 m
= gfc_match (" %n%t", name
);
3359 /* Make sure the name isn't the name of an intrinsic type. The
3360 'double precision' type doesn't get past the name matcher. */
3361 if (strcmp (name
, "integer") == 0
3362 || strcmp (name
, "real") == 0
3363 || strcmp (name
, "character") == 0
3364 || strcmp (name
, "logical") == 0
3365 || strcmp (name
, "complex") == 0)
3368 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3373 if (gfc_get_symbol (name
, NULL
, &sym
))
3376 if (sym
->ts
.type
!= BT_UNKNOWN
)
3378 gfc_error ("Derived type name '%s' at %C already has a basic type "
3379 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3383 /* The symbol may already have the derived attribute without the
3384 components. The ways this can happen is via a function
3385 definition, an INTRINSIC statement or a subtype in another
3386 derived type that is a pointer. The first part of the AND clause
3387 is true if a the symbol is not the return value of a function. */
3388 if (sym
->attr
.flavor
!= FL_DERIVED
3389 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3392 if (sym
->components
!= NULL
)
3395 ("Derived type definition of '%s' at %C has already been defined",
3400 if (attr
.access
!= ACCESS_UNKNOWN
3401 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3404 gfc_new_block
= sym
;