1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004 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 a 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
, &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
, NULL
) == FAILURE
)
608 /* Function called by variable_decl() that adds a name to the symbol
612 build_sym (const char *name
, gfc_charlen
* cl
,
613 gfc_array_spec
** as
, locus
* var_locus
)
615 symbol_attribute attr
;
618 if (find_special (name
, &sym
))
621 /* Start updating the symbol table. Add basic type attribute
623 if (current_ts
.type
!= BT_UNKNOWN
624 &&(sym
->attr
.implicit_type
== 0
625 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
626 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
629 if (sym
->ts
.type
== BT_CHARACTER
)
632 /* Add dimension attribute if present. */
633 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
637 /* Add attribute to symbol. The copy is so that we can reset the
638 dimension attribute. */
642 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
649 /* Function called by variable_decl() that adds an initialization
650 expression to a symbol. */
653 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
656 symbol_attribute attr
;
661 if (find_special (name
, &sym
))
666 /* If this symbol is confirming an implicit parameter type,
667 then an initialization expression is not allowed. */
668 if (attr
.flavor
== FL_PARAMETER
669 && sym
->value
!= NULL
672 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
681 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
688 /* An initializer is required for PARAMETER declarations. */
689 if (attr
.flavor
== FL_PARAMETER
)
691 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
697 /* If a variable appears in a DATA block, it cannot have an
702 ("Variable '%s' at %C with an initializer already appears "
703 "in a DATA statement", sym
->name
);
707 /* Checking a derived type parameter has to be put off until later. */
708 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
709 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
712 /* Add initializer. Make sure we keep the ranks sane. */
713 if (sym
->attr
.dimension
&& init
->rank
== 0)
714 init
->rank
= sym
->as
->rank
;
724 /* Function called by variable_decl() that adds a name to a structure
728 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
729 gfc_array_spec
** as
)
733 /* If the current symbol is of the same derived type that we're
734 constructing, it must have the pointer attribute. */
735 if (current_ts
.type
== BT_DERIVED
736 && current_ts
.derived
== gfc_current_block ()
737 && current_attr
.pointer
== 0)
739 gfc_error ("Component at %C must have the POINTER attribute");
743 if (gfc_current_block ()->attr
.pointer
746 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
748 gfc_error ("Array component of structure at %C must have explicit "
749 "or deferred shape");
754 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
759 gfc_set_component_attr (c
, ¤t_attr
);
761 c
->initializer
= *init
;
769 /* Check array components. */
775 if (c
->as
->type
!= AS_DEFERRED
)
777 gfc_error ("Pointer array component of structure at %C "
778 "must have a deferred shape");
784 if (c
->as
->type
!= AS_EXPLICIT
)
787 ("Array component of structure at %C must have an explicit "
797 /* Match a 'NULL()', and possibly take care of some side effects. */
800 gfc_match_null (gfc_expr
** result
)
806 m
= gfc_match (" null ( )");
810 /* The NULL symbol now has to be/become an intrinsic function. */
811 if (gfc_get_symbol ("null", NULL
, &sym
))
813 gfc_error ("NULL() initialization at %C is ambiguous");
817 gfc_intrinsic_symbol (sym
);
819 if (sym
->attr
.proc
!= PROC_INTRINSIC
820 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
, NULL
) == FAILURE
821 || gfc_add_function (&sym
->attr
, NULL
) == FAILURE
))
825 e
->where
= gfc_current_locus
;
826 e
->expr_type
= EXPR_NULL
;
827 e
->ts
.type
= BT_UNKNOWN
;
835 /* Match a variable name with an optional initializer. When this
836 subroutine is called, a variable is expected to be parsed next.
837 Depending on what is happening at the moment, updates either the
838 symbol table or the current interface. */
843 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
844 gfc_expr
*initializer
, *char_len
;
854 /* When we get here, we've just matched a list of attributes and
855 maybe a type and a double colon. The next thing we expect to see
856 is the name of the symbol. */
857 m
= gfc_match_name (name
);
861 var_locus
= gfc_current_locus
;
863 /* Now we could see the optional array spec. or character length. */
864 m
= gfc_match_array_spec (&as
);
865 if (m
== MATCH_ERROR
)
868 as
= gfc_copy_array_spec (current_as
);
873 if (current_ts
.type
== BT_CHARACTER
)
875 switch (match_char_length (&char_len
))
878 cl
= gfc_get_charlen ();
879 cl
->next
= gfc_current_ns
->cl_list
;
880 gfc_current_ns
->cl_list
= cl
;
882 cl
->length
= char_len
;
894 /* OK, we've successfully matched the declaration. Now put the
895 symbol in the current namespace, because it might be used in the
896 optional intialization expression for this symbol, e.g. this is
899 integer, parameter :: i = huge(i)
901 This is only true for parameters or variables of a basic type.
902 For components of derived types, it is not true, so we don't
903 create a symbol for those yet. If we fail to create the symbol,
905 if (gfc_current_state () != COMP_DERIVED
906 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
912 /* In functions that have a RESULT variable defined, the function
913 name always refers to function calls. Therefore, the name is
914 not allowed to appear in specification statements. */
915 if (gfc_current_state () == COMP_FUNCTION
916 && gfc_current_block () != NULL
917 && gfc_current_block ()->result
!= NULL
918 && gfc_current_block ()->result
!= gfc_current_block ()
919 && strcmp (gfc_current_block ()->name
, name
) == 0)
921 gfc_error ("Function name '%s' not allowed at %C", name
);
926 /* We allow old-style initializations of the form
927 integer i /2/, j(4) /3*3, 1/
928 (if no colon has been seen). These are different from data
929 statements in that initializers are only allowed to apply to the
930 variable immediately preceding, i.e.
932 is not allowed. Therefore we have to do some work manually, that
933 could otherwise be let to the matchers for DATA statements. */
935 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
937 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
938 "initialization at %C") == FAILURE
)
941 return match_old_style_init (name
);
944 /* The double colon must be present in order to have initializers.
945 Otherwise the statement is ambiguous with an assignment statement. */
948 if (gfc_match (" =>") == MATCH_YES
)
951 if (!current_attr
.pointer
)
953 gfc_error ("Initialization at %C isn't for a pointer variable");
958 m
= gfc_match_null (&initializer
);
961 gfc_error ("Pointer initialization requires a NULL at %C");
968 ("Initialization of pointer at %C is not allowed in a "
976 initializer
->ts
= current_ts
;
979 else if (gfc_match_char ('=') == MATCH_YES
)
981 if (current_attr
.pointer
)
984 ("Pointer initialization at %C requires '=>', not '='");
989 m
= gfc_match_init_expr (&initializer
);
992 gfc_error ("Expected an initialization expression at %C");
996 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
999 ("Initialization of variable at %C is not allowed in a "
1009 /* Add the initializer. Note that it is fine if initializer is
1010 NULL here, because we sometimes also need to check if a
1011 declaration *must* have an initialization expression. */
1012 if (gfc_current_state () != COMP_DERIVED
)
1013 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1016 if (current_ts
.type
== BT_DERIVED
&& !initializer
)
1017 initializer
= gfc_default_initializer (¤t_ts
);
1018 t
= build_struct (name
, cl
, &initializer
, &as
);
1021 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1024 /* Free stuff up and return. */
1025 gfc_free_expr (initializer
);
1026 gfc_free_array_spec (as
);
1032 /* Match an extended-f77 kind specification. */
1035 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1039 if (gfc_match_char ('*') != MATCH_YES
)
1042 m
= gfc_match_small_literal_int (&ts
->kind
);
1046 /* Massage the kind numbers for complex types. */
1047 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1049 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1052 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1054 gfc_error ("Old-style kind %d not supported for type %s at %C",
1055 ts
->kind
, gfc_basic_typename (ts
->type
));
1064 /* Match a kind specification. Since kinds are generally optional, we
1065 usually return MATCH_NO if something goes wrong. If a "kind="
1066 string is found, then we know we have an error. */
1069 gfc_match_kind_spec (gfc_typespec
* ts
)
1079 where
= gfc_current_locus
;
1081 if (gfc_match_char ('(') == MATCH_NO
)
1084 /* Also gobbles optional text. */
1085 if (gfc_match (" kind = ") == MATCH_YES
)
1088 n
= gfc_match_init_expr (&e
);
1090 gfc_error ("Expected initialization expression at %C");
1096 gfc_error ("Expected scalar initialization expression at %C");
1101 msg
= gfc_extract_int (e
, &ts
->kind
);
1112 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1114 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1115 gfc_basic_typename (ts
->type
));
1121 if (gfc_match_char (')') != MATCH_YES
)
1123 gfc_error ("Missing right paren at %C");
1131 gfc_current_locus
= where
;
1136 /* Match the various kind/length specifications in a CHARACTER
1137 declaration. We don't return MATCH_NO. */
1140 match_char_spec (gfc_typespec
* ts
)
1142 int i
, kind
, seen_length
;
1147 kind
= gfc_default_character_kind
;
1151 /* Try the old-style specification first. */
1152 old_char_selector
= 0;
1154 m
= match_char_length (&len
);
1158 old_char_selector
= 1;
1163 m
= gfc_match_char ('(');
1166 m
= MATCH_YES
; /* character without length is a single char */
1170 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1171 if (gfc_match (" kind =") == MATCH_YES
)
1173 m
= gfc_match_small_int (&kind
);
1174 if (m
== MATCH_ERROR
)
1179 if (gfc_match (" , len =") == MATCH_NO
)
1182 m
= char_len_param_value (&len
);
1185 if (m
== MATCH_ERROR
)
1192 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1193 if (gfc_match (" len =") == MATCH_YES
)
1195 m
= char_len_param_value (&len
);
1198 if (m
== MATCH_ERROR
)
1202 if (gfc_match_char (')') == MATCH_YES
)
1205 if (gfc_match (" , kind =") != MATCH_YES
)
1208 gfc_match_small_int (&kind
);
1210 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1212 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1219 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1220 m
= char_len_param_value (&len
);
1223 if (m
== MATCH_ERROR
)
1227 m
= gfc_match_char (')');
1231 if (gfc_match_char (',') != MATCH_YES
)
1234 gfc_match (" kind ="); /* Gobble optional text */
1236 m
= gfc_match_small_int (&kind
);
1237 if (m
== MATCH_ERROR
)
1243 /* Require a right-paren at this point. */
1244 m
= gfc_match_char (')');
1249 gfc_error ("Syntax error in CHARACTER declaration at %C");
1253 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1255 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1261 gfc_free_expr (len
);
1265 /* Do some final massaging of the length values. */
1266 cl
= gfc_get_charlen ();
1267 cl
->next
= gfc_current_ns
->cl_list
;
1268 gfc_current_ns
->cl_list
= cl
;
1270 if (seen_length
== 0)
1271 cl
->length
= gfc_int_expr (1);
1274 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1278 gfc_free_expr (len
);
1279 cl
->length
= gfc_int_expr (0);
1290 /* Matches a type specification. If successful, sets the ts structure
1291 to the matched specification. This is necessary for FUNCTION and
1292 IMPLICIT statements.
1294 If implicit_flag is nonzero, then we don't check for the optional
1295 kind specification. Not doing so is needed for matching an IMPLICIT
1296 statement correctly. */
1299 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1301 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1308 if (gfc_match (" integer") == MATCH_YES
)
1310 ts
->type
= BT_INTEGER
;
1311 ts
->kind
= gfc_default_integer_kind
;
1315 if (gfc_match (" character") == MATCH_YES
)
1317 ts
->type
= BT_CHARACTER
;
1318 if (implicit_flag
== 0)
1319 return match_char_spec (ts
);
1324 if (gfc_match (" real") == MATCH_YES
)
1327 ts
->kind
= gfc_default_real_kind
;
1331 if (gfc_match (" double precision") == MATCH_YES
)
1334 ts
->kind
= gfc_default_double_kind
;
1338 if (gfc_match (" complex") == MATCH_YES
)
1340 ts
->type
= BT_COMPLEX
;
1341 ts
->kind
= gfc_default_complex_kind
;
1345 if (gfc_match (" double complex") == MATCH_YES
)
1347 ts
->type
= BT_COMPLEX
;
1348 ts
->kind
= gfc_default_double_kind
;
1352 if (gfc_match (" logical") == MATCH_YES
)
1354 ts
->type
= BT_LOGICAL
;
1355 ts
->kind
= gfc_default_logical_kind
;
1359 m
= gfc_match (" type ( %n )", name
);
1363 /* Search for the name but allow the components to be defined later. */
1364 if (gfc_get_ha_symbol (name
, &sym
))
1366 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1370 if (sym
->attr
.flavor
!= FL_DERIVED
1371 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
1374 ts
->type
= BT_DERIVED
;
1381 /* For all types except double, derived and character, look for an
1382 optional kind specifier. MATCH_NO is actually OK at this point. */
1383 if (implicit_flag
== 1)
1386 if (gfc_current_form
== FORM_FREE
)
1388 c
= gfc_peek_char();
1389 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1390 && c
!= ':' && c
!= ',')
1394 m
= gfc_match_kind_spec (ts
);
1395 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1396 m
= gfc_match_old_kind_spec (ts
);
1399 m
= MATCH_YES
; /* No kind specifier found. */
1405 /* Match an IMPLICIT NONE statement. Actually, this statement is
1406 already matched in parse.c, or we would not end up here in the
1407 first place. So the only thing we need to check, is if there is
1408 trailing garbage. If not, the match is successful. */
1411 gfc_match_implicit_none (void)
1414 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1418 /* Match the letter range(s) of an IMPLICIT statement. */
1421 match_implicit_range (void)
1423 int c
, c1
, c2
, inner
;
1426 cur_loc
= gfc_current_locus
;
1428 gfc_gobble_whitespace ();
1429 c
= gfc_next_char ();
1432 gfc_error ("Missing character range in IMPLICIT at %C");
1439 gfc_gobble_whitespace ();
1440 c1
= gfc_next_char ();
1444 gfc_gobble_whitespace ();
1445 c
= gfc_next_char ();
1450 inner
= 0; /* Fall through */
1457 gfc_gobble_whitespace ();
1458 c2
= gfc_next_char ();
1462 gfc_gobble_whitespace ();
1463 c
= gfc_next_char ();
1465 if ((c
!= ',') && (c
!= ')'))
1478 gfc_error ("Letters must be in alphabetic order in "
1479 "IMPLICIT statement at %C");
1483 /* See if we can add the newly matched range to the pending
1484 implicits from this IMPLICIT statement. We do not check for
1485 conflicts with whatever earlier IMPLICIT statements may have
1486 set. This is done when we've successfully finished matching
1488 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1495 gfc_syntax_error (ST_IMPLICIT
);
1497 gfc_current_locus
= cur_loc
;
1502 /* Match an IMPLICIT statement, storing the types for
1503 gfc_set_implicit() if the statement is accepted by the parser.
1504 There is a strange looking, but legal syntactic construction
1505 possible. It looks like:
1507 IMPLICIT INTEGER (a-b) (c-d)
1509 This is legal if "a-b" is a constant expression that happens to
1510 equal one of the legal kinds for integers. The real problem
1511 happens with an implicit specification that looks like:
1513 IMPLICIT INTEGER (a-b)
1515 In this case, a typespec matcher that is "greedy" (as most of the
1516 matchers are) gobbles the character range as a kindspec, leaving
1517 nothing left. We therefore have to go a bit more slowly in the
1518 matching process by inhibiting the kindspec checking during
1519 typespec matching and checking for a kind later. */
1522 gfc_match_implicit (void)
1529 /* We don't allow empty implicit statements. */
1530 if (gfc_match_eos () == MATCH_YES
)
1532 gfc_error ("Empty IMPLICIT statement at %C");
1538 /* First cleanup. */
1539 gfc_clear_new_implicit ();
1541 /* A basic type is mandatory here. */
1542 m
= match_type_spec (&ts
, 1);
1543 if (m
== MATCH_ERROR
)
1548 cur_loc
= gfc_current_locus
;
1549 m
= match_implicit_range ();
1553 /* We may have <TYPE> (<RANGE>). */
1554 gfc_gobble_whitespace ();
1555 c
= gfc_next_char ();
1556 if ((c
== '\n') || (c
== ','))
1558 /* Check for CHARACTER with no length parameter. */
1559 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1561 ts
.kind
= gfc_default_character_kind
;
1562 ts
.cl
= gfc_get_charlen ();
1563 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1564 gfc_current_ns
->cl_list
= ts
.cl
;
1565 ts
.cl
->length
= gfc_int_expr (1);
1568 /* Record the Successful match. */
1569 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1574 gfc_current_locus
= cur_loc
;
1577 /* Discard the (incorrectly) matched range. */
1578 gfc_clear_new_implicit ();
1580 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1581 if (ts
.type
== BT_CHARACTER
)
1582 m
= match_char_spec (&ts
);
1585 m
= gfc_match_kind_spec (&ts
);
1588 m
= gfc_match_old_kind_spec (&ts
);
1589 if (m
== MATCH_ERROR
)
1595 if (m
== MATCH_ERROR
)
1598 m
= match_implicit_range ();
1599 if (m
== MATCH_ERROR
)
1604 gfc_gobble_whitespace ();
1605 c
= gfc_next_char ();
1606 if ((c
!= '\n') && (c
!= ','))
1609 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1617 gfc_syntax_error (ST_IMPLICIT
);
1624 /* Matches an attribute specification including array specs. If
1625 successful, leaves the variables current_attr and current_as
1626 holding the specification. Also sets the colon_seen variable for
1627 later use by matchers associated with initializations.
1629 This subroutine is a little tricky in the sense that we don't know
1630 if we really have an attr-spec until we hit the double colon.
1631 Until that time, we can only return MATCH_NO. This forces us to
1632 check for duplicate specification at this level. */
1635 match_attr_spec (void)
1638 /* Modifiers that can exist in a type statement. */
1640 { GFC_DECL_BEGIN
= 0,
1641 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1642 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1643 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1644 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1645 GFC_DECL_END
/* Sentinel */
1649 /* GFC_DECL_END is the sentinel, index starts at 0. */
1650 #define NUM_DECL GFC_DECL_END
1652 static mstring decls
[] = {
1653 minit (", allocatable", DECL_ALLOCATABLE
),
1654 minit (", dimension", DECL_DIMENSION
),
1655 minit (", external", DECL_EXTERNAL
),
1656 minit (", intent ( in )", DECL_IN
),
1657 minit (", intent ( out )", DECL_OUT
),
1658 minit (", intent ( in out )", DECL_INOUT
),
1659 minit (", intrinsic", DECL_INTRINSIC
),
1660 minit (", optional", DECL_OPTIONAL
),
1661 minit (", parameter", DECL_PARAMETER
),
1662 minit (", pointer", DECL_POINTER
),
1663 minit (", private", DECL_PRIVATE
),
1664 minit (", public", DECL_PUBLIC
),
1665 minit (", save", DECL_SAVE
),
1666 minit (", target", DECL_TARGET
),
1667 minit ("::", DECL_COLON
),
1668 minit (NULL
, DECL_NONE
)
1671 locus start
, seen_at
[NUM_DECL
];
1678 gfc_clear_attr (¤t_attr
);
1679 start
= gfc_current_locus
;
1684 /* See if we get all of the keywords up to the final double colon. */
1685 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1690 d
= (decl_types
) gfc_match_strings (decls
);
1691 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1695 seen_at
[d
] = gfc_current_locus
;
1697 if (d
== DECL_DIMENSION
)
1699 m
= gfc_match_array_spec (¤t_as
);
1703 gfc_error ("Missing dimension specification at %C");
1707 if (m
== MATCH_ERROR
)
1712 /* No double colon, so assume that we've been looking at something
1713 else the whole time. */
1720 /* Since we've seen a double colon, we have to be looking at an
1721 attr-spec. This means that we can now issue errors. */
1722 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1727 case DECL_ALLOCATABLE
:
1728 attr
= "ALLOCATABLE";
1730 case DECL_DIMENSION
:
1737 attr
= "INTENT (IN)";
1740 attr
= "INTENT (OUT)";
1743 attr
= "INTENT (IN OUT)";
1745 case DECL_INTRINSIC
:
1751 case DECL_PARAMETER
:
1770 attr
= NULL
; /* This shouldn't happen */
1773 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
1778 /* Now that we've dealt with duplicate attributes, add the attributes
1779 to the current attribute. */
1780 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1785 if (gfc_current_state () == COMP_DERIVED
1786 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
1787 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
1790 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
1798 case DECL_ALLOCATABLE
:
1799 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
1802 case DECL_DIMENSION
:
1803 t
= gfc_add_dimension (¤t_attr
, &seen_at
[d
]);
1807 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
1811 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
1815 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
1819 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
1822 case DECL_INTRINSIC
:
1823 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
1827 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
1830 case DECL_PARAMETER
:
1831 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, &seen_at
[d
]);
1835 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
1839 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, &seen_at
[d
]);
1843 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, &seen_at
[d
]);
1847 t
= gfc_add_save (¤t_attr
, &seen_at
[d
]);
1851 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
1855 gfc_internal_error ("match_attr_spec(): Bad attribute");
1869 gfc_current_locus
= start
;
1870 gfc_free_array_spec (current_as
);
1876 /* Match a data declaration statement. */
1879 gfc_match_data_decl (void)
1884 m
= match_type_spec (¤t_ts
, 0);
1888 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
1890 sym
= gfc_use_derived (current_ts
.derived
);
1898 current_ts
.derived
= sym
;
1901 m
= match_attr_spec ();
1902 if (m
== MATCH_ERROR
)
1908 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
1911 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
1914 if (gfc_find_symbol (current_ts
.derived
->name
,
1915 current_ts
.derived
->ns
->parent
, 1, &sym
) == 0)
1918 /* Hope that an ambiguous symbol is itself masked by a type definition. */
1919 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
)
1922 gfc_error ("Derived type at %C has not been previously defined");
1928 /* If we have an old-style character declaration, and no new-style
1929 attribute specifications, then there a comma is optional between
1930 the type specification and the variable list. */
1931 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
1932 gfc_match_char (',');
1934 /* Give the types/attributes to symbols that follow. */
1937 m
= variable_decl ();
1938 if (m
== MATCH_ERROR
)
1943 if (gfc_match_eos () == MATCH_YES
)
1945 if (gfc_match_char (',') != MATCH_YES
)
1949 gfc_error ("Syntax error in data declaration at %C");
1953 gfc_free_array_spec (current_as
);
1959 /* Match a prefix associated with a function or subroutine
1960 declaration. If the typespec pointer is nonnull, then a typespec
1961 can be matched. Note that if nothing matches, MATCH_YES is
1962 returned (the null string was matched). */
1965 match_prefix (gfc_typespec
* ts
)
1969 gfc_clear_attr (¤t_attr
);
1973 if (!seen_type
&& ts
!= NULL
1974 && match_type_spec (ts
, 0) == MATCH_YES
1975 && gfc_match_space () == MATCH_YES
)
1982 if (gfc_match ("elemental% ") == MATCH_YES
)
1984 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
1990 if (gfc_match ("pure% ") == MATCH_YES
)
1992 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
1998 if (gfc_match ("recursive% ") == MATCH_YES
)
2000 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2006 /* At this point, the next item is not a prefix. */
2011 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2014 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2017 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2020 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2023 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2030 /* Match a formal argument list. */
2033 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2035 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2036 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2042 if (gfc_match_char ('(') != MATCH_YES
)
2049 if (gfc_match_char (')') == MATCH_YES
)
2054 if (gfc_match_char ('*') == MATCH_YES
)
2058 m
= gfc_match_name (name
);
2062 if (gfc_get_symbol (name
, NULL
, &sym
))
2066 p
= gfc_get_formal_arglist ();
2078 /* We don't add the VARIABLE flavor because the name could be a
2079 dummy procedure. We don't apply these attributes to formal
2080 arguments of statement functions. */
2081 if (sym
!= NULL
&& !st_flag
2082 && (gfc_add_dummy (&sym
->attr
, NULL
) == FAILURE
2083 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2089 /* The name of a program unit can be in a different namespace,
2090 so check for it explicitly. After the statement is accepted,
2091 the name is checked for especially in gfc_get_symbol(). */
2092 if (gfc_new_block
!= NULL
&& sym
!= NULL
2093 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2095 gfc_error ("Name '%s' at %C is the name of the procedure",
2101 if (gfc_match_char (')') == MATCH_YES
)
2104 m
= gfc_match_char (',');
2107 gfc_error ("Unexpected junk in formal argument list at %C");
2113 /* Check for duplicate symbols in the formal argument list. */
2116 for (p
= head
; p
->next
; p
= p
->next
)
2121 for (q
= p
->next
; q
; q
= q
->next
)
2122 if (p
->sym
== q
->sym
)
2125 ("Duplicate symbol '%s' in formal argument list at %C",
2134 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2144 gfc_free_formal_arglist (head
);
2149 /* Match a RESULT specification following a function declaration or
2150 ENTRY statement. Also matches the end-of-statement. */
2153 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2155 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2159 if (gfc_match (" result (") != MATCH_YES
)
2162 m
= gfc_match_name (name
);
2166 if (gfc_match (" )%t") != MATCH_YES
)
2168 gfc_error ("Unexpected junk following RESULT variable at %C");
2172 if (strcmp (function
->name
, name
) == 0)
2175 ("RESULT variable at %C must be different than function name");
2179 if (gfc_get_symbol (name
, NULL
, &r
))
2182 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, NULL
) == FAILURE
2183 || gfc_add_result (&r
->attr
, NULL
) == FAILURE
)
2192 /* Match a function declaration. */
2195 gfc_match_function_decl (void)
2197 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2198 gfc_symbol
*sym
, *result
;
2202 if (gfc_current_state () != COMP_NONE
2203 && gfc_current_state () != COMP_INTERFACE
2204 && gfc_current_state () != COMP_CONTAINS
)
2207 gfc_clear_ts (¤t_ts
);
2209 old_loc
= gfc_current_locus
;
2211 m
= match_prefix (¤t_ts
);
2214 gfc_current_locus
= old_loc
;
2218 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2220 gfc_current_locus
= old_loc
;
2224 if (get_proc_name (name
, &sym
))
2226 gfc_new_block
= sym
;
2228 m
= gfc_match_formal_arglist (sym
, 0, 0);
2230 gfc_error ("Expected formal argument list in function definition at %C");
2231 else if (m
== MATCH_ERROR
)
2236 if (gfc_match_eos () != MATCH_YES
)
2238 /* See if a result variable is present. */
2239 m
= match_result (sym
, &result
);
2241 gfc_error ("Unexpected junk after function declaration at %C");
2250 /* Make changes to the symbol. */
2253 if (gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
2256 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2257 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2260 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2262 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2263 gfc_basic_typename (sym
->ts
.type
));
2269 sym
->ts
= current_ts
;
2274 result
->ts
= current_ts
;
2275 sym
->result
= result
;
2281 gfc_current_locus
= old_loc
;
2286 /* Match an ENTRY statement. */
2289 gfc_match_entry (void)
2294 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2295 gfc_compile_state state
;
2299 m
= gfc_match_name (name
);
2303 state
= gfc_current_state ();
2304 if (state
!= COMP_SUBROUTINE
2305 && state
!= COMP_FUNCTION
)
2307 gfc_error ("ENTRY statement at %C cannot appear within %s",
2308 gfc_state_name (gfc_current_state ()));
2312 if (gfc_current_ns
->parent
!= NULL
2313 && gfc_current_ns
->parent
->proc_name
2314 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2316 gfc_error("ENTRY statement at %C cannot appear in a "
2317 "contained procedure");
2321 if (get_proc_name (name
, &entry
))
2324 proc
= gfc_current_block ();
2326 if (state
== COMP_SUBROUTINE
)
2328 /* And entry in a subroutine. */
2329 m
= gfc_match_formal_arglist (entry
, 0, 1);
2333 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
2334 || gfc_add_subroutine (&entry
->attr
, NULL
) == FAILURE
)
2339 /* An entry in a function. */
2340 m
= gfc_match_formal_arglist (entry
, 0, 0);
2346 if (gfc_match_eos () == MATCH_YES
)
2348 if (gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
2349 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
2352 entry
->result
= proc
->result
;
2357 m
= match_result (proc
, &result
);
2359 gfc_syntax_error (ST_ENTRY
);
2363 if (gfc_add_result (&result
->attr
, NULL
) == FAILURE
2364 || gfc_add_entry (&entry
->attr
, NULL
) == FAILURE
2365 || gfc_add_function (&entry
->attr
, NULL
) == FAILURE
)
2369 if (proc
->attr
.recursive
&& result
== NULL
)
2371 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2376 if (gfc_match_eos () != MATCH_YES
)
2378 gfc_syntax_error (ST_ENTRY
);
2382 entry
->attr
.recursive
= proc
->attr
.recursive
;
2383 entry
->attr
.elemental
= proc
->attr
.elemental
;
2384 entry
->attr
.pure
= proc
->attr
.pure
;
2386 el
= gfc_get_entry_list ();
2388 el
->next
= gfc_current_ns
->entries
;
2389 gfc_current_ns
->entries
= el
;
2391 el
->id
= el
->next
->id
+ 1;
2395 new_st
.op
= EXEC_ENTRY
;
2396 new_st
.ext
.entry
= el
;
2402 /* Match a subroutine statement, including optional prefixes. */
2405 gfc_match_subroutine (void)
2407 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2411 if (gfc_current_state () != COMP_NONE
2412 && gfc_current_state () != COMP_INTERFACE
2413 && gfc_current_state () != COMP_CONTAINS
)
2416 m
= match_prefix (NULL
);
2420 m
= gfc_match ("subroutine% %n", name
);
2424 if (get_proc_name (name
, &sym
))
2426 gfc_new_block
= sym
;
2428 if (gfc_add_subroutine (&sym
->attr
, NULL
) == FAILURE
)
2431 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2434 if (gfc_match_eos () != MATCH_YES
)
2436 gfc_syntax_error (ST_SUBROUTINE
);
2440 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2447 /* Return nonzero if we're currently compiling a contained procedure. */
2450 contained_procedure (void)
2454 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2455 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2456 && s
->previous
!= NULL
2457 && s
->previous
->state
== COMP_CONTAINS
)
2463 /* Match any of the various end-block statements. Returns the type of
2464 END to the caller. The END INTERFACE, END IF, END DO and END
2465 SELECT statements cannot be replaced by a single END statement. */
2468 gfc_match_end (gfc_statement
* st
)
2470 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2471 gfc_compile_state state
;
2473 const char *block_name
;
2478 old_loc
= gfc_current_locus
;
2479 if (gfc_match ("end") != MATCH_YES
)
2482 state
= gfc_current_state ();
2484 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2486 if (state
== COMP_CONTAINS
)
2488 state
= gfc_state_stack
->previous
->state
;
2489 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2490 : gfc_state_stack
->previous
->sym
->name
;
2497 *st
= ST_END_PROGRAM
;
2498 target
= " program";
2502 case COMP_SUBROUTINE
:
2503 *st
= ST_END_SUBROUTINE
;
2504 target
= " subroutine";
2505 eos_ok
= !contained_procedure ();
2509 *st
= ST_END_FUNCTION
;
2510 target
= " function";
2511 eos_ok
= !contained_procedure ();
2514 case COMP_BLOCK_DATA
:
2515 *st
= ST_END_BLOCK_DATA
;
2516 target
= " block data";
2521 *st
= ST_END_MODULE
;
2526 case COMP_INTERFACE
:
2527 *st
= ST_END_INTERFACE
;
2528 target
= " interface";
2551 *st
= ST_END_SELECT
;
2557 *st
= ST_END_FORALL
;
2569 gfc_error ("Unexpected END statement at %C");
2573 if (gfc_match_eos () == MATCH_YES
)
2577 /* We would have required END [something] */
2578 gfc_error ("%s statement expected at %C",
2579 gfc_ascii_statement (*st
));
2586 /* Verify that we've got the sort of end-block that we're expecting. */
2587 if (gfc_match (target
) != MATCH_YES
)
2589 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
2593 /* If we're at the end, make sure a block name wasn't required. */
2594 if (gfc_match_eos () == MATCH_YES
)
2597 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
2600 if (gfc_current_block () == NULL
)
2603 gfc_error ("Expected block name of '%s' in %s statement at %C",
2604 block_name
, gfc_ascii_statement (*st
));
2609 /* END INTERFACE has a special handler for its several possible endings. */
2610 if (*st
== ST_END_INTERFACE
)
2611 return gfc_match_end_interface ();
2613 /* We haven't hit the end of statement, so what is left must be an end-name. */
2614 m
= gfc_match_space ();
2616 m
= gfc_match_name (name
);
2619 gfc_error ("Expected terminating name at %C");
2623 if (block_name
== NULL
)
2626 if (strcmp (name
, block_name
) != 0)
2628 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
2629 gfc_ascii_statement (*st
));
2633 if (gfc_match_eos () == MATCH_YES
)
2637 gfc_syntax_error (*st
);
2640 gfc_current_locus
= old_loc
;
2646 /***************** Attribute declaration statements ****************/
2648 /* Set the attribute of a single variable. */
2653 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2661 m
= gfc_match_name (name
);
2665 if (find_special (name
, &sym
))
2668 var_locus
= gfc_current_locus
;
2670 /* Deal with possible array specification for certain attributes. */
2671 if (current_attr
.dimension
2672 || current_attr
.allocatable
2673 || current_attr
.pointer
2674 || current_attr
.target
)
2676 m
= gfc_match_array_spec (&as
);
2677 if (m
== MATCH_ERROR
)
2680 if (current_attr
.dimension
&& m
== MATCH_NO
)
2683 ("Missing array specification at %L in DIMENSION statement",
2689 if ((current_attr
.allocatable
|| current_attr
.pointer
)
2690 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
2692 gfc_error ("Array specification must be deferred at %L",
2699 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
2700 if (current_attr
.dimension
== 0
2701 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
2707 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
2713 if ((current_attr
.external
|| current_attr
.intrinsic
)
2714 && sym
->attr
.flavor
!= FL_PROCEDURE
2715 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, NULL
) == FAILURE
)
2724 gfc_free_array_spec (as
);
2729 /* Generic attribute declaration subroutine. Used for attributes that
2730 just have a list of names. */
2737 /* Gobble the optional double colon, by simply ignoring the result
2747 if (gfc_match_eos () == MATCH_YES
)
2753 if (gfc_match_char (',') != MATCH_YES
)
2755 gfc_error ("Unexpected character in variable list at %C");
2766 gfc_match_external (void)
2769 gfc_clear_attr (¤t_attr
);
2770 gfc_add_external (¤t_attr
, NULL
);
2772 return attr_decl ();
2778 gfc_match_intent (void)
2782 intent
= match_intent_spec ();
2783 if (intent
== INTENT_UNKNOWN
)
2786 gfc_clear_attr (¤t_attr
);
2787 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
2789 return attr_decl ();
2794 gfc_match_intrinsic (void)
2797 gfc_clear_attr (¤t_attr
);
2798 gfc_add_intrinsic (¤t_attr
, NULL
);
2800 return attr_decl ();
2805 gfc_match_optional (void)
2808 gfc_clear_attr (¤t_attr
);
2809 gfc_add_optional (¤t_attr
, NULL
);
2811 return attr_decl ();
2816 gfc_match_pointer (void)
2819 gfc_clear_attr (¤t_attr
);
2820 gfc_add_pointer (¤t_attr
, NULL
);
2822 return attr_decl ();
2827 gfc_match_allocatable (void)
2830 gfc_clear_attr (¤t_attr
);
2831 gfc_add_allocatable (¤t_attr
, NULL
);
2833 return attr_decl ();
2838 gfc_match_dimension (void)
2841 gfc_clear_attr (¤t_attr
);
2842 gfc_add_dimension (¤t_attr
, NULL
);
2844 return attr_decl ();
2849 gfc_match_target (void)
2852 gfc_clear_attr (¤t_attr
);
2853 gfc_add_target (¤t_attr
, NULL
);
2855 return attr_decl ();
2859 /* Match the list of entities being specified in a PUBLIC or PRIVATE
2863 access_attr_decl (gfc_statement st
)
2865 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2866 interface_type type
;
2869 gfc_intrinsic_op
operator;
2872 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
2877 m
= gfc_match_generic_spec (&type
, name
, &operator);
2880 if (m
== MATCH_ERROR
)
2885 case INTERFACE_NAMELESS
:
2888 case INTERFACE_GENERIC
:
2889 if (gfc_get_symbol (name
, NULL
, &sym
))
2892 if (gfc_add_access (&sym
->attr
,
2894 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
2900 case INTERFACE_INTRINSIC_OP
:
2901 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
2903 gfc_current_ns
->operator_access
[operator] =
2904 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2908 gfc_error ("Access specification of the %s operator at %C has "
2909 "already been specified", gfc_op2string (operator));
2915 case INTERFACE_USER_OP
:
2916 uop
= gfc_get_uop (name
);
2918 if (uop
->access
== ACCESS_UNKNOWN
)
2921 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
2926 ("Access specification of the .%s. operator at %C has "
2927 "already been specified", sym
->name
);
2934 if (gfc_match_char (',') == MATCH_NO
)
2938 if (gfc_match_eos () != MATCH_YES
)
2943 gfc_syntax_error (st
);
2950 /* The PRIVATE statement is a bit weird in that it can be a attribute
2951 declaration, but also works as a standlone statement inside of a
2952 type declaration or a module. */
2955 gfc_match_private (gfc_statement
* st
)
2958 if (gfc_match ("private") != MATCH_YES
)
2961 if (gfc_current_state () == COMP_DERIVED
)
2963 if (gfc_match_eos () == MATCH_YES
)
2969 gfc_syntax_error (ST_PRIVATE
);
2973 if (gfc_match_eos () == MATCH_YES
)
2980 return access_attr_decl (ST_PRIVATE
);
2985 gfc_match_public (gfc_statement
* st
)
2988 if (gfc_match ("public") != MATCH_YES
)
2991 if (gfc_match_eos () == MATCH_YES
)
2998 return access_attr_decl (ST_PUBLIC
);
3002 /* Workhorse for gfc_match_parameter. */
3011 m
= gfc_match_symbol (&sym
, 0);
3013 gfc_error ("Expected variable name at %C in PARAMETER statement");
3018 if (gfc_match_char ('=') == MATCH_NO
)
3020 gfc_error ("Expected = sign in PARAMETER statement at %C");
3024 m
= gfc_match_init_expr (&init
);
3026 gfc_error ("Expected expression at %C in PARAMETER statement");
3030 if (sym
->ts
.type
== BT_UNKNOWN
3031 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3037 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3038 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, NULL
) == FAILURE
)
3048 gfc_free_expr (init
);
3053 /* Match a parameter statement, with the weird syntax that these have. */
3056 gfc_match_parameter (void)
3060 if (gfc_match_char ('(') == MATCH_NO
)
3069 if (gfc_match (" )%t") == MATCH_YES
)
3072 if (gfc_match_char (',') != MATCH_YES
)
3074 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3084 /* Save statements have a special syntax. */
3087 gfc_match_save (void)
3089 char n
[GFC_MAX_SYMBOL_LEN
+1];
3094 if (gfc_match_eos () == MATCH_YES
)
3096 if (gfc_current_ns
->seen_save
)
3098 gfc_error ("Blanket SAVE statement at %C follows previous "
3104 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3108 if (gfc_current_ns
->save_all
)
3110 gfc_error ("SAVE statement at %C follows blanket SAVE statement");
3118 m
= gfc_match_symbol (&sym
, 0);
3122 if (gfc_add_save (&sym
->attr
, &gfc_current_locus
) == FAILURE
)
3133 m
= gfc_match (" / %n /", &n
);
3134 if (m
== MATCH_ERROR
)
3139 c
= gfc_get_common (n
, 0);
3142 gfc_current_ns
->seen_save
= 1;
3145 if (gfc_match_eos () == MATCH_YES
)
3147 if (gfc_match_char (',') != MATCH_YES
)
3154 gfc_error ("Syntax error in SAVE statement at %C");
3159 /* Match a module procedure statement. Note that we have to modify
3160 symbols in the parent's namespace because the current one was there
3161 to receive symbols that are in a interface's formal argument list. */
3164 gfc_match_modproc (void)
3166 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3170 if (gfc_state_stack
->state
!= COMP_INTERFACE
3171 || gfc_state_stack
->previous
== NULL
3172 || current_interface
.type
== INTERFACE_NAMELESS
)
3175 ("MODULE PROCEDURE at %C must be in a generic module interface");
3181 m
= gfc_match_name (name
);
3187 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3190 if (sym
->attr
.proc
!= PROC_MODULE
3191 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
, NULL
) == FAILURE
)
3194 if (gfc_add_interface (sym
) == FAILURE
)
3197 if (gfc_match_eos () == MATCH_YES
)
3199 if (gfc_match_char (',') != MATCH_YES
)
3206 gfc_syntax_error (ST_MODULE_PROC
);
3211 /* Match the beginning of a derived type declaration. If a type name
3212 was the result of a function, then it is possible to have a symbol
3213 already to be known as a derived type yet have no components. */
3216 gfc_match_derived_decl (void)
3218 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3219 symbol_attribute attr
;
3223 if (gfc_current_state () == COMP_DERIVED
)
3226 gfc_clear_attr (&attr
);
3229 if (gfc_match (" , private") == MATCH_YES
)
3231 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3234 ("Derived type at %C can only be PRIVATE within a MODULE");
3238 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
) == FAILURE
)
3243 if (gfc_match (" , public") == MATCH_YES
)
3245 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3247 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3251 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
) == FAILURE
)
3256 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3258 gfc_error ("Expected :: in TYPE definition at %C");
3262 m
= gfc_match (" %n%t", name
);
3266 /* Make sure the name isn't the name of an intrinsic type. The
3267 'double precision' type doesn't get past the name matcher. */
3268 if (strcmp (name
, "integer") == 0
3269 || strcmp (name
, "real") == 0
3270 || strcmp (name
, "character") == 0
3271 || strcmp (name
, "logical") == 0
3272 || strcmp (name
, "complex") == 0)
3275 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3280 if (gfc_get_symbol (name
, NULL
, &sym
))
3283 if (sym
->ts
.type
!= BT_UNKNOWN
)
3285 gfc_error ("Derived type name '%s' at %C already has a basic type "
3286 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3290 /* The symbol may already have the derived attribute without the
3291 components. The ways this can happen is via a function
3292 definition, an INTRINSIC statement or a subtype in another
3293 derived type that is a pointer. The first part of the AND clause
3294 is true if a the symbol is not the return value of a function. */
3295 if (sym
->attr
.flavor
!= FL_DERIVED
3296 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, NULL
) == FAILURE
)
3299 if (sym
->components
!= NULL
)
3302 ("Derived type definition of '%s' at %C has already been defined",
3307 if (attr
.access
!= ACCESS_UNKNOWN
3308 && gfc_add_access (&sym
->attr
, attr
.access
, NULL
) == FAILURE
)
3311 gfc_new_block
= sym
;