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 /* Free all data in a namespace. */
133 gfc_free_data_all (gfc_namespace
* ns
)
146 static match
var_element (gfc_data_variable
*);
148 /* Match a list of variables terminated by an iterator and a right
152 var_list (gfc_data_variable
* parent
)
154 gfc_data_variable
*tail
, var
;
157 m
= var_element (&var
);
158 if (m
== MATCH_ERROR
)
163 tail
= gfc_get_data_variable ();
170 if (gfc_match_char (',') != MATCH_YES
)
173 m
= gfc_match_iterator (&parent
->iter
, 1);
176 if (m
== MATCH_ERROR
)
179 m
= var_element (&var
);
180 if (m
== MATCH_ERROR
)
185 tail
->next
= gfc_get_data_variable ();
191 if (gfc_match_char (')') != MATCH_YES
)
196 gfc_syntax_error (ST_DATA
);
201 /* Match a single element in a data variable list, which can be a
202 variable-iterator list. */
205 var_element (gfc_data_variable
* new)
210 memset (new, 0, sizeof (gfc_data_variable
));
212 if (gfc_match_char ('(') == MATCH_YES
)
213 return var_list (new);
215 m
= gfc_match_variable (&new->expr
, 0);
219 sym
= new->expr
->symtree
->n
.sym
;
221 if (!sym
->attr
.function
&& gfc_current_ns
->parent
&& gfc_current_ns
->parent
== sym
->ns
)
223 gfc_error ("Host associated variable '%s' may not be in the DATA "
224 "statement at %C.", sym
->name
);
228 if (gfc_current_state () != COMP_BLOCK_DATA
229 && sym
->attr
.in_common
230 && gfc_notify_std (GFC_STD_GNU
, "Extension: initialization of "
231 "common block variable '%s' in DATA statement at %C",
232 sym
->name
) == FAILURE
)
235 if (gfc_add_data (&sym
->attr
, sym
->name
, &new->expr
->where
) == FAILURE
)
242 /* Match the top-level list of data variables. */
245 top_var_list (gfc_data
* d
)
247 gfc_data_variable var
, *tail
, *new;
254 m
= var_element (&var
);
257 if (m
== MATCH_ERROR
)
260 new = gfc_get_data_variable ();
270 if (gfc_match_char ('/') == MATCH_YES
)
272 if (gfc_match_char (',') != MATCH_YES
)
279 gfc_syntax_error (ST_DATA
);
280 gfc_free_data_all (gfc_current_ns
);
286 match_data_constant (gfc_expr
** result
)
288 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
293 m
= gfc_match_literal_constant (&expr
, 1);
300 if (m
== MATCH_ERROR
)
303 m
= gfc_match_null (result
);
307 m
= gfc_match_name (name
);
311 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
315 || (sym
->attr
.flavor
!= FL_PARAMETER
&& sym
->attr
.flavor
!= FL_DERIVED
))
317 gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
321 else if (sym
->attr
.flavor
== FL_DERIVED
)
322 return gfc_match_structure_constructor (sym
, result
);
324 *result
= gfc_copy_expr (sym
->value
);
329 /* Match a list of values in a DATA statement. The leading '/' has
330 already been seen at this point. */
333 top_val_list (gfc_data
* data
)
335 gfc_data_value
*new, *tail
;
344 m
= match_data_constant (&expr
);
347 if (m
== MATCH_ERROR
)
350 new = gfc_get_data_value ();
359 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
367 msg
= gfc_extract_int (expr
, &tmp
);
368 gfc_free_expr (expr
);
376 m
= match_data_constant (&tail
->expr
);
379 if (m
== MATCH_ERROR
)
383 if (gfc_match_char ('/') == MATCH_YES
)
385 if (gfc_match_char (',') == MATCH_NO
)
392 gfc_syntax_error (ST_DATA
);
393 gfc_free_data_all (gfc_current_ns
);
398 /* Matches an old style initialization. */
401 match_old_style_init (const char *name
)
408 /* Set up data structure to hold initializers. */
409 gfc_find_sym_tree (name
, NULL
, 0, &st
);
412 newdata
= gfc_get_data ();
413 newdata
->var
= gfc_get_data_variable ();
414 newdata
->var
->expr
= gfc_get_variable_expr (st
);
415 newdata
->where
= gfc_current_locus
;
417 /* Match initial value list. This also eats the terminal
419 m
= top_val_list (newdata
);
428 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
433 /* Mark the variable as having appeared in a data statement. */
434 if (gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
) == FAILURE
)
440 /* Chain in namespace list of DATA initializers. */
441 newdata
->next
= gfc_current_ns
->data
;
442 gfc_current_ns
->data
= newdata
;
447 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
448 we are matching a DATA statement and are therefore issuing an error
449 if we encounter something unexpected, if not, we're trying to match
450 an old-style initialization expression of the form INTEGER I /2/. */
453 gfc_match_data (void)
460 new = gfc_get_data ();
461 new->where
= gfc_current_locus
;
463 m
= top_var_list (new);
467 m
= top_val_list (new);
471 new->next
= gfc_current_ns
->data
;
472 gfc_current_ns
->data
= new;
474 if (gfc_match_eos () == MATCH_YES
)
477 gfc_match_char (','); /* Optional comma */
482 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
494 /************************ Declaration statements *********************/
496 /* Match an intent specification. Since this can only happen after an
497 INTENT word, a legal intent-spec must follow. */
500 match_intent_spec (void)
503 if (gfc_match (" ( in out )") == MATCH_YES
)
505 if (gfc_match (" ( in )") == MATCH_YES
)
507 if (gfc_match (" ( out )") == MATCH_YES
)
510 gfc_error ("Bad INTENT specification at %C");
511 return INTENT_UNKNOWN
;
515 /* Matches a character length specification, which is either a
516 specification expression or a '*'. */
519 char_len_param_value (gfc_expr
** expr
)
522 if (gfc_match_char ('*') == MATCH_YES
)
528 return gfc_match_expr (expr
);
532 /* A character length is a '*' followed by a literal integer or a
533 char_len_param_value in parenthesis. */
536 match_char_length (gfc_expr
** expr
)
541 m
= gfc_match_char ('*');
545 m
= gfc_match_small_literal_int (&length
, NULL
);
546 if (m
== MATCH_ERROR
)
551 *expr
= gfc_int_expr (length
);
555 if (gfc_match_char ('(') == MATCH_NO
)
558 m
= char_len_param_value (expr
);
559 if (m
== MATCH_ERROR
)
564 if (gfc_match_char (')') == MATCH_NO
)
566 gfc_free_expr (*expr
);
574 gfc_error ("Syntax error in character length specification at %C");
579 /* Special subroutine for finding a symbol. Check if the name is found
580 in the current name space. If not, and we're compiling a function or
581 subroutine and the parent compilation unit is an interface, then check
582 to see if the name we've been given is the name of the interface
583 (located in another namespace). */
586 find_special (const char *name
, gfc_symbol
** result
)
591 i
= gfc_get_symbol (name
, NULL
, result
);
595 if (gfc_current_state () != COMP_SUBROUTINE
596 && gfc_current_state () != COMP_FUNCTION
)
599 s
= gfc_state_stack
->previous
;
603 if (s
->state
!= COMP_INTERFACE
)
606 goto end
; /* Nameless interface */
608 if (strcmp (name
, s
->sym
->name
) == 0)
619 /* Special subroutine for getting a symbol node associated with a
620 procedure name, used in SUBROUTINE and FUNCTION statements. The
621 symbol is created in the parent using with symtree node in the
622 child unit pointing to the symbol. If the current namespace has no
623 parent, then the symbol is just created in the current unit. */
626 get_proc_name (const char *name
, gfc_symbol
** result
,
627 bool module_fcn_entry
)
633 /* Module functions have to be left in their own namespace because
634 they have potentially (almost certainly!) already been referenced.
635 In this sense, they are rather like external functions. This is
636 fixed up in resolve.c(resolve_entries), where the symbol name-
637 space is set to point to the master function, so that the fake
638 result mechanism can work. */
639 if (module_fcn_entry
)
640 rc
= gfc_get_symbol (name
, NULL
, result
);
642 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
645 gfc_current_ns
->refs
++;
647 if (sym
&& !sym
->new && gfc_current_state () != COMP_INTERFACE
)
649 /* Trap another encompassed procedure with the same name. All
650 these conditions are necessary to avoid picking up an entry
651 whose name clashes with that of the encompassing procedure;
652 this is handled using gsymbols to register unique,globally
654 if (sym
->attr
.flavor
!= 0
655 && sym
->attr
.proc
!= 0
656 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
657 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
658 gfc_error_now ("Procedure '%s' at %C is already defined at %L",
659 name
, &sym
->declared_at
);
661 /* Trap declarations of attributes in encompassing scope. The
662 signature for this is that ts.kind is set. Legitimate
663 references only set ts.type. */
664 if (sym
->ts
.kind
!= 0
665 && !sym
->attr
.implicit_type
666 && sym
->attr
.proc
== 0
667 && gfc_current_ns
->parent
!= NULL
668 && sym
->attr
.access
== 0
669 && !module_fcn_entry
)
670 gfc_error_now ("Procedure '%s' at %C has an explicit interface"
671 " and must not have attributes declared at %L",
672 name
, &sym
->declared_at
);
675 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
678 /* Module function entries will already have a symtree in
679 the current namespace but will need one at module level. */
680 if (module_fcn_entry
)
681 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
683 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
688 /* See if the procedure should be a module procedure */
690 if (((sym
->ns
->proc_name
!= NULL
691 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
692 && sym
->attr
.proc
!= PROC_MODULE
) || module_fcn_entry
)
693 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
694 sym
->name
, NULL
) == FAILURE
)
701 /* Function called by variable_decl() that adds a name to the symbol
705 build_sym (const char *name
, gfc_charlen
* cl
,
706 gfc_array_spec
** as
, locus
* var_locus
)
708 symbol_attribute attr
;
711 /* if (find_special (name, &sym)) */
712 if (gfc_get_symbol (name
, NULL
, &sym
))
715 /* Start updating the symbol table. Add basic type attribute
717 if (current_ts
.type
!= BT_UNKNOWN
718 &&(sym
->attr
.implicit_type
== 0
719 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
720 && gfc_add_type (sym
, ¤t_ts
, var_locus
) == FAILURE
)
723 if (sym
->ts
.type
== BT_CHARACTER
)
726 /* Add dimension attribute if present. */
727 if (gfc_set_array_spec (sym
, *as
, var_locus
) == FAILURE
)
731 /* Add attribute to symbol. The copy is so that we can reset the
732 dimension attribute. */
736 if (gfc_copy_attr (&sym
->attr
, &attr
, var_locus
) == FAILURE
)
742 /* Set character constant to the given length. The constant will be padded or
746 gfc_set_constant_character_len (int len
, gfc_expr
* expr
)
751 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
);
752 gcc_assert (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.kind
== 1);
754 slen
= expr
->value
.character
.length
;
757 s
= gfc_getmem (len
+ 1);
758 memcpy (s
, expr
->value
.character
.string
, MIN (len
, slen
));
760 memset (&s
[slen
], ' ', len
- slen
);
762 gfc_free (expr
->value
.character
.string
);
763 expr
->value
.character
.string
= s
;
764 expr
->value
.character
.length
= len
;
769 /* Function to create and update the enumerator history
770 using the information passed as arguments.
771 Pointer "max_enum" is also updated, to point to
772 enum history node containing largest initializer.
774 SYM points to the symbol node of enumerator.
775 INIT points to its enumerator value. */
778 create_enum_history(gfc_symbol
*sym
, gfc_expr
*init
)
780 enumerator_history
*new_enum_history
;
781 gcc_assert (sym
!= NULL
&& init
!= NULL
);
783 new_enum_history
= gfc_getmem (sizeof (enumerator_history
));
785 new_enum_history
->sym
= sym
;
786 new_enum_history
->initializer
= init
;
787 new_enum_history
->next
= NULL
;
789 if (enum_history
== NULL
)
791 enum_history
= new_enum_history
;
792 max_enum
= enum_history
;
796 new_enum_history
->next
= enum_history
;
797 enum_history
= new_enum_history
;
799 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
800 new_enum_history
->initializer
->value
.integer
) < 0)
801 max_enum
= new_enum_history
;
806 /* Function to free enum kind history. */
809 gfc_free_enum_history(void)
811 enumerator_history
*current
= enum_history
;
812 enumerator_history
*next
;
814 while (current
!= NULL
)
816 next
= current
->next
;
825 /* Function called by variable_decl() that adds an initialization
826 expression to a symbol. */
829 add_init_expr_to_sym (const char *name
, gfc_expr
** initp
,
832 symbol_attribute attr
;
837 if (find_special (name
, &sym
))
842 /* If this symbol is confirming an implicit parameter type,
843 then an initialization expression is not allowed. */
844 if (attr
.flavor
== FL_PARAMETER
845 && sym
->value
!= NULL
848 gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
857 gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
864 /* An initializer is required for PARAMETER declarations. */
865 if (attr
.flavor
== FL_PARAMETER
)
867 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
873 /* If a variable appears in a DATA block, it cannot have an
878 ("Variable '%s' at %C with an initializer already appears "
879 "in a DATA statement", sym
->name
);
883 /* Check if the assignment can happen. This has to be put off
884 until later for a derived type variable. */
885 if (sym
->ts
.type
!= BT_DERIVED
&& init
->ts
.type
!= BT_DERIVED
886 && gfc_check_assign_symbol (sym
, init
) == FAILURE
)
889 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
)
891 /* Update symbol character length according initializer. */
892 if (sym
->ts
.cl
->length
== NULL
)
894 /* If there are multiple CHARACTER variables declared on
895 the same line, we don't want them to share the same
897 sym
->ts
.cl
= gfc_get_charlen ();
898 sym
->ts
.cl
->next
= gfc_current_ns
->cl_list
;
899 gfc_current_ns
->cl_list
= sym
->ts
.cl
;
901 if (sym
->attr
.flavor
== FL_PARAMETER
902 && init
->expr_type
== EXPR_ARRAY
)
903 sym
->ts
.cl
->length
= gfc_copy_expr (init
->ts
.cl
->length
);
905 /* Update initializer character length according symbol. */
906 else if (sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
)
908 int len
= mpz_get_si (sym
->ts
.cl
->length
->value
.integer
);
911 if (init
->expr_type
== EXPR_CONSTANT
)
912 gfc_set_constant_character_len (len
, init
);
913 else if (init
->expr_type
== EXPR_ARRAY
)
915 gfc_free_expr (init
->ts
.cl
->length
);
916 init
->ts
.cl
->length
= gfc_copy_expr (sym
->ts
.cl
->length
);
917 for (p
= init
->value
.constructor
; p
; p
= p
->next
)
918 gfc_set_constant_character_len (len
, p
->expr
);
923 /* Add initializer. Make sure we keep the ranks sane. */
924 if (sym
->attr
.dimension
&& init
->rank
== 0)
925 init
->rank
= sym
->as
->rank
;
931 /* Maintain enumerator history. */
932 if (gfc_current_state () == COMP_ENUM
)
933 create_enum_history (sym
, init
);
939 /* Function called by variable_decl() that adds a name to a structure
943 build_struct (const char *name
, gfc_charlen
* cl
, gfc_expr
** init
,
944 gfc_array_spec
** as
)
948 /* If the current symbol is of the same derived type that we're
949 constructing, it must have the pointer attribute. */
950 if (current_ts
.type
== BT_DERIVED
951 && current_ts
.derived
== gfc_current_block ()
952 && current_attr
.pointer
== 0)
954 gfc_error ("Component at %C must have the POINTER attribute");
958 if (gfc_current_block ()->attr
.pointer
961 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
963 gfc_error ("Array component of structure at %C must have explicit "
964 "or deferred shape");
969 if (gfc_add_component (gfc_current_block (), name
, &c
) == FAILURE
)
974 gfc_set_component_attr (c
, ¤t_attr
);
976 c
->initializer
= *init
;
984 /* Check array components. */
989 gfc_error ("Allocatable component at %C must be an array");
998 if (c
->as
->type
!= AS_DEFERRED
)
1000 gfc_error ("Pointer array component of structure at %C must have a "
1005 else if (c
->allocatable
)
1007 if (c
->as
->type
!= AS_DEFERRED
)
1009 gfc_error ("Allocatable component of structure at %C must have a "
1016 if (c
->as
->type
!= AS_EXPLICIT
)
1019 ("Array component of structure at %C must have an explicit "
1029 /* Match a 'NULL()', and possibly take care of some side effects. */
1032 gfc_match_null (gfc_expr
** result
)
1038 m
= gfc_match (" null ( )");
1042 /* The NULL symbol now has to be/become an intrinsic function. */
1043 if (gfc_get_symbol ("null", NULL
, &sym
))
1045 gfc_error ("NULL() initialization at %C is ambiguous");
1049 gfc_intrinsic_symbol (sym
);
1051 if (sym
->attr
.proc
!= PROC_INTRINSIC
1052 && (gfc_add_procedure (&sym
->attr
, PROC_INTRINSIC
,
1053 sym
->name
, NULL
) == FAILURE
1054 || gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
))
1057 e
= gfc_get_expr ();
1058 e
->where
= gfc_current_locus
;
1059 e
->expr_type
= EXPR_NULL
;
1060 e
->ts
.type
= BT_UNKNOWN
;
1068 /* Match a variable name with an optional initializer. When this
1069 subroutine is called, a variable is expected to be parsed next.
1070 Depending on what is happening at the moment, updates either the
1071 symbol table or the current interface. */
1074 variable_decl (int elem
)
1076 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1077 gfc_expr
*initializer
, *char_len
;
1079 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
1090 old_locus
= gfc_current_locus
;
1092 /* When we get here, we've just matched a list of attributes and
1093 maybe a type and a double colon. The next thing we expect to see
1094 is the name of the symbol. */
1095 m
= gfc_match_name (name
);
1099 var_locus
= gfc_current_locus
;
1101 /* Now we could see the optional array spec. or character length. */
1102 m
= gfc_match_array_spec (&as
);
1103 if (gfc_option
.flag_cray_pointer
&& m
== MATCH_YES
)
1104 cp_as
= gfc_copy_array_spec (as
);
1105 else if (m
== MATCH_ERROR
)
1109 as
= gfc_copy_array_spec (current_as
);
1110 else if (gfc_current_state () == COMP_ENUM
)
1112 gfc_error ("Enumerator cannot be array at %C");
1113 gfc_free_enum_history ();
1122 if (current_ts
.type
== BT_CHARACTER
)
1124 switch (match_char_length (&char_len
))
1127 cl
= gfc_get_charlen ();
1128 cl
->next
= gfc_current_ns
->cl_list
;
1129 gfc_current_ns
->cl_list
= cl
;
1131 cl
->length
= char_len
;
1134 /* Non-constant lengths need to be copied after the first
1137 if (elem
> 1 && current_ts
.cl
->length
1138 && current_ts
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1140 cl
= gfc_get_charlen ();
1141 cl
->next
= gfc_current_ns
->cl_list
;
1142 gfc_current_ns
->cl_list
= cl
;
1143 cl
->length
= gfc_copy_expr (current_ts
.cl
->length
);
1155 /* If this symbol has already shown up in a Cray Pointer declaration,
1156 then we want to set the type & bail out. */
1157 if (gfc_option
.flag_cray_pointer
)
1159 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
1160 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
1162 sym
->ts
.type
= current_ts
.type
;
1163 sym
->ts
.kind
= current_ts
.kind
;
1165 sym
->ts
.derived
= current_ts
.derived
;
1168 /* Check to see if we have an array specification. */
1171 if (sym
->as
!= NULL
)
1173 gfc_error ("Duplicate array spec for Cray pointee at %C.");
1174 gfc_free_array_spec (cp_as
);
1180 if (gfc_set_array_spec (sym
, cp_as
, &var_locus
) == FAILURE
)
1181 gfc_internal_error ("Couldn't set pointee array spec.");
1183 /* Fix the array spec. */
1184 m
= gfc_mod_pointee_as (sym
->as
);
1185 if (m
== MATCH_ERROR
)
1193 gfc_free_array_spec (cp_as
);
1198 /* OK, we've successfully matched the declaration. Now put the
1199 symbol in the current namespace, because it might be used in the
1200 optional initialization expression for this symbol, e.g. this is
1203 integer, parameter :: i = huge(i)
1205 This is only true for parameters or variables of a basic type.
1206 For components of derived types, it is not true, so we don't
1207 create a symbol for those yet. If we fail to create the symbol,
1209 if (gfc_current_state () != COMP_DERIVED
1210 && build_sym (name
, cl
, &as
, &var_locus
) == FAILURE
)
1216 /* An interface body specifies all of the procedure's characteristics and these
1217 shall be consistent with those specified in the procedure definition, except
1218 that the interface may specify a procedure that is not pure if the procedure
1219 is defined to be pure(12.3.2). */
1220 if (current_ts
.type
== BT_DERIVED
1221 && gfc_current_ns
->proc_name
1222 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1223 && current_ts
.derived
->ns
!= gfc_current_ns
)
1225 gfc_error ("the type of '%s' at %C has not been declared within the "
1231 /* In functions that have a RESULT variable defined, the function
1232 name always refers to function calls. Therefore, the name is
1233 not allowed to appear in specification statements. */
1234 if (gfc_current_state () == COMP_FUNCTION
1235 && gfc_current_block () != NULL
1236 && gfc_current_block ()->result
!= NULL
1237 && gfc_current_block ()->result
!= gfc_current_block ()
1238 && strcmp (gfc_current_block ()->name
, name
) == 0)
1240 gfc_error ("Function name '%s' not allowed at %C", name
);
1245 /* We allow old-style initializations of the form
1246 integer i /2/, j(4) /3*3, 1/
1247 (if no colon has been seen). These are different from data
1248 statements in that initializers are only allowed to apply to the
1249 variable immediately preceding, i.e.
1251 is not allowed. Therefore we have to do some work manually, that
1252 could otherwise be left to the matchers for DATA statements. */
1254 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
1256 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Old-style "
1257 "initialization at %C") == FAILURE
)
1260 return match_old_style_init (name
);
1263 /* The double colon must be present in order to have initializers.
1264 Otherwise the statement is ambiguous with an assignment statement. */
1267 if (gfc_match (" =>") == MATCH_YES
)
1270 if (!current_attr
.pointer
)
1272 gfc_error ("Initialization at %C isn't for a pointer variable");
1277 m
= gfc_match_null (&initializer
);
1280 gfc_error ("Pointer initialization requires a NULL() at %C");
1284 if (gfc_pure (NULL
))
1287 ("Initialization of pointer at %C is not allowed in a "
1296 else if (gfc_match_char ('=') == MATCH_YES
)
1298 if (current_attr
.pointer
)
1301 ("Pointer initialization at %C requires '=>', not '='");
1306 m
= gfc_match_init_expr (&initializer
);
1309 gfc_error ("Expected an initialization expression at %C");
1313 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
))
1316 ("Initialization of variable at %C is not allowed in a "
1326 if (initializer
!= NULL
&& current_attr
.allocatable
1327 && gfc_current_state () == COMP_DERIVED
)
1329 gfc_error ("Initialization of allocatable component at %C is not allowed");
1334 /* Check if we are parsing an enumeration and if the current enumerator
1335 variable has an initializer or not. If it does not have an
1336 initializer, the initialization value of the previous enumerator
1337 (stored in last_initializer) is incremented by 1 and is used to
1338 initialize the current enumerator. */
1339 if (gfc_current_state () == COMP_ENUM
)
1341 if (initializer
== NULL
)
1342 initializer
= gfc_enum_initializer (last_initializer
, old_locus
);
1344 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
1346 gfc_error("ENUMERATOR %L not initialized with integer expression",
1349 gfc_free_enum_history ();
1353 /* Store this current initializer, for the next enumerator
1354 variable to be parsed. */
1355 last_initializer
= initializer
;
1358 /* Add the initializer. Note that it is fine if initializer is
1359 NULL here, because we sometimes also need to check if a
1360 declaration *must* have an initialization expression. */
1361 if (gfc_current_state () != COMP_DERIVED
)
1362 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
1365 if (current_ts
.type
== BT_DERIVED
1366 && !current_attr
.pointer
1368 initializer
= gfc_default_initializer (¤t_ts
);
1369 t
= build_struct (name
, cl
, &initializer
, &as
);
1372 m
= (t
== SUCCESS
) ? MATCH_YES
: MATCH_ERROR
;
1375 /* Free stuff up and return. */
1376 gfc_free_expr (initializer
);
1377 gfc_free_array_spec (as
);
1383 /* Match an extended-f77 kind specification. */
1386 gfc_match_old_kind_spec (gfc_typespec
* ts
)
1391 if (gfc_match_char ('*') != MATCH_YES
)
1394 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
1398 original_kind
= ts
->kind
;
1400 /* Massage the kind numbers for complex types. */
1401 if (ts
->type
== BT_COMPLEX
)
1405 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1406 gfc_basic_typename (ts
->type
), original_kind
);
1412 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1414 gfc_error ("Old-style type declaration %s*%d not supported at %C",
1415 gfc_basic_typename (ts
->type
), original_kind
);
1419 if (gfc_notify_std (GFC_STD_GNU
, "Nonstandard type declaration %s*%d at %C",
1420 gfc_basic_typename (ts
->type
), original_kind
) == FAILURE
)
1427 /* Match a kind specification. Since kinds are generally optional, we
1428 usually return MATCH_NO if something goes wrong. If a "kind="
1429 string is found, then we know we have an error. */
1432 gfc_match_kind_spec (gfc_typespec
* ts
)
1442 where
= gfc_current_locus
;
1444 if (gfc_match_char ('(') == MATCH_NO
)
1447 /* Also gobbles optional text. */
1448 if (gfc_match (" kind = ") == MATCH_YES
)
1451 n
= gfc_match_init_expr (&e
);
1453 gfc_error ("Expected initialization expression at %C");
1459 gfc_error ("Expected scalar initialization expression at %C");
1464 msg
= gfc_extract_int (e
, &ts
->kind
);
1475 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
1477 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
1478 gfc_basic_typename (ts
->type
));
1484 if (gfc_match_char (')') != MATCH_YES
)
1486 gfc_error ("Missing right paren at %C");
1494 gfc_current_locus
= where
;
1499 /* Match the various kind/length specifications in a CHARACTER
1500 declaration. We don't return MATCH_NO. */
1503 match_char_spec (gfc_typespec
* ts
)
1505 int i
, kind
, seen_length
;
1510 kind
= gfc_default_character_kind
;
1514 /* Try the old-style specification first. */
1515 old_char_selector
= 0;
1517 m
= match_char_length (&len
);
1521 old_char_selector
= 1;
1526 m
= gfc_match_char ('(');
1529 m
= MATCH_YES
; /* character without length is a single char */
1533 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */
1534 if (gfc_match (" kind =") == MATCH_YES
)
1536 m
= gfc_match_small_int (&kind
);
1537 if (m
== MATCH_ERROR
)
1542 if (gfc_match (" , len =") == MATCH_NO
)
1545 m
= char_len_param_value (&len
);
1548 if (m
== MATCH_ERROR
)
1555 /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */
1556 if (gfc_match (" len =") == MATCH_YES
)
1558 m
= char_len_param_value (&len
);
1561 if (m
== MATCH_ERROR
)
1565 if (gfc_match_char (')') == MATCH_YES
)
1568 if (gfc_match (" , kind =") != MATCH_YES
)
1571 gfc_match_small_int (&kind
);
1573 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1575 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1582 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */
1583 m
= char_len_param_value (&len
);
1586 if (m
== MATCH_ERROR
)
1590 m
= gfc_match_char (')');
1594 if (gfc_match_char (',') != MATCH_YES
)
1597 gfc_match (" kind ="); /* Gobble optional text */
1599 m
= gfc_match_small_int (&kind
);
1600 if (m
== MATCH_ERROR
)
1606 /* Require a right-paren at this point. */
1607 m
= gfc_match_char (')');
1612 gfc_error ("Syntax error in CHARACTER declaration at %C");
1616 if (m
== MATCH_YES
&& gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
1618 gfc_error ("Kind %d is not a CHARACTER kind at %C", kind
);
1624 gfc_free_expr (len
);
1628 /* Do some final massaging of the length values. */
1629 cl
= gfc_get_charlen ();
1630 cl
->next
= gfc_current_ns
->cl_list
;
1631 gfc_current_ns
->cl_list
= cl
;
1633 if (seen_length
== 0)
1634 cl
->length
= gfc_int_expr (1);
1637 if (len
== NULL
|| gfc_extract_int (len
, &i
) != NULL
|| i
>= 0)
1641 gfc_free_expr (len
);
1642 cl
->length
= gfc_int_expr (0);
1653 /* Matches a type specification. If successful, sets the ts structure
1654 to the matched specification. This is necessary for FUNCTION and
1655 IMPLICIT statements.
1657 If implicit_flag is nonzero, then we don't check for the optional
1658 kind specification. Not doing so is needed for matching an IMPLICIT
1659 statement correctly. */
1662 match_type_spec (gfc_typespec
* ts
, int implicit_flag
)
1664 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1671 if (gfc_match (" byte") == MATCH_YES
)
1673 if (gfc_notify_std(GFC_STD_GNU
, "Extension: BYTE type at %C")
1677 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
1679 gfc_error ("BYTE type used at %C "
1680 "is not available on the target machine");
1684 ts
->type
= BT_INTEGER
;
1689 if (gfc_match (" integer") == MATCH_YES
)
1691 ts
->type
= BT_INTEGER
;
1692 ts
->kind
= gfc_default_integer_kind
;
1696 if (gfc_match (" character") == MATCH_YES
)
1698 ts
->type
= BT_CHARACTER
;
1699 if (implicit_flag
== 0)
1700 return match_char_spec (ts
);
1705 if (gfc_match (" real") == MATCH_YES
)
1708 ts
->kind
= gfc_default_real_kind
;
1712 if (gfc_match (" double precision") == MATCH_YES
)
1715 ts
->kind
= gfc_default_double_kind
;
1719 if (gfc_match (" complex") == MATCH_YES
)
1721 ts
->type
= BT_COMPLEX
;
1722 ts
->kind
= gfc_default_complex_kind
;
1726 if (gfc_match (" double complex") == MATCH_YES
)
1728 if (gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C does not "
1729 "conform to the Fortran 95 standard") == FAILURE
)
1732 ts
->type
= BT_COMPLEX
;
1733 ts
->kind
= gfc_default_double_kind
;
1737 if (gfc_match (" logical") == MATCH_YES
)
1739 ts
->type
= BT_LOGICAL
;
1740 ts
->kind
= gfc_default_logical_kind
;
1744 m
= gfc_match (" type ( %n )", name
);
1748 /* Search for the name but allow the components to be defined later. */
1749 if (gfc_get_ha_symbol (name
, &sym
))
1751 gfc_error ("Type name '%s' at %C is ambiguous", name
);
1755 if (sym
->attr
.flavor
!= FL_DERIVED
1756 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
1759 ts
->type
= BT_DERIVED
;
1766 /* For all types except double, derived and character, look for an
1767 optional kind specifier. MATCH_NO is actually OK at this point. */
1768 if (implicit_flag
== 1)
1771 if (gfc_current_form
== FORM_FREE
)
1773 c
= gfc_peek_char();
1774 if (!gfc_is_whitespace(c
) && c
!= '*' && c
!= '('
1775 && c
!= ':' && c
!= ',')
1779 m
= gfc_match_kind_spec (ts
);
1780 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
1781 m
= gfc_match_old_kind_spec (ts
);
1784 m
= MATCH_YES
; /* No kind specifier found. */
1790 /* Match an IMPLICIT NONE statement. Actually, this statement is
1791 already matched in parse.c, or we would not end up here in the
1792 first place. So the only thing we need to check, is if there is
1793 trailing garbage. If not, the match is successful. */
1796 gfc_match_implicit_none (void)
1799 return (gfc_match_eos () == MATCH_YES
) ? MATCH_YES
: MATCH_NO
;
1803 /* Match the letter range(s) of an IMPLICIT statement. */
1806 match_implicit_range (void)
1808 int c
, c1
, c2
, inner
;
1811 cur_loc
= gfc_current_locus
;
1813 gfc_gobble_whitespace ();
1814 c
= gfc_next_char ();
1817 gfc_error ("Missing character range in IMPLICIT at %C");
1824 gfc_gobble_whitespace ();
1825 c1
= gfc_next_char ();
1829 gfc_gobble_whitespace ();
1830 c
= gfc_next_char ();
1835 inner
= 0; /* Fall through */
1842 gfc_gobble_whitespace ();
1843 c2
= gfc_next_char ();
1847 gfc_gobble_whitespace ();
1848 c
= gfc_next_char ();
1850 if ((c
!= ',') && (c
!= ')'))
1863 gfc_error ("Letters must be in alphabetic order in "
1864 "IMPLICIT statement at %C");
1868 /* See if we can add the newly matched range to the pending
1869 implicits from this IMPLICIT statement. We do not check for
1870 conflicts with whatever earlier IMPLICIT statements may have
1871 set. This is done when we've successfully finished matching
1873 if (gfc_add_new_implicit_range (c1
, c2
) != SUCCESS
)
1880 gfc_syntax_error (ST_IMPLICIT
);
1882 gfc_current_locus
= cur_loc
;
1887 /* Match an IMPLICIT statement, storing the types for
1888 gfc_set_implicit() if the statement is accepted by the parser.
1889 There is a strange looking, but legal syntactic construction
1890 possible. It looks like:
1892 IMPLICIT INTEGER (a-b) (c-d)
1894 This is legal if "a-b" is a constant expression that happens to
1895 equal one of the legal kinds for integers. The real problem
1896 happens with an implicit specification that looks like:
1898 IMPLICIT INTEGER (a-b)
1900 In this case, a typespec matcher that is "greedy" (as most of the
1901 matchers are) gobbles the character range as a kindspec, leaving
1902 nothing left. We therefore have to go a bit more slowly in the
1903 matching process by inhibiting the kindspec checking during
1904 typespec matching and checking for a kind later. */
1907 gfc_match_implicit (void)
1914 /* We don't allow empty implicit statements. */
1915 if (gfc_match_eos () == MATCH_YES
)
1917 gfc_error ("Empty IMPLICIT statement at %C");
1923 /* First cleanup. */
1924 gfc_clear_new_implicit ();
1926 /* A basic type is mandatory here. */
1927 m
= match_type_spec (&ts
, 1);
1928 if (m
== MATCH_ERROR
)
1933 cur_loc
= gfc_current_locus
;
1934 m
= match_implicit_range ();
1938 /* We may have <TYPE> (<RANGE>). */
1939 gfc_gobble_whitespace ();
1940 c
= gfc_next_char ();
1941 if ((c
== '\n') || (c
== ','))
1943 /* Check for CHARACTER with no length parameter. */
1944 if (ts
.type
== BT_CHARACTER
&& !ts
.cl
)
1946 ts
.kind
= gfc_default_character_kind
;
1947 ts
.cl
= gfc_get_charlen ();
1948 ts
.cl
->next
= gfc_current_ns
->cl_list
;
1949 gfc_current_ns
->cl_list
= ts
.cl
;
1950 ts
.cl
->length
= gfc_int_expr (1);
1953 /* Record the Successful match. */
1954 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
1959 gfc_current_locus
= cur_loc
;
1962 /* Discard the (incorrectly) matched range. */
1963 gfc_clear_new_implicit ();
1965 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
1966 if (ts
.type
== BT_CHARACTER
)
1967 m
= match_char_spec (&ts
);
1970 m
= gfc_match_kind_spec (&ts
);
1973 m
= gfc_match_old_kind_spec (&ts
);
1974 if (m
== MATCH_ERROR
)
1980 if (m
== MATCH_ERROR
)
1983 m
= match_implicit_range ();
1984 if (m
== MATCH_ERROR
)
1989 gfc_gobble_whitespace ();
1990 c
= gfc_next_char ();
1991 if ((c
!= '\n') && (c
!= ','))
1994 if (gfc_merge_new_implicit (&ts
) != SUCCESS
)
2002 gfc_syntax_error (ST_IMPLICIT
);
2009 /* Matches an attribute specification including array specs. If
2010 successful, leaves the variables current_attr and current_as
2011 holding the specification. Also sets the colon_seen variable for
2012 later use by matchers associated with initializations.
2014 This subroutine is a little tricky in the sense that we don't know
2015 if we really have an attr-spec until we hit the double colon.
2016 Until that time, we can only return MATCH_NO. This forces us to
2017 check for duplicate specification at this level. */
2020 match_attr_spec (void)
2023 /* Modifiers that can exist in a type statement. */
2025 { GFC_DECL_BEGIN
= 0,
2026 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
2027 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
2028 DECL_PARAMETER
, DECL_POINTER
, DECL_PRIVATE
, DECL_PUBLIC
, DECL_SAVE
,
2029 DECL_TARGET
, DECL_VOLATILE
, DECL_COLON
, DECL_NONE
,
2030 GFC_DECL_END
/* Sentinel */
2034 /* GFC_DECL_END is the sentinel, index starts at 0. */
2035 #define NUM_DECL GFC_DECL_END
2037 static mstring decls
[] = {
2038 minit (", allocatable", DECL_ALLOCATABLE
),
2039 minit (", dimension", DECL_DIMENSION
),
2040 minit (", external", DECL_EXTERNAL
),
2041 minit (", intent ( in )", DECL_IN
),
2042 minit (", intent ( out )", DECL_OUT
),
2043 minit (", intent ( in out )", DECL_INOUT
),
2044 minit (", intrinsic", DECL_INTRINSIC
),
2045 minit (", optional", DECL_OPTIONAL
),
2046 minit (", parameter", DECL_PARAMETER
),
2047 minit (", pointer", DECL_POINTER
),
2048 minit (", private", DECL_PRIVATE
),
2049 minit (", public", DECL_PUBLIC
),
2050 minit (", save", DECL_SAVE
),
2051 minit (", target", DECL_TARGET
),
2052 minit (", volatile", DECL_VOLATILE
),
2053 minit ("::", DECL_COLON
),
2054 minit (NULL
, DECL_NONE
)
2057 locus start
, seen_at
[NUM_DECL
];
2064 gfc_clear_attr (¤t_attr
);
2065 start
= gfc_current_locus
;
2070 /* See if we get all of the keywords up to the final double colon. */
2071 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2076 d
= (decl_types
) gfc_match_strings (decls
);
2077 if (d
== DECL_NONE
|| d
== DECL_COLON
)
2080 if (gfc_current_state () == COMP_ENUM
)
2082 gfc_error ("Enumerator cannot have attributes %C");
2087 seen_at
[d
] = gfc_current_locus
;
2089 if (d
== DECL_DIMENSION
)
2091 m
= gfc_match_array_spec (¤t_as
);
2095 gfc_error ("Missing dimension specification at %C");
2099 if (m
== MATCH_ERROR
)
2104 /* If we are parsing an enumeration and have ensured that no other
2105 attributes are present we can now set the parameter attribute. */
2106 if (gfc_current_state () == COMP_ENUM
)
2108 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
2116 /* No double colon, so assume that we've been looking at something
2117 else the whole time. */
2124 /* Since we've seen a double colon, we have to be looking at an
2125 attr-spec. This means that we can now issue errors. */
2126 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2131 case DECL_ALLOCATABLE
:
2132 attr
= "ALLOCATABLE";
2134 case DECL_DIMENSION
:
2141 attr
= "INTENT (IN)";
2144 attr
= "INTENT (OUT)";
2147 attr
= "INTENT (IN OUT)";
2149 case DECL_INTRINSIC
:
2155 case DECL_PARAMETER
:
2177 attr
= NULL
; /* This shouldn't happen */
2180 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
2185 /* Now that we've dealt with duplicate attributes, add the attributes
2186 to the current attribute. */
2187 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
2192 if (gfc_current_state () == COMP_DERIVED
2193 && d
!= DECL_DIMENSION
&& d
!= DECL_POINTER
2194 && d
!= DECL_COLON
&& d
!= DECL_NONE
)
2196 if (d
== DECL_ALLOCATABLE
)
2198 if (gfc_notify_std (GFC_STD_F2003
,
2199 "Fortran 2003: ALLOCATABLE "
2200 "attribute at %C in a TYPE "
2201 "definition") == FAILURE
)
2209 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2216 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
2217 && gfc_current_state () != COMP_MODULE
)
2219 if (d
== DECL_PRIVATE
)
2224 gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
2232 case DECL_ALLOCATABLE
:
2233 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
2236 case DECL_DIMENSION
:
2237 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
2241 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
2245 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
2249 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
2253 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
2256 case DECL_INTRINSIC
:
2257 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
2261 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
2264 case DECL_PARAMETER
:
2265 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
2269 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
2273 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
2278 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
2283 t
= gfc_add_save (¤t_attr
, NULL
, &seen_at
[d
]);
2287 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
2291 if (gfc_notify_std (GFC_STD_F2003
,
2292 "Fortran 2003: VOLATILE attribute at %C")
2296 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
2300 gfc_internal_error ("match_attr_spec(): Bad attribute");
2314 gfc_current_locus
= start
;
2315 gfc_free_array_spec (current_as
);
2321 /* Match a data declaration statement. */
2324 gfc_match_data_decl (void)
2330 m
= match_type_spec (¤t_ts
, 0);
2334 if (current_ts
.type
== BT_DERIVED
&& gfc_current_state () != COMP_DERIVED
)
2336 sym
= gfc_use_derived (current_ts
.derived
);
2344 current_ts
.derived
= sym
;
2347 m
= match_attr_spec ();
2348 if (m
== MATCH_ERROR
)
2354 if (current_ts
.type
== BT_DERIVED
&& current_ts
.derived
->components
== NULL
)
2357 if (current_attr
.pointer
&& gfc_current_state () == COMP_DERIVED
)
2360 gfc_find_symbol (current_ts
.derived
->name
,
2361 current_ts
.derived
->ns
->parent
, 1, &sym
);
2363 /* Any symbol that we find had better be a type definition
2364 which has its components defined. */
2365 if (sym
!= NULL
&& sym
->attr
.flavor
== FL_DERIVED
2366 && current_ts
.derived
->components
!= NULL
)
2369 /* Now we have an error, which we signal, and then fix up
2370 because the knock-on is plain and simple confusing. */
2371 gfc_error_now ("Derived type at %C has not been previously defined "
2372 "and so cannot appear in a derived type definition.");
2373 current_attr
.pointer
= 1;
2378 /* If we have an old-style character declaration, and no new-style
2379 attribute specifications, then there a comma is optional between
2380 the type specification and the variable list. */
2381 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
2382 gfc_match_char (',');
2384 /* Give the types/attributes to symbols that follow. Give the element
2385 a number so that repeat character length expressions can be copied. */
2389 m
= variable_decl (elem
++);
2390 if (m
== MATCH_ERROR
)
2395 if (gfc_match_eos () == MATCH_YES
)
2397 if (gfc_match_char (',') != MATCH_YES
)
2401 if (gfc_error_flag_test () == 0)
2402 gfc_error ("Syntax error in data declaration at %C");
2405 gfc_free_data_all (gfc_current_ns
);
2408 gfc_free_array_spec (current_as
);
2414 /* Match a prefix associated with a function or subroutine
2415 declaration. If the typespec pointer is nonnull, then a typespec
2416 can be matched. Note that if nothing matches, MATCH_YES is
2417 returned (the null string was matched). */
2420 match_prefix (gfc_typespec
* ts
)
2424 gfc_clear_attr (¤t_attr
);
2428 if (!seen_type
&& ts
!= NULL
2429 && match_type_spec (ts
, 0) == MATCH_YES
2430 && gfc_match_space () == MATCH_YES
)
2437 if (gfc_match ("elemental% ") == MATCH_YES
)
2439 if (gfc_add_elemental (¤t_attr
, NULL
) == FAILURE
)
2445 if (gfc_match ("pure% ") == MATCH_YES
)
2447 if (gfc_add_pure (¤t_attr
, NULL
) == FAILURE
)
2453 if (gfc_match ("recursive% ") == MATCH_YES
)
2455 if (gfc_add_recursive (¤t_attr
, NULL
) == FAILURE
)
2461 /* At this point, the next item is not a prefix. */
2466 /* Copy attributes matched by match_prefix() to attributes on a symbol. */
2469 copy_prefix (symbol_attribute
* dest
, locus
* where
)
2472 if (current_attr
.pure
&& gfc_add_pure (dest
, where
) == FAILURE
)
2475 if (current_attr
.elemental
&& gfc_add_elemental (dest
, where
) == FAILURE
)
2478 if (current_attr
.recursive
&& gfc_add_recursive (dest
, where
) == FAILURE
)
2485 /* Match a formal argument list. */
2488 gfc_match_formal_arglist (gfc_symbol
* progname
, int st_flag
, int null_flag
)
2490 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
2491 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2497 if (gfc_match_char ('(') != MATCH_YES
)
2504 if (gfc_match_char (')') == MATCH_YES
)
2509 if (gfc_match_char ('*') == MATCH_YES
)
2513 m
= gfc_match_name (name
);
2517 if (gfc_get_symbol (name
, NULL
, &sym
))
2521 p
= gfc_get_formal_arglist ();
2533 /* We don't add the VARIABLE flavor because the name could be a
2534 dummy procedure. We don't apply these attributes to formal
2535 arguments of statement functions. */
2536 if (sym
!= NULL
&& !st_flag
2537 && (gfc_add_dummy (&sym
->attr
, sym
->name
, NULL
) == FAILURE
2538 || gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
))
2544 /* The name of a program unit can be in a different namespace,
2545 so check for it explicitly. After the statement is accepted,
2546 the name is checked for especially in gfc_get_symbol(). */
2547 if (gfc_new_block
!= NULL
&& sym
!= NULL
2548 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
2550 gfc_error ("Name '%s' at %C is the name of the procedure",
2556 if (gfc_match_char (')') == MATCH_YES
)
2559 m
= gfc_match_char (',');
2562 gfc_error ("Unexpected junk in formal argument list at %C");
2568 /* Check for duplicate symbols in the formal argument list. */
2571 for (p
= head
; p
->next
; p
= p
->next
)
2576 for (q
= p
->next
; q
; q
= q
->next
)
2577 if (p
->sym
== q
->sym
)
2580 ("Duplicate symbol '%s' in formal argument list at %C",
2589 if (gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
) ==
2599 gfc_free_formal_arglist (head
);
2604 /* Match a RESULT specification following a function declaration or
2605 ENTRY statement. Also matches the end-of-statement. */
2608 match_result (gfc_symbol
* function
, gfc_symbol
** result
)
2610 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2614 if (gfc_match (" result (") != MATCH_YES
)
2617 m
= gfc_match_name (name
);
2621 if (gfc_match (" )%t") != MATCH_YES
)
2623 gfc_error ("Unexpected junk following RESULT variable at %C");
2627 if (strcmp (function
->name
, name
) == 0)
2630 ("RESULT variable at %C must be different than function name");
2634 if (gfc_get_symbol (name
, NULL
, &r
))
2637 if (gfc_add_flavor (&r
->attr
, FL_VARIABLE
, r
->name
, NULL
) == FAILURE
2638 || gfc_add_result (&r
->attr
, r
->name
, NULL
) == FAILURE
)
2647 /* Match a function declaration. */
2650 gfc_match_function_decl (void)
2652 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2653 gfc_symbol
*sym
, *result
;
2657 if (gfc_current_state () != COMP_NONE
2658 && gfc_current_state () != COMP_INTERFACE
2659 && gfc_current_state () != COMP_CONTAINS
)
2662 gfc_clear_ts (¤t_ts
);
2664 old_loc
= gfc_current_locus
;
2666 m
= match_prefix (¤t_ts
);
2669 gfc_current_locus
= old_loc
;
2673 if (gfc_match ("function% %n", name
) != MATCH_YES
)
2675 gfc_current_locus
= old_loc
;
2679 if (get_proc_name (name
, &sym
, false))
2681 gfc_new_block
= sym
;
2683 m
= gfc_match_formal_arglist (sym
, 0, 0);
2686 gfc_error ("Expected formal argument list in function "
2687 "definition at %C");
2691 else if (m
== MATCH_ERROR
)
2696 if (gfc_match_eos () != MATCH_YES
)
2698 /* See if a result variable is present. */
2699 m
= match_result (sym
, &result
);
2701 gfc_error ("Unexpected junk after function declaration at %C");
2710 /* Make changes to the symbol. */
2713 if (gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2716 if (gfc_missing_attr (&sym
->attr
, NULL
) == FAILURE
2717 || copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
2720 if (current_ts
.type
!= BT_UNKNOWN
2721 && sym
->ts
.type
!= BT_UNKNOWN
2722 && !sym
->attr
.implicit_type
)
2724 gfc_error ("Function '%s' at %C already has a type of %s", name
,
2725 gfc_basic_typename (sym
->ts
.type
));
2731 sym
->ts
= current_ts
;
2736 result
->ts
= current_ts
;
2737 sym
->result
= result
;
2743 gfc_current_locus
= old_loc
;
2747 /* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
2748 name of the entry, rather than the gfc_current_block name, and to return false
2749 upon finding an existing global entry. */
2752 add_global_entry (const char * name
, int sub
)
2756 s
= gfc_get_gsymbol(name
);
2759 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
2760 global_used(s
, NULL
);
2763 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2764 s
->where
= gfc_current_locus
;
2771 /* Match an ENTRY statement. */
2774 gfc_match_entry (void)
2779 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2780 gfc_compile_state state
;
2784 bool module_procedure
;
2786 m
= gfc_match_name (name
);
2790 state
= gfc_current_state ();
2791 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
2796 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2799 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2801 case COMP_BLOCK_DATA
:
2803 ("ENTRY statement at %C cannot appear within a BLOCK DATA");
2805 case COMP_INTERFACE
:
2807 ("ENTRY statement at %C cannot appear within an INTERFACE");
2811 ("ENTRY statement at %C cannot appear "
2812 "within a DERIVED TYPE block");
2816 ("ENTRY statement at %C cannot appear within an IF-THEN block");
2820 ("ENTRY statement at %C cannot appear within a DO block");
2824 ("ENTRY statement at %C cannot appear within a SELECT block");
2828 ("ENTRY statement at %C cannot appear within a FORALL block");
2832 ("ENTRY statement at %C cannot appear within a WHERE block");
2836 ("ENTRY statement at %C cannot appear "
2837 "within a contained subprogram");
2840 gfc_internal_error ("gfc_match_entry(): Bad state");
2845 module_procedure
= gfc_current_ns
->parent
!= NULL
2846 && gfc_current_ns
->parent
->proc_name
2847 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
== FL_MODULE
;
2849 if (gfc_current_ns
->parent
!= NULL
2850 && gfc_current_ns
->parent
->proc_name
2851 && !module_procedure
)
2853 gfc_error("ENTRY statement at %C cannot appear in a "
2854 "contained procedure");
2858 /* Module function entries need special care in get_proc_name
2859 because previous references within the function will have
2860 created symbols attached to the current namespace. */
2861 if (get_proc_name (name
, &entry
,
2862 gfc_current_ns
->parent
!= NULL
2864 && gfc_current_ns
->proc_name
->attr
.function
))
2867 proc
= gfc_current_block ();
2869 if (state
== COMP_SUBROUTINE
)
2871 /* An entry in a subroutine. */
2872 if (!add_global_entry (name
, 1))
2875 m
= gfc_match_formal_arglist (entry
, 0, 1);
2879 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2880 || gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2885 /* An entry in a function.
2886 We need to take special care because writing
2891 ENTRY f() RESULT (r)
2893 ENTRY f RESULT (r). */
2894 if (!add_global_entry (name
, 0))
2897 old_loc
= gfc_current_locus
;
2898 if (gfc_match_eos () == MATCH_YES
)
2900 gfc_current_locus
= old_loc
;
2901 /* Match the empty argument list, and add the interface to
2903 m
= gfc_match_formal_arglist (entry
, 0, 1);
2906 m
= gfc_match_formal_arglist (entry
, 0, 0);
2913 if (gfc_match_eos () == MATCH_YES
)
2915 if (gfc_add_entry (&entry
->attr
, entry
->name
, NULL
) == FAILURE
2916 || gfc_add_function (&entry
->attr
, entry
->name
, NULL
) == FAILURE
)
2919 entry
->result
= entry
;
2923 m
= match_result (proc
, &result
);
2925 gfc_syntax_error (ST_ENTRY
);
2929 if (gfc_add_result (&result
->attr
, result
->name
, NULL
) == FAILURE
2930 || gfc_add_entry (&entry
->attr
, result
->name
, NULL
) == FAILURE
2931 || gfc_add_function (&entry
->attr
, result
->name
,
2935 entry
->result
= result
;
2938 if (proc
->attr
.recursive
&& result
== NULL
)
2940 gfc_error ("RESULT attribute required in ENTRY statement at %C");
2945 if (gfc_match_eos () != MATCH_YES
)
2947 gfc_syntax_error (ST_ENTRY
);
2951 entry
->attr
.recursive
= proc
->attr
.recursive
;
2952 entry
->attr
.elemental
= proc
->attr
.elemental
;
2953 entry
->attr
.pure
= proc
->attr
.pure
;
2955 el
= gfc_get_entry_list ();
2957 el
->next
= gfc_current_ns
->entries
;
2958 gfc_current_ns
->entries
= el
;
2960 el
->id
= el
->next
->id
+ 1;
2964 new_st
.op
= EXEC_ENTRY
;
2965 new_st
.ext
.entry
= el
;
2971 /* Match a subroutine statement, including optional prefixes. */
2974 gfc_match_subroutine (void)
2976 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2980 if (gfc_current_state () != COMP_NONE
2981 && gfc_current_state () != COMP_INTERFACE
2982 && gfc_current_state () != COMP_CONTAINS
)
2985 m
= match_prefix (NULL
);
2989 m
= gfc_match ("subroutine% %n", name
);
2993 if (get_proc_name (name
, &sym
, false))
2995 gfc_new_block
= sym
;
2997 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3000 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
3003 if (gfc_match_eos () != MATCH_YES
)
3005 gfc_syntax_error (ST_SUBROUTINE
);
3009 if (copy_prefix (&sym
->attr
, &sym
->declared_at
) == FAILURE
)
3016 /* Return nonzero if we're currently compiling a contained procedure. */
3019 contained_procedure (void)
3023 for (s
=gfc_state_stack
; s
; s
=s
->previous
)
3024 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
3025 && s
->previous
!= NULL
3026 && s
->previous
->state
== COMP_CONTAINS
)
3032 /* Set the kind of each enumerator. The kind is selected such that it is
3033 interoperable with the corresponding C enumeration type, making
3034 sure that -fshort-enums is honored. */
3039 enumerator_history
*current_history
= NULL
;
3043 if (max_enum
== NULL
|| enum_history
== NULL
)
3046 if (!gfc_option
.fshort_enums
)
3052 kind
= gfc_integer_kinds
[i
++].kind
;
3054 while (kind
< gfc_c_int_kind
3055 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
3058 current_history
= enum_history
;
3059 while (current_history
!= NULL
)
3061 current_history
->sym
->ts
.kind
= kind
;
3062 current_history
= current_history
->next
;
3066 /* Match any of the various end-block statements. Returns the type of
3067 END to the caller. The END INTERFACE, END IF, END DO and END
3068 SELECT statements cannot be replaced by a single END statement. */
3071 gfc_match_end (gfc_statement
* st
)
3073 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3074 gfc_compile_state state
;
3076 const char *block_name
;
3081 old_loc
= gfc_current_locus
;
3082 if (gfc_match ("end") != MATCH_YES
)
3085 state
= gfc_current_state ();
3087 gfc_current_block () == NULL
? NULL
: gfc_current_block ()->name
;
3089 if (state
== COMP_CONTAINS
)
3091 state
= gfc_state_stack
->previous
->state
;
3092 block_name
= gfc_state_stack
->previous
->sym
== NULL
? NULL
3093 : gfc_state_stack
->previous
->sym
->name
;
3100 *st
= ST_END_PROGRAM
;
3101 target
= " program";
3105 case COMP_SUBROUTINE
:
3106 *st
= ST_END_SUBROUTINE
;
3107 target
= " subroutine";
3108 eos_ok
= !contained_procedure ();
3112 *st
= ST_END_FUNCTION
;
3113 target
= " function";
3114 eos_ok
= !contained_procedure ();
3117 case COMP_BLOCK_DATA
:
3118 *st
= ST_END_BLOCK_DATA
;
3119 target
= " block data";
3124 *st
= ST_END_MODULE
;
3129 case COMP_INTERFACE
:
3130 *st
= ST_END_INTERFACE
;
3131 target
= " interface";
3154 *st
= ST_END_SELECT
;
3160 *st
= ST_END_FORALL
;
3175 last_initializer
= NULL
;
3177 gfc_free_enum_history ();
3181 gfc_error ("Unexpected END statement at %C");
3185 if (gfc_match_eos () == MATCH_YES
)
3189 /* We would have required END [something] */
3190 gfc_error ("%s statement expected at %L",
3191 gfc_ascii_statement (*st
), &old_loc
);
3198 /* Verify that we've got the sort of end-block that we're expecting. */
3199 if (gfc_match (target
) != MATCH_YES
)
3201 gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st
));
3205 /* If we're at the end, make sure a block name wasn't required. */
3206 if (gfc_match_eos () == MATCH_YES
)
3209 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
)
3212 if (gfc_current_block () == NULL
)
3215 gfc_error ("Expected block name of '%s' in %s statement at %C",
3216 block_name
, gfc_ascii_statement (*st
));
3221 /* END INTERFACE has a special handler for its several possible endings. */
3222 if (*st
== ST_END_INTERFACE
)
3223 return gfc_match_end_interface ();
3225 /* We haven't hit the end of statement, so what is left must be an end-name. */
3226 m
= gfc_match_space ();
3228 m
= gfc_match_name (name
);
3231 gfc_error ("Expected terminating name at %C");
3235 if (block_name
== NULL
)
3238 if (strcmp (name
, block_name
) != 0)
3240 gfc_error ("Expected label '%s' for %s statement at %C", block_name
,
3241 gfc_ascii_statement (*st
));
3245 if (gfc_match_eos () == MATCH_YES
)
3249 gfc_syntax_error (*st
);
3252 gfc_current_locus
= old_loc
;
3258 /***************** Attribute declaration statements ****************/
3260 /* Set the attribute of a single variable. */
3265 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3273 m
= gfc_match_name (name
);
3277 if (find_special (name
, &sym
))
3280 var_locus
= gfc_current_locus
;
3282 /* Deal with possible array specification for certain attributes. */
3283 if (current_attr
.dimension
3284 || current_attr
.allocatable
3285 || current_attr
.pointer
3286 || current_attr
.target
)
3288 m
= gfc_match_array_spec (&as
);
3289 if (m
== MATCH_ERROR
)
3292 if (current_attr
.dimension
&& m
== MATCH_NO
)
3295 ("Missing array specification at %L in DIMENSION statement",
3301 if ((current_attr
.allocatable
|| current_attr
.pointer
)
3302 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
3304 gfc_error ("Array specification must be deferred at %L",
3311 /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */
3312 if (current_attr
.dimension
== 0
3313 && gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
) == FAILURE
)
3319 if (gfc_set_array_spec (sym
, as
, &var_locus
) == FAILURE
)
3325 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
3327 /* Fix the array spec. */
3328 m
= gfc_mod_pointee_as (sym
->as
);
3329 if (m
== MATCH_ERROR
)
3333 if (gfc_add_attribute (&sym
->attr
, &var_locus
) == FAILURE
)
3339 if ((current_attr
.external
|| current_attr
.intrinsic
)
3340 && sym
->attr
.flavor
!= FL_PROCEDURE
3341 && gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
) == FAILURE
)
3350 gfc_free_array_spec (as
);
3355 /* Generic attribute declaration subroutine. Used for attributes that
3356 just have a list of names. */
3363 /* Gobble the optional double colon, by simply ignoring the result
3373 if (gfc_match_eos () == MATCH_YES
)
3379 if (gfc_match_char (',') != MATCH_YES
)
3381 gfc_error ("Unexpected character in variable list at %C");
3391 /* This routine matches Cray Pointer declarations of the form:
3392 pointer ( <pointer>, <pointee> )
3394 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3395 The pointer, if already declared, should be an integer. Otherwise, we
3396 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
3397 be either a scalar, or an array declaration. No space is allocated for
3398 the pointee. For the statement
3399 pointer (ipt, ar(10))
3400 any subsequent uses of ar will be translated (in C-notation) as
3401 ar(i) => ((<type> *) ipt)(i)
3402 After gimplification, pointee variable will disappear in the code. */
3405 cray_pointer_decl (void)
3409 gfc_symbol
*cptr
; /* Pointer symbol. */
3410 gfc_symbol
*cpte
; /* Pointee symbol. */
3416 if (gfc_match_char ('(') != MATCH_YES
)
3418 gfc_error ("Expected '(' at %C");
3422 /* Match pointer. */
3423 var_locus
= gfc_current_locus
;
3424 gfc_clear_attr (¤t_attr
);
3425 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
3426 current_ts
.type
= BT_INTEGER
;
3427 current_ts
.kind
= gfc_index_integer_kind
;
3429 m
= gfc_match_symbol (&cptr
, 0);
3432 gfc_error ("Expected variable name at %C");
3436 if (gfc_add_cray_pointer (&cptr
->attr
, &var_locus
) == FAILURE
)
3439 gfc_set_sym_referenced (cptr
);
3441 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
3443 cptr
->ts
.type
= BT_INTEGER
;
3444 cptr
->ts
.kind
= gfc_index_integer_kind
;
3446 else if (cptr
->ts
.type
!= BT_INTEGER
)
3448 gfc_error ("Cray pointer at %C must be an integer.");
3451 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
3452 gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3453 " memory addresses require %d bytes.",
3455 gfc_index_integer_kind
);
3457 if (gfc_match_char (',') != MATCH_YES
)
3459 gfc_error ("Expected \",\" at %C");
3463 /* Match Pointee. */
3464 var_locus
= gfc_current_locus
;
3465 gfc_clear_attr (¤t_attr
);
3466 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
3467 current_ts
.type
= BT_UNKNOWN
;
3468 current_ts
.kind
= 0;
3470 m
= gfc_match_symbol (&cpte
, 0);
3473 gfc_error ("Expected variable name at %C");
3477 /* Check for an optional array spec. */
3478 m
= gfc_match_array_spec (&as
);
3479 if (m
== MATCH_ERROR
)
3481 gfc_free_array_spec (as
);
3484 else if (m
== MATCH_NO
)
3486 gfc_free_array_spec (as
);
3490 if (gfc_add_cray_pointee (&cpte
->attr
, &var_locus
) == FAILURE
)
3493 gfc_set_sym_referenced (cpte
);
3495 if (cpte
->as
== NULL
)
3497 if (gfc_set_array_spec (cpte
, as
, &var_locus
) == FAILURE
)
3498 gfc_internal_error ("Couldn't set Cray pointee array spec.");
3500 else if (as
!= NULL
)
3502 gfc_error ("Duplicate array spec for Cray pointee at %C.");
3503 gfc_free_array_spec (as
);
3509 if (cpte
->as
!= NULL
)
3511 /* Fix array spec. */
3512 m
= gfc_mod_pointee_as (cpte
->as
);
3513 if (m
== MATCH_ERROR
)
3517 /* Point the Pointee at the Pointer. */
3518 cpte
->cp_pointer
= cptr
;
3520 if (gfc_match_char (')') != MATCH_YES
)
3522 gfc_error ("Expected \")\" at %C");
3525 m
= gfc_match_char (',');
3527 done
= true; /* Stop searching for more declarations. */
3531 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
3532 || gfc_match_eos () != MATCH_YES
)
3534 gfc_error ("Expected \",\" or end of statement at %C");
3542 gfc_match_external (void)
3545 gfc_clear_attr (¤t_attr
);
3546 current_attr
.external
= 1;
3548 return attr_decl ();
3554 gfc_match_intent (void)
3558 intent
= match_intent_spec ();
3559 if (intent
== INTENT_UNKNOWN
)
3562 gfc_clear_attr (¤t_attr
);
3563 current_attr
.intent
= intent
;
3565 return attr_decl ();
3570 gfc_match_intrinsic (void)
3573 gfc_clear_attr (¤t_attr
);
3574 current_attr
.intrinsic
= 1;
3576 return attr_decl ();
3581 gfc_match_optional (void)
3584 gfc_clear_attr (¤t_attr
);
3585 current_attr
.optional
= 1;
3587 return attr_decl ();
3592 gfc_match_pointer (void)
3594 gfc_gobble_whitespace ();
3595 if (gfc_peek_char () == '(')
3597 if (!gfc_option
.flag_cray_pointer
)
3599 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3603 return cray_pointer_decl ();
3607 gfc_clear_attr (¤t_attr
);
3608 current_attr
.pointer
= 1;
3610 return attr_decl ();
3616 gfc_match_allocatable (void)
3619 gfc_clear_attr (¤t_attr
);
3620 current_attr
.allocatable
= 1;
3622 return attr_decl ();
3627 gfc_match_dimension (void)
3630 gfc_clear_attr (¤t_attr
);
3631 current_attr
.dimension
= 1;
3633 return attr_decl ();
3638 gfc_match_target (void)
3641 gfc_clear_attr (¤t_attr
);
3642 current_attr
.target
= 1;
3644 return attr_decl ();
3648 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3652 access_attr_decl (gfc_statement st
)
3654 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3655 interface_type type
;
3658 gfc_intrinsic_op
operator;
3661 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3666 m
= gfc_match_generic_spec (&type
, name
, &operator);
3669 if (m
== MATCH_ERROR
)
3674 case INTERFACE_NAMELESS
:
3677 case INTERFACE_GENERIC
:
3678 if (gfc_get_symbol (name
, NULL
, &sym
))
3681 if (gfc_add_access (&sym
->attr
,
3683 ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
3684 sym
->name
, NULL
) == FAILURE
)
3689 case INTERFACE_INTRINSIC_OP
:
3690 if (gfc_current_ns
->operator_access
[operator] == ACCESS_UNKNOWN
)
3692 gfc_current_ns
->operator_access
[operator] =
3693 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3697 gfc_error ("Access specification of the %s operator at %C has "
3698 "already been specified", gfc_op2string (operator));
3704 case INTERFACE_USER_OP
:
3705 uop
= gfc_get_uop (name
);
3707 if (uop
->access
== ACCESS_UNKNOWN
)
3710 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3715 ("Access specification of the .%s. operator at %C has "
3716 "already been specified", sym
->name
);
3723 if (gfc_match_char (',') == MATCH_NO
)
3727 if (gfc_match_eos () != MATCH_YES
)
3732 gfc_syntax_error (st
);
3739 /* The PRIVATE statement is a bit weird in that it can be a attribute
3740 declaration, but also works as a standlone statement inside of a
3741 type declaration or a module. */
3744 gfc_match_private (gfc_statement
* st
)
3747 if (gfc_match ("private") != MATCH_YES
)
3750 if (gfc_current_state () == COMP_DERIVED
)
3752 if (gfc_match_eos () == MATCH_YES
)
3758 gfc_syntax_error (ST_PRIVATE
);
3762 if (gfc_match_eos () == MATCH_YES
)
3769 return access_attr_decl (ST_PRIVATE
);
3774 gfc_match_public (gfc_statement
* st
)
3777 if (gfc_match ("public") != MATCH_YES
)
3780 if (gfc_match_eos () == MATCH_YES
)
3787 return access_attr_decl (ST_PUBLIC
);
3791 /* Workhorse for gfc_match_parameter. */
3800 m
= gfc_match_symbol (&sym
, 0);
3802 gfc_error ("Expected variable name at %C in PARAMETER statement");
3807 if (gfc_match_char ('=') == MATCH_NO
)
3809 gfc_error ("Expected = sign in PARAMETER statement at %C");
3813 m
= gfc_match_init_expr (&init
);
3815 gfc_error ("Expected expression at %C in PARAMETER statement");
3819 if (sym
->ts
.type
== BT_UNKNOWN
3820 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
3826 if (gfc_check_assign_symbol (sym
, init
) == FAILURE
3827 || gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
) == FAILURE
)
3833 if (sym
->ts
.type
== BT_CHARACTER
3834 && sym
->ts
.cl
!= NULL
3835 && sym
->ts
.cl
->length
!= NULL
3836 && sym
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
3837 && init
->expr_type
== EXPR_CONSTANT
3838 && init
->ts
.type
== BT_CHARACTER
3839 && init
->ts
.kind
== 1)
3840 gfc_set_constant_character_len (
3841 mpz_get_si (sym
->ts
.cl
->length
->value
.integer
), init
);
3847 gfc_free_expr (init
);
3852 /* Match a parameter statement, with the weird syntax that these have. */
3855 gfc_match_parameter (void)
3859 if (gfc_match_char ('(') == MATCH_NO
)
3868 if (gfc_match (" )%t") == MATCH_YES
)
3871 if (gfc_match_char (',') != MATCH_YES
)
3873 gfc_error ("Unexpected characters in PARAMETER statement at %C");
3883 /* Save statements have a special syntax. */
3886 gfc_match_save (void)
3888 char n
[GFC_MAX_SYMBOL_LEN
+1];
3893 if (gfc_match_eos () == MATCH_YES
)
3895 if (gfc_current_ns
->seen_save
)
3897 if (gfc_notify_std (GFC_STD_LEGACY
,
3898 "Blanket SAVE statement at %C follows previous "
3904 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
3908 if (gfc_current_ns
->save_all
)
3910 if (gfc_notify_std (GFC_STD_LEGACY
,
3911 "SAVE statement at %C follows blanket SAVE statement")
3920 m
= gfc_match_symbol (&sym
, 0);
3924 if (gfc_add_save (&sym
->attr
, sym
->name
,
3925 &gfc_current_locus
) == FAILURE
)
3936 m
= gfc_match (" / %n /", &n
);
3937 if (m
== MATCH_ERROR
)
3942 c
= gfc_get_common (n
, 0);
3945 gfc_current_ns
->seen_save
= 1;
3948 if (gfc_match_eos () == MATCH_YES
)
3950 if (gfc_match_char (',') != MATCH_YES
)
3957 gfc_error ("Syntax error in SAVE statement at %C");
3963 gfc_match_volatile (void)
3968 if (gfc_notify_std (GFC_STD_F2003
,
3969 "Fortran 2003: VOLATILE statement at %C")
3973 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
3978 if (gfc_match_eos () == MATCH_YES
)
3983 m
= gfc_match_symbol (&sym
, 0);
3987 if (gfc_add_volatile (&sym
->attr
, sym
->name
,
3988 &gfc_current_locus
) == FAILURE
)
4000 if (gfc_match_eos () == MATCH_YES
)
4002 if (gfc_match_char (',') != MATCH_YES
)
4009 gfc_error ("Syntax error in VOLATILE statement at %C");
4015 /* Match a module procedure statement. Note that we have to modify
4016 symbols in the parent's namespace because the current one was there
4017 to receive symbols that are in an interface's formal argument list. */
4020 gfc_match_modproc (void)
4022 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4026 if (gfc_state_stack
->state
!= COMP_INTERFACE
4027 || gfc_state_stack
->previous
== NULL
4028 || current_interface
.type
== INTERFACE_NAMELESS
)
4031 ("MODULE PROCEDURE at %C must be in a generic module interface");
4037 m
= gfc_match_name (name
);
4043 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
4046 if (sym
->attr
.proc
!= PROC_MODULE
4047 && gfc_add_procedure (&sym
->attr
, PROC_MODULE
,
4048 sym
->name
, NULL
) == FAILURE
)
4051 if (gfc_add_interface (sym
) == FAILURE
)
4054 if (gfc_match_eos () == MATCH_YES
)
4056 if (gfc_match_char (',') != MATCH_YES
)
4063 gfc_syntax_error (ST_MODULE_PROC
);
4068 /* Match the beginning of a derived type declaration. If a type name
4069 was the result of a function, then it is possible to have a symbol
4070 already to be known as a derived type yet have no components. */
4073 gfc_match_derived_decl (void)
4075 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4076 symbol_attribute attr
;
4080 if (gfc_current_state () == COMP_DERIVED
)
4083 gfc_clear_attr (&attr
);
4086 if (gfc_match (" , private") == MATCH_YES
)
4088 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4091 ("Derived type at %C can only be PRIVATE within a MODULE");
4095 if (gfc_add_access (&attr
, ACCESS_PRIVATE
, NULL
, NULL
) == FAILURE
)
4100 if (gfc_match (" , public") == MATCH_YES
)
4102 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
4104 gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
4108 if (gfc_add_access (&attr
, ACCESS_PUBLIC
, NULL
, NULL
) == FAILURE
)
4113 if (gfc_match (" ::") != MATCH_YES
&& attr
.access
!= ACCESS_UNKNOWN
)
4115 gfc_error ("Expected :: in TYPE definition at %C");
4119 m
= gfc_match (" %n%t", name
);
4123 /* Make sure the name isn't the name of an intrinsic type. The
4124 'double precision' type doesn't get past the name matcher. */
4125 if (strcmp (name
, "integer") == 0
4126 || strcmp (name
, "real") == 0
4127 || strcmp (name
, "character") == 0
4128 || strcmp (name
, "logical") == 0
4129 || strcmp (name
, "complex") == 0)
4132 ("Type name '%s' at %C cannot be the same as an intrinsic type",
4137 if (gfc_get_symbol (name
, NULL
, &sym
))
4140 if (sym
->ts
.type
!= BT_UNKNOWN
)
4142 gfc_error ("Derived type name '%s' at %C already has a basic type "
4143 "of %s", sym
->name
, gfc_typename (&sym
->ts
));
4147 /* The symbol may already have the derived attribute without the
4148 components. The ways this can happen is via a function
4149 definition, an INTRINSIC statement or a subtype in another
4150 derived type that is a pointer. The first part of the AND clause
4151 is true if a the symbol is not the return value of a function. */
4152 if (sym
->attr
.flavor
!= FL_DERIVED
4153 && gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
) == FAILURE
)
4156 if (sym
->components
!= NULL
)
4159 ("Derived type definition of '%s' at %C has already been defined",
4164 if (attr
.access
!= ACCESS_UNKNOWN
4165 && gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
) == FAILURE
)
4168 gfc_new_block
= sym
;
4174 /* Cray Pointees can be declared as:
4175 pointer (ipt, a (n,m,...,*))
4176 By default, this is treated as an AS_ASSUMED_SIZE array. We'll
4177 cheat and set a constant bound of 1 for the last dimension, if this
4178 is the case. Since there is no bounds-checking for Cray Pointees,
4179 this will be okay. */
4182 gfc_mod_pointee_as (gfc_array_spec
*as
)
4184 as
->cray_pointee
= true; /* This will be useful to know later. */
4185 if (as
->type
== AS_ASSUMED_SIZE
)
4187 as
->type
= AS_EXPLICIT
;
4188 as
->upper
[as
->rank
- 1] = gfc_int_expr (1);
4189 as
->cp_was_assumed
= true;
4191 else if (as
->type
== AS_ASSUMED_SHAPE
)
4193 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4200 /* Match the enum definition statement, here we are trying to match
4201 the first line of enum definition statement.
4202 Returns MATCH_YES if match is found. */
4205 gfc_match_enum (void)
4209 m
= gfc_match_eos ();
4213 if (gfc_notify_std (GFC_STD_F2003
,
4214 "Fortran 2003: ENUM AND ENUMERATOR at %C")
4222 /* Match the enumerator definition statement. */
4225 gfc_match_enumerator_def (void)
4230 gfc_clear_ts (¤t_ts
);
4232 m
= gfc_match (" enumerator");
4236 if (gfc_current_state () != COMP_ENUM
)
4238 gfc_error ("ENUM definition statement expected before %C");
4239 gfc_free_enum_history ();
4243 (¤t_ts
)->type
= BT_INTEGER
;
4244 (¤t_ts
)->kind
= gfc_c_int_kind
;
4246 m
= match_attr_spec ();
4247 if (m
== MATCH_ERROR
)
4256 m
= variable_decl (elem
++);
4257 if (m
== MATCH_ERROR
)
4262 if (gfc_match_eos () == MATCH_YES
)
4264 if (gfc_match_char (',') != MATCH_YES
)
4268 if (gfc_current_state () == COMP_ENUM
)
4270 gfc_free_enum_history ();
4271 gfc_error ("Syntax error in ENUMERATOR definition at %C");
4276 gfc_free_array_spec (current_as
);