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 intialization 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
)
650 /* Function called by variable_decl() that adds an initialization
651 expression to a symbol. */
654 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
657 symbol_attribute attr
;
662 if (find_special (name
, &sym
))
667 /* If this symbol is confirming an implicit parameter type,
668 then an initialization expression is not allowed. */
669 if (attr
.flavor
== FL_PARAMETER
670 && sym
->value
!= NULL
673 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
682 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
689 /* An initializer is required for PARAMETER declarations. */
690 if (attr
.flavor
== FL_PARAMETER
)
692 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
698 /* If a variable appears in a DATA block, it cannot have an
703 ("Variable '%s' at %C with an initializer already appears "
704 "in a DATA statement", sym
->name
);
708 /* Check if the assignment can happen. This has to be put off
709 until later for a derived type variable. */
710 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
711 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
714 /* Add initializer. Make sure we keep the ranks sane. */
715 if (sym
->attr
.dimension
&& init
->rank
== 0)
716 init
->rank
= sym
->as
->rank
;
726 /* Function called by variable_decl() that adds a name to a structure
730 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
731 gfc_array_spec
** as
)
735 /* If the current symbol is of the same derived type that we're
736 constructing, it must have the pointer attribute. */
737 if (current_ts
.type
== BT_DERIVED
738 && current_ts
.derived
== gfc_current_block ()
739 && current_attr
.pointer
== 0)
741 gfc_error ("Component at %C must have the POINTER attribute");
745 if (gfc_current_block ()->attr
.pointer
748 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
750 gfc_error ("Array component of structure at %C must have explicit "
751 "or deferred shape");
756 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
761 gfc_set_component_attr (c
, ¤t_attr
);
763 c
->initializer
= *init
;
771 /* Check array components. */
777 if (c
->as
->type
!= AS_DEFERRED
)
779 gfc_error ("Pointer array component of structure at %C "
780 "must have a deferred shape");
786 if (c
->as
->type
!= AS_EXPLICIT
)
789 ("Array component of structure at %C must have an explicit "
799 /* Match a 'NULL()', and possibly take care of some side effects. */
802 gfc_match_null (gfc_expr
** result
)
808 m
= gfc_match (" null ( )");
812 /* The NULL symbol now has to be/become an intrinsic function. */
813 if (gfc_get_symbol ("null", NULL
, &sym
))
815 gfc_error ("NULL() initialization at %C is ambiguous");
819 gfc_intrinsic_symbol (sym
);
821 if (sym
->attr
.proc
!= PROC_INTRINSIC
822 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
823 sym
->name
, NULL
) == FAILURE
824 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
828 e
->where
= gfc_current_locus
;
829 e
->expr_type
= EXPR_NULL
;
830 e
->ts
.type
= BT_UNKNOWN
;
838 /* Match a variable name with an optional initializer. When this
839 subroutine is called, a variable is expected to be parsed next.
840 Depending on what is happening at the moment, updates either the
841 symbol table or the current interface. */
846 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
847 gfc_expr
*initializer
, *char_len
;
857 /* When we get here, we've just matched a list of attributes and
858 maybe a type and a double colon. The next thing we expect to see
859 is the name of the symbol. */
860 m
= gfc_match_name (name
);
864 var_locus
= gfc_current_locus
;
866 /* Now we could see the optional array spec. or character length. */
867 m
= gfc_match_array_spec (&as
);
868 if (m
== MATCH_ERROR
)
871 as
= gfc_copy_array_spec (current_as
);
876 if (current_ts
.type
== BT_CHARACTER
)
878 switch (match_char_length (&char_len
))
881 cl
= gfc_get_charlen ();
882 cl
->next
= gfc_current_ns
->cl_list
;
883 gfc_current_ns
->cl_list
= cl
;
885 cl
->length
= char_len
;
897 /* OK, we've successfully matched the declaration. Now put the
898 symbol in the current namespace, because it might be used in the
899 optional intialization expression for this symbol, e.g. this is
902 integer, parameter :: i = huge(i)
904 This is only true for parameters or variables of a basic type.
905 For components of derived types, it is not true, so we don't
906 create a symbol for those yet. If we fail to create the symbol,
908 if (gfc_current_state () != COMP_DERIVED
909 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
915 /* In functions that have a RESULT variable defined, the function
916 name always refers to function calls. Therefore, the name is
917 not allowed to appear in specification statements. */
918 if (gfc_current_state () == COMP_FUNCTION
919 && gfc_current_block () != NULL
920 && gfc_current_block ()->result
!= NULL
921 && gfc_current_block ()->result
!= gfc_current_block ()
922 && strcmp (gfc_current_block ()->name
, name
) == 0)
924 gfc_error ("Function name '%s' not allowed at %C", name
);
929 /* We allow old-style initializations of the form
930 integer i /2/, j(4) /3*3, 1/
931 (if no colon has been seen). These are different from data
932 statements in that initializers are only allowed to apply to the
933 variable immediately preceding, i.e.
935 is not allowed. Therefore we have to do some work manually, that
936 could otherwise be left to the matchers for DATA statements. */
938 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
940 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
941 "initialization at %C") == FAILURE
)
944 return match_old_style_init (name
);
947 /* The double colon must be present in order to have initializers.
948 Otherwise the statement is ambiguous with an assignment statement. */
951 if (gfc_match (" =>") == MATCH_YES
)
954 if (!current_attr
.pointer
)
956 gfc_error ("Initialization at %C isn't for a pointer variable");
961 m
= gfc_match_null (&initializer
);
964 gfc_error ("Pointer initialization requires a NULL at %C");
971 ("Initialization of pointer at %C is not allowed in a "
979 initializer
->ts
= current_ts
;
982 else if (gfc_match_char ('=') == MATCH_YES
)
984 if (current_attr
.pointer
)
987 ("Pointer initialization at %C requires '=>', not '='");
992 m
= gfc_match_init_expr (&initializer
);
995 gfc_error ("Expected an initialization expression at %C");
999 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1002 ("Initialization of variable at %C is not allowed in a "
1012 /* Add the initializer. Note that it is fine if initializer is
1013 NULL here, because we sometimes also need to check if a
1014 declaration *must* have an initialization expression. */
1015 if (gfc_current_state () != COMP_DERIVED
)
1016 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1019 if (current_ts
.type
== BT_DERIVED
&& !initializer
)
1020 initializer
= gfc_default_initializer (¤t_ts
);
1021 t
= build_struct (name
, cl
, &initializer
, &as
);
1024 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1027 /* Free stuff up and return. */
1028 gfc_free_expr (initializer
);
1029 gfc_free_array_spec (as
);
1035 /* Match an extended-f77 kind specification. */
1038 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1042 if (gfc_match_char ('*') != MATCH_YES
)
1045 m
= gfc_match_small_literal_int (&ts
->kind
);
1049 /* Massage the kind numbers for complex types. */
1050 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1052 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1055 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1057 gfc_error ("Old-style kind %d not supported for type %s at %C",
1058 ts
->kind
, gfc_basic_typename (ts
->type
));
1067 /* Match a kind specification. Since kinds are generally optional, we
1068 usually return MATCH_NO if something goes wrong. If a "kind="
1069 string is found, then we know we have an error. */
1072 gfc_match_kind_spec (gfc_typespec
* ts
)
1082 where
= gfc_current_locus
;
1084 if (gfc_match_char ('(') == MATCH_NO
)
1087 /* Also gobbles optional text. */
1088 if (gfc_match (" kind = ") == MATCH_YES
)
1091 n
= gfc_match_init_expr (&e
);
1093 gfc_error ("Expected initialization expression at %C");
1099 gfc_error ("Expected scalar initialization expression at %C");
1104 msg
= gfc_extract_int (e
, &ts
->kind
);
1115 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1117 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1118 gfc_basic_typename (ts
->type
));
1124 if (gfc_match_char (')') != MATCH_YES
)
1126 gfc_error ("Missing right paren at %C");
1134 gfc_current_locus
= where
;
1139 /* Match the various kind/length specifications in a CHARACTER
1140 declaration. We don't return MATCH_NO. */
1143 match_char_spec (gfc_typespec
* ts
)
1145 int i
, kind
, seen_length
;
1150 kind
= gfc_default_character_kind
;
1154 /* Try the old-style specification first. */
1155 old_char_selector
= 0;
1157 m
= match_char_length (&len
);
1161 old_char_selector
= 1;
1166 m
= gfc_match_char ('(');
1169 m
= MATCH_YES
; /* character without length is a single char */
1173 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1174 if (gfc_match (" kind =") == MATCH_YES
)
1176 m
= gfc_match_small_int (&kind
);
1177 if (m
== MATCH_ERROR
)
1182 if (gfc_match (" , len =") == MATCH_NO
)
1185 m
= char_len_param_value (&len
);
1188 if (m
== MATCH_ERROR
)
1195 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1196 if (gfc_match (" len =") == MATCH_YES
)
1198 m
= char_len_param_value (&len
);
1201 if (m
== MATCH_ERROR
)
1205 if (gfc_match_char (')') == MATCH_YES
)
1208 if (gfc_match (" , kind =") != MATCH_YES
)
1211 gfc_match_small_int (&kind
);
1213 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1215 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1222 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1223 m
= char_len_param_value (&len
);
1226 if (m
== MATCH_ERROR
)
1230 m
= gfc_match_char (')');
1234 if (gfc_match_char (',') != MATCH_YES
)
1237 gfc_match (" kind ="); /* Gobble optional text */
1239 m
= gfc_match_small_int (&kind
);
1240 if (m
== MATCH_ERROR
)
1246 /* Require a right-paren at this point. */
1247 m
= gfc_match_char (')');
1252 gfc_error ("Syntax error in CHARACTER declaration at %C");
1256 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1258 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1264 gfc_free_expr (len
);
1268 /* Do some final massaging of the length values. */
1269 cl
= gfc_get_charlen ();
1270 cl
->next
= gfc_current_ns
->cl_list
;
1271 gfc_current_ns
->cl_list
= cl
;
1273 if (seen_length
== 0)
1274 cl
->length
= gfc_int_expr (1);
1277 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1281 gfc_free_expr (len
);
1282 cl
->length
= gfc_int_expr (0);
1293 /* Matches a type specification. If successful, sets the ts structure
1294 to the matched specification. This is necessary for FUNCTION and
1295 IMPLICIT statements.
1297 If implicit_flag is nonzero, then we don't check for the optional
1298 kind specification. Not doing so is needed for matching an IMPLICIT
1299 statement correctly. */
1302 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1304 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1311 if (gfc_match (" integer") == MATCH_YES
)
1313 ts
->type
= BT_INTEGER
;
1314 ts
->kind
= gfc_default_integer_kind
;
1318 if (gfc_match (" character") == MATCH_YES
)
1320 ts
->type
= BT_CHARACTER
;
1321 if (implicit_flag
== 0)
1322 return match_char_spec (ts
);
1327 if (gfc_match (" real") == MATCH_YES
)
1330 ts
->kind
= gfc_default_real_kind
;
1334 if (gfc_match (" double precision") == MATCH_YES
)
1337 ts
->kind
= gfc_default_double_kind
;
1341 if (gfc_match (" complex") == MATCH_YES
)
1343 ts
->type
= BT_COMPLEX
;
1344 ts
->kind
= gfc_default_complex_kind
;
1348 if (gfc_match (" double complex") == MATCH_YES
)
1350 ts
->type
= BT_COMPLEX
;
1351 ts
->kind
= gfc_default_double_kind
;
1355 if (gfc_match (" logical") == MATCH_YES
)
1357 ts
->type
= BT_LOGICAL
;
1358 ts
->kind
= gfc_default_logical_kind
;
1362 m
= gfc_match (" type ( %n )", name
);
1366 /* Search for the name but allow the components to be defined later. */
1367 if (gfc_get_ha_symbol (name
, &sym
))
1369 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1373 if (sym
->attr
.flavor
!= FL_DERIVED
1374 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1377 ts
->type
= BT_DERIVED
;
1384 /* For all types except double, derived and character, look for an
1385 optional kind specifier. MATCH_NO is actually OK at this point. */
1386 if (implicit_flag
== 1)
1389 if (gfc_current_form
== FORM_FREE
)
1391 c
= gfc_peek_char();
1392 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1393 && c
!= ':' && c
!= ',')
1397 m
= gfc_match_kind_spec (ts
);
1398 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1399 m
= gfc_match_old_kind_spec (ts
);
1402 m
= MATCH_YES
; /* No kind specifier found. */
1408 /* Match an IMPLICIT NONE statement. Actually, this statement is
1409 already matched in parse.c, or we would not end up here in the
1410 first place. So the only thing we need to check, is if there is
1411 trailing garbage. If not, the match is successful. */
1414 gfc_match_implicit_none (void)
1417 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1421 /* Match the letter range(s) of an IMPLICIT statement. */
1424 match_implicit_range (void)
1426 int c
, c1
, c2
, inner
;
1429 cur_loc
= gfc_current_locus
;
1431 gfc_gobble_whitespace ();
1432 c
= gfc_next_char ();
1435 gfc_error ("Missing character range in IMPLICIT at %C");
1442 gfc_gobble_whitespace ();
1443 c1
= gfc_next_char ();
1447 gfc_gobble_whitespace ();
1448 c
= gfc_next_char ();
1453 inner
= 0; /* Fall through */
1460 gfc_gobble_whitespace ();
1461 c2
= gfc_next_char ();
1465 gfc_gobble_whitespace ();
1466 c
= gfc_next_char ();
1468 if ((c
!= ',') && (c
!= ')'))
1481 gfc_error ("Letters must be in alphabetic order in "
1482 "IMPLICIT statement at %C");
1486 /* See if we can add the newly matched range to the pending
1487 implicits from this IMPLICIT statement. We do not check for
1488 conflicts with whatever earlier IMPLICIT statements may have
1489 set. This is done when we've successfully finished matching
1491 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1498 gfc_syntax_error (ST_IMPLICIT
);
1500 gfc_current_locus
= cur_loc
;
1505 /* Match an IMPLICIT statement, storing the types for
1506 gfc_set_implicit() if the statement is accepted by the parser.
1507 There is a strange looking, but legal syntactic construction
1508 possible. It looks like:
1510 IMPLICIT INTEGER (a-b) (c-d)
1512 This is legal if "a-b" is a constant expression that happens to
1513 equal one of the legal kinds for integers. The real problem
1514 happens with an implicit specification that looks like:
1516 IMPLICIT INTEGER (a-b)
1518 In this case, a typespec matcher that is "greedy" (as most of the
1519 matchers are) gobbles the character range as a kindspec, leaving
1520 nothing left. We therefore have to go a bit more slowly in the
1521 matching process by inhibiting the kindspec checking during
1522 typespec matching and checking for a kind later. */
1525 gfc_match_implicit (void)
1532 /* We don't allow empty implicit statements. */
1533 if (gfc_match_eos () == MATCH_YES
)
1535 gfc_error ("Empty IMPLICIT statement at %C");
1541 /* First cleanup. */
1542 gfc_clear_new_implicit ();
1544 /* A basic type is mandatory here. */
1545 m
= match_type_spec (&ts
, 1);
1546 if (m
== MATCH_ERROR
)
1551 cur_loc
= gfc_current_locus
;
1552 m
= match_implicit_range ();
1556 /* We may have <TYPE> (<RANGE>). */
1557 gfc_gobble_whitespace ();
1558 c
= gfc_next_char ();
1559 if ((c
== '\n') || (c
== ','))
1561 /* Check for CHARACTER with no length parameter. */
1562 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1564 ts
.kind
= gfc_default_character_kind
;
1565 ts
.cl
= gfc_get_charlen ();
1566 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1567 gfc_current_ns
->cl_list
= ts
.cl
;
1568 ts
.cl
->length
= gfc_int_expr (1);
1571 /* Record the Successful match. */
1572 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1577 gfc_current_locus
= cur_loc
;
1580 /* Discard the (incorrectly) matched range. */
1581 gfc_clear_new_implicit ();
1583 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1584 if (ts
.type
== BT_CHARACTER
)
1585 m
= match_char_spec (&ts
);
1588 m
= gfc_match_kind_spec (&ts
);
1591 m
= gfc_match_old_kind_spec (&ts
);
1592 if (m
== MATCH_ERROR
)
1598 if (m
== MATCH_ERROR
)
1601 m
= match_implicit_range ();
1602 if (m
== MATCH_ERROR
)
1607 gfc_gobble_whitespace ();
1608 c
= gfc_next_char ();
1609 if ((c
!= '\n') && (c
!= ','))
1612 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1620 gfc_syntax_error (ST_IMPLICIT
);
1627 /* Matches an attribute specification including array specs. If
1628 successful, leaves the variables current_attr and current_as
1629 holding the specification. Also sets the colon_seen variable for
1630 later use by matchers associated with initializations.
1632 This subroutine is a little tricky in the sense that we don't know
1633 if we really have an attr-spec until we hit the double colon.
1634 Until that time, we can only return MATCH_NO. This forces us to
1635 check for duplicate specification at this level. */
1638 match_attr_spec (void)
1641 /* Modifiers that can exist in a type statement. */
1643 { GFC_DECL_BEGIN
= 0,
1644 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1645 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1646 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1647 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1648 GFC_DECL_END
/* Sentinel */
1652 /* GFC_DECL_END is the sentinel, index starts at 0. */
1653 #define NUM_DECL GFC_DECL_END
1655 static mstring decls
[] = {
1656 minit (", allocatable", DECL_ALLOCATABLE
),
1657 minit (", dimension", DECL_DIMENSION
),
1658 minit (", external", DECL_EXTERNAL
),
1659 minit (", intent ( in )", DECL_IN
),
1660 minit (", intent ( out )", DECL_OUT
),
1661 minit (", intent ( in out )", DECL_INOUT
),
1662 minit (", intrinsic", DECL_INTRINSIC
),
1663 minit (", optional", DECL_OPTIONAL
),
1664 minit (", parameter", DECL_PARAMETER
),
1665 minit (", pointer", DECL_POINTER
),
1666 minit (", private", DECL_PRIVATE
),
1667 minit (", public", DECL_PUBLIC
),
1668 minit (", save", DECL_SAVE
),
1669 minit (", target", DECL_TARGET
),
1670 minit ("::", DECL_COLON
),
1671 minit (NULL
, DECL_NONE
)
1674 locus start
, seen_at
[NUM_DECL
];
1681 gfc_clear_attr (¤t_attr
);
1682 start
= gfc_current_locus
;
1687 /* See if we get all of the keywords up to the final double colon. */
1688 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1693 d
= (decl_types
) gfc_match_strings (decls
);
1694 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1698 seen_at
[d
] = gfc_current_locus
;
1700 if (d
== DECL_DIMENSION
)
1702 m
= gfc_match_array_spec (¤t_as
);
1706 gfc_error ("Missing dimension specification at %C");
1710 if (m
== MATCH_ERROR
)
1715 /* No double colon, so assume that we've been looking at something
1716 else the whole time. */
1723 /* Since we've seen a double colon, we have to be looking at an
1724 attr-spec. This means that we can now issue errors. */
1725 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1730 case DECL_ALLOCATABLE
:
1731 attr
= "ALLOCATABLE";
1733 case DECL_DIMENSION
:
1740 attr
= "INTENT (IN)";
1743 attr
= "INTENT (OUT)";
1746 attr
= "INTENT (IN OUT)";
1748 case DECL_INTRINSIC
:
1754 case DECL_PARAMETER
:
1773 attr
= NULL
; /* This shouldn't happen */
1776 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1781 /* Now that we've dealt with duplicate attributes, add the attributes
1782 to the current attribute. */
1783 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1788 if (gfc_current_state () == COMP_DERIVED
1789 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1790 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1793 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1801 case DECL_ALLOCATABLE
:
1802 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1805 case DECL_DIMENSION
:
1806 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
1810 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1814 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1818 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1822 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1825 case DECL_INTRINSIC
:
1826 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1830 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1833 case DECL_PARAMETER
:
1834 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
1838 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1842 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
1847 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
1852 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
1856 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1860 gfc_internal_error ("match_attr_spec(): Bad attribute");
1874 gfc_current_locus
= start
;
1875 gfc_free_array_spec (current_as
);
1881 /* Match a data declaration statement. */
1884 gfc_match_data_decl (void)
1889 m
= match_type_spec (¤t_ts
, 0);
1893 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1895 sym
= gfc_use_derived (current_ts
.derived
);
1903 current_ts
.derived
= sym
;
1906 m
= match_attr_spec ();
1907 if (m
== MATCH_ERROR
)
1913 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1916 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1919 if (gfc_find_symbol (current_ts
.derived
->name
,
1920 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1923 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1924 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1927 gfc_error ("Derived type at %C has not been previously defined");
1933 /* If we have an old-style character declaration, and no new-style
1934 attribute specifications, then there a comma is optional between
1935 the type specification and the variable list. */
1936 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
1937 gfc_match_char (',');
1939 /* Give the types/attributes to symbols that follow. */
1942 m
= variable_decl ();
1943 if (m
== MATCH_ERROR
)
1948 if (gfc_match_eos () == MATCH_YES
)
1950 if (gfc_match_char (',') != MATCH_YES
)
1954 gfc_error ("Syntax error in data declaration at %C");
1958 gfc_free_array_spec (current_as
);
1964 /* Match a prefix associated with a function or subroutine
1965 declaration. If the typespec pointer is nonnull, then a typespec
1966 can be matched. Note that if nothing matches, MATCH_YES is
1967 returned (the null string was matched). */
1970 match_prefix (gfc_typespec
* ts
)
1974 gfc_clear_attr (¤t_attr
);
1978 if (!seen_type
&& ts
!= NULL
1979 && match_type_spec (ts
, 0) == MATCH_YES
1980 && gfc_match_space () == MATCH_YES
)
1987 if (gfc_match ("elemental% ") == MATCH_YES
)
1989 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
1995 if (gfc_match ("pure% ") == MATCH_YES
)
1997 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2003 if (gfc_match ("recursive% ") == MATCH_YES
)
2005 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2011 /* At this point, the next item is not a prefix. */
2016 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2019 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2022 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2025 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2028 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2035 /* Match a formal argument list. */
2038 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2040 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2041 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2047 if (gfc_match_char ('(') != MATCH_YES
)
2054 if (gfc_match_char (')') == MATCH_YES
)
2059 if (gfc_match_char ('*') == MATCH_YES
)
2063 m
= gfc_match_name (name
);
2067 if (gfc_get_symbol (name
, NULL
, &sym
))
2071 p
= gfc_get_formal_arglist ();
2083 /* We don't add the VARIABLE flavor because the name could be a
2084 dummy procedure. We don't apply these attributes to formal
2085 arguments of statement functions. */
2086 if (sym
!= NULL
&& !st_flag
2087 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2088 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2094 /* The name of a program unit can be in a different namespace,
2095 so check for it explicitly. After the statement is accepted,
2096 the name is checked for especially in gfc_get_symbol(). */
2097 if (gfc_new_block
!= NULL
&& sym
!= NULL
2098 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2100 gfc_error ("Name '%s' at %C is the name of the procedure",
2106 if (gfc_match_char (')') == MATCH_YES
)
2109 m
= gfc_match_char (',');
2112 gfc_error ("Unexpected junk in formal argument list at %C");
2118 /* Check for duplicate symbols in the formal argument list. */
2121 for (p
= head
; p
->next
; p
= p
->next
)
2126 for (q
= p
->next
; q
; q
= q
->next
)
2127 if (p
->sym
== q
->sym
)
2130 ("Duplicate symbol '%s' in formal argument list at %C",
2139 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2149 gfc_free_formal_arglist (head
);
2154 /* Match a RESULT specification following a function declaration or
2155 ENTRY statement. Also matches the end-of-statement. */
2158 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2160 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2164 if (gfc_match (" result (") != MATCH_YES
)
2167 m
= gfc_match_name (name
);
2171 if (gfc_match (" )%t") != MATCH_YES
)
2173 gfc_error ("Unexpected junk following RESULT variable at %C");
2177 if (strcmp (function
->name
, name
) == 0)
2180 ("RESULT variable at %C must be different than function name");
2184 if (gfc_get_symbol (name
, NULL
, &r
))
2187 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2188 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2197 /* Match a function declaration. */
2200 gfc_match_function_decl (void)
2202 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2203 gfc_symbol
*sym
, *result
;
2207 if (gfc_current_state () != COMP_NONE
2208 && gfc_current_state () != COMP_INTERFACE
2209 && gfc_current_state () != COMP_CONTAINS
)
2212 gfc_clear_ts (¤t_ts
);
2214 old_loc
= gfc_current_locus
;
2216 m
= match_prefix (¤t_ts
);
2219 gfc_current_locus
= old_loc
;
2223 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2225 gfc_current_locus
= old_loc
;
2229 if (get_proc_name (name
, &sym
))
2231 gfc_new_block
= sym
;
2233 m
= gfc_match_formal_arglist (sym
, 0, 0);
2235 gfc_error ("Expected formal argument list in function definition at %C");
2236 else if (m
== MATCH_ERROR
)
2241 if (gfc_match_eos () != MATCH_YES
)
2243 /* See if a result variable is present. */
2244 m
= match_result (sym
, &result
);
2246 gfc_error ("Unexpected junk after function declaration at %C");
2255 /* Make changes to the symbol. */
2258 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2261 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2262 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2265 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2267 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2268 gfc_basic_typename (sym
->ts
.type
));
2274 sym
->ts
= current_ts
;
2279 result
->ts
= current_ts
;
2280 sym
->result
= result
;
2286 gfc_current_locus
= old_loc
;
2291 /* Match an ENTRY statement. */
2294 gfc_match_entry (void)
2299 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2300 gfc_compile_state state
;
2304 m
= gfc_match_name (name
);
2308 state
= gfc_current_state ();
2309 if (state
!= COMP_SUBROUTINE
2310 && state
!= COMP_FUNCTION
)
2312 gfc_error ("ENTRY statement at %C cannot appear within %s",
2313 gfc_state_name (gfc_current_state ()));
2317 if (gfc_current_ns
->parent
!= NULL
2318 && gfc_current_ns
->parent
->proc_name
2319 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2321 gfc_error("ENTRY statement at %C cannot appear in a "
2322 "contained procedure");
2326 if (get_proc_name (name
, &entry
))
2329 proc
= gfc_current_block ();
2331 if (state
== COMP_SUBROUTINE
)
2333 /* An entry in a subroutine. */
2334 m
= gfc_match_formal_arglist (entry
, 0, 1);
2338 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2339 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2344 /* An entry in a function. */
2345 m
= gfc_match_formal_arglist (entry
, 0, 0);
2351 if (gfc_match_eos () == MATCH_YES
)
2353 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2354 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2357 entry
->result
= proc
->result
;
2362 m
= match_result (proc
, &result
);
2364 gfc_syntax_error (ST_ENTRY
);
2368 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2369 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2370 || gfc_add_function (&entry
->attr
, result
->name
,
2375 if (proc
->attr
.recursive
&& result
== NULL
)
2377 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2382 if (gfc_match_eos () != MATCH_YES
)
2384 gfc_syntax_error (ST_ENTRY
);
2388 entry
->attr
.recursive
= proc
->attr
.recursive
;
2389 entry
->attr
.elemental
= proc
->attr
.elemental
;
2390 entry
->attr
.pure
= proc
->attr
.pure
;
2392 el
= gfc_get_entry_list ();
2394 el
->next
= gfc_current_ns
->entries
;
2395 gfc_current_ns
->entries
= el
;
2397 el
->id
= el
->next
->id
+ 1;
2401 new_st
.op
= EXEC_ENTRY
;
2402 new_st
.ext
.entry
= el
;
2408 /* Match a subroutine statement, including optional prefixes. */
2411 gfc_match_subroutine (void)
2413 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2417 if (gfc_current_state () != COMP_NONE
2418 && gfc_current_state () != COMP_INTERFACE
2419 && gfc_current_state () != COMP_CONTAINS
)
2422 m
= match_prefix (NULL
);
2426 m
= gfc_match ("subroutine% %n", name
);
2430 if (get_proc_name (name
, &sym
))
2432 gfc_new_block
= sym
;
2434 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2437 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2440 if (gfc_match_eos () != MATCH_YES
)
2442 gfc_syntax_error (ST_SUBROUTINE
);
2446 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2453 /* Return nonzero if we're currently compiling a contained procedure. */
2456 contained_procedure (void)
2460 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2461 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2462 && s
->previous
!= NULL
2463 && s
->previous
->state
== COMP_CONTAINS
)
2469 /* Match any of the various end-block statements. Returns the type of
2470 END to the caller. The END INTERFACE, END IF, END DO and END
2471 SELECT statements cannot be replaced by a single END statement. */
2474 gfc_match_end (gfc_statement
* st
)
2476 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2477 gfc_compile_state state
;
2479 const char *block_name
;
2484 old_loc
= gfc_current_locus
;
2485 if (gfc_match ("end") != MATCH_YES
)
2488 state
= gfc_current_state ();
2490 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2492 if (state
== COMP_CONTAINS
)
2494 state
= gfc_state_stack
->previous
->state
;
2495 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2496 : gfc_state_stack
->previous
->sym
->name
;
2503 *st
= ST_END_PROGRAM
;
2504 target
= " program";
2508 case COMP_SUBROUTINE
:
2509 *st
= ST_END_SUBROUTINE
;
2510 target
= " subroutine";
2511 eos_ok
= !contained_procedure ();
2515 *st
= ST_END_FUNCTION
;
2516 target
= " function";
2517 eos_ok
= !contained_procedure ();
2520 case COMP_BLOCK_DATA
:
2521 *st
= ST_END_BLOCK_DATA
;
2522 target
= " block data";
2527 *st
= ST_END_MODULE
;
2532 case COMP_INTERFACE
:
2533 *st
= ST_END_INTERFACE
;
2534 target
= " interface";
2557 *st
= ST_END_SELECT
;
2563 *st
= ST_END_FORALL
;
2575 gfc_error ("Unexpected END statement at %C");
2579 if (gfc_match_eos () == MATCH_YES
)
2583 /* We would have required END [something] */
2584 gfc_error ("%s statement expected at %L",
2585 gfc_ascii_statement (*st
), &old_loc
);
2592 /* Verify that we've got the sort of end-block that we're expecting. */
2593 if (gfc_match (target
) != MATCH_YES
)
2595 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2599 /* If we're at the end, make sure a block name wasn't required. */
2600 if (gfc_match_eos () == MATCH_YES
)
2603 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2606 if (gfc_current_block () == NULL
)
2609 gfc_error ("Expected block name of '%s' in %s statement at %C",
2610 block_name
, gfc_ascii_statement (*st
));
2615 /* END INTERFACE has a special handler for its several possible endings. */
2616 if (*st
== ST_END_INTERFACE
)
2617 return gfc_match_end_interface ();
2619 /* We haven't hit the end of statement, so what is left must be an end-name. */
2620 m
= gfc_match_space ();
2622 m
= gfc_match_name (name
);
2625 gfc_error ("Expected terminating name at %C");
2629 if (block_name
== NULL
)
2632 if (strcmp (name
, block_name
) != 0)
2634 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2635 gfc_ascii_statement (*st
));
2639 if (gfc_match_eos () == MATCH_YES
)
2643 gfc_syntax_error (*st
);
2646 gfc_current_locus
= old_loc
;
2652 /***************** Attribute declaration statements ****************/
2654 /* Set the attribute of a single variable. */
2659 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2667 m
= gfc_match_name (name
);
2671 if (find_special (name
, &sym
))
2674 var_locus
= gfc_current_locus
;
2676 /* Deal with possible array specification for certain attributes. */
2677 if (current_attr
.dimension
2678 || current_attr
.allocatable
2679 || current_attr
.pointer
2680 || current_attr
.target
)
2682 m
= gfc_match_array_spec (&as
);
2683 if (m
== MATCH_ERROR
)
2686 if (current_attr
.dimension
&& m
== MATCH_NO
)
2689 ("Missing array specification at %L in DIMENSION statement",
2695 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2696 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2698 gfc_error ("Array specification must be deferred at %L",
2705 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2706 if (current_attr
.dimension
== 0
2707 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2713 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2719 if ((current_attr
.external
|| current_attr
.intrinsic
)
2720 && sym
->attr
.flavor
!= FL_PROCEDURE
2721 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
2730 gfc_free_array_spec (as
);
2735 /* Generic attribute declaration subroutine. Used for attributes that
2736 just have a list of names. */
2743 /* Gobble the optional double colon, by simply ignoring the result
2753 if (gfc_match_eos () == MATCH_YES
)
2759 if (gfc_match_char (',') != MATCH_YES
)
2761 gfc_error ("Unexpected character in variable list at %C");
2772 gfc_match_external (void)
2775 gfc_clear_attr (¤t_attr
);
2776 gfc_add_external (¤t_attr
, NULL
);
2778 return attr_decl ();
2784 gfc_match_intent (void)
2788 intent
= match_intent_spec ();
2789 if (intent
== INTENT_UNKNOWN
)
2792 gfc_clear_attr (¤t_attr
);
2793 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2795 return attr_decl ();
2800 gfc_match_intrinsic (void)
2803 gfc_clear_attr (¤t_attr
);
2804 gfc_add_intrinsic (¤t_attr
, NULL
);
2806 return attr_decl ();
2811 gfc_match_optional (void)
2814 gfc_clear_attr (¤t_attr
);
2815 gfc_add_optional (¤t_attr
, NULL
);
2817 return attr_decl ();
2822 gfc_match_pointer (void)
2825 gfc_clear_attr (¤t_attr
);
2826 gfc_add_pointer (¤t_attr
, NULL
);
2828 return attr_decl ();
2833 gfc_match_allocatable (void)
2836 gfc_clear_attr (¤t_attr
);
2837 gfc_add_allocatable (¤t_attr
, NULL
);
2839 return attr_decl ();
2844 gfc_match_dimension (void)
2847 gfc_clear_attr (¤t_attr
);
2848 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
2850 return attr_decl ();
2855 gfc_match_target (void)
2858 gfc_clear_attr (¤t_attr
);
2859 gfc_add_target (¤t_attr
, NULL
);
2861 return attr_decl ();
2865 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2869 access_attr_decl (gfc_statement st
)
2871 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2872 interface_type type
;
2875 gfc_intrinsic_op
operator;
2878 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2883 m
= gfc_match_generic_spec (&type
, name
, &operator);
2886 if (m
== MATCH_ERROR
)
2891 case INTERFACE_NAMELESS
:
2894 case INTERFACE_GENERIC
:
2895 if (gfc_get_symbol (name
, NULL
, &sym
))
2898 if (gfc_add_access (&sym
->attr
,
2900 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2901 sym
->name
, NULL
) == FAILURE
)
2906 case INTERFACE_INTRINSIC_OP
:
2907 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2909 gfc_current_ns
->operator_access
[operator] =
2910 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2914 gfc_error ("Access specification of the %s operator at %C has "
2915 "already been specified", gfc_op2string (operator));
2921 case INTERFACE_USER_OP
:
2922 uop
= gfc_get_uop (name
);
2924 if (uop
->access
== ACCESS_UNKNOWN
)
2927 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2932 ("Access specification of the .%s. operator at %C has "
2933 "already been specified", sym
->name
);
2940 if (gfc_match_char (',') == MATCH_NO
)
2944 if (gfc_match_eos () != MATCH_YES
)
2949 gfc_syntax_error (st
);
2956 /* The PRIVATE statement is a bit weird in that it can be a attribute
2957 declaration, but also works as a standlone statement inside of a
2958 type declaration or a module. */
2961 gfc_match_private (gfc_statement
* st
)
2964 if (gfc_match ("private") != MATCH_YES
)
2967 if (gfc_current_state () == COMP_DERIVED
)
2969 if (gfc_match_eos () == MATCH_YES
)
2975 gfc_syntax_error (ST_PRIVATE
);
2979 if (gfc_match_eos () == MATCH_YES
)
2986 return access_attr_decl (ST_PRIVATE
);
2991 gfc_match_public (gfc_statement
* st
)
2994 if (gfc_match ("public") != MATCH_YES
)
2997 if (gfc_match_eos () == MATCH_YES
)
3004 return access_attr_decl (ST_PUBLIC
);
3008 /* Workhorse for gfc_match_parameter. */
3017 m
= gfc_match_symbol (&sym
, 0);
3019 gfc_error ("Expected variable name at %C in PARAMETER statement");
3024 if (gfc_match_char ('=') == MATCH_NO
)
3026 gfc_error ("Expected = sign in PARAMETER statement at %C");
3030 m
= gfc_match_init_expr (&init
);
3032 gfc_error ("Expected expression at %C in PARAMETER statement");
3036 if (sym
->ts
.type
== BT_UNKNOWN
3037 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3043 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3044 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3054 gfc_free_expr (init
);
3059 /* Match a parameter statement, with the weird syntax that these have. */
3062 gfc_match_parameter (void)
3066 if (gfc_match_char ('(') == MATCH_NO
)
3075 if (gfc_match (" )%t") == MATCH_YES
)
3078 if (gfc_match_char (',') != MATCH_YES
)
3080 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3090 /* Save statements have a special syntax. */
3093 gfc_match_save (void)
3095 char n
[GFC_MAX_SYMBOL_LEN
+1];
3100 if (gfc_match_eos () == MATCH_YES
)
3102 if (gfc_current_ns
->seen_save
)
3104 gfc_error ("Blanket SAVE statement at %C follows previous "
3110 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3114 if (gfc_current_ns
->save_all
)
3116 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3124 m
= gfc_match_symbol (&sym
, 0);
3128 if (gfc_add_save (&sym
->attr
, sym
->name
,
3129 &gfc_current_locus
) == FAILURE
)
3140 m
= gfc_match (" / %n /", &n
);
3141 if (m
== MATCH_ERROR
)
3146 c
= gfc_get_common (n
, 0);
3149 gfc_current_ns
->seen_save
= 1;
3152 if (gfc_match_eos () == MATCH_YES
)
3154 if (gfc_match_char (',') != MATCH_YES
)
3161 gfc_error ("Syntax error in SAVE statement at %C");
3166 /* Match a module procedure statement. Note that we have to modify
3167 symbols in the parent's namespace because the current one was there
3168 to receive symbols that are in a interface's formal argument list. */
3171 gfc_match_modproc (void)
3173 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3177 if (gfc_state_stack
->state
!= COMP_INTERFACE
3178 || gfc_state_stack
->previous
== NULL
3179 || current_interface
.type
== INTERFACE_NAMELESS
)
3182 ("MODULE PROCEDURE at %C must be in a generic module interface");
3188 m
= gfc_match_name (name
);
3194 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3197 if (sym
->attr
.proc
!= PROC_MODULE
3198 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3199 sym
->name
, NULL
) == FAILURE
)
3202 if (gfc_add_interface (sym
) == FAILURE
)
3205 if (gfc_match_eos () == MATCH_YES
)
3207 if (gfc_match_char (',') != MATCH_YES
)
3214 gfc_syntax_error (ST_MODULE_PROC
);
3219 /* Match the beginning of a derived type declaration. If a type name
3220 was the result of a function, then it is possible to have a symbol
3221 already to be known as a derived type yet have no components. */
3224 gfc_match_derived_decl (void)
3226 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3227 symbol_attribute attr
;
3231 if (gfc_current_state () == COMP_DERIVED
)
3234 gfc_clear_attr (&attr
);
3237 if (gfc_match (" , private") == MATCH_YES
)
3239 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3242 ("Derived type at %C can only be PRIVATE within a MODULE");
3246 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3251 if (gfc_match (" , public") == MATCH_YES
)
3253 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3255 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3259 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3264 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3266 gfc_error ("Expected :: in TYPE definition at %C");
3270 m
= gfc_match (" %n%t", name
);
3274 /* Make sure the name isn't the name of an intrinsic type. The
3275 'double precision' type doesn't get past the name matcher. */
3276 if (strcmp (name
, "integer") == 0
3277 || strcmp (name
, "real") == 0
3278 || strcmp (name
, "character") == 0
3279 || strcmp (name
, "logical") == 0
3280 || strcmp (name
, "complex") == 0)
3283 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3288 if (gfc_get_symbol (name
, NULL
, &sym
))
3291 if (sym
->ts
.type
!= BT_UNKNOWN
)
3293 gfc_error ("Derived type name '%s' at %C already has a basic type "
3294 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3298 /* The symbol may already have the derived attribute without the
3299 components. The ways this can happen is via a function
3300 definition, an INTRINSIC statement or a subtype in another
3301 derived type that is a pointer. The first part of the AND clause
3302 is true if a the symbol is not the return value of a function. */
3303 if (sym
->attr
.flavor
!= FL_DERIVED
3304 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3307 if (sym
->components
!= NULL
)
3310 ("Derived type definition of '%s' at %C has already been defined",
3315 if (attr
.access
!= ACCESS_UNKNOWN
3316 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3319 gfc_new_block
= sym
;