1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* This flag is set if an old-style length selector is matched
31 during a type-declaration statement. */
33 static int old_char_selector
;
35 /* When variables acquire types and attributes from a declaration
36 statement, they get them from the following static variables. The
37 first part of a declaration sets these variables and the second
38 part copies these into symbol structures. */
40 static gfc_typespec current_ts
;
42 static symbol_attribute current_attr
;
43 static gfc_array_spec
*current_as
;
44 static int colon_seen
;
46 /* Initializer of the previous enumerator. */
48 static gfc_expr
*last_initializer
;
50 /* History of all the enumerators is maintained, so that
51 kind values of all the enumerators could be updated depending
52 upon the maximum initialized value. */
54 typedef struct enumerator_history
57 gfc_expr
*initializer
;
58 struct enumerator_history
*next
;
62 /* Header of enum history chain. */
64 static enumerator_history
*enum_history
= NULL
;
66 /* Pointer of enum history node containing largest initializer. */
68 static enumerator_history
*max_enum
= NULL
;
70 /* gfc_new_block points to the symbol of a newly matched block. */
72 gfc_symbol
*gfc_new_block
;
75 /********************* DATA statement subroutines *********************/
77 /* Free a gfc_data_variable structure and everything beneath it. */
80 free_variable (gfc_data_variable
* p
)
87 gfc_free_expr (p
->expr
);
88 gfc_free_iterator (&p
->iter
, 0);
89 free_variable (p
->list
);
96 /* Free a gfc_data_value structure and everything beneath it. */
99 free_value (gfc_data_value
* p
)
106 gfc_free_expr (p
->expr
);
112 /* Free a list of gfc_data structures. */
115 gfc_free_data (gfc_data
* p
)
123 free_variable (p
->var
);
124 free_value (p
->value
);
131 static match
var_element (gfc_data_variable
*);
133 /* Match a list of variables terminated by an iterator and a right
137 var_list (gfc_data_variable
* parent
)
139 gfc_data_variable
*tail
, var
;
142 m
= var_element (&var
);
143 if (m
== MATCH_ERROR
)
148 tail
= gfc_get_data_variable ();
155 if (gfc_match_char (',') != MATCH_YES
)
158 m
= gfc_match_iterator (&parent
->iter
, 1);
161 if (m
== MATCH_ERROR
)
164 m
= var_element (&var
);
165 if (m
== MATCH_ERROR
)
170 tail
->next
= gfc_get_data_variable ();
176 if (gfc_match_char (')') != MATCH_YES
)
181 gfc_syntax_error (ST_DATA
);
186 /* Match a single element in a data variable list, which can be a
187 variable-iterator list. */
190 var_element (gfc_data_variable
* new)
195 memset (new, 0, sizeof (gfc_data_variable
));
197 if (gfc_match_char ('(') == MATCH_YES
)
198 return var_list (new);
200 m
= gfc_match_variable (&new->expr
, 0);
204 sym
= new->expr
->symtree
->n
.sym
;
206 if(sym
->value
!= NULL
)
208 gfc_error ("Variable '%s' at %C already has an initialization",
213 #if 0 /* TODO: Find out where to move this message */
214 if (sym
->attr
.in_common
)
215 /* See if sym is in the blank common block. */
216 for (t
= &sym
->ns
->blank_common
; t
; t
= t
->common_next
)
219 gfc_error ("DATA statement at %C may not initialize variable "
220 "'%s' from blank COMMON", sym
->name
);
225 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
232 /* Match the top-level list of data variables. */
235 top_var_list (gfc_data
* d
)
237 gfc_data_variable var
, *tail
, *new;
244 m
= var_element (&var
);
247 if (m
== MATCH_ERROR
)
250 new = gfc_get_data_variable ();
260 if (gfc_match_char ('/') == MATCH_YES
)
262 if (gfc_match_char (',') != MATCH_YES
)
269 gfc_syntax_error (ST_DATA
);
275 match_data_constant (gfc_expr
** result
)
277 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
282 m
= gfc_match_literal_constant (&expr
, 1);
289 if (m
== MATCH_ERROR
)
292 m
= gfc_match_null (result
);
296 m
= gfc_match_name (name
);
300 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
304 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
306 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
310 else if (sym
->attr
.flavor
== FL_DERIVED
)
311 return gfc_match_structure_constructor (sym
, result
);
313 *result
= gfc_copy_expr (sym
->value
);
318 /* Match a list of values in a DATA statement. The leading '/' has
319 already been seen at this point. */
322 top_val_list (gfc_data
* data
)
324 gfc_data_value
*new, *tail
;
333 m
= match_data_constant (&expr
);
336 if (m
== MATCH_ERROR
)
339 new = gfc_get_data_value ();
348 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
356 msg
= gfc_extract_int (expr
, &tmp
);
357 gfc_free_expr (expr
);
365 m
= match_data_constant (&tail
->expr
);
368 if (m
== MATCH_ERROR
)
372 if (gfc_match_char ('/') == MATCH_YES
)
374 if (gfc_match_char (',') == MATCH_NO
)
381 gfc_syntax_error (ST_DATA
);
386 /* Matches an old style initialization. */
389 match_old_style_init (const char *name
)
395 /* Set up data structure to hold initializers. */
396 gfc_find_sym_tree (name
, NULL
, 0, &st
);
398 newdata
= gfc_get_data ();
399 newdata
->var
= gfc_get_data_variable ();
400 newdata
->var
->expr
= gfc_get_variable_expr (st
);
402 /* Match initial value list. This also eats the terminal
404 m
= top_val_list (newdata
);
413 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
418 /* Chain in namespace list of DATA initializers. */
419 newdata
->next
= gfc_current_ns
->data
;
420 gfc_current_ns
->data
= newdata
;
425 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
426 we are matching a DATA statement and are therefore issuing an error
427 if we encounter something unexpected, if not, we're trying to match
428 an old-style initialization expression of the form INTEGER I /2/. */
431 gfc_match_data (void)
438 new = gfc_get_data ();
439 new->where
= gfc_current_locus
;
441 m
= top_var_list (new);
445 m
= top_val_list (new);
449 new->next
= gfc_current_ns
->data
;
450 gfc_current_ns
->data
= new;
452 if (gfc_match_eos () == MATCH_YES
)
455 gfc_match_char (','); /* Optional comma */
460 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
472 /************************ Declaration statements *********************/
474 /* Match an intent specification. Since this can only happen after an
475 INTENT word, a legal intent-spec must follow. */
478 match_intent_spec (void)
481 if (gfc_match (" ( in out )") == MATCH_YES
)
483 if (gfc_match (" ( in )") == MATCH_YES
)
485 if (gfc_match (" ( out )") == MATCH_YES
)
488 gfc_error ("Bad INTENT specification at %C");
489 return INTENT_UNKNOWN
;
493 /* Matches a character length specification, which is either a
494 specification expression or a '*'. */
497 char_len_param_value (gfc_expr
** expr
)
500 if (gfc_match_char ('*') == MATCH_YES
)
506 return gfc_match_expr (expr
);
510 /* A character length is a '*' followed by a literal integer or a
511 char_len_param_value in parenthesis. */
514 match_char_length (gfc_expr
** expr
)
519 m
= gfc_match_char ('*');
523 m
= gfc_match_small_literal_int (&length
);
524 if (m
== MATCH_ERROR
)
529 *expr
= gfc_int_expr (length
);
533 if (gfc_match_char ('(') == MATCH_NO
)
536 m
= char_len_param_value (expr
);
537 if (m
== MATCH_ERROR
)
542 if (gfc_match_char (')') == MATCH_NO
)
544 gfc_free_expr (*expr
);
552 gfc_error ("Syntax error in character length specification at %C");
557 /* Special subroutine for finding a symbol. Check if the name is found
558 in the current name space. If not, and we're compiling a function or
559 subroutine and the parent compilation unit is an interface, then check
560 to see if the name we've been given is the name of the interface
561 (located in another namespace). */
564 find_special (const char *name
, gfc_symbol
** result
)
569 i
= gfc_get_symbol (name
, NULL
, result
);
573 if (gfc_current_state () != COMP_SUBROUTINE
574 && gfc_current_state () != COMP_FUNCTION
)
577 s
= gfc_state_stack
->previous
;
581 if (s
->state
!= COMP_INTERFACE
)
584 goto end
; /* Nameless interface */
586 if (strcmp (name
, s
->sym
->name
) == 0)
597 /* Special subroutine for getting a symbol node associated with a
598 procedure name, used in SUBROUTINE and FUNCTION statements. The
599 symbol is created in the parent using with symtree node in the
600 child unit pointing to the symbol. If the current namespace has no
601 parent, then the symbol is just created in the current unit. */
604 get_proc_name (const char *name
, gfc_symbol
** result
)
610 if (gfc_current_ns
->parent
== NULL
)
611 return gfc_get_symbol (name
, NULL
, result
);
613 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
617 /* ??? Deal with ENTRY problem */
619 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
625 /* See if the procedure should be a module procedure */
627 if (sym
->ns
->proc_name
!= NULL
628 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
629 && sym
->attr
.proc
!= PROC_MODULE
630 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
631 sym
->name
, NULL
) == FAILURE
)
638 /* Function called by variable_decl() that adds a name to the symbol
642 build_sym (const char *name
, gfc_charlen
* cl
,
643 gfc_array_spec
** as
, locus
* var_locus
)
645 symbol_attribute attr
;
648 /* if (find_special (name, &sym)) */
649 if (gfc_get_symbol (name
, NULL
, &sym
))
652 /* Start updating the symbol table. Add basic type attribute
654 if (current_ts
.type
!= BT_UNKNOWN
655 &&(sym
->attr
.implicit_type
== 0
656 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
657 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
660 if (sym
->ts
.type
== BT_CHARACTER
)
663 /* Add dimension attribute if present. */
664 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
668 /* Add attribute to symbol. The copy is so that we can reset the
669 dimension attribute. */
673 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
679 /* Set character constant to the given length. The constant will be padded or
683 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
688 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
689 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
691 slen
= expr
->value
.character
.length
;
694 s
= gfc_getmem (len
);
695 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
697 memset (&s
[slen
], ' ', len
- slen
);
698 gfc_free (expr
->value
.character
.string
);
699 expr
->value
.character
.string
= s
;
700 expr
->value
.character
.length
= len
;
705 /* Function to create and update the enumumerator history
706 using the information passed as arguments.
707 Pointer "max_enum" is also updated, to point to
708 enum history node containing largest initializer.
710 SYM points to the symbol node of enumerator.
711 INIT points to its enumerator value. */
714 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
716 enumerator_history
*new_enum_history
;
717 gcc_assert (sym
!= NULL
&& init
!= NULL
);
719 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
721 new_enum_history
->sym
= sym
;
722 new_enum_history
->initializer
= init
;
723 new_enum_history
->next
= NULL
;
725 if (enum_history
== NULL
)
727 enum_history
= new_enum_history
;
728 max_enum
= enum_history
;
732 new_enum_history
->next
= enum_history
;
733 enum_history
= new_enum_history
;
735 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
736 new_enum_history
->initializer
->value
.integer
) < 0)
737 max_enum
= new_enum_history
;
742 /* Function to free enum kind history. */
745 gfc_free_enum_history(void)
747 enumerator_history
*current
= enum_history
;
748 enumerator_history
*next
;
750 while (current
!= NULL
)
752 next
= current
->next
;
761 /* Function called by variable_decl() that adds an initialization
762 expression to a symbol. */
765 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
768 symbol_attribute attr
;
773 if (find_special (name
, &sym
))
778 /* If this symbol is confirming an implicit parameter type,
779 then an initialization expression is not allowed. */
780 if (attr
.flavor
== FL_PARAMETER
781 && sym
->value
!= NULL
784 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
793 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
800 /* An initializer is required for PARAMETER declarations. */
801 if (attr
.flavor
== FL_PARAMETER
)
803 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
809 /* If a variable appears in a DATA block, it cannot have an
814 ("Variable '%s' at %C with an initializer already appears "
815 "in a DATA statement", sym
->name
);
819 /* Check if the assignment can happen. This has to be put off
820 until later for a derived type variable. */
821 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
822 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
825 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
827 /* Update symbol character length according initializer. */
828 if (sym
->ts
.cl
->length
== NULL
)
830 /* If there are multiple CHARACTER variables declared on
831 the same line, we don't want them to share the same
833 sym
->ts
.cl
= gfc_get_charlen ();
834 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
835 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
837 if (init
->expr_type
== EXPR_CONSTANT
)
839 gfc_int_expr (init
->value
.character
.length
);
840 else if (init
->expr_type
== EXPR_ARRAY
)
841 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
843 /* Update initializer character length according symbol. */
844 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
846 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
849 if (init
->expr_type
== EXPR_CONSTANT
)
850 gfc_set_constant_character_len (len
, init
);
851 else if (init
->expr_type
== EXPR_ARRAY
)
853 gfc_free_expr (init
->ts
.cl
->length
);
854 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
855 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
856 gfc_set_constant_character_len (len
, p
->expr
);
861 /* Add initializer. Make sure we keep the ranks sane. */
862 if (sym
->attr
.dimension
&& init
->rank
== 0)
863 init
->rank
= sym
->as
->rank
;
869 /* Maintain enumerator history. */
870 if (gfc_current_state () == COMP_ENUM
)
871 create_enum_history (sym
, init
);
877 /* Function called by variable_decl() that adds a name to a structure
881 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
882 gfc_array_spec
** as
)
886 /* If the current symbol is of the same derived type that we're
887 constructing, it must have the pointer attribute. */
888 if (current_ts
.type
== BT_DERIVED
889 && current_ts
.derived
== gfc_current_block ()
890 && current_attr
.pointer
== 0)
892 gfc_error ("Component at %C must have the POINTER attribute");
896 if (gfc_current_block ()->attr
.pointer
899 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
901 gfc_error ("Array component of structure at %C must have explicit "
902 "or deferred shape");
907 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
912 gfc_set_component_attr (c
, ¤t_attr
);
914 c
->initializer
= *init
;
922 /* Check array components. */
928 if (c
->as
->type
!= AS_DEFERRED
)
930 gfc_error ("Pointer array component of structure at %C "
931 "must have a deferred shape");
937 if (c
->as
->type
!= AS_EXPLICIT
)
940 ("Array component of structure at %C must have an explicit "
950 /* Match a 'NULL()', and possibly take care of some side effects. */
953 gfc_match_null (gfc_expr
** result
)
959 m
= gfc_match (" null ( )");
963 /* The NULL symbol now has to be/become an intrinsic function. */
964 if (gfc_get_symbol ("null", NULL
, &sym
))
966 gfc_error ("NULL() initialization at %C is ambiguous");
970 gfc_intrinsic_symbol (sym
);
972 if (sym
->attr
.proc
!= PROC_INTRINSIC
973 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
974 sym
->name
, NULL
) == FAILURE
975 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
979 e
->where
= gfc_current_locus
;
980 e
->expr_type
= EXPR_NULL
;
981 e
->ts
.type
= BT_UNKNOWN
;
989 /* Match a variable name with an optional initializer. When this
990 subroutine is called, a variable is expected to be parsed next.
991 Depending on what is happening at the moment, updates either the
992 symbol table or the current interface. */
995 variable_decl (int elem
)
997 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
998 gfc_expr
*initializer
, *char_len
;
1000 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1011 old_locus
= gfc_current_locus
;
1013 /* When we get here, we've just matched a list of attributes and
1014 maybe a type and a double colon. The next thing we expect to see
1015 is the name of the symbol. */
1016 m
= gfc_match_name (name
);
1020 var_locus
= gfc_current_locus
;
1022 /* Now we could see the optional array spec. or character length. */
1023 m
= gfc_match_array_spec (&as
);
1024 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1025 cp_as
= gfc_copy_array_spec (as
);
1026 else if (m
== MATCH_ERROR
)
1030 as
= gfc_copy_array_spec (current_as
);
1031 else if (gfc_current_state () == COMP_ENUM
)
1033 gfc_error ("Enumerator cannot be array at %C");
1034 gfc_free_enum_history ();
1043 if (current_ts
.type
== BT_CHARACTER
)
1045 switch (match_char_length (&char_len
))
1048 cl
= gfc_get_charlen ();
1049 cl
->next
= gfc_current_ns
->cl_list
;
1050 gfc_current_ns
->cl_list
= cl
;
1052 cl
->length
= char_len
;
1055 /* Non-constant lengths need to be copied after the first
1058 if (elem
> 1 && current_ts
.cl
->length
1059 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1061 cl
= gfc_get_charlen ();
1062 cl
->next
= gfc_current_ns
->cl_list
;
1063 gfc_current_ns
->cl_list
= cl
;
1064 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1076 /* If this symbol has already shown up in a Cray Pointer declaration,
1077 then we want to set the type & bail out. */
1078 if (gfc_option
.flag_cray_pointer
)
1080 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1081 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1083 sym
->ts
.type
= current_ts
.type
;
1084 sym
->ts
.kind
= current_ts
.kind
;
1086 sym
->ts
.derived
= current_ts
.derived
;
1089 /* Check to see if we have an array specification. */
1092 if (sym
->as
!= NULL
)
1094 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1095 gfc_free_array_spec (cp_as
);
1101 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1102 gfc_internal_error ("Couldn't set pointee array spec.");
1104 /* Fix the array spec. */
1105 m
= gfc_mod_pointee_as (sym
->as
);
1106 if (m
== MATCH_ERROR
)
1114 gfc_free_array_spec (cp_as
);
1119 /* OK, we've successfully matched the declaration. Now put the
1120 symbol in the current namespace, because it might be used in the
1121 optional initialization expression for this symbol, e.g. this is
1124 integer, parameter :: i = huge(i)
1126 This is only true for parameters or variables of a basic type.
1127 For components of derived types, it is not true, so we don't
1128 create a symbol for those yet. If we fail to create the symbol,
1130 if (gfc_current_state () != COMP_DERIVED
1131 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1137 /* In functions that have a RESULT variable defined, the function
1138 name always refers to function calls. Therefore, the name is
1139 not allowed to appear in specification statements. */
1140 if (gfc_current_state () == COMP_FUNCTION
1141 && gfc_current_block () != NULL
1142 && gfc_current_block ()->result
!= NULL
1143 && gfc_current_block ()->result
!= gfc_current_block ()
1144 && strcmp (gfc_current_block ()->name
, name
) == 0)
1146 gfc_error ("Function name '%s' not allowed at %C", name
);
1151 /* We allow old-style initializations of the form
1152 integer i /2/, j(4) /3*3, 1/
1153 (if no colon has been seen). These are different from data
1154 statements in that initializers are only allowed to apply to the
1155 variable immediately preceding, i.e.
1157 is not allowed. Therefore we have to do some work manually, that
1158 could otherwise be left to the matchers for DATA statements. */
1160 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1162 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1163 "initialization at %C") == FAILURE
)
1166 return match_old_style_init (name
);
1169 /* The double colon must be present in order to have initializers.
1170 Otherwise the statement is ambiguous with an assignment statement. */
1173 if (gfc_match (" =>") == MATCH_YES
)
1176 if (!current_attr
.pointer
)
1178 gfc_error ("Initialization at %C isn't for a pointer variable");
1183 m
= gfc_match_null (&initializer
);
1186 gfc_error ("Pointer initialization requires a NULL at %C");
1190 if (gfc_pure (NULL
))
1193 ("Initialization of pointer at %C is not allowed in a "
1201 initializer
->ts
= current_ts
;
1204 else if (gfc_match_char ('=') == MATCH_YES
)
1206 if (current_attr
.pointer
)
1209 ("Pointer initialization at %C requires '=>', not '='");
1214 m
= gfc_match_init_expr (&initializer
);
1217 gfc_error ("Expected an initialization expression at %C");
1221 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1224 ("Initialization of variable at %C is not allowed in a "
1234 /* Check if we are parsing an enumeration and if the current enumerator
1235 variable has an initializer or not. If it does not have an
1236 initializer, the initialization value of the previous enumerator
1237 (stored in last_initializer) is incremented by 1 and is used to
1238 initialize the current enumerator. */
1239 if (gfc_current_state () == COMP_ENUM
)
1241 if (initializer
== NULL
)
1242 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1244 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1246 gfc_error("ENUMERATOR %L not initialized with integer expression",
1249 gfc_free_enum_history ();
1253 /* Store this current initializer, for the next enumerator
1254 variable to be parsed. */
1255 last_initializer
= initializer
;
1258 /* Add the initializer. Note that it is fine if initializer is
1259 NULL here, because we sometimes also need to check if a
1260 declaration *must* have an initialization expression. */
1261 if (gfc_current_state () != COMP_DERIVED
)
1262 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1265 if (current_ts
.type
== BT_DERIVED
&& !current_attr
.pointer
&& !initializer
)
1266 initializer
= gfc_default_initializer (¤t_ts
);
1267 t
= build_struct (name
, cl
, &initializer
, &as
);
1270 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1273 /* Free stuff up and return. */
1274 gfc_free_expr (initializer
);
1275 gfc_free_array_spec (as
);
1281 /* Match an extended-f77 kind specification. */
1284 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1288 if (gfc_match_char ('*') != MATCH_YES
)
1291 m
= gfc_match_small_literal_int (&ts
->kind
);
1295 /* Massage the kind numbers for complex types. */
1296 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 8)
1298 if (ts
->type
== BT_COMPLEX
&& ts
->kind
== 16)
1301 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1303 gfc_error ("Old-style kind %d not supported for type %s at %C",
1304 ts
->kind
, gfc_basic_typename (ts
->type
));
1313 /* Match a kind specification. Since kinds are generally optional, we
1314 usually return MATCH_NO if something goes wrong. If a "kind="
1315 string is found, then we know we have an error. */
1318 gfc_match_kind_spec (gfc_typespec
* ts
)
1328 where
= gfc_current_locus
;
1330 if (gfc_match_char ('(') == MATCH_NO
)
1333 /* Also gobbles optional text. */
1334 if (gfc_match (" kind = ") == MATCH_YES
)
1337 n
= gfc_match_init_expr (&e
);
1339 gfc_error ("Expected initialization expression at %C");
1345 gfc_error ("Expected scalar initialization expression at %C");
1350 msg
= gfc_extract_int (e
, &ts
->kind
);
1361 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1363 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1364 gfc_basic_typename (ts
->type
));
1370 if (gfc_match_char (')') != MATCH_YES
)
1372 gfc_error ("Missing right paren at %C");
1380 gfc_current_locus
= where
;
1385 /* Match the various kind/length specifications in a CHARACTER
1386 declaration. We don't return MATCH_NO. */
1389 match_char_spec (gfc_typespec
* ts
)
1391 int i
, kind
, seen_length
;
1396 kind
= gfc_default_character_kind
;
1400 /* Try the old-style specification first. */
1401 old_char_selector
= 0;
1403 m
= match_char_length (&len
);
1407 old_char_selector
= 1;
1412 m
= gfc_match_char ('(');
1415 m
= MATCH_YES
; /* character without length is a single char */
1419 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1420 if (gfc_match (" kind =") == MATCH_YES
)
1422 m
= gfc_match_small_int (&kind
);
1423 if (m
== MATCH_ERROR
)
1428 if (gfc_match (" , len =") == MATCH_NO
)
1431 m
= char_len_param_value (&len
);
1434 if (m
== MATCH_ERROR
)
1441 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1442 if (gfc_match (" len =") == MATCH_YES
)
1444 m
= char_len_param_value (&len
);
1447 if (m
== MATCH_ERROR
)
1451 if (gfc_match_char (')') == MATCH_YES
)
1454 if (gfc_match (" , kind =") != MATCH_YES
)
1457 gfc_match_small_int (&kind
);
1459 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1461 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1468 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1469 m
= char_len_param_value (&len
);
1472 if (m
== MATCH_ERROR
)
1476 m
= gfc_match_char (')');
1480 if (gfc_match_char (',') != MATCH_YES
)
1483 gfc_match (" kind ="); /* Gobble optional text */
1485 m
= gfc_match_small_int (&kind
);
1486 if (m
== MATCH_ERROR
)
1492 /* Require a right-paren at this point. */
1493 m
= gfc_match_char (')');
1498 gfc_error ("Syntax error in CHARACTER declaration at %C");
1502 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1504 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1510 gfc_free_expr (len
);
1514 /* Do some final massaging of the length values. */
1515 cl
= gfc_get_charlen ();
1516 cl
->next
= gfc_current_ns
->cl_list
;
1517 gfc_current_ns
->cl_list
= cl
;
1519 if (seen_length
== 0)
1520 cl
->length
= gfc_int_expr (1);
1523 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1527 gfc_free_expr (len
);
1528 cl
->length
= gfc_int_expr (0);
1539 /* Matches a type specification. If successful, sets the ts structure
1540 to the matched specification. This is necessary for FUNCTION and
1541 IMPLICIT statements.
1543 If implicit_flag is nonzero, then we don't check for the optional
1544 kind specification. Not doing so is needed for matching an IMPLICIT
1545 statement correctly. */
1548 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1550 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1557 if (gfc_match (" byte") == MATCH_YES
)
1559 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1563 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1565 gfc_error ("BYTE type used at %C "
1566 "is not available on the target machine");
1570 ts
->type
= BT_INTEGER
;
1575 if (gfc_match (" integer") == MATCH_YES
)
1577 ts
->type
= BT_INTEGER
;
1578 ts
->kind
= gfc_default_integer_kind
;
1582 if (gfc_match (" character") == MATCH_YES
)
1584 ts
->type
= BT_CHARACTER
;
1585 if (implicit_flag
== 0)
1586 return match_char_spec (ts
);
1591 if (gfc_match (" real") == MATCH_YES
)
1594 ts
->kind
= gfc_default_real_kind
;
1598 if (gfc_match (" double precision") == MATCH_YES
)
1601 ts
->kind
= gfc_default_double_kind
;
1605 if (gfc_match (" complex") == MATCH_YES
)
1607 ts
->type
= BT_COMPLEX
;
1608 ts
->kind
= gfc_default_complex_kind
;
1612 if (gfc_match (" double complex") == MATCH_YES
)
1614 ts
->type
= BT_COMPLEX
;
1615 ts
->kind
= gfc_default_double_kind
;
1619 if (gfc_match (" logical") == MATCH_YES
)
1621 ts
->type
= BT_LOGICAL
;
1622 ts
->kind
= gfc_default_logical_kind
;
1626 m
= gfc_match (" type ( %n )", name
);
1630 /* Search for the name but allow the components to be defined later. */
1631 if (gfc_get_ha_symbol (name
, &sym
))
1633 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1637 if (sym
->attr
.flavor
!= FL_DERIVED
1638 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1641 ts
->type
= BT_DERIVED
;
1648 /* For all types except double, derived and character, look for an
1649 optional kind specifier. MATCH_NO is actually OK at this point. */
1650 if (implicit_flag
== 1)
1653 if (gfc_current_form
== FORM_FREE
)
1655 c
= gfc_peek_char();
1656 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1657 && c
!= ':' && c
!= ',')
1661 m
= gfc_match_kind_spec (ts
);
1662 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1663 m
= gfc_match_old_kind_spec (ts
);
1666 m
= MATCH_YES
; /* No kind specifier found. */
1672 /* Match an IMPLICIT NONE statement. Actually, this statement is
1673 already matched in parse.c, or we would not end up here in the
1674 first place. So the only thing we need to check, is if there is
1675 trailing garbage. If not, the match is successful. */
1678 gfc_match_implicit_none (void)
1681 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1685 /* Match the letter range(s) of an IMPLICIT statement. */
1688 match_implicit_range (void)
1690 int c
, c1
, c2
, inner
;
1693 cur_loc
= gfc_current_locus
;
1695 gfc_gobble_whitespace ();
1696 c
= gfc_next_char ();
1699 gfc_error ("Missing character range in IMPLICIT at %C");
1706 gfc_gobble_whitespace ();
1707 c1
= gfc_next_char ();
1711 gfc_gobble_whitespace ();
1712 c
= gfc_next_char ();
1717 inner
= 0; /* Fall through */
1724 gfc_gobble_whitespace ();
1725 c2
= gfc_next_char ();
1729 gfc_gobble_whitespace ();
1730 c
= gfc_next_char ();
1732 if ((c
!= ',') && (c
!= ')'))
1745 gfc_error ("Letters must be in alphabetic order in "
1746 "IMPLICIT statement at %C");
1750 /* See if we can add the newly matched range to the pending
1751 implicits from this IMPLICIT statement. We do not check for
1752 conflicts with whatever earlier IMPLICIT statements may have
1753 set. This is done when we've successfully finished matching
1755 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1762 gfc_syntax_error (ST_IMPLICIT
);
1764 gfc_current_locus
= cur_loc
;
1769 /* Match an IMPLICIT statement, storing the types for
1770 gfc_set_implicit() if the statement is accepted by the parser.
1771 There is a strange looking, but legal syntactic construction
1772 possible. It looks like:
1774 IMPLICIT INTEGER (a-b) (c-d)
1776 This is legal if "a-b" is a constant expression that happens to
1777 equal one of the legal kinds for integers. The real problem
1778 happens with an implicit specification that looks like:
1780 IMPLICIT INTEGER (a-b)
1782 In this case, a typespec matcher that is "greedy" (as most of the
1783 matchers are) gobbles the character range as a kindspec, leaving
1784 nothing left. We therefore have to go a bit more slowly in the
1785 matching process by inhibiting the kindspec checking during
1786 typespec matching and checking for a kind later. */
1789 gfc_match_implicit (void)
1796 /* We don't allow empty implicit statements. */
1797 if (gfc_match_eos () == MATCH_YES
)
1799 gfc_error ("Empty IMPLICIT statement at %C");
1805 /* First cleanup. */
1806 gfc_clear_new_implicit ();
1808 /* A basic type is mandatory here. */
1809 m
= match_type_spec (&ts
, 1);
1810 if (m
== MATCH_ERROR
)
1815 cur_loc
= gfc_current_locus
;
1816 m
= match_implicit_range ();
1820 /* We may have <TYPE> (<RANGE>). */
1821 gfc_gobble_whitespace ();
1822 c
= gfc_next_char ();
1823 if ((c
== '\n') || (c
== ','))
1825 /* Check for CHARACTER with no length parameter. */
1826 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1828 ts
.kind
= gfc_default_character_kind
;
1829 ts
.cl
= gfc_get_charlen ();
1830 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1831 gfc_current_ns
->cl_list
= ts
.cl
;
1832 ts
.cl
->length
= gfc_int_expr (1);
1835 /* Record the Successful match. */
1836 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1841 gfc_current_locus
= cur_loc
;
1844 /* Discard the (incorrectly) matched range. */
1845 gfc_clear_new_implicit ();
1847 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1848 if (ts
.type
== BT_CHARACTER
)
1849 m
= match_char_spec (&ts
);
1852 m
= gfc_match_kind_spec (&ts
);
1855 m
= gfc_match_old_kind_spec (&ts
);
1856 if (m
== MATCH_ERROR
)
1862 if (m
== MATCH_ERROR
)
1865 m
= match_implicit_range ();
1866 if (m
== MATCH_ERROR
)
1871 gfc_gobble_whitespace ();
1872 c
= gfc_next_char ();
1873 if ((c
!= '\n') && (c
!= ','))
1876 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1884 gfc_syntax_error (ST_IMPLICIT
);
1891 /* Matches an attribute specification including array specs. If
1892 successful, leaves the variables current_attr and current_as
1893 holding the specification. Also sets the colon_seen variable for
1894 later use by matchers associated with initializations.
1896 This subroutine is a little tricky in the sense that we don't know
1897 if we really have an attr-spec until we hit the double colon.
1898 Until that time, we can only return MATCH_NO. This forces us to
1899 check for duplicate specification at this level. */
1902 match_attr_spec (void)
1905 /* Modifiers that can exist in a type statement. */
1907 { GFC_DECL_BEGIN
= 0,
1908 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1909 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1910 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1911 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1912 GFC_DECL_END
/* Sentinel */
1916 /* GFC_DECL_END is the sentinel, index starts at 0. */
1917 #define NUM_DECL GFC_DECL_END
1919 static mstring decls
[] = {
1920 minit (", allocatable", DECL_ALLOCATABLE
),
1921 minit (", dimension", DECL_DIMENSION
),
1922 minit (", external", DECL_EXTERNAL
),
1923 minit (", intent ( in )", DECL_IN
),
1924 minit (", intent ( out )", DECL_OUT
),
1925 minit (", intent ( in out )", DECL_INOUT
),
1926 minit (", intrinsic", DECL_INTRINSIC
),
1927 minit (", optional", DECL_OPTIONAL
),
1928 minit (", parameter", DECL_PARAMETER
),
1929 minit (", pointer", DECL_POINTER
),
1930 minit (", private", DECL_PRIVATE
),
1931 minit (", public", DECL_PUBLIC
),
1932 minit (", save", DECL_SAVE
),
1933 minit (", target", DECL_TARGET
),
1934 minit ("::", DECL_COLON
),
1935 minit (NULL
, DECL_NONE
)
1938 locus start
, seen_at
[NUM_DECL
];
1945 gfc_clear_attr (¤t_attr
);
1946 start
= gfc_current_locus
;
1951 /* See if we get all of the keywords up to the final double colon. */
1952 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
1957 d
= (decl_types
) gfc_match_strings (decls
);
1958 if (d
== DECL_NONE
|| d
== DECL_COLON
)
1961 if (gfc_current_state () == COMP_ENUM
)
1963 gfc_error ("Enumerator cannot have attributes %C");
1968 seen_at
[d
] = gfc_current_locus
;
1970 if (d
== DECL_DIMENSION
)
1972 m
= gfc_match_array_spec (¤t_as
);
1976 gfc_error ("Missing dimension specification at %C");
1980 if (m
== MATCH_ERROR
)
1985 /* If we are parsing an enumeration and have enusured that no other
1986 attributes are present we can now set the parameter attribute. */
1987 if (gfc_current_state () == COMP_ENUM
)
1989 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
1997 /* No double colon, so assume that we've been looking at something
1998 else the whole time. */
2005 /* Since we've seen a double colon, we have to be looking at an
2006 attr-spec. This means that we can now issue errors. */
2007 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2012 case DECL_ALLOCATABLE
:
2013 attr
= "ALLOCATABLE";
2015 case DECL_DIMENSION
:
2022 attr
= "INTENT (IN)";
2025 attr
= "INTENT (OUT)";
2028 attr
= "INTENT (IN OUT)";
2030 case DECL_INTRINSIC
:
2036 case DECL_PARAMETER
:
2055 attr
= NULL
; /* This shouldn't happen */
2058 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2063 /* Now that we've dealt with duplicate attributes, add the attributes
2064 to the current attribute. */
2065 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2070 if (gfc_current_state () == COMP_DERIVED
2071 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2072 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2075 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2081 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2082 && gfc_current_state () != COMP_MODULE
)
2084 if (d
== DECL_PRIVATE
)
2089 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2097 case DECL_ALLOCATABLE
:
2098 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2101 case DECL_DIMENSION
:
2102 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2106 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2110 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2114 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2118 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2121 case DECL_INTRINSIC
:
2122 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2126 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2129 case DECL_PARAMETER
:
2130 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2134 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2138 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2143 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2148 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2152 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2156 gfc_internal_error ("match_attr_spec(): Bad attribute");
2170 gfc_current_locus
= start
;
2171 gfc_free_array_spec (current_as
);
2177 /* Match a data declaration statement. */
2180 gfc_match_data_decl (void)
2186 m
= match_type_spec (¤t_ts
, 0);
2190 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2192 sym
= gfc_use_derived (current_ts
.derived
);
2200 current_ts
.derived
= sym
;
2203 m
= match_attr_spec ();
2204 if (m
== MATCH_ERROR
)
2210 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2213 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2216 gfc_find_symbol (current_ts
.derived
->name
,
2217 current_ts
.derived
->ns
->parent
, 1, &sym
);
2219 /* Any symbol that we find had better be a type definition
2220 which has its components defined. */
2221 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2222 && current_ts
.derived
->components
!= NULL
)
2225 /* Now we have an error, which we signal, and then fix up
2226 because the knock-on is plain and simple confusing. */
2227 gfc_error_now ("Derived type at %C has not been previously defined "
2228 "and so cannot appear in a derived type definition.");
2229 current_attr
.pointer
= 1;
2234 /* If we have an old-style character declaration, and no new-style
2235 attribute specifications, then there a comma is optional between
2236 the type specification and the variable list. */
2237 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2238 gfc_match_char (',');
2240 /* Give the types/attributes to symbols that follow. Give the element
2241 a number so that repeat character length expressions can be copied. */
2245 m
= variable_decl (elem
++);
2246 if (m
== MATCH_ERROR
)
2251 if (gfc_match_eos () == MATCH_YES
)
2253 if (gfc_match_char (',') != MATCH_YES
)
2257 gfc_error ("Syntax error in data declaration at %C");
2261 gfc_free_array_spec (current_as
);
2267 /* Match a prefix associated with a function or subroutine
2268 declaration. If the typespec pointer is nonnull, then a typespec
2269 can be matched. Note that if nothing matches, MATCH_YES is
2270 returned (the null string was matched). */
2273 match_prefix (gfc_typespec
* ts
)
2277 gfc_clear_attr (¤t_attr
);
2281 if (!seen_type
&& ts
!= NULL
2282 && match_type_spec (ts
, 0) == MATCH_YES
2283 && gfc_match_space () == MATCH_YES
)
2290 if (gfc_match ("elemental% ") == MATCH_YES
)
2292 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2298 if (gfc_match ("pure% ") == MATCH_YES
)
2300 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2306 if (gfc_match ("recursive% ") == MATCH_YES
)
2308 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2314 /* At this point, the next item is not a prefix. */
2319 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2322 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2325 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2328 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2331 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2338 /* Match a formal argument list. */
2341 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2343 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2344 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2350 if (gfc_match_char ('(') != MATCH_YES
)
2357 if (gfc_match_char (')') == MATCH_YES
)
2362 if (gfc_match_char ('*') == MATCH_YES
)
2366 m
= gfc_match_name (name
);
2370 if (gfc_get_symbol (name
, NULL
, &sym
))
2374 p
= gfc_get_formal_arglist ();
2386 /* We don't add the VARIABLE flavor because the name could be a
2387 dummy procedure. We don't apply these attributes to formal
2388 arguments of statement functions. */
2389 if (sym
!= NULL
&& !st_flag
2390 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2391 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2397 /* The name of a program unit can be in a different namespace,
2398 so check for it explicitly. After the statement is accepted,
2399 the name is checked for especially in gfc_get_symbol(). */
2400 if (gfc_new_block
!= NULL
&& sym
!= NULL
2401 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2403 gfc_error ("Name '%s' at %C is the name of the procedure",
2409 if (gfc_match_char (')') == MATCH_YES
)
2412 m
= gfc_match_char (',');
2415 gfc_error ("Unexpected junk in formal argument list at %C");
2421 /* Check for duplicate symbols in the formal argument list. */
2424 for (p
= head
; p
->next
; p
= p
->next
)
2429 for (q
= p
->next
; q
; q
= q
->next
)
2430 if (p
->sym
== q
->sym
)
2433 ("Duplicate symbol '%s' in formal argument list at %C",
2442 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2452 gfc_free_formal_arglist (head
);
2457 /* Match a RESULT specification following a function declaration or
2458 ENTRY statement. Also matches the end-of-statement. */
2461 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2463 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2467 if (gfc_match (" result (") != MATCH_YES
)
2470 m
= gfc_match_name (name
);
2474 if (gfc_match (" )%t") != MATCH_YES
)
2476 gfc_error ("Unexpected junk following RESULT variable at %C");
2480 if (strcmp (function
->name
, name
) == 0)
2483 ("RESULT variable at %C must be different than function name");
2487 if (gfc_get_symbol (name
, NULL
, &r
))
2490 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2491 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2500 /* Match a function declaration. */
2503 gfc_match_function_decl (void)
2505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2506 gfc_symbol
*sym
, *result
;
2510 if (gfc_current_state () != COMP_NONE
2511 && gfc_current_state () != COMP_INTERFACE
2512 && gfc_current_state () != COMP_CONTAINS
)
2515 gfc_clear_ts (¤t_ts
);
2517 old_loc
= gfc_current_locus
;
2519 m
= match_prefix (¤t_ts
);
2522 gfc_current_locus
= old_loc
;
2526 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2528 gfc_current_locus
= old_loc
;
2532 if (get_proc_name (name
, &sym
))
2534 gfc_new_block
= sym
;
2536 m
= gfc_match_formal_arglist (sym
, 0, 0);
2538 gfc_error ("Expected formal argument list in function definition at %C");
2539 else if (m
== MATCH_ERROR
)
2544 if (gfc_match_eos () != MATCH_YES
)
2546 /* See if a result variable is present. */
2547 m
= match_result (sym
, &result
);
2549 gfc_error ("Unexpected junk after function declaration at %C");
2558 /* Make changes to the symbol. */
2561 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2564 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2565 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2568 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2570 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2571 gfc_basic_typename (sym
->ts
.type
));
2577 sym
->ts
= current_ts
;
2582 result
->ts
= current_ts
;
2583 sym
->result
= result
;
2589 gfc_current_locus
= old_loc
;
2594 /* Match an ENTRY statement. */
2597 gfc_match_entry (void)
2602 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2603 gfc_compile_state state
;
2608 m
= gfc_match_name (name
);
2612 state
= gfc_current_state ();
2613 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2618 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2621 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2623 case COMP_BLOCK_DATA
:
2625 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2627 case COMP_INTERFACE
:
2629 ("ENTRY statement at %C cannot appear within an INTERFACE");
2633 ("ENTRY statement at %C cannot appear "
2634 "within a DERIVED TYPE block");
2638 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2642 ("ENTRY statement at %C cannot appear within a DO block");
2646 ("ENTRY statement at %C cannot appear within a SELECT block");
2650 ("ENTRY statement at %C cannot appear within a FORALL block");
2654 ("ENTRY statement at %C cannot appear within a WHERE block");
2658 ("ENTRY statement at %C cannot appear "
2659 "within a contained subprogram");
2662 gfc_internal_error ("gfc_match_entry(): Bad state");
2667 if (gfc_current_ns
->parent
!= NULL
2668 && gfc_current_ns
->parent
->proc_name
2669 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
!= FL_MODULE
)
2671 gfc_error("ENTRY statement at %C cannot appear in a "
2672 "contained procedure");
2676 if (get_proc_name (name
, &entry
))
2679 proc
= gfc_current_block ();
2681 if (state
== COMP_SUBROUTINE
)
2683 /* An entry in a subroutine. */
2684 m
= gfc_match_formal_arglist (entry
, 0, 1);
2688 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2689 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2694 /* An entry in a function.
2695 We need to take special care because writing
2700 ENTRY f() RESULT (r)
2702 ENTRY f RESULT (r). */
2703 old_loc
= gfc_current_locus
;
2704 if (gfc_match_eos () == MATCH_YES
)
2706 gfc_current_locus
= old_loc
;
2707 /* Match the empty argument list, and add the interface to
2709 m
= gfc_match_formal_arglist (entry
, 0, 1);
2712 m
= gfc_match_formal_arglist (entry
, 0, 0);
2719 if (gfc_match_eos () == MATCH_YES
)
2721 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2722 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2725 entry
->result
= entry
;
2729 m
= match_result (proc
, &result
);
2731 gfc_syntax_error (ST_ENTRY
);
2735 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2736 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2737 || gfc_add_function (&entry
->attr
, result
->name
,
2741 entry
->result
= result
;
2744 if (proc
->attr
.recursive
&& result
== NULL
)
2746 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2751 if (gfc_match_eos () != MATCH_YES
)
2753 gfc_syntax_error (ST_ENTRY
);
2757 entry
->attr
.recursive
= proc
->attr
.recursive
;
2758 entry
->attr
.elemental
= proc
->attr
.elemental
;
2759 entry
->attr
.pure
= proc
->attr
.pure
;
2761 el
= gfc_get_entry_list ();
2763 el
->next
= gfc_current_ns
->entries
;
2764 gfc_current_ns
->entries
= el
;
2766 el
->id
= el
->next
->id
+ 1;
2770 new_st
.op
= EXEC_ENTRY
;
2771 new_st
.ext
.entry
= el
;
2777 /* Match a subroutine statement, including optional prefixes. */
2780 gfc_match_subroutine (void)
2782 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2786 if (gfc_current_state () != COMP_NONE
2787 && gfc_current_state () != COMP_INTERFACE
2788 && gfc_current_state () != COMP_CONTAINS
)
2791 m
= match_prefix (NULL
);
2795 m
= gfc_match ("subroutine% %n", name
);
2799 if (get_proc_name (name
, &sym
))
2801 gfc_new_block
= sym
;
2803 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2806 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2809 if (gfc_match_eos () != MATCH_YES
)
2811 gfc_syntax_error (ST_SUBROUTINE
);
2815 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2822 /* Return nonzero if we're currently compiling a contained procedure. */
2825 contained_procedure (void)
2829 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2830 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2831 && s
->previous
!= NULL
2832 && s
->previous
->state
== COMP_CONTAINS
)
2838 /* Set the kind of each enumerator. The kind is selected such that it is
2839 interoperable with the corresponding C enumeration type, making
2840 sure that -fshort-enums is honored. */
2845 enumerator_history
*current_history
= NULL
;
2849 if (max_enum
== NULL
|| enum_history
== NULL
)
2852 if (!gfc_option
.fshort_enums
)
2858 kind
= gfc_integer_kinds
[i
++].kind
;
2860 while (kind
< gfc_c_int_kind
2861 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
2864 current_history
= enum_history
;
2865 while (current_history
!= NULL
)
2867 current_history
->sym
->ts
.kind
= kind
;
2868 current_history
= current_history
->next
;
2872 /* Match any of the various end-block statements. Returns the type of
2873 END to the caller. The END INTERFACE, END IF, END DO and END
2874 SELECT statements cannot be replaced by a single END statement. */
2877 gfc_match_end (gfc_statement
* st
)
2879 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2880 gfc_compile_state state
;
2882 const char *block_name
;
2887 old_loc
= gfc_current_locus
;
2888 if (gfc_match ("end") != MATCH_YES
)
2891 state
= gfc_current_state ();
2893 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2895 if (state
== COMP_CONTAINS
)
2897 state
= gfc_state_stack
->previous
->state
;
2898 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
2899 : gfc_state_stack
->previous
->sym
->name
;
2906 *st
= ST_END_PROGRAM
;
2907 target
= " program";
2911 case COMP_SUBROUTINE
:
2912 *st
= ST_END_SUBROUTINE
;
2913 target
= " subroutine";
2914 eos_ok
= !contained_procedure ();
2918 *st
= ST_END_FUNCTION
;
2919 target
= " function";
2920 eos_ok
= !contained_procedure ();
2923 case COMP_BLOCK_DATA
:
2924 *st
= ST_END_BLOCK_DATA
;
2925 target
= " block data";
2930 *st
= ST_END_MODULE
;
2935 case COMP_INTERFACE
:
2936 *st
= ST_END_INTERFACE
;
2937 target
= " interface";
2960 *st
= ST_END_SELECT
;
2966 *st
= ST_END_FORALL
;
2981 last_initializer
= NULL
;
2983 gfc_free_enum_history ();
2987 gfc_error ("Unexpected END statement at %C");
2991 if (gfc_match_eos () == MATCH_YES
)
2995 /* We would have required END [something] */
2996 gfc_error ("%s statement expected at %L",
2997 gfc_ascii_statement (*st
), &old_loc
);
3004 /* Verify that we've got the sort of end-block that we're expecting. */
3005 if (gfc_match (target
) != MATCH_YES
)
3007 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3011 /* If we're at the end, make sure a block name wasn't required. */
3012 if (gfc_match_eos () == MATCH_YES
)
3015 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3018 if (gfc_current_block () == NULL
)
3021 gfc_error ("Expected block name of '%s' in %s statement at %C",
3022 block_name
, gfc_ascii_statement (*st
));
3027 /* END INTERFACE has a special handler for its several possible endings. */
3028 if (*st
== ST_END_INTERFACE
)
3029 return gfc_match_end_interface ();
3031 /* We haven't hit the end of statement, so what is left must be an end-name. */
3032 m
= gfc_match_space ();
3034 m
= gfc_match_name (name
);
3037 gfc_error ("Expected terminating name at %C");
3041 if (block_name
== NULL
)
3044 if (strcmp (name
, block_name
) != 0)
3046 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3047 gfc_ascii_statement (*st
));
3051 if (gfc_match_eos () == MATCH_YES
)
3055 gfc_syntax_error (*st
);
3058 gfc_current_locus
= old_loc
;
3064 /***************** Attribute declaration statements ****************/
3066 /* Set the attribute of a single variable. */
3071 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3079 m
= gfc_match_name (name
);
3083 if (find_special (name
, &sym
))
3086 var_locus
= gfc_current_locus
;
3088 /* Deal with possible array specification for certain attributes. */
3089 if (current_attr
.dimension
3090 || current_attr
.allocatable
3091 || current_attr
.pointer
3092 || current_attr
.target
)
3094 m
= gfc_match_array_spec (&as
);
3095 if (m
== MATCH_ERROR
)
3098 if (current_attr
.dimension
&& m
== MATCH_NO
)
3101 ("Missing array specification at %L in DIMENSION statement",
3107 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3108 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3110 gfc_error ("Array specification must be deferred at %L",
3117 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3118 if (current_attr
.dimension
== 0
3119 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3125 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3131 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3133 /* Fix the array spec. */
3134 m
= gfc_mod_pointee_as (sym
->as
);
3135 if (m
== MATCH_ERROR
)
3139 if ((current_attr
.external
|| current_attr
.intrinsic
)
3140 && sym
->attr
.flavor
!= FL_PROCEDURE
3141 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3150 gfc_free_array_spec (as
);
3155 /* Generic attribute declaration subroutine. Used for attributes that
3156 just have a list of names. */
3163 /* Gobble the optional double colon, by simply ignoring the result
3173 if (gfc_match_eos () == MATCH_YES
)
3179 if (gfc_match_char (',') != MATCH_YES
)
3181 gfc_error ("Unexpected character in variable list at %C");
3191 /* This routine matches Cray Pointer declarations of the form:
3192 pointer ( <pointer>, <pointee> )
3194 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3195 The pointer, if already declared, should be an integer. Otherwise, we
3196 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3197 be either a scalar, or an array declaration. No space is allocated for
3198 the pointee. For the statement
3199 pointer (ipt, ar(10))
3200 any subsequent uses of ar will be translated (in C-notation) as
3201 ar(i) => ((<type> *) ipt)(i)
3202 After gimplification, pointee variable will disappear in the code. */
3205 cray_pointer_decl (void)
3209 gfc_symbol
*cptr
; /* Pointer symbol. */
3210 gfc_symbol
*cpte
; /* Pointee symbol. */
3216 if (gfc_match_char ('(') != MATCH_YES
)
3218 gfc_error ("Expected '(' at %C");
3222 /* Match pointer. */
3223 var_locus
= gfc_current_locus
;
3224 gfc_clear_attr (¤t_attr
);
3225 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3226 current_ts
.type
= BT_INTEGER
;
3227 current_ts
.kind
= gfc_index_integer_kind
;
3229 m
= gfc_match_symbol (&cptr
, 0);
3232 gfc_error ("Expected variable name at %C");
3236 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3239 gfc_set_sym_referenced (cptr
);
3241 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3243 cptr
->ts
.type
= BT_INTEGER
;
3244 cptr
->ts
.kind
= gfc_index_integer_kind
;
3246 else if (cptr
->ts
.type
!= BT_INTEGER
)
3248 gfc_error ("Cray pointer at %C must be an integer.");
3251 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3252 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3253 " memory addresses require %d bytes.",
3255 gfc_index_integer_kind
);
3257 if (gfc_match_char (',') != MATCH_YES
)
3259 gfc_error ("Expected \",\" at %C");
3263 /* Match Pointee. */
3264 var_locus
= gfc_current_locus
;
3265 gfc_clear_attr (¤t_attr
);
3266 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3267 current_ts
.type
= BT_UNKNOWN
;
3268 current_ts
.kind
= 0;
3270 m
= gfc_match_symbol (&cpte
, 0);
3273 gfc_error ("Expected variable name at %C");
3277 /* Check for an optional array spec. */
3278 m
= gfc_match_array_spec (&as
);
3279 if (m
== MATCH_ERROR
)
3281 gfc_free_array_spec (as
);
3284 else if (m
== MATCH_NO
)
3286 gfc_free_array_spec (as
);
3290 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3293 gfc_set_sym_referenced (cpte
);
3295 if (cpte
->as
== NULL
)
3297 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3298 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3300 else if (as
!= NULL
)
3302 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3303 gfc_free_array_spec (as
);
3309 if (cpte
->as
!= NULL
)
3311 /* Fix array spec. */
3312 m
= gfc_mod_pointee_as (cpte
->as
);
3313 if (m
== MATCH_ERROR
)
3317 /* Point the Pointee at the Pointer. */
3318 cpte
->cp_pointer
= cptr
;
3320 if (gfc_match_char (')') != MATCH_YES
)
3322 gfc_error ("Expected \")\" at %C");
3325 m
= gfc_match_char (',');
3327 done
= true; /* Stop searching for more declarations. */
3331 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3332 || gfc_match_eos () != MATCH_YES
)
3334 gfc_error ("Expected \",\" or end of statement at %C");
3342 gfc_match_external (void)
3345 gfc_clear_attr (¤t_attr
);
3346 gfc_add_external (¤t_attr
, NULL
);
3348 return attr_decl ();
3354 gfc_match_intent (void)
3358 intent
= match_intent_spec ();
3359 if (intent
== INTENT_UNKNOWN
)
3362 gfc_clear_attr (¤t_attr
);
3363 gfc_add_intent (¤t_attr
, intent
, NULL
); /* Can't fail */
3365 return attr_decl ();
3370 gfc_match_intrinsic (void)
3373 gfc_clear_attr (¤t_attr
);
3374 gfc_add_intrinsic (¤t_attr
, NULL
);
3376 return attr_decl ();
3381 gfc_match_optional (void)
3384 gfc_clear_attr (¤t_attr
);
3385 gfc_add_optional (¤t_attr
, NULL
);
3387 return attr_decl ();
3392 gfc_match_pointer (void)
3394 gfc_gobble_whitespace ();
3395 if (gfc_peek_char () == '(')
3397 if (!gfc_option
.flag_cray_pointer
)
3399 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3403 return cray_pointer_decl ();
3407 gfc_clear_attr (¤t_attr
);
3408 gfc_add_pointer (¤t_attr
, NULL
);
3410 return attr_decl ();
3416 gfc_match_allocatable (void)
3419 gfc_clear_attr (¤t_attr
);
3420 gfc_add_allocatable (¤t_attr
, NULL
);
3422 return attr_decl ();
3427 gfc_match_dimension (void)
3430 gfc_clear_attr (¤t_attr
);
3431 gfc_add_dimension (¤t_attr
, NULL
, NULL
);
3433 return attr_decl ();
3438 gfc_match_target (void)
3441 gfc_clear_attr (¤t_attr
);
3442 gfc_add_target (¤t_attr
, NULL
);
3444 return attr_decl ();
3448 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3452 access_attr_decl (gfc_statement st
)
3454 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3455 interface_type type
;
3458 gfc_intrinsic_op
operator;
3461 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3466 m
= gfc_match_generic_spec (&type
, name
, &operator);
3469 if (m
== MATCH_ERROR
)
3474 case INTERFACE_NAMELESS
:
3477 case INTERFACE_GENERIC
:
3478 if (gfc_get_symbol (name
, NULL
, &sym
))
3481 if (gfc_add_access (&sym
->attr
,
3483 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3484 sym
->name
, NULL
) == FAILURE
)
3489 case INTERFACE_INTRINSIC_OP
:
3490 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3492 gfc_current_ns
->operator_access
[operator] =
3493 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3497 gfc_error ("Access specification of the %s operator at %C has "
3498 "already been specified", gfc_op2string (operator));
3504 case INTERFACE_USER_OP
:
3505 uop
= gfc_get_uop (name
);
3507 if (uop
->access
== ACCESS_UNKNOWN
)
3510 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3515 ("Access specification of the .%s. operator at %C has "
3516 "already been specified", sym
->name
);
3523 if (gfc_match_char (',') == MATCH_NO
)
3527 if (gfc_match_eos () != MATCH_YES
)
3532 gfc_syntax_error (st
);
3539 /* The PRIVATE statement is a bit weird in that it can be a attribute
3540 declaration, but also works as a standlone statement inside of a
3541 type declaration or a module. */
3544 gfc_match_private (gfc_statement
* st
)
3547 if (gfc_match ("private") != MATCH_YES
)
3550 if (gfc_current_state () == COMP_DERIVED
)
3552 if (gfc_match_eos () == MATCH_YES
)
3558 gfc_syntax_error (ST_PRIVATE
);
3562 if (gfc_match_eos () == MATCH_YES
)
3569 return access_attr_decl (ST_PRIVATE
);
3574 gfc_match_public (gfc_statement
* st
)
3577 if (gfc_match ("public") != MATCH_YES
)
3580 if (gfc_match_eos () == MATCH_YES
)
3587 return access_attr_decl (ST_PUBLIC
);
3591 /* Workhorse for gfc_match_parameter. */
3600 m
= gfc_match_symbol (&sym
, 0);
3602 gfc_error ("Expected variable name at %C in PARAMETER statement");
3607 if (gfc_match_char ('=') == MATCH_NO
)
3609 gfc_error ("Expected = sign in PARAMETER statement at %C");
3613 m
= gfc_match_init_expr (&init
);
3615 gfc_error ("Expected expression at %C in PARAMETER statement");
3619 if (sym
->ts
.type
== BT_UNKNOWN
3620 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3626 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3627 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3633 if (sym
->ts
.type
== BT_CHARACTER
3634 && sym
->ts
.cl
!= NULL
3635 && sym
->ts
.cl
->length
!= NULL
3636 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3637 && init
->expr_type
== EXPR_CONSTANT
3638 && init
->ts
.type
== BT_CHARACTER
3639 && init
->ts
.kind
== 1)
3640 gfc_set_constant_character_len (
3641 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3647 gfc_free_expr (init
);
3652 /* Match a parameter statement, with the weird syntax that these have. */
3655 gfc_match_parameter (void)
3659 if (gfc_match_char ('(') == MATCH_NO
)
3668 if (gfc_match (" )%t") == MATCH_YES
)
3671 if (gfc_match_char (',') != MATCH_YES
)
3673 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3683 /* Save statements have a special syntax. */
3686 gfc_match_save (void)
3688 char n
[GFC_MAX_SYMBOL_LEN
+1];
3693 if (gfc_match_eos () == MATCH_YES
)
3695 if (gfc_current_ns
->seen_save
)
3697 if (gfc_notify_std (GFC_STD_LEGACY
,
3698 "Blanket SAVE statement at %C follows previous "
3704 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3708 if (gfc_current_ns
->save_all
)
3710 if (gfc_notify_std (GFC_STD_LEGACY
,
3711 "SAVE statement at %C follows blanket SAVE statement")
3720 m
= gfc_match_symbol (&sym
, 0);
3724 if (gfc_add_save (&sym
->attr
, sym
->name
,
3725 &gfc_current_locus
) == FAILURE
)
3736 m
= gfc_match (" / %n /", &n
);
3737 if (m
== MATCH_ERROR
)
3742 c
= gfc_get_common (n
, 0);
3745 gfc_current_ns
->seen_save
= 1;
3748 if (gfc_match_eos () == MATCH_YES
)
3750 if (gfc_match_char (',') != MATCH_YES
)
3757 gfc_error ("Syntax error in SAVE statement at %C");
3762 /* Match a module procedure statement. Note that we have to modify
3763 symbols in the parent's namespace because the current one was there
3764 to receive symbols that are in an interface's formal argument list. */
3767 gfc_match_modproc (void)
3769 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3773 if (gfc_state_stack
->state
!= COMP_INTERFACE
3774 || gfc_state_stack
->previous
== NULL
3775 || current_interface
.type
== INTERFACE_NAMELESS
)
3778 ("MODULE PROCEDURE at %C must be in a generic module interface");
3784 m
= gfc_match_name (name
);
3790 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3793 if (sym
->attr
.proc
!= PROC_MODULE
3794 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3795 sym
->name
, NULL
) == FAILURE
)
3798 if (gfc_add_interface (sym
) == FAILURE
)
3801 if (gfc_match_eos () == MATCH_YES
)
3803 if (gfc_match_char (',') != MATCH_YES
)
3810 gfc_syntax_error (ST_MODULE_PROC
);
3815 /* Match the beginning of a derived type declaration. If a type name
3816 was the result of a function, then it is possible to have a symbol
3817 already to be known as a derived type yet have no components. */
3820 gfc_match_derived_decl (void)
3822 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3823 symbol_attribute attr
;
3827 if (gfc_current_state () == COMP_DERIVED
)
3830 gfc_clear_attr (&attr
);
3833 if (gfc_match (" , private") == MATCH_YES
)
3835 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3838 ("Derived type at %C can only be PRIVATE within a MODULE");
3842 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3847 if (gfc_match (" , public") == MATCH_YES
)
3849 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3851 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3855 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3860 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3862 gfc_error ("Expected :: in TYPE definition at %C");
3866 m
= gfc_match (" %n%t", name
);
3870 /* Make sure the name isn't the name of an intrinsic type. The
3871 'double precision' type doesn't get past the name matcher. */
3872 if (strcmp (name
, "integer") == 0
3873 || strcmp (name
, "real") == 0
3874 || strcmp (name
, "character") == 0
3875 || strcmp (name
, "logical") == 0
3876 || strcmp (name
, "complex") == 0)
3879 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3884 if (gfc_get_symbol (name
, NULL
, &sym
))
3887 if (sym
->ts
.type
!= BT_UNKNOWN
)
3889 gfc_error ("Derived type name '%s' at %C already has a basic type "
3890 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
3894 /* The symbol may already have the derived attribute without the
3895 components. The ways this can happen is via a function
3896 definition, an INTRINSIC statement or a subtype in another
3897 derived type that is a pointer. The first part of the AND clause
3898 is true if a the symbol is not the return value of a function. */
3899 if (sym
->attr
.flavor
!= FL_DERIVED
3900 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
3903 if (sym
->components
!= NULL
)
3906 ("Derived type definition of '%s' at %C has already been defined",
3911 if (attr
.access
!= ACCESS_UNKNOWN
3912 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
3915 gfc_new_block
= sym
;
3921 /* Cray Pointees can be declared as:
3922 pointer (ipt, a (n,m,...,*))
3923 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
3924 cheat and set a constant bound of 1 for the last dimension, if this
3925 is the case. Since there is no bounds-checking for Cray Pointees,
3926 this will be okay. */
3929 gfc_mod_pointee_as (gfc_array_spec
*as
)
3931 as
->cray_pointee
= true; /* This will be useful to know later. */
3932 if (as
->type
== AS_ASSUMED_SIZE
)
3934 as
->type
= AS_EXPLICIT
;
3935 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
3936 as
->cp_was_assumed
= true;
3938 else if (as
->type
== AS_ASSUMED_SHAPE
)
3940 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
3947 /* Match the enum definition statement, here we are trying to match
3948 the first line of enum definition statement.
3949 Returns MATCH_YES if match is found. */
3952 gfc_match_enum (void)
3956 m
= gfc_match_eos ();
3960 if (gfc_notify_std (GFC_STD_F2003
,
3961 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
3969 /* Match the enumerator definition statement. */
3972 gfc_match_enumerator_def (void)
3977 gfc_clear_ts (¤t_ts
);
3979 m
= gfc_match (" enumerator");
3983 if (gfc_current_state () != COMP_ENUM
)
3985 gfc_error ("ENUM definition statement expected before %C");
3986 gfc_free_enum_history ();
3990 (¤t_ts
)->type
= BT_INTEGER
;
3991 (¤t_ts
)->kind
= gfc_c_int_kind
;
3993 m
= match_attr_spec ();
3994 if (m
== MATCH_ERROR
)
4003 m
= variable_decl (elem
++);
4004 if (m
== MATCH_ERROR
)
4009 if (gfc_match_eos () == MATCH_YES
)
4011 if (gfc_match_char (',') != MATCH_YES
)
4015 if (gfc_current_state () == COMP_ENUM
)
4017 gfc_free_enum_history ();
4018 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4023 gfc_free_array_spec (current_as
);