1 /* Declaration statement matcher
2 Copyright (C) 2002, 2004, 2005, 2006 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
->attr
.function
&& gfc_current_ns
->parent
&& gfc_current_ns
->parent
== sym
->ns
)
208 gfc_error ("Host associated variable '%s' may not be in the DATA "
209 "statement at %C.", sym
->name
);
213 if (gfc_current_state () != COMP_BLOCK_DATA
214 && sym
->attr
.in_common
215 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
216 "common block variable '%s' in DATA statement at %C",
217 sym
->name
) == FAILURE
)
220 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
227 /* Match the top-level list of data variables. */
230 top_var_list (gfc_data
* d
)
232 gfc_data_variable var
, *tail
, *new;
239 m
= var_element (&var
);
242 if (m
== MATCH_ERROR
)
245 new = gfc_get_data_variable ();
255 if (gfc_match_char ('/') == MATCH_YES
)
257 if (gfc_match_char (',') != MATCH_YES
)
264 gfc_syntax_error (ST_DATA
);
270 match_data_constant (gfc_expr
** result
)
272 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
277 m
= gfc_match_literal_constant (&expr
, 1);
284 if (m
== MATCH_ERROR
)
287 m
= gfc_match_null (result
);
291 m
= gfc_match_name (name
);
295 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
299 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
301 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
305 else if (sym
->attr
.flavor
== FL_DERIVED
)
306 return gfc_match_structure_constructor (sym
, result
);
308 *result
= gfc_copy_expr (sym
->value
);
313 /* Match a list of values in a DATA statement. The leading '/' has
314 already been seen at this point. */
317 top_val_list (gfc_data
* data
)
319 gfc_data_value
*new, *tail
;
328 m
= match_data_constant (&expr
);
331 if (m
== MATCH_ERROR
)
334 new = gfc_get_data_value ();
343 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
351 msg
= gfc_extract_int (expr
, &tmp
);
352 gfc_free_expr (expr
);
360 m
= match_data_constant (&tail
->expr
);
363 if (m
== MATCH_ERROR
)
367 if (gfc_match_char ('/') == MATCH_YES
)
369 if (gfc_match_char (',') == MATCH_NO
)
376 gfc_syntax_error (ST_DATA
);
381 /* Matches an old style initialization. */
384 match_old_style_init (const char *name
)
391 /* Set up data structure to hold initializers. */
392 gfc_find_sym_tree (name
, NULL
, 0, &st
);
395 newdata
= gfc_get_data ();
396 newdata
->var
= gfc_get_data_variable ();
397 newdata
->var
->expr
= gfc_get_variable_expr (st
);
399 /* Match initial value list. This also eats the terminal
401 m
= top_val_list (newdata
);
410 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
415 /* Mark the variable as having appeared in a data statement. */
416 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
422 /* Chain in namespace list of DATA initializers. */
423 newdata
->next
= gfc_current_ns
->data
;
424 gfc_current_ns
->data
= newdata
;
429 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
430 we are matching a DATA statement and are therefore issuing an error
431 if we encounter something unexpected, if not, we're trying to match
432 an old-style initialization expression of the form INTEGER I /2/. */
435 gfc_match_data (void)
442 new = gfc_get_data ();
443 new->where
= gfc_current_locus
;
445 m
= top_var_list (new);
449 m
= top_val_list (new);
453 new->next
= gfc_current_ns
->data
;
454 gfc_current_ns
->data
= new;
456 if (gfc_match_eos () == MATCH_YES
)
459 gfc_match_char (','); /* Optional comma */
464 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
476 /************************ Declaration statements *********************/
478 /* Match an intent specification. Since this can only happen after an
479 INTENT word, a legal intent-spec must follow. */
482 match_intent_spec (void)
485 if (gfc_match (" ( in out )") == MATCH_YES
)
487 if (gfc_match (" ( in )") == MATCH_YES
)
489 if (gfc_match (" ( out )") == MATCH_YES
)
492 gfc_error ("Bad INTENT specification at %C");
493 return INTENT_UNKNOWN
;
497 /* Matches a character length specification, which is either a
498 specification expression or a '*'. */
501 char_len_param_value (gfc_expr
** expr
)
504 if (gfc_match_char ('*') == MATCH_YES
)
510 return gfc_match_expr (expr
);
514 /* A character length is a '*' followed by a literal integer or a
515 char_len_param_value in parenthesis. */
518 match_char_length (gfc_expr
** expr
)
523 m
= gfc_match_char ('*');
527 m
= gfc_match_small_literal_int (&length
, NULL
);
528 if (m
== MATCH_ERROR
)
533 *expr
= gfc_int_expr (length
);
537 if (gfc_match_char ('(') == MATCH_NO
)
540 m
= char_len_param_value (expr
);
541 if (m
== MATCH_ERROR
)
546 if (gfc_match_char (')') == MATCH_NO
)
548 gfc_free_expr (*expr
);
556 gfc_error ("Syntax error in character length specification at %C");
561 /* Special subroutine for finding a symbol. Check if the name is found
562 in the current name space. If not, and we're compiling a function or
563 subroutine and the parent compilation unit is an interface, then check
564 to see if the name we've been given is the name of the interface
565 (located in another namespace). */
568 find_special (const char *name
, gfc_symbol
** result
)
573 i
= gfc_get_symbol (name
, NULL
, result
);
577 if (gfc_current_state () != COMP_SUBROUTINE
578 && gfc_current_state () != COMP_FUNCTION
)
581 s
= gfc_state_stack
->previous
;
585 if (s
->state
!= COMP_INTERFACE
)
588 goto end
; /* Nameless interface */
590 if (strcmp (name
, s
->sym
->name
) == 0)
601 /* Special subroutine for getting a symbol node associated with a
602 procedure name, used in SUBROUTINE and FUNCTION statements. The
603 symbol is created in the parent using with symtree node in the
604 child unit pointing to the symbol. If the current namespace has no
605 parent, then the symbol is just created in the current unit. */
608 get_proc_name (const char *name
, gfc_symbol
** result
,
609 bool module_fcn_entry
)
615 /* Module functions have to be left in their own namespace because
616 they have potentially (almost certainly!) already been referenced.
617 In this sense, they are rather like external functions. This is
618 fixed up in resolve.c(resolve_entries), where the symbol name-
619 space is set to point to the master function, so that the fake
620 result mechanism can work. */
621 if (module_fcn_entry
)
622 rc
= gfc_get_symbol (name
, NULL
, result
);
624 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
628 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
630 /* Trap another encompassed procedure with the same name. All
631 these conditions are necessary to avoid picking up an entry
632 whose name clashes with that of the encompassing procedure;
633 this is handled using gsymbols to register unique,globally
635 if (sym
->attr
.flavor
!= 0
636 && sym
->attr
.proc
!= 0
638 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
639 name
, &sym
->declared_at
);
641 /* Trap declarations of attributes in encompassing scope. The
642 signature for this is that ts.kind is set. Legitimate
643 references only set ts.type. */
644 if (sym
->ts
.kind
!= 0
645 && sym
->attr
.proc
== 0
646 && gfc_current_ns
->parent
!= NULL
647 && sym
->attr
.access
== 0
648 && !module_fcn_entry
)
649 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
650 " and must not have attributes declared at %L",
651 name
, &sym
->declared_at
);
654 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
657 /* Module function entries will already have a symtree in
658 the current namespace but will need one at module level. */
659 if (module_fcn_entry
)
660 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
662 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
667 /* See if the procedure should be a module procedure */
669 if (((sym
->ns
->proc_name
!= NULL
670 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
671 && sym
->attr
.proc
!= PROC_MODULE
) || module_fcn_entry
)
672 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
673 sym
->name
, NULL
) == FAILURE
)
680 /* Function called by variable_decl() that adds a name to the symbol
684 build_sym (const char *name
, gfc_charlen
* cl
,
685 gfc_array_spec
** as
, locus
* var_locus
)
687 symbol_attribute attr
;
690 /* if (find_special (name, &sym)) */
691 if (gfc_get_symbol (name
, NULL
, &sym
))
694 /* Start updating the symbol table. Add basic type attribute
696 if (current_ts
.type
!= BT_UNKNOWN
697 &&(sym
->attr
.implicit_type
== 0
698 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
699 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
702 if (sym
->ts
.type
== BT_CHARACTER
)
705 /* Add dimension attribute if present. */
706 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
710 /* Add attribute to symbol. The copy is so that we can reset the
711 dimension attribute. */
715 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
721 /* Set character constant to the given length. The constant will be padded or
725 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
730 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
731 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
733 slen
= expr
->value
.character
.length
;
736 s
= gfc_getmem (len
);
737 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
739 memset (&s
[slen
], ' ', len
- slen
);
740 gfc_free (expr
->value
.character
.string
);
741 expr
->value
.character
.string
= s
;
742 expr
->value
.character
.length
= len
;
747 /* Function to create and update the enumerator history
748 using the information passed as arguments.
749 Pointer "max_enum" is also updated, to point to
750 enum history node containing largest initializer.
752 SYM points to the symbol node of enumerator.
753 INIT points to its enumerator value. */
756 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
758 enumerator_history
*new_enum_history
;
759 gcc_assert (sym
!= NULL
&& init
!= NULL
);
761 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
763 new_enum_history
->sym
= sym
;
764 new_enum_history
->initializer
= init
;
765 new_enum_history
->next
= NULL
;
767 if (enum_history
== NULL
)
769 enum_history
= new_enum_history
;
770 max_enum
= enum_history
;
774 new_enum_history
->next
= enum_history
;
775 enum_history
= new_enum_history
;
777 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
778 new_enum_history
->initializer
->value
.integer
) < 0)
779 max_enum
= new_enum_history
;
784 /* Function to free enum kind history. */
787 gfc_free_enum_history(void)
789 enumerator_history
*current
= enum_history
;
790 enumerator_history
*next
;
792 while (current
!= NULL
)
794 next
= current
->next
;
803 /* Function called by variable_decl() that adds an initialization
804 expression to a symbol. */
807 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
810 symbol_attribute attr
;
815 if (find_special (name
, &sym
))
820 /* If this symbol is confirming an implicit parameter type,
821 then an initialization expression is not allowed. */
822 if (attr
.flavor
== FL_PARAMETER
823 && sym
->value
!= NULL
826 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
835 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
842 /* An initializer is required for PARAMETER declarations. */
843 if (attr
.flavor
== FL_PARAMETER
)
845 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
851 /* If a variable appears in a DATA block, it cannot have an
856 ("Variable '%s' at %C with an initializer already appears "
857 "in a DATA statement", sym
->name
);
861 /* Check if the assignment can happen. This has to be put off
862 until later for a derived type variable. */
863 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
864 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
867 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
869 /* Update symbol character length according initializer. */
870 if (sym
->ts
.cl
->length
== NULL
)
872 /* If there are multiple CHARACTER variables declared on
873 the same line, we don't want them to share the same
875 sym
->ts
.cl
= gfc_get_charlen ();
876 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
877 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
879 if (init
->expr_type
== EXPR_CONSTANT
)
881 gfc_int_expr (init
->value
.character
.length
);
882 else if (init
->expr_type
== EXPR_ARRAY
)
883 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
885 /* Update initializer character length according symbol. */
886 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
888 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
891 if (init
->expr_type
== EXPR_CONSTANT
)
892 gfc_set_constant_character_len (len
, init
);
893 else if (init
->expr_type
== EXPR_ARRAY
)
895 gfc_free_expr (init
->ts
.cl
->length
);
896 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
897 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
898 gfc_set_constant_character_len (len
, p
->expr
);
903 /* Add initializer. Make sure we keep the ranks sane. */
904 if (sym
->attr
.dimension
&& init
->rank
== 0)
905 init
->rank
= sym
->as
->rank
;
911 /* Maintain enumerator history. */
912 if (gfc_current_state () == COMP_ENUM
)
913 create_enum_history (sym
, init
);
919 /* Function called by variable_decl() that adds a name to a structure
923 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
924 gfc_array_spec
** as
)
928 /* If the current symbol is of the same derived type that we're
929 constructing, it must have the pointer attribute. */
930 if (current_ts
.type
== BT_DERIVED
931 && current_ts
.derived
== gfc_current_block ()
932 && current_attr
.pointer
== 0)
934 gfc_error ("Component at %C must have the POINTER attribute");
938 if (gfc_current_block ()->attr
.pointer
941 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
943 gfc_error ("Array component of structure at %C must have explicit "
944 "or deferred shape");
949 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
954 gfc_set_component_attr (c
, ¤t_attr
);
956 c
->initializer
= *init
;
964 /* Check array components. */
970 if (c
->as
->type
!= AS_DEFERRED
)
972 gfc_error ("Pointer array component of structure at %C "
973 "must have a deferred shape");
979 if (c
->as
->type
!= AS_EXPLICIT
)
982 ("Array component of structure at %C must have an explicit "
992 /* Match a 'NULL()', and possibly take care of some side effects. */
995 gfc_match_null (gfc_expr
** result
)
1001 m
= gfc_match (" null ( )");
1005 /* The NULL symbol now has to be/become an intrinsic function. */
1006 if (gfc_get_symbol ("null", NULL
, &sym
))
1008 gfc_error ("NULL() initialization at %C is ambiguous");
1012 gfc_intrinsic_symbol (sym
);
1014 if (sym
->attr
.proc
!= PROC_INTRINSIC
1015 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1016 sym
->name
, NULL
) == FAILURE
1017 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1020 e
= gfc_get_expr ();
1021 e
->where
= gfc_current_locus
;
1022 e
->expr_type
= EXPR_NULL
;
1023 e
->ts
.type
= BT_UNKNOWN
;
1031 /* Match a variable name with an optional initializer. When this
1032 subroutine is called, a variable is expected to be parsed next.
1033 Depending on what is happening at the moment, updates either the
1034 symbol table or the current interface. */
1037 variable_decl (int elem
)
1039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1040 gfc_expr
*initializer
, *char_len
;
1042 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1053 old_locus
= gfc_current_locus
;
1055 /* When we get here, we've just matched a list of attributes and
1056 maybe a type and a double colon. The next thing we expect to see
1057 is the name of the symbol. */
1058 m
= gfc_match_name (name
);
1062 var_locus
= gfc_current_locus
;
1064 /* Now we could see the optional array spec. or character length. */
1065 m
= gfc_match_array_spec (&as
);
1066 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1067 cp_as
= gfc_copy_array_spec (as
);
1068 else if (m
== MATCH_ERROR
)
1072 as
= gfc_copy_array_spec (current_as
);
1073 else if (gfc_current_state () == COMP_ENUM
)
1075 gfc_error ("Enumerator cannot be array at %C");
1076 gfc_free_enum_history ();
1085 if (current_ts
.type
== BT_CHARACTER
)
1087 switch (match_char_length (&char_len
))
1090 cl
= gfc_get_charlen ();
1091 cl
->next
= gfc_current_ns
->cl_list
;
1092 gfc_current_ns
->cl_list
= cl
;
1094 cl
->length
= char_len
;
1097 /* Non-constant lengths need to be copied after the first
1100 if (elem
> 1 && current_ts
.cl
->length
1101 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1103 cl
= gfc_get_charlen ();
1104 cl
->next
= gfc_current_ns
->cl_list
;
1105 gfc_current_ns
->cl_list
= cl
;
1106 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1118 /* If this symbol has already shown up in a Cray Pointer declaration,
1119 then we want to set the type & bail out. */
1120 if (gfc_option
.flag_cray_pointer
)
1122 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1123 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1125 sym
->ts
.type
= current_ts
.type
;
1126 sym
->ts
.kind
= current_ts
.kind
;
1128 sym
->ts
.derived
= current_ts
.derived
;
1131 /* Check to see if we have an array specification. */
1134 if (sym
->as
!= NULL
)
1136 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1137 gfc_free_array_spec (cp_as
);
1143 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1144 gfc_internal_error ("Couldn't set pointee array spec.");
1146 /* Fix the array spec. */
1147 m
= gfc_mod_pointee_as (sym
->as
);
1148 if (m
== MATCH_ERROR
)
1156 gfc_free_array_spec (cp_as
);
1161 /* OK, we've successfully matched the declaration. Now put the
1162 symbol in the current namespace, because it might be used in the
1163 optional initialization expression for this symbol, e.g. this is
1166 integer, parameter :: i = huge(i)
1168 This is only true for parameters or variables of a basic type.
1169 For components of derived types, it is not true, so we don't
1170 create a symbol for those yet. If we fail to create the symbol,
1172 if (gfc_current_state () != COMP_DERIVED
1173 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1179 /* In functions that have a RESULT variable defined, the function
1180 name always refers to function calls. Therefore, the name is
1181 not allowed to appear in specification statements. */
1182 if (gfc_current_state () == COMP_FUNCTION
1183 && gfc_current_block () != NULL
1184 && gfc_current_block ()->result
!= NULL
1185 && gfc_current_block ()->result
!= gfc_current_block ()
1186 && strcmp (gfc_current_block ()->name
, name
) == 0)
1188 gfc_error ("Function name '%s' not allowed at %C", name
);
1193 /* We allow old-style initializations of the form
1194 integer i /2/, j(4) /3*3, 1/
1195 (if no colon has been seen). These are different from data
1196 statements in that initializers are only allowed to apply to the
1197 variable immediately preceding, i.e.
1199 is not allowed. Therefore we have to do some work manually, that
1200 could otherwise be left to the matchers for DATA statements. */
1202 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1204 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1205 "initialization at %C") == FAILURE
)
1208 return match_old_style_init (name
);
1211 /* The double colon must be present in order to have initializers.
1212 Otherwise the statement is ambiguous with an assignment statement. */
1215 if (gfc_match (" =>") == MATCH_YES
)
1218 if (!current_attr
.pointer
)
1220 gfc_error ("Initialization at %C isn't for a pointer variable");
1225 m
= gfc_match_null (&initializer
);
1228 gfc_error ("Pointer initialization requires a NULL() at %C");
1232 if (gfc_pure (NULL
))
1235 ("Initialization of pointer at %C is not allowed in a "
1244 else if (gfc_match_char ('=') == MATCH_YES
)
1246 if (current_attr
.pointer
)
1249 ("Pointer initialization at %C requires '=>', not '='");
1254 m
= gfc_match_init_expr (&initializer
);
1257 gfc_error ("Expected an initialization expression at %C");
1261 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1264 ("Initialization of variable at %C is not allowed in a "
1274 /* Check if we are parsing an enumeration and if the current enumerator
1275 variable has an initializer or not. If it does not have an
1276 initializer, the initialization value of the previous enumerator
1277 (stored in last_initializer) is incremented by 1 and is used to
1278 initialize the current enumerator. */
1279 if (gfc_current_state () == COMP_ENUM
)
1281 if (initializer
== NULL
)
1282 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1284 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1286 gfc_error("ENUMERATOR %L not initialized with integer expression",
1289 gfc_free_enum_history ();
1293 /* Store this current initializer, for the next enumerator
1294 variable to be parsed. */
1295 last_initializer
= initializer
;
1298 /* Add the initializer. Note that it is fine if initializer is
1299 NULL here, because we sometimes also need to check if a
1300 declaration *must* have an initialization expression. */
1301 if (gfc_current_state () != COMP_DERIVED
)
1302 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1305 if (current_ts
.type
== BT_DERIVED
&& !current_attr
.pointer
1307 initializer
= gfc_default_initializer (¤t_ts
);
1308 t
= build_struct (name
, cl
, &initializer
, &as
);
1311 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1314 /* Free stuff up and return. */
1315 gfc_free_expr (initializer
);
1316 gfc_free_array_spec (as
);
1322 /* Match an extended-f77 kind specification. */
1325 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1330 if (gfc_match_char ('*') != MATCH_YES
)
1333 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1337 original_kind
= ts
->kind
;
1339 /* Massage the kind numbers for complex types. */
1340 if (ts
->type
== BT_COMPLEX
)
1344 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1345 gfc_basic_typename (ts
->type
), original_kind
);
1351 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1353 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1354 gfc_basic_typename (ts
->type
), original_kind
);
1358 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1359 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1366 /* Match a kind specification. Since kinds are generally optional, we
1367 usually return MATCH_NO if something goes wrong. If a "kind="
1368 string is found, then we know we have an error. */
1371 gfc_match_kind_spec (gfc_typespec
* ts
)
1381 where
= gfc_current_locus
;
1383 if (gfc_match_char ('(') == MATCH_NO
)
1386 /* Also gobbles optional text. */
1387 if (gfc_match (" kind = ") == MATCH_YES
)
1390 n
= gfc_match_init_expr (&e
);
1392 gfc_error ("Expected initialization expression at %C");
1398 gfc_error ("Expected scalar initialization expression at %C");
1403 msg
= gfc_extract_int (e
, &ts
->kind
);
1414 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1416 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1417 gfc_basic_typename (ts
->type
));
1423 if (gfc_match_char (')') != MATCH_YES
)
1425 gfc_error ("Missing right paren at %C");
1433 gfc_current_locus
= where
;
1438 /* Match the various kind/length specifications in a CHARACTER
1439 declaration. We don't return MATCH_NO. */
1442 match_char_spec (gfc_typespec
* ts
)
1444 int i
, kind
, seen_length
;
1449 kind
= gfc_default_character_kind
;
1453 /* Try the old-style specification first. */
1454 old_char_selector
= 0;
1456 m
= match_char_length (&len
);
1460 old_char_selector
= 1;
1465 m
= gfc_match_char ('(');
1468 m
= MATCH_YES
; /* character without length is a single char */
1472 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1473 if (gfc_match (" kind =") == MATCH_YES
)
1475 m
= gfc_match_small_int (&kind
);
1476 if (m
== MATCH_ERROR
)
1481 if (gfc_match (" , len =") == MATCH_NO
)
1484 m
= char_len_param_value (&len
);
1487 if (m
== MATCH_ERROR
)
1494 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1495 if (gfc_match (" len =") == MATCH_YES
)
1497 m
= char_len_param_value (&len
);
1500 if (m
== MATCH_ERROR
)
1504 if (gfc_match_char (')') == MATCH_YES
)
1507 if (gfc_match (" , kind =") != MATCH_YES
)
1510 gfc_match_small_int (&kind
);
1512 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1514 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1521 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1522 m
= char_len_param_value (&len
);
1525 if (m
== MATCH_ERROR
)
1529 m
= gfc_match_char (')');
1533 if (gfc_match_char (',') != MATCH_YES
)
1536 gfc_match (" kind ="); /* Gobble optional text */
1538 m
= gfc_match_small_int (&kind
);
1539 if (m
== MATCH_ERROR
)
1545 /* Require a right-paren at this point. */
1546 m
= gfc_match_char (')');
1551 gfc_error ("Syntax error in CHARACTER declaration at %C");
1555 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1557 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1563 gfc_free_expr (len
);
1567 /* Do some final massaging of the length values. */
1568 cl
= gfc_get_charlen ();
1569 cl
->next
= gfc_current_ns
->cl_list
;
1570 gfc_current_ns
->cl_list
= cl
;
1572 if (seen_length
== 0)
1573 cl
->length
= gfc_int_expr (1);
1576 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1580 gfc_free_expr (len
);
1581 cl
->length
= gfc_int_expr (0);
1592 /* Matches a type specification. If successful, sets the ts structure
1593 to the matched specification. This is necessary for FUNCTION and
1594 IMPLICIT statements.
1596 If implicit_flag is nonzero, then we don't check for the optional
1597 kind specification. Not doing so is needed for matching an IMPLICIT
1598 statement correctly. */
1601 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1603 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1610 if (gfc_match (" byte") == MATCH_YES
)
1612 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1616 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1618 gfc_error ("BYTE type used at %C "
1619 "is not available on the target machine");
1623 ts
->type
= BT_INTEGER
;
1628 if (gfc_match (" integer") == MATCH_YES
)
1630 ts
->type
= BT_INTEGER
;
1631 ts
->kind
= gfc_default_integer_kind
;
1635 if (gfc_match (" character") == MATCH_YES
)
1637 ts
->type
= BT_CHARACTER
;
1638 if (implicit_flag
== 0)
1639 return match_char_spec (ts
);
1644 if (gfc_match (" real") == MATCH_YES
)
1647 ts
->kind
= gfc_default_real_kind
;
1651 if (gfc_match (" double precision") == MATCH_YES
)
1654 ts
->kind
= gfc_default_double_kind
;
1658 if (gfc_match (" complex") == MATCH_YES
)
1660 ts
->type
= BT_COMPLEX
;
1661 ts
->kind
= gfc_default_complex_kind
;
1665 if (gfc_match (" double complex") == MATCH_YES
)
1667 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1668 "conform to the Fortran 95 standard") == FAILURE
)
1671 ts
->type
= BT_COMPLEX
;
1672 ts
->kind
= gfc_default_double_kind
;
1676 if (gfc_match (" logical") == MATCH_YES
)
1678 ts
->type
= BT_LOGICAL
;
1679 ts
->kind
= gfc_default_logical_kind
;
1683 m
= gfc_match (" type ( %n )", name
);
1687 /* Search for the name but allow the components to be defined later. */
1688 if (gfc_get_ha_symbol (name
, &sym
))
1690 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1694 if (sym
->attr
.flavor
!= FL_DERIVED
1695 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1698 ts
->type
= BT_DERIVED
;
1705 /* For all types except double, derived and character, look for an
1706 optional kind specifier. MATCH_NO is actually OK at this point. */
1707 if (implicit_flag
== 1)
1710 if (gfc_current_form
== FORM_FREE
)
1712 c
= gfc_peek_char();
1713 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1714 && c
!= ':' && c
!= ',')
1718 m
= gfc_match_kind_spec (ts
);
1719 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1720 m
= gfc_match_old_kind_spec (ts
);
1723 m
= MATCH_YES
; /* No kind specifier found. */
1729 /* Match an IMPLICIT NONE statement. Actually, this statement is
1730 already matched in parse.c, or we would not end up here in the
1731 first place. So the only thing we need to check, is if there is
1732 trailing garbage. If not, the match is successful. */
1735 gfc_match_implicit_none (void)
1738 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1742 /* Match the letter range(s) of an IMPLICIT statement. */
1745 match_implicit_range (void)
1747 int c
, c1
, c2
, inner
;
1750 cur_loc
= gfc_current_locus
;
1752 gfc_gobble_whitespace ();
1753 c
= gfc_next_char ();
1756 gfc_error ("Missing character range in IMPLICIT at %C");
1763 gfc_gobble_whitespace ();
1764 c1
= gfc_next_char ();
1768 gfc_gobble_whitespace ();
1769 c
= gfc_next_char ();
1774 inner
= 0; /* Fall through */
1781 gfc_gobble_whitespace ();
1782 c2
= gfc_next_char ();
1786 gfc_gobble_whitespace ();
1787 c
= gfc_next_char ();
1789 if ((c
!= ',') && (c
!= ')'))
1802 gfc_error ("Letters must be in alphabetic order in "
1803 "IMPLICIT statement at %C");
1807 /* See if we can add the newly matched range to the pending
1808 implicits from this IMPLICIT statement. We do not check for
1809 conflicts with whatever earlier IMPLICIT statements may have
1810 set. This is done when we've successfully finished matching
1812 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1819 gfc_syntax_error (ST_IMPLICIT
);
1821 gfc_current_locus
= cur_loc
;
1826 /* Match an IMPLICIT statement, storing the types for
1827 gfc_set_implicit() if the statement is accepted by the parser.
1828 There is a strange looking, but legal syntactic construction
1829 possible. It looks like:
1831 IMPLICIT INTEGER (a-b) (c-d)
1833 This is legal if "a-b" is a constant expression that happens to
1834 equal one of the legal kinds for integers. The real problem
1835 happens with an implicit specification that looks like:
1837 IMPLICIT INTEGER (a-b)
1839 In this case, a typespec matcher that is "greedy" (as most of the
1840 matchers are) gobbles the character range as a kindspec, leaving
1841 nothing left. We therefore have to go a bit more slowly in the
1842 matching process by inhibiting the kindspec checking during
1843 typespec matching and checking for a kind later. */
1846 gfc_match_implicit (void)
1853 /* We don't allow empty implicit statements. */
1854 if (gfc_match_eos () == MATCH_YES
)
1856 gfc_error ("Empty IMPLICIT statement at %C");
1862 /* First cleanup. */
1863 gfc_clear_new_implicit ();
1865 /* A basic type is mandatory here. */
1866 m
= match_type_spec (&ts
, 1);
1867 if (m
== MATCH_ERROR
)
1872 cur_loc
= gfc_current_locus
;
1873 m
= match_implicit_range ();
1877 /* We may have <TYPE> (<RANGE>). */
1878 gfc_gobble_whitespace ();
1879 c
= gfc_next_char ();
1880 if ((c
== '\n') || (c
== ','))
1882 /* Check for CHARACTER with no length parameter. */
1883 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1885 ts
.kind
= gfc_default_character_kind
;
1886 ts
.cl
= gfc_get_charlen ();
1887 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1888 gfc_current_ns
->cl_list
= ts
.cl
;
1889 ts
.cl
->length
= gfc_int_expr (1);
1892 /* Record the Successful match. */
1893 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1898 gfc_current_locus
= cur_loc
;
1901 /* Discard the (incorrectly) matched range. */
1902 gfc_clear_new_implicit ();
1904 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1905 if (ts
.type
== BT_CHARACTER
)
1906 m
= match_char_spec (&ts
);
1909 m
= gfc_match_kind_spec (&ts
);
1912 m
= gfc_match_old_kind_spec (&ts
);
1913 if (m
== MATCH_ERROR
)
1919 if (m
== MATCH_ERROR
)
1922 m
= match_implicit_range ();
1923 if (m
== MATCH_ERROR
)
1928 gfc_gobble_whitespace ();
1929 c
= gfc_next_char ();
1930 if ((c
!= '\n') && (c
!= ','))
1933 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1941 gfc_syntax_error (ST_IMPLICIT
);
1948 /* Matches an attribute specification including array specs. If
1949 successful, leaves the variables current_attr and current_as
1950 holding the specification. Also sets the colon_seen variable for
1951 later use by matchers associated with initializations.
1953 This subroutine is a little tricky in the sense that we don't know
1954 if we really have an attr-spec until we hit the double colon.
1955 Until that time, we can only return MATCH_NO. This forces us to
1956 check for duplicate specification at this level. */
1959 match_attr_spec (void)
1962 /* Modifiers that can exist in a type statement. */
1964 { GFC_DECL_BEGIN
= 0,
1965 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
1966 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
1967 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
1968 DECL_TARGET
, DECL_COLON
, DECL_NONE
,
1969 GFC_DECL_END
/* Sentinel */
1973 /* GFC_DECL_END is the sentinel, index starts at 0. */
1974 #define NUM_DECL GFC_DECL_END
1976 static mstring decls
[] = {
1977 minit (", allocatable", DECL_ALLOCATABLE
),
1978 minit (", dimension", DECL_DIMENSION
),
1979 minit (", external", DECL_EXTERNAL
),
1980 minit (", intent ( in )", DECL_IN
),
1981 minit (", intent ( out )", DECL_OUT
),
1982 minit (", intent ( in out )", DECL_INOUT
),
1983 minit (", intrinsic", DECL_INTRINSIC
),
1984 minit (", optional", DECL_OPTIONAL
),
1985 minit (", parameter", DECL_PARAMETER
),
1986 minit (", pointer", DECL_POINTER
),
1987 minit (", private", DECL_PRIVATE
),
1988 minit (", public", DECL_PUBLIC
),
1989 minit (", save", DECL_SAVE
),
1990 minit (", target", DECL_TARGET
),
1991 minit ("::", DECL_COLON
),
1992 minit (NULL
, DECL_NONE
)
1995 locus start
, seen_at
[NUM_DECL
];
2002 gfc_clear_attr (¤t_attr
);
2003 start
= gfc_current_locus
;
2008 /* See if we get all of the keywords up to the final double colon. */
2009 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2014 d
= (decl_types
) gfc_match_strings (decls
);
2015 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2018 if (gfc_current_state () == COMP_ENUM
)
2020 gfc_error ("Enumerator cannot have attributes %C");
2025 seen_at
[d
] = gfc_current_locus
;
2027 if (d
== DECL_DIMENSION
)
2029 m
= gfc_match_array_spec (¤t_as
);
2033 gfc_error ("Missing dimension specification at %C");
2037 if (m
== MATCH_ERROR
)
2042 /* If we are parsing an enumeration and have ensured that no other
2043 attributes are present we can now set the parameter attribute. */
2044 if (gfc_current_state () == COMP_ENUM
)
2046 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
2054 /* No double colon, so assume that we've been looking at something
2055 else the whole time. */
2062 /* Since we've seen a double colon, we have to be looking at an
2063 attr-spec. This means that we can now issue errors. */
2064 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2069 case DECL_ALLOCATABLE
:
2070 attr
= "ALLOCATABLE";
2072 case DECL_DIMENSION
:
2079 attr
= "INTENT (IN)";
2082 attr
= "INTENT (OUT)";
2085 attr
= "INTENT (IN OUT)";
2087 case DECL_INTRINSIC
:
2093 case DECL_PARAMETER
:
2112 attr
= NULL
; /* This shouldn't happen */
2115 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2120 /* Now that we've dealt with duplicate attributes, add the attributes
2121 to the current attribute. */
2122 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2127 if (gfc_current_state () == COMP_DERIVED
2128 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2129 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2132 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2138 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2139 && gfc_current_state () != COMP_MODULE
)
2141 if (d
== DECL_PRIVATE
)
2146 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2154 case DECL_ALLOCATABLE
:
2155 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2158 case DECL_DIMENSION
:
2159 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2163 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2167 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2171 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2175 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2178 case DECL_INTRINSIC
:
2179 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2183 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2186 case DECL_PARAMETER
:
2187 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2191 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2195 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2200 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2205 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2209 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2213 gfc_internal_error ("match_attr_spec(): Bad attribute");
2227 gfc_current_locus
= start
;
2228 gfc_free_array_spec (current_as
);
2234 /* Match a data declaration statement. */
2237 gfc_match_data_decl (void)
2243 m
= match_type_spec (¤t_ts
, 0);
2247 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2249 sym
= gfc_use_derived (current_ts
.derived
);
2257 current_ts
.derived
= sym
;
2260 m
= match_attr_spec ();
2261 if (m
== MATCH_ERROR
)
2267 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2270 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2273 gfc_find_symbol (current_ts
.derived
->name
,
2274 current_ts
.derived
->ns
->parent
, 1, &sym
);
2276 /* Any symbol that we find had better be a type definition
2277 which has its components defined. */
2278 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2279 && current_ts
.derived
->components
!= NULL
)
2282 /* Now we have an error, which we signal, and then fix up
2283 because the knock-on is plain and simple confusing. */
2284 gfc_error_now ("Derived type at %C has not been previously defined "
2285 "and so cannot appear in a derived type definition.");
2286 current_attr
.pointer
= 1;
2291 /* If we have an old-style character declaration, and no new-style
2292 attribute specifications, then there a comma is optional between
2293 the type specification and the variable list. */
2294 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2295 gfc_match_char (',');
2297 /* Give the types/attributes to symbols that follow. Give the element
2298 a number so that repeat character length expressions can be copied. */
2302 m
= variable_decl (elem
++);
2303 if (m
== MATCH_ERROR
)
2308 if (gfc_match_eos () == MATCH_YES
)
2310 if (gfc_match_char (',') != MATCH_YES
)
2314 gfc_error ("Syntax error in data declaration at %C");
2318 gfc_free_array_spec (current_as
);
2324 /* Match a prefix associated with a function or subroutine
2325 declaration. If the typespec pointer is nonnull, then a typespec
2326 can be matched. Note that if nothing matches, MATCH_YES is
2327 returned (the null string was matched). */
2330 match_prefix (gfc_typespec
* ts
)
2334 gfc_clear_attr (¤t_attr
);
2338 if (!seen_type
&& ts
!= NULL
2339 && match_type_spec (ts
, 0) == MATCH_YES
2340 && gfc_match_space () == MATCH_YES
)
2347 if (gfc_match ("elemental% ") == MATCH_YES
)
2349 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2355 if (gfc_match ("pure% ") == MATCH_YES
)
2357 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2363 if (gfc_match ("recursive% ") == MATCH_YES
)
2365 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2371 /* At this point, the next item is not a prefix. */
2376 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2379 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2382 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2385 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2388 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2395 /* Match a formal argument list. */
2398 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2400 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2401 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2407 if (gfc_match_char ('(') != MATCH_YES
)
2414 if (gfc_match_char (')') == MATCH_YES
)
2419 if (gfc_match_char ('*') == MATCH_YES
)
2423 m
= gfc_match_name (name
);
2427 if (gfc_get_symbol (name
, NULL
, &sym
))
2431 p
= gfc_get_formal_arglist ();
2443 /* We don't add the VARIABLE flavor because the name could be a
2444 dummy procedure. We don't apply these attributes to formal
2445 arguments of statement functions. */
2446 if (sym
!= NULL
&& !st_flag
2447 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2448 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2454 /* The name of a program unit can be in a different namespace,
2455 so check for it explicitly. After the statement is accepted,
2456 the name is checked for especially in gfc_get_symbol(). */
2457 if (gfc_new_block
!= NULL
&& sym
!= NULL
2458 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2460 gfc_error ("Name '%s' at %C is the name of the procedure",
2466 if (gfc_match_char (')') == MATCH_YES
)
2469 m
= gfc_match_char (',');
2472 gfc_error ("Unexpected junk in formal argument list at %C");
2478 /* Check for duplicate symbols in the formal argument list. */
2481 for (p
= head
; p
->next
; p
= p
->next
)
2486 for (q
= p
->next
; q
; q
= q
->next
)
2487 if (p
->sym
== q
->sym
)
2490 ("Duplicate symbol '%s' in formal argument list at %C",
2499 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2509 gfc_free_formal_arglist (head
);
2514 /* Match a RESULT specification following a function declaration or
2515 ENTRY statement. Also matches the end-of-statement. */
2518 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2520 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2524 if (gfc_match (" result (") != MATCH_YES
)
2527 m
= gfc_match_name (name
);
2531 if (gfc_match (" )%t") != MATCH_YES
)
2533 gfc_error ("Unexpected junk following RESULT variable at %C");
2537 if (strcmp (function
->name
, name
) == 0)
2540 ("RESULT variable at %C must be different than function name");
2544 if (gfc_get_symbol (name
, NULL
, &r
))
2547 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2548 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2557 /* Match a function declaration. */
2560 gfc_match_function_decl (void)
2562 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2563 gfc_symbol
*sym
, *result
;
2567 if (gfc_current_state () != COMP_NONE
2568 && gfc_current_state () != COMP_INTERFACE
2569 && gfc_current_state () != COMP_CONTAINS
)
2572 gfc_clear_ts (¤t_ts
);
2574 old_loc
= gfc_current_locus
;
2576 m
= match_prefix (¤t_ts
);
2579 gfc_current_locus
= old_loc
;
2583 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2585 gfc_current_locus
= old_loc
;
2589 if (get_proc_name (name
, &sym
, false))
2591 gfc_new_block
= sym
;
2593 m
= gfc_match_formal_arglist (sym
, 0, 0);
2596 gfc_error ("Expected formal argument list in function "
2597 "definition at %C");
2601 else if (m
== MATCH_ERROR
)
2606 if (gfc_match_eos () != MATCH_YES
)
2608 /* See if a result variable is present. */
2609 m
= match_result (sym
, &result
);
2611 gfc_error ("Unexpected junk after function declaration at %C");
2620 /* Make changes to the symbol. */
2623 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2626 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2627 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2630 if (current_ts
.type
!= BT_UNKNOWN
&& sym
->ts
.type
!= BT_UNKNOWN
)
2632 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2633 gfc_basic_typename (sym
->ts
.type
));
2639 sym
->ts
= current_ts
;
2644 result
->ts
= current_ts
;
2645 sym
->result
= result
;
2651 gfc_current_locus
= old_loc
;
2655 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2656 name of the entry, rather than the gfc_current_block name, and to return false
2657 upon finding an existing global entry. */
2660 add_global_entry (const char * name
, int sub
)
2664 s
= gfc_get_gsymbol(name
);
2667 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2668 global_used(s
, NULL
);
2671 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2672 s
->where
= gfc_current_locus
;
2679 /* Match an ENTRY statement. */
2682 gfc_match_entry (void)
2687 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2688 gfc_compile_state state
;
2692 bool module_procedure
;
2694 m
= gfc_match_name (name
);
2698 state
= gfc_current_state ();
2699 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2704 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2707 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2709 case COMP_BLOCK_DATA
:
2711 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2713 case COMP_INTERFACE
:
2715 ("ENTRY statement at %C cannot appear within an INTERFACE");
2719 ("ENTRY statement at %C cannot appear "
2720 "within a DERIVED TYPE block");
2724 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2728 ("ENTRY statement at %C cannot appear within a DO block");
2732 ("ENTRY statement at %C cannot appear within a SELECT block");
2736 ("ENTRY statement at %C cannot appear within a FORALL block");
2740 ("ENTRY statement at %C cannot appear within a WHERE block");
2744 ("ENTRY statement at %C cannot appear "
2745 "within a contained subprogram");
2748 gfc_internal_error ("gfc_match_entry(): Bad state");
2753 module_procedure
= gfc_current_ns
->parent
!= NULL
2754 && gfc_current_ns
->parent
->proc_name
2755 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
;
2757 if (gfc_current_ns
->parent
!= NULL
2758 && gfc_current_ns
->parent
->proc_name
2759 && !module_procedure
)
2761 gfc_error("ENTRY statement at %C cannot appear in a "
2762 "contained procedure");
2766 /* Module function entries need special care in get_proc_name
2767 because previous references within the function will have
2768 created symbols attached to the current namespace. */
2769 if (get_proc_name (name
, &entry
,
2770 gfc_current_ns
->parent
!= NULL
2772 && gfc_current_ns
->proc_name
->attr
.function
))
2775 proc
= gfc_current_block ();
2777 if (state
== COMP_SUBROUTINE
)
2779 /* An entry in a subroutine. */
2780 if (!add_global_entry (name
, 1))
2783 m
= gfc_match_formal_arglist (entry
, 0, 1);
2787 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2788 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2793 /* An entry in a function.
2794 We need to take special care because writing
2799 ENTRY f() RESULT (r)
2801 ENTRY f RESULT (r). */
2802 if (!add_global_entry (name
, 0))
2805 old_loc
= gfc_current_locus
;
2806 if (gfc_match_eos () == MATCH_YES
)
2808 gfc_current_locus
= old_loc
;
2809 /* Match the empty argument list, and add the interface to
2811 m
= gfc_match_formal_arglist (entry
, 0, 1);
2814 m
= gfc_match_formal_arglist (entry
, 0, 0);
2821 if (gfc_match_eos () == MATCH_YES
)
2823 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2824 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2827 entry
->result
= entry
;
2831 m
= match_result (proc
, &result
);
2833 gfc_syntax_error (ST_ENTRY
);
2837 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2838 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2839 || gfc_add_function (&entry
->attr
, result
->name
,
2843 entry
->result
= result
;
2846 if (proc
->attr
.recursive
&& result
== NULL
)
2848 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2853 if (gfc_match_eos () != MATCH_YES
)
2855 gfc_syntax_error (ST_ENTRY
);
2859 entry
->attr
.recursive
= proc
->attr
.recursive
;
2860 entry
->attr
.elemental
= proc
->attr
.elemental
;
2861 entry
->attr
.pure
= proc
->attr
.pure
;
2863 el
= gfc_get_entry_list ();
2865 el
->next
= gfc_current_ns
->entries
;
2866 gfc_current_ns
->entries
= el
;
2868 el
->id
= el
->next
->id
+ 1;
2872 new_st
.op
= EXEC_ENTRY
;
2873 new_st
.ext
.entry
= el
;
2879 /* Match a subroutine statement, including optional prefixes. */
2882 gfc_match_subroutine (void)
2884 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2888 if (gfc_current_state () != COMP_NONE
2889 && gfc_current_state () != COMP_INTERFACE
2890 && gfc_current_state () != COMP_CONTAINS
)
2893 m
= match_prefix (NULL
);
2897 m
= gfc_match ("subroutine% %n", name
);
2901 if (get_proc_name (name
, &sym
, false))
2903 gfc_new_block
= sym
;
2905 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2908 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
2911 if (gfc_match_eos () != MATCH_YES
)
2913 gfc_syntax_error (ST_SUBROUTINE
);
2917 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2924 /* Return nonzero if we're currently compiling a contained procedure. */
2927 contained_procedure (void)
2931 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
2932 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
2933 && s
->previous
!= NULL
2934 && s
->previous
->state
== COMP_CONTAINS
)
2940 /* Set the kind of each enumerator. The kind is selected such that it is
2941 interoperable with the corresponding C enumeration type, making
2942 sure that -fshort-enums is honored. */
2947 enumerator_history
*current_history
= NULL
;
2951 if (max_enum
== NULL
|| enum_history
== NULL
)
2954 if (!gfc_option
.fshort_enums
)
2960 kind
= gfc_integer_kinds
[i
++].kind
;
2962 while (kind
< gfc_c_int_kind
2963 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
2966 current_history
= enum_history
;
2967 while (current_history
!= NULL
)
2969 current_history
->sym
->ts
.kind
= kind
;
2970 current_history
= current_history
->next
;
2974 /* Match any of the various end-block statements. Returns the type of
2975 END to the caller. The END INTERFACE, END IF, END DO and END
2976 SELECT statements cannot be replaced by a single END statement. */
2979 gfc_match_end (gfc_statement
* st
)
2981 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2982 gfc_compile_state state
;
2984 const char *block_name
;
2989 old_loc
= gfc_current_locus
;
2990 if (gfc_match ("end") != MATCH_YES
)
2993 state
= gfc_current_state ();
2995 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
2997 if (state
== COMP_CONTAINS
)
2999 state
= gfc_state_stack
->previous
->state
;
3000 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
3001 : gfc_state_stack
->previous
->sym
->name
;
3008 *st
= ST_END_PROGRAM
;
3009 target
= " program";
3013 case COMP_SUBROUTINE
:
3014 *st
= ST_END_SUBROUTINE
;
3015 target
= " subroutine";
3016 eos_ok
= !contained_procedure ();
3020 *st
= ST_END_FUNCTION
;
3021 target
= " function";
3022 eos_ok
= !contained_procedure ();
3025 case COMP_BLOCK_DATA
:
3026 *st
= ST_END_BLOCK_DATA
;
3027 target
= " block data";
3032 *st
= ST_END_MODULE
;
3037 case COMP_INTERFACE
:
3038 *st
= ST_END_INTERFACE
;
3039 target
= " interface";
3062 *st
= ST_END_SELECT
;
3068 *st
= ST_END_FORALL
;
3083 last_initializer
= NULL
;
3085 gfc_free_enum_history ();
3089 gfc_error ("Unexpected END statement at %C");
3093 if (gfc_match_eos () == MATCH_YES
)
3097 /* We would have required END [something] */
3098 gfc_error ("%s statement expected at %L",
3099 gfc_ascii_statement (*st
), &old_loc
);
3106 /* Verify that we've got the sort of end-block that we're expecting. */
3107 if (gfc_match (target
) != MATCH_YES
)
3109 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3113 /* If we're at the end, make sure a block name wasn't required. */
3114 if (gfc_match_eos () == MATCH_YES
)
3117 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3120 if (gfc_current_block () == NULL
)
3123 gfc_error ("Expected block name of '%s' in %s statement at %C",
3124 block_name
, gfc_ascii_statement (*st
));
3129 /* END INTERFACE has a special handler for its several possible endings. */
3130 if (*st
== ST_END_INTERFACE
)
3131 return gfc_match_end_interface ();
3133 /* We haven't hit the end of statement, so what is left must be an end-name. */
3134 m
= gfc_match_space ();
3136 m
= gfc_match_name (name
);
3139 gfc_error ("Expected terminating name at %C");
3143 if (block_name
== NULL
)
3146 if (strcmp (name
, block_name
) != 0)
3148 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3149 gfc_ascii_statement (*st
));
3153 if (gfc_match_eos () == MATCH_YES
)
3157 gfc_syntax_error (*st
);
3160 gfc_current_locus
= old_loc
;
3166 /***************** Attribute declaration statements ****************/
3168 /* Set the attribute of a single variable. */
3173 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3181 m
= gfc_match_name (name
);
3185 if (find_special (name
, &sym
))
3188 var_locus
= gfc_current_locus
;
3190 /* Deal with possible array specification for certain attributes. */
3191 if (current_attr
.dimension
3192 || current_attr
.allocatable
3193 || current_attr
.pointer
3194 || current_attr
.target
)
3196 m
= gfc_match_array_spec (&as
);
3197 if (m
== MATCH_ERROR
)
3200 if (current_attr
.dimension
&& m
== MATCH_NO
)
3203 ("Missing array specification at %L in DIMENSION statement",
3209 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3210 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3212 gfc_error ("Array specification must be deferred at %L",
3219 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3220 if (current_attr
.dimension
== 0
3221 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3227 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3233 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3235 /* Fix the array spec. */
3236 m
= gfc_mod_pointee_as (sym
->as
);
3237 if (m
== MATCH_ERROR
)
3241 if (gfc_add_attribute (&sym
->attr
, &var_locus
, current_attr
.intent
) == FAILURE
)
3247 if ((current_attr
.external
|| current_attr
.intrinsic
)
3248 && sym
->attr
.flavor
!= FL_PROCEDURE
3249 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3258 gfc_free_array_spec (as
);
3263 /* Generic attribute declaration subroutine. Used for attributes that
3264 just have a list of names. */
3271 /* Gobble the optional double colon, by simply ignoring the result
3281 if (gfc_match_eos () == MATCH_YES
)
3287 if (gfc_match_char (',') != MATCH_YES
)
3289 gfc_error ("Unexpected character in variable list at %C");
3299 /* This routine matches Cray Pointer declarations of the form:
3300 pointer ( <pointer>, <pointee> )
3302 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3303 The pointer, if already declared, should be an integer. Otherwise, we
3304 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3305 be either a scalar, or an array declaration. No space is allocated for
3306 the pointee. For the statement
3307 pointer (ipt, ar(10))
3308 any subsequent uses of ar will be translated (in C-notation) as
3309 ar(i) => ((<type> *) ipt)(i)
3310 After gimplification, pointee variable will disappear in the code. */
3313 cray_pointer_decl (void)
3317 gfc_symbol
*cptr
; /* Pointer symbol. */
3318 gfc_symbol
*cpte
; /* Pointee symbol. */
3324 if (gfc_match_char ('(') != MATCH_YES
)
3326 gfc_error ("Expected '(' at %C");
3330 /* Match pointer. */
3331 var_locus
= gfc_current_locus
;
3332 gfc_clear_attr (¤t_attr
);
3333 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3334 current_ts
.type
= BT_INTEGER
;
3335 current_ts
.kind
= gfc_index_integer_kind
;
3337 m
= gfc_match_symbol (&cptr
, 0);
3340 gfc_error ("Expected variable name at %C");
3344 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3347 gfc_set_sym_referenced (cptr
);
3349 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3351 cptr
->ts
.type
= BT_INTEGER
;
3352 cptr
->ts
.kind
= gfc_index_integer_kind
;
3354 else if (cptr
->ts
.type
!= BT_INTEGER
)
3356 gfc_error ("Cray pointer at %C must be an integer.");
3359 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3360 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3361 " memory addresses require %d bytes.",
3363 gfc_index_integer_kind
);
3365 if (gfc_match_char (',') != MATCH_YES
)
3367 gfc_error ("Expected \",\" at %C");
3371 /* Match Pointee. */
3372 var_locus
= gfc_current_locus
;
3373 gfc_clear_attr (¤t_attr
);
3374 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3375 current_ts
.type
= BT_UNKNOWN
;
3376 current_ts
.kind
= 0;
3378 m
= gfc_match_symbol (&cpte
, 0);
3381 gfc_error ("Expected variable name at %C");
3385 /* Check for an optional array spec. */
3386 m
= gfc_match_array_spec (&as
);
3387 if (m
== MATCH_ERROR
)
3389 gfc_free_array_spec (as
);
3392 else if (m
== MATCH_NO
)
3394 gfc_free_array_spec (as
);
3398 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3401 gfc_set_sym_referenced (cpte
);
3403 if (cpte
->as
== NULL
)
3405 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3406 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3408 else if (as
!= NULL
)
3410 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3411 gfc_free_array_spec (as
);
3417 if (cpte
->as
!= NULL
)
3419 /* Fix array spec. */
3420 m
= gfc_mod_pointee_as (cpte
->as
);
3421 if (m
== MATCH_ERROR
)
3425 /* Point the Pointee at the Pointer. */
3426 cpte
->cp_pointer
= cptr
;
3428 if (gfc_match_char (')') != MATCH_YES
)
3430 gfc_error ("Expected \")\" at %C");
3433 m
= gfc_match_char (',');
3435 done
= true; /* Stop searching for more declarations. */
3439 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3440 || gfc_match_eos () != MATCH_YES
)
3442 gfc_error ("Expected \",\" or end of statement at %C");
3450 gfc_match_external (void)
3453 gfc_clear_attr (¤t_attr
);
3454 current_attr
.external
= 1;
3456 return attr_decl ();
3462 gfc_match_intent (void)
3466 intent
= match_intent_spec ();
3467 if (intent
== INTENT_UNKNOWN
)
3470 gfc_clear_attr (¤t_attr
);
3471 current_attr
.intent
= intent
;
3473 return attr_decl ();
3478 gfc_match_intrinsic (void)
3481 gfc_clear_attr (¤t_attr
);
3482 current_attr
.intrinsic
= 1;
3484 return attr_decl ();
3489 gfc_match_optional (void)
3492 gfc_clear_attr (¤t_attr
);
3493 current_attr
.optional
= 1;
3495 return attr_decl ();
3500 gfc_match_pointer (void)
3502 gfc_gobble_whitespace ();
3503 if (gfc_peek_char () == '(')
3505 if (!gfc_option
.flag_cray_pointer
)
3507 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3511 return cray_pointer_decl ();
3515 gfc_clear_attr (¤t_attr
);
3516 current_attr
.pointer
= 1;
3518 return attr_decl ();
3524 gfc_match_allocatable (void)
3527 gfc_clear_attr (¤t_attr
);
3528 current_attr
.allocatable
= 1;
3530 return attr_decl ();
3535 gfc_match_dimension (void)
3538 gfc_clear_attr (¤t_attr
);
3539 current_attr
.dimension
= 1;
3541 return attr_decl ();
3546 gfc_match_target (void)
3549 gfc_clear_attr (¤t_attr
);
3550 current_attr
.target
= 1;
3552 return attr_decl ();
3556 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3560 access_attr_decl (gfc_statement st
)
3562 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3563 interface_type type
;
3566 gfc_intrinsic_op
operator;
3569 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3574 m
= gfc_match_generic_spec (&type
, name
, &operator);
3577 if (m
== MATCH_ERROR
)
3582 case INTERFACE_NAMELESS
:
3585 case INTERFACE_GENERIC
:
3586 if (gfc_get_symbol (name
, NULL
, &sym
))
3589 if (gfc_add_access (&sym
->attr
,
3591 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3592 sym
->name
, NULL
) == FAILURE
)
3597 case INTERFACE_INTRINSIC_OP
:
3598 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3600 gfc_current_ns
->operator_access
[operator] =
3601 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3605 gfc_error ("Access specification of the %s operator at %C has "
3606 "already been specified", gfc_op2string (operator));
3612 case INTERFACE_USER_OP
:
3613 uop
= gfc_get_uop (name
);
3615 if (uop
->access
== ACCESS_UNKNOWN
)
3618 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3623 ("Access specification of the .%s. operator at %C has "
3624 "already been specified", sym
->name
);
3631 if (gfc_match_char (',') == MATCH_NO
)
3635 if (gfc_match_eos () != MATCH_YES
)
3640 gfc_syntax_error (st
);
3647 /* The PRIVATE statement is a bit weird in that it can be a attribute
3648 declaration, but also works as a standlone statement inside of a
3649 type declaration or a module. */
3652 gfc_match_private (gfc_statement
* st
)
3655 if (gfc_match ("private") != MATCH_YES
)
3658 if (gfc_current_state () == COMP_DERIVED
)
3660 if (gfc_match_eos () == MATCH_YES
)
3666 gfc_syntax_error (ST_PRIVATE
);
3670 if (gfc_match_eos () == MATCH_YES
)
3677 return access_attr_decl (ST_PRIVATE
);
3682 gfc_match_public (gfc_statement
* st
)
3685 if (gfc_match ("public") != MATCH_YES
)
3688 if (gfc_match_eos () == MATCH_YES
)
3695 return access_attr_decl (ST_PUBLIC
);
3699 /* Workhorse for gfc_match_parameter. */
3708 m
= gfc_match_symbol (&sym
, 0);
3710 gfc_error ("Expected variable name at %C in PARAMETER statement");
3715 if (gfc_match_char ('=') == MATCH_NO
)
3717 gfc_error ("Expected = sign in PARAMETER statement at %C");
3721 m
= gfc_match_init_expr (&init
);
3723 gfc_error ("Expected expression at %C in PARAMETER statement");
3727 if (sym
->ts
.type
== BT_UNKNOWN
3728 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3734 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3735 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3741 if (sym
->ts
.type
== BT_CHARACTER
3742 && sym
->ts
.cl
!= NULL
3743 && sym
->ts
.cl
->length
!= NULL
3744 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3745 && init
->expr_type
== EXPR_CONSTANT
3746 && init
->ts
.type
== BT_CHARACTER
3747 && init
->ts
.kind
== 1)
3748 gfc_set_constant_character_len (
3749 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3755 gfc_free_expr (init
);
3760 /* Match a parameter statement, with the weird syntax that these have. */
3763 gfc_match_parameter (void)
3767 if (gfc_match_char ('(') == MATCH_NO
)
3776 if (gfc_match (" )%t") == MATCH_YES
)
3779 if (gfc_match_char (',') != MATCH_YES
)
3781 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3791 /* Save statements have a special syntax. */
3794 gfc_match_save (void)
3796 char n
[GFC_MAX_SYMBOL_LEN
+1];
3801 if (gfc_match_eos () == MATCH_YES
)
3803 if (gfc_current_ns
->seen_save
)
3805 if (gfc_notify_std (GFC_STD_LEGACY
,
3806 "Blanket SAVE statement at %C follows previous "
3812 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3816 if (gfc_current_ns
->save_all
)
3818 if (gfc_notify_std (GFC_STD_LEGACY
,
3819 "SAVE statement at %C follows blanket SAVE statement")
3828 m
= gfc_match_symbol (&sym
, 0);
3832 if (gfc_add_save (&sym
->attr
, sym
->name
,
3833 &gfc_current_locus
) == FAILURE
)
3844 m
= gfc_match (" / %n /", &n
);
3845 if (m
== MATCH_ERROR
)
3850 c
= gfc_get_common (n
, 0);
3853 gfc_current_ns
->seen_save
= 1;
3856 if (gfc_match_eos () == MATCH_YES
)
3858 if (gfc_match_char (',') != MATCH_YES
)
3865 gfc_error ("Syntax error in SAVE statement at %C");
3870 /* Match a module procedure statement. Note that we have to modify
3871 symbols in the parent's namespace because the current one was there
3872 to receive symbols that are in an interface's formal argument list. */
3875 gfc_match_modproc (void)
3877 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3881 if (gfc_state_stack
->state
!= COMP_INTERFACE
3882 || gfc_state_stack
->previous
== NULL
3883 || current_interface
.type
== INTERFACE_NAMELESS
)
3886 ("MODULE PROCEDURE at %C must be in a generic module interface");
3892 m
= gfc_match_name (name
);
3898 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
3901 if (sym
->attr
.proc
!= PROC_MODULE
3902 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
3903 sym
->name
, NULL
) == FAILURE
)
3906 if (gfc_add_interface (sym
) == FAILURE
)
3909 if (gfc_match_eos () == MATCH_YES
)
3911 if (gfc_match_char (',') != MATCH_YES
)
3918 gfc_syntax_error (ST_MODULE_PROC
);
3923 /* Match the beginning of a derived type declaration. If a type name
3924 was the result of a function, then it is possible to have a symbol
3925 already to be known as a derived type yet have no components. */
3928 gfc_match_derived_decl (void)
3930 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3931 symbol_attribute attr
;
3935 if (gfc_current_state () == COMP_DERIVED
)
3938 gfc_clear_attr (&attr
);
3941 if (gfc_match (" , private") == MATCH_YES
)
3943 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3946 ("Derived type at %C can only be PRIVATE within a MODULE");
3950 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
3955 if (gfc_match (" , public") == MATCH_YES
)
3957 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
3959 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3963 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
3968 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
3970 gfc_error ("Expected :: in TYPE definition at %C");
3974 m
= gfc_match (" %n%t", name
);
3978 /* Make sure the name isn't the name of an intrinsic type. The
3979 'double precision' type doesn't get past the name matcher. */
3980 if (strcmp (name
, "integer") == 0
3981 || strcmp (name
, "real") == 0
3982 || strcmp (name
, "character") == 0
3983 || strcmp (name
, "logical") == 0
3984 || strcmp (name
, "complex") == 0)
3987 ("Type name '%s' at %C cannot be the same as an intrinsic type",
3992 if (gfc_get_symbol (name
, NULL
, &sym
))
3995 if (sym
->ts
.type
!= BT_UNKNOWN
)
3997 gfc_error ("Derived type name '%s' at %C already has a basic type "
3998 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
4002 /* The symbol may already have the derived attribute without the
4003 components. The ways this can happen is via a function
4004 definition, an INTRINSIC statement or a subtype in another
4005 derived type that is a pointer. The first part of the AND clause
4006 is true if a the symbol is not the return value of a function. */
4007 if (sym
->attr
.flavor
!= FL_DERIVED
4008 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
4011 if (sym
->components
!= NULL
)
4014 ("Derived type definition of '%s' at %C has already been defined",
4019 if (attr
.access
!= ACCESS_UNKNOWN
4020 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
4023 gfc_new_block
= sym
;
4029 /* Cray Pointees can be declared as:
4030 pointer (ipt, a (n,m,...,*))
4031 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4032 cheat and set a constant bound of 1 for the last dimension, if this
4033 is the case. Since there is no bounds-checking for Cray Pointees,
4034 this will be okay. */
4037 gfc_mod_pointee_as (gfc_array_spec
*as
)
4039 as
->cray_pointee
= true; /* This will be useful to know later. */
4040 if (as
->type
== AS_ASSUMED_SIZE
)
4042 as
->type
= AS_EXPLICIT
;
4043 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4044 as
->cp_was_assumed
= true;
4046 else if (as
->type
== AS_ASSUMED_SHAPE
)
4048 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4055 /* Match the enum definition statement, here we are trying to match
4056 the first line of enum definition statement.
4057 Returns MATCH_YES if match is found. */
4060 gfc_match_enum (void)
4064 m
= gfc_match_eos ();
4068 if (gfc_notify_std (GFC_STD_F2003
,
4069 "New in Fortran 2003: ENUM AND ENUMERATOR at %C")
4077 /* Match the enumerator definition statement. */
4080 gfc_match_enumerator_def (void)
4085 gfc_clear_ts (¤t_ts
);
4087 m
= gfc_match (" enumerator");
4091 if (gfc_current_state () != COMP_ENUM
)
4093 gfc_error ("ENUM definition statement expected before %C");
4094 gfc_free_enum_history ();
4098 (¤t_ts
)->type
= BT_INTEGER
;
4099 (¤t_ts
)->kind
= gfc_c_int_kind
;
4101 m
= match_attr_spec ();
4102 if (m
== MATCH_ERROR
)
4111 m
= variable_decl (elem
++);
4112 if (m
== MATCH_ERROR
)
4117 if (gfc_match_eos () == MATCH_YES
)
4119 if (gfc_match_char (',') != MATCH_YES
)
4123 if (gfc_current_state () == COMP_ENUM
)
4125 gfc_free_enum_history ();
4126 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4131 gfc_free_array_spec (current_as
);