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, 59 Temple Place - Suite 330, 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 aquire 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. If we're compiling a
534 function or subroutine and the parent compilation unit is an
535 interface, then check to see if the name we've been given is the
536 name of the interface (located in another namespace). If so,
537 return that symbol. If not, use gfc_get_symbol(). */
540 find_special (const char *name
, gfc_symbol
** result
)
544 if (gfc_current_state () != COMP_SUBROUTINE
545 && gfc_current_state () != COMP_FUNCTION
)
548 s
= gfc_state_stack
->previous
;
552 if (s
->state
!= COMP_INTERFACE
)
555 goto normal
; /* Nameless interface */
557 if (strcmp (name
, s
->sym
->name
) == 0)
564 return gfc_get_symbol (name
, NULL
, result
);
568 /* Special subroutine for getting a symbol node associated with a
569 procedure name, used in SUBROUTINE and FUNCTION statements. The
570 symbol is created in the parent using with symtree node in the
571 child unit pointing to the symbol. If the current namespace has no
572 parent, then the symbol is just created in the current unit. */
575 get_proc_name (const char *name
, gfc_symbol
** result
)
581 if (gfc_current_ns
->parent
== NULL
)
582 return gfc_get_symbol (name
, NULL
, result
);
584 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
588 /* ??? Deal with ENTRY problem */
590 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
596 /* See if the procedure should be a module procedure */
598 if (sym
->ns
->proc_name
!= NULL
599 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
600 && sym
->attr
.proc
!= PROC_MODULE
601 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
602 sym
->name
, NULL
) == FAILURE
)
609 /* Function called by variable_decl() that adds a name to the symbol
613 build_sym (const char *name
, gfc_charlen
* cl
,
614 gfc_array_spec
** as
, locus
* var_locus
)
616 symbol_attribute attr
;
619 if (find_special (name
, &sym
))
622 /* Start updating the symbol table. Add basic type attribute
624 if (current_ts
.type
!= BT_UNKNOWN
625 &&(sym
->attr
.implicit_type
== 0
626 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
627 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
630 if (sym
->ts
.type
== BT_CHARACTER
)
633 /* Add dimension attribute if present. */
634 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
638 /* Add attribute to symbol. The copy is so that we can reset the
639 dimension attribute. */
643 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
649 /* Set character constant to the given length. The constant will be padded or
653 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
658 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
659 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
661 slen
= expr
->value
.character
.length
;
664 s
= gfc_getmem (len
);
665 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
667 memset (&s
[slen
], ' ', len
- slen
);
668 gfc_free (expr
->value
.character
.string
);
669 expr
->value
.character
.string
= s
;
670 expr
->value
.character
.length
= len
;
674 /* Function called by variable_decl() that adds an initialization
675 expression to a symbol. */
678 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
681 symbol_attribute attr
;
686 if (find_special (name
, &sym
))
691 /* If this symbol is confirming an implicit parameter type,
692 then an initialization expression is not allowed. */
693 if (attr
.flavor
== FL_PARAMETER
694 && sym
->value
!= NULL
697 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
706 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
713 /* An initializer is required for PARAMETER declarations. */
714 if (attr
.flavor
== FL_PARAMETER
)
716 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
722 /* If a variable appears in a DATA block, it cannot have an
727 ("Variable '%s' at %C with an initializer already appears "
728 "in a DATA statement", sym
->name
);
732 /* Check if the assignment can happen. This has to be put off
733 until later for a derived type variable. */
734 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
735 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
738 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
740 /* Update symbol character length according initializer. */
741 if (sym
->ts
.cl
->length
== NULL
)
743 if (init
->expr_type
== EXPR_CONSTANT
)
745 gfc_int_expr (init
->value
.character
.length
);
746 else if (init
->expr_type
== EXPR_ARRAY
)
747 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
749 /* Update initializer character length according symbol. */
750 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
752 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
755 if (init
->expr_type
== EXPR_CONSTANT
)
756 gfc_set_constant_character_len (len
, init
);
757 else if (init
->expr_type
== EXPR_ARRAY
)
759 gfc_free_expr (init
->ts
.cl
->length
);
760 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
761 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
762 gfc_set_constant_character_len (len
, p
->expr
);
767 /* Add initializer. Make sure we keep the ranks sane. */
768 if (sym
->attr
.dimension
&& init
->rank
== 0)
769 init
->rank
= sym
->as
->rank
;
779 /* Function called by variable_decl() that adds a name to a structure
783 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
784 gfc_array_spec
** as
)
788 /* If the current symbol is of the same derived type that we're
789 constructing, it must have the pointer attribute. */
790 if (current_ts
.type
== BT_DERIVED
791 && current_ts
.derived
== gfc_current_block ()
792 && current_attr
.pointer
== 0)
794 gfc_error ("Component at %C must have the POINTER attribute");
798 if (gfc_current_block ()->attr
.pointer
801 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
803 gfc_error ("Array component of structure at %C must have explicit "
804 "or deferred shape");
809 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
814 gfc_set_component_attr (c
, ¤t_attr
);
816 c
->initializer
= *init
;
824 /* Check array components. */
830 if (c
->as
->type
!= AS_DEFERRED
)
832 gfc_error ("Pointer array component of structure at %C "
833 "must have a deferred shape");
839 if (c
->as
->type
!= AS_EXPLICIT
)
842 ("Array component of structure at %C must have an explicit "
852 /* Match a 'NULL()', and possibly take care of some side effects. */
855 gfc_match_null (gfc_expr
** result
)
861 m
= gfc_match (" null ( )");
865 /* The NULL symbol now has to be/become an intrinsic function. */
866 if (gfc_get_symbol ("null", NULL
, &sym
))
868 gfc_error ("NULL() initialization at %C is ambiguous");
872 gfc_intrinsic_symbol (sym
);
874 if (sym
->attr
.proc
!= PROC_INTRINSIC
875 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
876 sym
->name
, NULL
) == FAILURE
877 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
881 e
->where
= gfc_current_locus
;
882 e
->expr_type
= EXPR_NULL
;
883 e
->ts
.type
= BT_UNKNOWN
;
891 /* Match a variable name with an optional initializer. When this
892 subroutine is called, a variable is expected to be parsed next.
893 Depending on what is happening at the moment, updates either the
894 symbol table or the current interface. */
899 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
900 gfc_expr
*initializer
, *char_len
;
910 /* When we get here, we've just matched a list of attributes and
911 maybe a type and a double colon. The next thing we expect to see
912 is the name of the symbol. */
913 m
= gfc_match_name (name
);
917 var_locus
= gfc_current_locus
;
919 /* Now we could see the optional array spec. or character length. */
920 m
= gfc_match_array_spec (&as
);
921 if (m
== MATCH_ERROR
)
924 as
= gfc_copy_array_spec (current_as
);
929 if (current_ts
.type
== BT_CHARACTER
)
931 switch (match_char_length (&char_len
))
934 cl
= gfc_get_charlen ();
935 cl
->next
= gfc_current_ns
->cl_list
;
936 gfc_current_ns
->cl_list
= cl
;
938 cl
->length
= char_len
;
950 /* OK, we've successfully matched the declaration. Now put the
951 symbol in the current namespace, because it might be used in the
952 optional initialization expression for this symbol, e.g. this is
955 integer, parameter :: i = huge(i)
957 This is only true for parameters or variables of a basic type.
958 For components of derived types, it is not true, so we don't
959 create a symbol for those yet. If we fail to create the symbol,
961 if (gfc_current_state () != COMP_DERIVED
962 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
968 /* In functions that have a RESULT variable defined, the function
969 name always refers to function calls. Therefore, the name is
970 not allowed to appear in specification statements. */
971 if (gfc_current_state () == COMP_FUNCTION
972 && gfc_current_block () != NULL
973 && gfc_current_block ()->result
!= NULL
974 && gfc_current_block ()->result
!= gfc_current_block ()
975 && strcmp (gfc_current_block ()->name
, name
) == 0)
977 gfc_error ("Function name '%s' not allowed at %C", name
);
982 /* We allow old-style initializations of the form
983 integer i /2/, j(4) /3*3, 1/
984 (if no colon has been seen). These are different from data
985 statements in that initializers are only allowed to apply to the
986 variable immediately preceding, i.e.
988 is not allowed. Therefore we have to do some work manually, that
989 could otherwise be left to the matchers for DATA statements. */
991 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
993 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
994 "initialization at %C") == FAILURE
)
997 return match_old_style_init (name
);
1000 /* The double colon must be present in order to have initializers.
1001 Otherwise the statement is ambiguous with an assignment statement. */
1004 if (gfc_match (" =>") == MATCH_YES
)
1007 if (!current_attr
.pointer
)
1009 gfc_error ("Initialization at %C isn't for a pointer variable");
1014 m
= gfc_match_null (&initializer
);
1017 gfc_error ("Pointer initialization requires a NULL at %C");
1021 if (gfc_pure (NULL
))
1024 ("Initialization of pointer at %C is not allowed in a "
1032 initializer
->ts
= current_ts
;
1035 else if (gfc_match_char ('=') == MATCH_YES
)
1037 if (current_attr
.pointer
)
1040 ("Pointer initialization at %C requires '=>', not '='");
1045 m
= gfc_match_init_expr (&initializer
);
1048 gfc_error ("Expected an initialization expression at %C");
1052 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1055 ("Initialization of variable at %C is not allowed in a "
1065 /* Add the initializer. Note that it is fine if initializer is
1066 NULL here, because we sometimes also need to check if a
1067 declaration *must* have an initialization expression. */
1068 if (gfc_current_state () != COMP_DERIVED
)
1069 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1072 if (current_ts
.type
== BT_DERIVED
&& !initializer
)
1073 initializer
= gfc_default_initializer (¤t_ts
);
1074 t
= build_struct (name
, cl
, &initializer
, &as
);
1077 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1080 /* Free stuff up and return. */
1081 gfc_free_expr (initializer
);
1082 gfc_free_array_spec (as
);
1088 /* Match an extended-f77 kind specification. */
1091 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1095 if (gfc_match_char ('*') != MATCH_YES
)
1098 m
= gfc_match_small_literal_int (&ts
->kind
);
1102 /* Massage the kind numbers for complex types. */
1103 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1105 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1108 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1110 gfc_error ("Old-style kind %d not supported for type %s at %C",
1111 ts
->kind
, gfc_basic_typename (ts
->type
));
1120 /* Match a kind specification. Since kinds are generally optional, we
1121 usually return MATCH_NO if something goes wrong. If a "kind="
1122 string is found, then we know we have an error. */
1125 gfc_match_kind_spec (gfc_typespec
* ts
)
1135 where
= gfc_current_locus
;
1137 if (gfc_match_char ('(') == MATCH_NO
)
1140 /* Also gobbles optional text. */
1141 if (gfc_match (" kind = ") == MATCH_YES
)
1144 n
= gfc_match_init_expr (&e
);
1146 gfc_error ("Expected initialization expression at %C");
1152 gfc_error ("Expected scalar initialization expression at %C");
1157 msg
= gfc_extract_int (e
, &ts
->kind
);
1168 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1170 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1171 gfc_basic_typename (ts
->type
));
1177 if (gfc_match_char (')') != MATCH_YES
)
1179 gfc_error ("Missing right paren at %C");
1187 gfc_current_locus
= where
;
1192 /* Match the various kind/length specifications in a CHARACTER
1193 declaration. We don't return MATCH_NO. */
1196 match_char_spec (gfc_typespec
* ts
)
1198 int i
, kind
, seen_length
;
1203 kind
= gfc_default_character_kind
;
1207 /* Try the old-style specification first. */
1208 old_char_selector
= 0;
1210 m
= match_char_length (&len
);
1214 old_char_selector
= 1;
1219 m
= gfc_match_char ('(');
1222 m
= MATCH_YES
; /* character without length is a single char */
1226 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1227 if (gfc_match (" kind =") == MATCH_YES
)
1229 m
= gfc_match_small_int (&kind
);
1230 if (m
== MATCH_ERROR
)
1235 if (gfc_match (" , len =") == MATCH_NO
)
1238 m
= char_len_param_value (&len
);
1241 if (m
== MATCH_ERROR
)
1248 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1249 if (gfc_match (" len =") == MATCH_YES
)
1251 m
= char_len_param_value (&len
);
1254 if (m
== MATCH_ERROR
)
1258 if (gfc_match_char (')') == MATCH_YES
)
1261 if (gfc_match (" , kind =") != MATCH_YES
)
1264 gfc_match_small_int (&kind
);
1266 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1268 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1275 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1276 m
= char_len_param_value (&len
);
1279 if (m
== MATCH_ERROR
)
1283 m
= gfc_match_char (')');
1287 if (gfc_match_char (',') != MATCH_YES
)
1290 gfc_match (" kind ="); /* Gobble optional text */
1292 m
= gfc_match_small_int (&kind
);
1293 if (m
== MATCH_ERROR
)
1299 /* Require a right-paren at this point. */
1300 m
= gfc_match_char (')');
1305 gfc_error ("Syntax error in CHARACTER declaration at %C");
1309 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1311 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1317 gfc_free_expr (len
);
1321 /* Do some final massaging of the length values. */
1322 cl
= gfc_get_charlen ();
1323 cl
->next
= gfc_current_ns
->cl_list
;
1324 gfc_current_ns
->cl_list
= cl
;
1326 if (seen_length
== 0)
1327 cl
->length
= gfc_int_expr (1);
1330 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1334 gfc_free_expr (len
);
1335 cl
->length
= gfc_int_expr (0);
1346 /* Matches a type specification. If successful, sets the ts structure
1347 to the matched specification. This is necessary for FUNCTION and
1348 IMPLICIT statements.
1350 If implicit_flag is nonzero, then we don't check for the optional
1351 kind specification. Not doing so is needed for matching an IMPLICIT
1352 statement correctly. */
1355 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1357 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1364 if (gfc_match (" integer") == MATCH_YES
)
1366 ts
->type
= BT_INTEGER
;
1367 ts
->kind
= gfc_default_integer_kind
;
1371 if (gfc_match (" character") == MATCH_YES
)
1373 ts
->type
= BT_CHARACTER
;
1374 if (implicit_flag
== 0)
1375 return match_char_spec (ts
);
1380 if (gfc_match (" real") == MATCH_YES
)
1383 ts
->kind
= gfc_default_real_kind
;
1387 if (gfc_match (" double precision") == MATCH_YES
)
1390 ts
->kind
= gfc_default_double_kind
;
1394 if (gfc_match (" complex") == MATCH_YES
)
1396 ts
->type
= BT_COMPLEX
;
1397 ts
->kind
= gfc_default_complex_kind
;
1401 if (gfc_match (" double complex") == MATCH_YES
)
1403 ts
->type
= BT_COMPLEX
;
1404 ts
->kind
= gfc_default_double_kind
;
1408 if (gfc_match (" logical") == MATCH_YES
)
1410 ts
->type
= BT_LOGICAL
;
1411 ts
->kind
= gfc_default_logical_kind
;
1415 m
= gfc_match (" type ( %n )", name
);
1419 /* Search for the name but allow the components to be defined later. */
1420 if (gfc_get_ha_symbol (name
, &sym
))
1422 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1426 if (sym
->attr
.flavor
!= FL_DERIVED
1427 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1430 ts
->type
= BT_DERIVED
;
1437 /* For all types except double, derived and character, look for an
1438 optional kind specifier. MATCH_NO is actually OK at this point. */
1439 if (implicit_flag
== 1)
1442 if (gfc_current_form
== FORM_FREE
)
1444 c
= gfc_peek_char();
1445 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1446 && c
!= ':' && c
!= ',')
1450 m
= gfc_match_kind_spec (ts
);
1451 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1452 m
= gfc_match_old_kind_spec (ts
);
1455 m
= MATCH_YES
; /* No kind specifier found. */
1461 /* Match an IMPLICIT NONE statement. Actually, this statement is
1462 already matched in parse.c, or we would not end up here in the
1463 first place. So the only thing we need to check, is if there is
1464 trailing garbage. If not, the match is successful. */
1467 gfc_match_implicit_none (void)
1470 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1474 /* Match the letter range(s) of an IMPLICIT statement. */
1477 match_implicit_range (void)
1479 int c
, c1
, c2
, inner
;
1482 cur_loc
= gfc_current_locus
;
1484 gfc_gobble_whitespace ();
1485 c
= gfc_next_char ();
1488 gfc_error ("Missing character range in IMPLICIT at %C");
1495 gfc_gobble_whitespace ();
1496 c1
= gfc_next_char ();
1500 gfc_gobble_whitespace ();
1501 c
= gfc_next_char ();
1506 inner
= 0; /* Fall through */
1513 gfc_gobble_whitespace ();
1514 c2
= gfc_next_char ();
1518 gfc_gobble_whitespace ();
1519 c
= gfc_next_char ();
1521 if ((c
!= ',') && (c
!= ')'))
1534 gfc_error ("Letters must be in alphabetic order in "
1535 "IMPLICIT statement at %C");
1539 /* See if we can add the newly matched range to the pending
1540 implicits from this IMPLICIT statement. We do not check for
1541 conflicts with whatever earlier IMPLICIT statements may have
1542 set. This is done when we've successfully finished matching
1544 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1551 gfc_syntax_error (ST_IMPLICIT
);
1553 gfc_current_locus
= cur_loc
;
1558 /* Match an IMPLICIT statement, storing the types for
1559 gfc_set_implicit() if the statement is accepted by the parser.
1560 There is a strange looking, but legal syntactic construction
1561 possible. It looks like:
1563 IMPLICIT INTEGER (a-b) (c-d)
1565 This is legal if "a-b" is a constant expression that happens to
1566 equal one of the legal kinds for integers. The real problem
1567 happens with an implicit specification that looks like:
1569 IMPLICIT INTEGER (a-b)
1571 In this case, a typespec matcher that is "greedy" (as most of the
1572 matchers are) gobbles the character range as a kindspec, leaving
1573 nothing left. We therefore have to go a bit more slowly in the
1574 matching process by inhibiting the kindspec checking during
1575 typespec matching and checking for a kind later. */
1578 gfc_match_implicit (void)
1585 /* We don't allow empty implicit statements. */
1586 if (gfc_match_eos () == MATCH_YES
)
1588 gfc_error ("Empty IMPLICIT statement at %C");
1594 /* First cleanup. */
1595 gfc_clear_new_implicit ();
1597 /* A basic type is mandatory here. */
1598 m
= match_type_spec (&ts
, 1);
1599 if (m
== MATCH_ERROR
)
1604 cur_loc
= gfc_current_locus
;
1605 m
= match_implicit_range ();
1609 /* We may have <TYPE> (<RANGE>). */
1610 gfc_gobble_whitespace ();
1611 c
= gfc_next_char ();
1612 if ((c
== '\n') || (c
== ','))
1614 /* Check for CHARACTER with no length parameter. */
1615 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1617 ts
.kind
= gfc_default_character_kind
;
1618 ts
.cl
= gfc_get_charlen ();
1619 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1620 gfc_current_ns
->cl_list
= ts
.cl
;
1621 ts
.cl
->length
= gfc_int_expr (1);
1624 /* Record the Successful match. */
1625 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1630 gfc_current_locus
= cur_loc
;
1633 /* Discard the (incorrectly) matched range. */
1634 gfc_clear_new_implicit ();
1636 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1637 if (ts
.type
== BT_CHARACTER
)
1638 m
= match_char_spec (&ts
);
1641 m
= gfc_match_kind_spec (&ts
);
1644 m
= gfc_match_old_kind_spec (&ts
);
1645 if (m
== MATCH_ERROR
)
1651 if (m
== MATCH_ERROR
)
1654 m
= match_implicit_range ();
1655 if (m
== MATCH_ERROR
)
1660 gfc_gobble_whitespace ();
1661 c
= gfc_next_char ();
1662 if ((c
!= '\n') && (c
!= ','))
1665 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1673 gfc_syntax_error (ST_IMPLICIT
);
1680 /* Matches an attribute specification including array specs. If
1681 successful, leaves the variables current_attr and current_as
1682 holding the specification. Also sets the colon_seen variable for
1683 later use by matchers associated with initializations.
1685 This subroutine is a little tricky in the sense that we don't know
1686 if we really have an attr-spec until we hit the double colon.
1687 Until that time, we can only return MATCH_NO. This forces us to
1688 check for duplicate specification at this level. */
1691 match_attr_spec (void)
1694 /* Modifiers that can exist in a type statement. */
1696 { GFC_DECL_BEGIN
= 0,
1697 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1698 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1699 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1700 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1701 GFC_DECL_END
/* Sentinel */
1705 /* GFC_DECL_END is the sentinel, index starts at 0. */
1706 #define NUM_DECL GFC_DECL_END
1708 static mstring decls
[] = {
1709 minit (", allocatable", DECL_ALLOCATABLE
),
1710 minit (", dimension", DECL_DIMENSION
),
1711 minit (", external", DECL_EXTERNAL
),
1712 minit (", intent ( in )", DECL_IN
),
1713 minit (", intent ( out )", DECL_OUT
),
1714 minit (", intent ( in out )", DECL_INOUT
),
1715 minit (", intrinsic", DECL_INTRINSIC
),
1716 minit (", optional", DECL_OPTIONAL
),
1717 minit (", parameter", DECL_PARAMETER
),
1718 minit (", pointer", DECL_POINTER
),
1719 minit (", private", DECL_PRIVATE
),
1720 minit (", public", DECL_PUBLIC
),
1721 minit (", save", DECL_SAVE
),
1722 minit (", target", DECL_TARGET
),
1723 minit ("::", DECL_COLON
),
1724 minit (NULL
, DECL_NONE
)
1727 locus start
, seen_at
[NUM_DECL
];
1734 gfc_clear_attr (¤t_attr
);
1735 start
= gfc_current_locus
;
1740 /* See if we get all of the keywords up to the final double colon. */
1741 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1746 d
= (decl_types
) gfc_match_strings (decls
);
1747 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1751 seen_at
[d
] = gfc_current_locus
;
1753 if (d
== DECL_DIMENSION
)
1755 m
= gfc_match_array_spec (¤t_as
);
1759 gfc_error ("Missing dimension specification at %C");
1763 if (m
== MATCH_ERROR
)
1768 /* No double colon, so assume that we've been looking at something
1769 else the whole time. */
1776 /* Since we've seen a double colon, we have to be looking at an
1777 attr-spec. This means that we can now issue errors. */
1778 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1783 case DECL_ALLOCATABLE
:
1784 attr
= "ALLOCATABLE";
1786 case DECL_DIMENSION
:
1793 attr
= "INTENT (IN)";
1796 attr
= "INTENT (OUT)";
1799 attr
= "INTENT (IN OUT)";
1801 case DECL_INTRINSIC
:
1807 case DECL_PARAMETER
:
1826 attr
= NULL
; /* This shouldn't happen */
1829 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1834 /* Now that we've dealt with duplicate attributes, add the attributes
1835 to the current attribute. */
1836 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1841 if (gfc_current_state () == COMP_DERIVED
1842 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1843 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1846 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1854 case DECL_ALLOCATABLE
:
1855 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1858 case DECL_DIMENSION
:
1859 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
1863 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1867 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1871 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1875 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1878 case DECL_INTRINSIC
:
1879 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1883 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1886 case DECL_PARAMETER
:
1887 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
1891 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1895 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
1900 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
1905 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
1909 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1913 gfc_internal_error ("match_attr_spec(): Bad attribute");
1927 gfc_current_locus
= start
;
1928 gfc_free_array_spec (current_as
);
1934 /* Match a data declaration statement. */
1937 gfc_match_data_decl (void)
1942 m
= match_type_spec (¤t_ts
, 0);
1946 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1948 sym
= gfc_use_derived (current_ts
.derived
);
1956 current_ts
.derived
= sym
;
1959 m
= match_attr_spec ();
1960 if (m
== MATCH_ERROR
)
1966 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1969 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1972 if (gfc_find_symbol (current_ts
.derived
->name
,
1973 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1976 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1977 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1980 gfc_error ("Derived type at %C has not been previously defined");
1986 /* If we have an old-style character declaration, and no new-style
1987 attribute specifications, then there a comma is optional between
1988 the type specification and the variable list. */
1989 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
1990 gfc_match_char (',');
1992 /* Give the types/attributes to symbols that follow. */
1995 m
= variable_decl ();
1996 if (m
== MATCH_ERROR
)
2001 if (gfc_match_eos () == MATCH_YES
)
2003 if (gfc_match_char (',') != MATCH_YES
)
2007 gfc_error ("Syntax error in data declaration at %C");
2011 gfc_free_array_spec (current_as
);
2017 /* Match a prefix associated with a function or subroutine
2018 declaration. If the typespec pointer is nonnull, then a typespec
2019 can be matched. Note that if nothing matches, MATCH_YES is
2020 returned (the null string was matched). */
2023 match_prefix (gfc_typespec
* ts
)
2027 gfc_clear_attr (¤t_attr
);
2031 if (!seen_type
&& ts
!= NULL
2032 && match_type_spec (ts
, 0) == MATCH_YES
2033 && gfc_match_space () == MATCH_YES
)
2040 if (gfc_match ("elemental% ") == MATCH_YES
)
2042 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2048 if (gfc_match ("pure% ") == MATCH_YES
)
2050 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2056 if (gfc_match ("recursive% ") == MATCH_YES
)
2058 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2064 /* At this point, the next item is not a prefix. */
2069 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2072 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2075 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2078 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2081 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2088 /* Match a formal argument list. */
2091 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2093 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2094 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2100 if (gfc_match_char ('(') != MATCH_YES
)
2107 if (gfc_match_char (')') == MATCH_YES
)
2112 if (gfc_match_char ('*') == MATCH_YES
)
2116 m
= gfc_match_name (name
);
2120 if (gfc_get_symbol (name
, NULL
, &sym
))
2124 p
= gfc_get_formal_arglist ();
2136 /* We don't add the VARIABLE flavor because the name could be a
2137 dummy procedure. We don't apply these attributes to formal
2138 arguments of statement functions. */
2139 if (sym
!= NULL
&& !st_flag
2140 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2141 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2147 /* The name of a program unit can be in a different namespace,
2148 so check for it explicitly. After the statement is accepted,
2149 the name is checked for especially in gfc_get_symbol(). */
2150 if (gfc_new_block
!= NULL
&& sym
!= NULL
2151 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2153 gfc_error ("Name '%s' at %C is the name of the procedure",
2159 if (gfc_match_char (')') == MATCH_YES
)
2162 m
= gfc_match_char (',');
2165 gfc_error ("Unexpected junk in formal argument list at %C");
2171 /* Check for duplicate symbols in the formal argument list. */
2174 for (p
= head
; p
->next
; p
= p
->next
)
2179 for (q
= p
->next
; q
; q
= q
->next
)
2180 if (p
->sym
== q
->sym
)
2183 ("Duplicate symbol '%s' in formal argument list at %C",
2192 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2202 gfc_free_formal_arglist (head
);
2207 /* Match a RESULT specification following a function declaration or
2208 ENTRY statement. Also matches the end-of-statement. */
2211 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2213 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2217 if (gfc_match (" result (") != MATCH_YES
)
2220 m
= gfc_match_name (name
);
2224 if (gfc_match (" )%t") != MATCH_YES
)
2226 gfc_error ("Unexpected junk following RESULT variable at %C");
2230 if (strcmp (function
->name
, name
) == 0)
2233 ("RESULT variable at %C must be different than function name");
2237 if (gfc_get_symbol (name
, NULL
, &r
))
2240 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2241 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2250 /* Match a function declaration. */
2253 gfc_match_function_decl (void)
2255 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2256 gfc_symbol
*sym
, *result
;
2260 if (gfc_current_state () != COMP_NONE
2261 && gfc_current_state () != COMP_INTERFACE
2262 && gfc_current_state () != COMP_CONTAINS
)
2265 gfc_clear_ts (¤t_ts
);
2267 old_loc
= gfc_current_locus
;
2269 m
= match_prefix (¤t_ts
);
2272 gfc_current_locus
= old_loc
;
2276 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2278 gfc_current_locus
= old_loc
;
2282 if (get_proc_name (name
, &sym
))
2284 gfc_new_block
= sym
;
2286 m
= gfc_match_formal_arglist (sym
, 0, 0);
2288 gfc_error ("Expected formal argument list in function definition at %C");
2289 else if (m
== MATCH_ERROR
)
2294 if (gfc_match_eos () != MATCH_YES
)
2296 /* See if a result variable is present. */
2297 m
= match_result (sym
, &result
);
2299 gfc_error ("Unexpected junk after function declaration at %C");
2308 /* Make changes to the symbol. */
2311 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2314 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2315 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2318 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2320 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2321 gfc_basic_typename (sym
->ts
.type
));
2327 sym
->ts
= current_ts
;
2332 result
->ts
= current_ts
;
2333 sym
->result
= result
;
2339 gfc_current_locus
= old_loc
;
2344 /* Match an ENTRY statement. */
2347 gfc_match_entry (void)
2352 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2353 gfc_compile_state state
;
2357 m
= gfc_match_name (name
);
2361 state
= gfc_current_state ();
2362 if (state
!= COMP_SUBROUTINE
2363 && state
!= COMP_FUNCTION
)
2365 gfc_error ("ENTRY statement at %C cannot appear within %s",
2366 gfc_state_name (gfc_current_state ()));
2370 if (gfc_current_ns
->parent
!= NULL
2371 && gfc_current_ns
->parent
->proc_name
2372 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2374 gfc_error("ENTRY statement at %C cannot appear in a "
2375 "contained procedure");
2379 if (get_proc_name (name
, &entry
))
2382 proc
= gfc_current_block ();
2384 if (state
== COMP_SUBROUTINE
)
2386 /* An entry in a subroutine. */
2387 m
= gfc_match_formal_arglist (entry
, 0, 1);
2391 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2392 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2397 /* An entry in a function. */
2398 m
= gfc_match_formal_arglist (entry
, 0, 0);
2404 if (gfc_match_eos () == MATCH_YES
)
2406 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2407 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2410 entry
->result
= entry
;
2414 m
= match_result (proc
, &result
);
2416 gfc_syntax_error (ST_ENTRY
);
2420 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2421 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2422 || gfc_add_function (&entry
->attr
, result
->name
,
2426 entry
->result
= result
;
2429 if (proc
->attr
.recursive
&& result
== NULL
)
2431 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2436 if (gfc_match_eos () != MATCH_YES
)
2438 gfc_syntax_error (ST_ENTRY
);
2442 entry
->attr
.recursive
= proc
->attr
.recursive
;
2443 entry
->attr
.elemental
= proc
->attr
.elemental
;
2444 entry
->attr
.pure
= proc
->attr
.pure
;
2446 el
= gfc_get_entry_list ();
2448 el
->next
= gfc_current_ns
->entries
;
2449 gfc_current_ns
->entries
= el
;
2451 el
->id
= el
->next
->id
+ 1;
2455 new_st
.op
= EXEC_ENTRY
;
2456 new_st
.ext
.entry
= el
;
2462 /* Match a subroutine statement, including optional prefixes. */
2465 gfc_match_subroutine (void)
2467 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2471 if (gfc_current_state () != COMP_NONE
2472 && gfc_current_state () != COMP_INTERFACE
2473 && gfc_current_state () != COMP_CONTAINS
)
2476 m
= match_prefix (NULL
);
2480 m
= gfc_match ("subroutine% %n", name
);
2484 if (get_proc_name (name
, &sym
))
2486 gfc_new_block
= sym
;
2488 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2491 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2494 if (gfc_match_eos () != MATCH_YES
)
2496 gfc_syntax_error (ST_SUBROUTINE
);
2500 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2507 /* Return nonzero if we're currently compiling a contained procedure. */
2510 contained_procedure (void)
2514 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2515 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2516 && s
->previous
!= NULL
2517 && s
->previous
->state
== COMP_CONTAINS
)
2523 /* Match any of the various end-block statements. Returns the type of
2524 END to the caller. The END INTERFACE, END IF, END DO and END
2525 SELECT statements cannot be replaced by a single END statement. */
2528 gfc_match_end (gfc_statement
* st
)
2530 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2531 gfc_compile_state state
;
2533 const char *block_name
;
2538 old_loc
= gfc_current_locus
;
2539 if (gfc_match ("end") != MATCH_YES
)
2542 state
= gfc_current_state ();
2544 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2546 if (state
== COMP_CONTAINS
)
2548 state
= gfc_state_stack
->previous
->state
;
2549 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2550 : gfc_state_stack
->previous
->sym
->name
;
2557 *st
= ST_END_PROGRAM
;
2558 target
= " program";
2562 case COMP_SUBROUTINE
:
2563 *st
= ST_END_SUBROUTINE
;
2564 target
= " subroutine";
2565 eos_ok
= !contained_procedure ();
2569 *st
= ST_END_FUNCTION
;
2570 target
= " function";
2571 eos_ok
= !contained_procedure ();
2574 case COMP_BLOCK_DATA
:
2575 *st
= ST_END_BLOCK_DATA
;
2576 target
= " block data";
2581 *st
= ST_END_MODULE
;
2586 case COMP_INTERFACE
:
2587 *st
= ST_END_INTERFACE
;
2588 target
= " interface";
2611 *st
= ST_END_SELECT
;
2617 *st
= ST_END_FORALL
;
2629 gfc_error ("Unexpected END statement at %C");
2633 if (gfc_match_eos () == MATCH_YES
)
2637 /* We would have required END [something] */
2638 gfc_error ("%s statement expected at %L",
2639 gfc_ascii_statement (*st
), &old_loc
);
2646 /* Verify that we've got the sort of end-block that we're expecting. */
2647 if (gfc_match (target
) != MATCH_YES
)
2649 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2653 /* If we're at the end, make sure a block name wasn't required. */
2654 if (gfc_match_eos () == MATCH_YES
)
2657 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2660 if (gfc_current_block () == NULL
)
2663 gfc_error ("Expected block name of '%s' in %s statement at %C",
2664 block_name
, gfc_ascii_statement (*st
));
2669 /* END INTERFACE has a special handler for its several possible endings. */
2670 if (*st
== ST_END_INTERFACE
)
2671 return gfc_match_end_interface ();
2673 /* We haven't hit the end of statement, so what is left must be an end-name. */
2674 m
= gfc_match_space ();
2676 m
= gfc_match_name (name
);
2679 gfc_error ("Expected terminating name at %C");
2683 if (block_name
== NULL
)
2686 if (strcmp (name
, block_name
) != 0)
2688 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2689 gfc_ascii_statement (*st
));
2693 if (gfc_match_eos () == MATCH_YES
)
2697 gfc_syntax_error (*st
);
2700 gfc_current_locus
= old_loc
;
2706 /***************** Attribute declaration statements ****************/
2708 /* Set the attribute of a single variable. */
2713 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2721 m
= gfc_match_name (name
);
2725 if (find_special (name
, &sym
))
2728 var_locus
= gfc_current_locus
;
2730 /* Deal with possible array specification for certain attributes. */
2731 if (current_attr
.dimension
2732 || current_attr
.allocatable
2733 || current_attr
.pointer
2734 || current_attr
.target
)
2736 m
= gfc_match_array_spec (&as
);
2737 if (m
== MATCH_ERROR
)
2740 if (current_attr
.dimension
&& m
== MATCH_NO
)
2743 ("Missing array specification at %L in DIMENSION statement",
2749 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2750 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2752 gfc_error ("Array specification must be deferred at %L",
2759 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2760 if (current_attr
.dimension
== 0
2761 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2767 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2773 if ((current_attr
.external
|| current_attr
.intrinsic
)
2774 && sym
->attr
.flavor
!= FL_PROCEDURE
2775 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
2784 gfc_free_array_spec (as
);
2789 /* Generic attribute declaration subroutine. Used for attributes that
2790 just have a list of names. */
2797 /* Gobble the optional double colon, by simply ignoring the result
2807 if (gfc_match_eos () == MATCH_YES
)
2813 if (gfc_match_char (',') != MATCH_YES
)
2815 gfc_error ("Unexpected character in variable list at %C");
2826 gfc_match_external (void)
2829 gfc_clear_attr (¤t_attr
);
2830 gfc_add_external (¤t_attr
, NULL
);
2832 return attr_decl ();
2838 gfc_match_intent (void)
2842 intent
= match_intent_spec ();
2843 if (intent
== INTENT_UNKNOWN
)
2846 gfc_clear_attr (¤t_attr
);
2847 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2849 return attr_decl ();
2854 gfc_match_intrinsic (void)
2857 gfc_clear_attr (¤t_attr
);
2858 gfc_add_intrinsic (¤t_attr
, NULL
);
2860 return attr_decl ();
2865 gfc_match_optional (void)
2868 gfc_clear_attr (¤t_attr
);
2869 gfc_add_optional (¤t_attr
, NULL
);
2871 return attr_decl ();
2876 gfc_match_pointer (void)
2879 gfc_clear_attr (¤t_attr
);
2880 gfc_add_pointer (¤t_attr
, NULL
);
2882 return attr_decl ();
2887 gfc_match_allocatable (void)
2890 gfc_clear_attr (¤t_attr
);
2891 gfc_add_allocatable (¤t_attr
, NULL
);
2893 return attr_decl ();
2898 gfc_match_dimension (void)
2901 gfc_clear_attr (¤t_attr
);
2902 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
2904 return attr_decl ();
2909 gfc_match_target (void)
2912 gfc_clear_attr (¤t_attr
);
2913 gfc_add_target (¤t_attr
, NULL
);
2915 return attr_decl ();
2919 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2923 access_attr_decl (gfc_statement st
)
2925 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2926 interface_type type
;
2929 gfc_intrinsic_op
operator;
2932 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2937 m
= gfc_match_generic_spec (&type
, name
, &operator);
2940 if (m
== MATCH_ERROR
)
2945 case INTERFACE_NAMELESS
:
2948 case INTERFACE_GENERIC
:
2949 if (gfc_get_symbol (name
, NULL
, &sym
))
2952 if (gfc_add_access (&sym
->attr
,
2954 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2955 sym
->name
, NULL
) == FAILURE
)
2960 case INTERFACE_INTRINSIC_OP
:
2961 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2963 gfc_current_ns
->operator_access
[operator] =
2964 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2968 gfc_error ("Access specification of the %s operator at %C has "
2969 "already been specified", gfc_op2string (operator));
2975 case INTERFACE_USER_OP
:
2976 uop
= gfc_get_uop (name
);
2978 if (uop
->access
== ACCESS_UNKNOWN
)
2981 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2986 ("Access specification of the .%s. operator at %C has "
2987 "already been specified", sym
->name
);
2994 if (gfc_match_char (',') == MATCH_NO
)
2998 if (gfc_match_eos () != MATCH_YES
)
3003 gfc_syntax_error (st
);
3010 /* The PRIVATE statement is a bit weird in that it can be a attribute
3011 declaration, but also works as a standlone statement inside of a
3012 type declaration or a module. */
3015 gfc_match_private (gfc_statement
* st
)
3018 if (gfc_match ("private") != MATCH_YES
)
3021 if (gfc_current_state () == COMP_DERIVED
)
3023 if (gfc_match_eos () == MATCH_YES
)
3029 gfc_syntax_error (ST_PRIVATE
);
3033 if (gfc_match_eos () == MATCH_YES
)
3040 return access_attr_decl (ST_PRIVATE
);
3045 gfc_match_public (gfc_statement
* st
)
3048 if (gfc_match ("public") != MATCH_YES
)
3051 if (gfc_match_eos () == MATCH_YES
)
3058 return access_attr_decl (ST_PUBLIC
);
3062 /* Workhorse for gfc_match_parameter. */
3071 m
= gfc_match_symbol (&sym
, 0);
3073 gfc_error ("Expected variable name at %C in PARAMETER statement");
3078 if (gfc_match_char ('=') == MATCH_NO
)
3080 gfc_error ("Expected = sign in PARAMETER statement at %C");
3084 m
= gfc_match_init_expr (&init
);
3086 gfc_error ("Expected expression at %C in PARAMETER statement");
3090 if (sym
->ts
.type
== BT_UNKNOWN
3091 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3097 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3098 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3108 gfc_free_expr (init
);
3113 /* Match a parameter statement, with the weird syntax that these have. */
3116 gfc_match_parameter (void)
3120 if (gfc_match_char ('(') == MATCH_NO
)
3129 if (gfc_match (" )%t") == MATCH_YES
)
3132 if (gfc_match_char (',') != MATCH_YES
)
3134 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3144 /* Save statements have a special syntax. */
3147 gfc_match_save (void)
3149 char n
[GFC_MAX_SYMBOL_LEN
+1];
3154 if (gfc_match_eos () == MATCH_YES
)
3156 if (gfc_current_ns
->seen_save
)
3158 gfc_error ("Blanket SAVE statement at %C follows previous "
3164 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3168 if (gfc_current_ns
->save_all
)
3170 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3178 m
= gfc_match_symbol (&sym
, 0);
3182 if (gfc_add_save (&sym
->attr
, sym
->name
,
3183 &gfc_current_locus
) == FAILURE
)
3194 m
= gfc_match (" / %n /", &n
);
3195 if (m
== MATCH_ERROR
)
3200 c
= gfc_get_common (n
, 0);
3203 gfc_current_ns
->seen_save
= 1;
3206 if (gfc_match_eos () == MATCH_YES
)
3208 if (gfc_match_char (',') != MATCH_YES
)
3215 gfc_error ("Syntax error in SAVE statement at %C");
3220 /* Match a module procedure statement. Note that we have to modify
3221 symbols in the parent's namespace because the current one was there
3222 to receive symbols that are in a interface's formal argument list. */
3225 gfc_match_modproc (void)
3227 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3231 if (gfc_state_stack
->state
!= COMP_INTERFACE
3232 || gfc_state_stack
->previous
== NULL
3233 || current_interface
.type
== INTERFACE_NAMELESS
)
3236 ("MODULE PROCEDURE at %C must be in a generic module interface");
3242 m
= gfc_match_name (name
);
3248 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3251 if (sym
->attr
.proc
!= PROC_MODULE
3252 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3253 sym
->name
, NULL
) == FAILURE
)
3256 if (gfc_add_interface (sym
) == FAILURE
)
3259 if (gfc_match_eos () == MATCH_YES
)
3261 if (gfc_match_char (',') != MATCH_YES
)
3268 gfc_syntax_error (ST_MODULE_PROC
);
3273 /* Match the beginning of a derived type declaration. If a type name
3274 was the result of a function, then it is possible to have a symbol
3275 already to be known as a derived type yet have no components. */
3278 gfc_match_derived_decl (void)
3280 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3281 symbol_attribute attr
;
3285 if (gfc_current_state () == COMP_DERIVED
)
3288 gfc_clear_attr (&attr
);
3291 if (gfc_match (" , private") == MATCH_YES
)
3293 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3296 ("Derived type at %C can only be PRIVATE within a MODULE");
3300 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3305 if (gfc_match (" , public") == MATCH_YES
)
3307 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3309 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3313 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3318 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3320 gfc_error ("Expected :: in TYPE definition at %C");
3324 m
= gfc_match (" %n%t", name
);
3328 /* Make sure the name isn't the name of an intrinsic type. The
3329 'double precision' type doesn't get past the name matcher. */
3330 if (strcmp (name
, "integer") == 0
3331 || strcmp (name
, "real") == 0
3332 || strcmp (name
, "character") == 0
3333 || strcmp (name
, "logical") == 0
3334 || strcmp (name
, "complex") == 0)
3337 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3342 if (gfc_get_symbol (name
, NULL
, &sym
))
3345 if (sym
->ts
.type
!= BT_UNKNOWN
)
3347 gfc_error ("Derived type name '%s' at %C already has a basic type "
3348 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3352 /* The symbol may already have the derived attribute without the
3353 components. The ways this can happen is via a function
3354 definition, an INTRINSIC statement or a subtype in another
3355 derived type that is a pointer. The first part of the AND clause
3356 is true if a the symbol is not the return value of a function. */
3357 if (sym
->attr
.flavor
!= FL_DERIVED
3358 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3361 if (sym
->components
!= NULL
)
3364 ("Derived type definition of '%s' at %C has already been defined",
3369 if (attr
.access
!= ACCESS_UNKNOWN
3370 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3373 gfc_new_block
= sym
;