1 /* Declaration statement matcher
2 Copyright (C) 2002-2017 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 3, 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 COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
27 #include "stringpool.h"
30 #include "constructor.h"
32 /* Macros to access allocate memory for gfc_data_variable,
33 gfc_data_value and gfc_data. */
34 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
35 #define gfc_get_data_value() XCNEW (gfc_data_value)
36 #define gfc_get_data() XCNEW (gfc_data)
39 static bool set_binding_label (const char **, const char *, int);
42 /* This flag is set if an old-style length selector is matched
43 during a type-declaration statement. */
45 static int old_char_selector
;
47 /* When variables acquire types and attributes from a declaration
48 statement, they get them from the following static variables. The
49 first part of a declaration sets these variables and the second
50 part copies these into symbol structures. */
52 static gfc_typespec current_ts
;
54 static symbol_attribute current_attr
;
55 static gfc_array_spec
*current_as
;
56 static int colon_seen
;
58 /* The current binding label (if any). */
59 static const char* curr_binding_label
;
60 /* Need to know how many identifiers are on the current data declaration
61 line in case we're given the BIND(C) attribute with a NAME= specifier. */
62 static int num_idents_on_line
;
63 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
64 can supply a name if the curr_binding_label is nil and NAME= was not. */
65 static int has_name_equals
= 0;
67 /* Initializer of the previous enumerator. */
69 static gfc_expr
*last_initializer
;
71 /* History of all the enumerators is maintained, so that
72 kind values of all the enumerators could be updated depending
73 upon the maximum initialized value. */
75 typedef struct enumerator_history
78 gfc_expr
*initializer
;
79 struct enumerator_history
*next
;
83 /* Header of enum history chain. */
85 static enumerator_history
*enum_history
= NULL
;
87 /* Pointer of enum history node containing largest initializer. */
89 static enumerator_history
*max_enum
= NULL
;
91 /* gfc_new_block points to the symbol of a newly matched block. */
93 gfc_symbol
*gfc_new_block
;
95 bool gfc_matching_function
;
98 /********************* DATA statement subroutines *********************/
100 static bool in_match_data
= false;
103 gfc_in_match_data (void)
105 return in_match_data
;
109 set_in_match_data (bool set_value
)
111 in_match_data
= set_value
;
114 /* Free a gfc_data_variable structure and everything beneath it. */
117 free_variable (gfc_data_variable
*p
)
119 gfc_data_variable
*q
;
124 gfc_free_expr (p
->expr
);
125 gfc_free_iterator (&p
->iter
, 0);
126 free_variable (p
->list
);
132 /* Free a gfc_data_value structure and everything beneath it. */
135 free_value (gfc_data_value
*p
)
142 mpz_clear (p
->repeat
);
143 gfc_free_expr (p
->expr
);
149 /* Free a list of gfc_data structures. */
152 gfc_free_data (gfc_data
*p
)
159 free_variable (p
->var
);
160 free_value (p
->value
);
166 /* Free all data in a namespace. */
169 gfc_free_data_all (gfc_namespace
*ns
)
181 /* Reject data parsed since the last restore point was marked. */
184 gfc_reject_data (gfc_namespace
*ns
)
188 while (ns
->data
&& ns
->data
!= ns
->old_data
)
196 static match
var_element (gfc_data_variable
*);
198 /* Match a list of variables terminated by an iterator and a right
202 var_list (gfc_data_variable
*parent
)
204 gfc_data_variable
*tail
, var
;
207 m
= var_element (&var
);
208 if (m
== MATCH_ERROR
)
213 tail
= gfc_get_data_variable ();
220 if (gfc_match_char (',') != MATCH_YES
)
223 m
= gfc_match_iterator (&parent
->iter
, 1);
226 if (m
== MATCH_ERROR
)
229 m
= var_element (&var
);
230 if (m
== MATCH_ERROR
)
235 tail
->next
= gfc_get_data_variable ();
241 if (gfc_match_char (')') != MATCH_YES
)
246 gfc_syntax_error (ST_DATA
);
251 /* Match a single element in a data variable list, which can be a
252 variable-iterator list. */
255 var_element (gfc_data_variable
*new_var
)
260 memset (new_var
, 0, sizeof (gfc_data_variable
));
262 if (gfc_match_char ('(') == MATCH_YES
)
263 return var_list (new_var
);
265 m
= gfc_match_variable (&new_var
->expr
, 0);
269 sym
= new_var
->expr
->symtree
->n
.sym
;
271 /* Symbol should already have an associated type. */
272 if (!gfc_check_symbol_typed (sym
, gfc_current_ns
, false, gfc_current_locus
))
275 if (!sym
->attr
.function
&& gfc_current_ns
->parent
276 && gfc_current_ns
->parent
== sym
->ns
)
278 gfc_error ("Host associated variable %qs may not be in the DATA "
279 "statement at %C", sym
->name
);
283 if (gfc_current_state () != COMP_BLOCK_DATA
284 && sym
->attr
.in_common
285 && !gfc_notify_std (GFC_STD_GNU
, "initialization of "
286 "common block variable %qs in DATA statement at %C",
290 if (!gfc_add_data (&sym
->attr
, sym
->name
, &new_var
->expr
->where
))
297 /* Match the top-level list of data variables. */
300 top_var_list (gfc_data
*d
)
302 gfc_data_variable var
, *tail
, *new_var
;
309 m
= var_element (&var
);
312 if (m
== MATCH_ERROR
)
315 new_var
= gfc_get_data_variable ();
321 tail
->next
= new_var
;
325 if (gfc_match_char ('/') == MATCH_YES
)
327 if (gfc_match_char (',') != MATCH_YES
)
334 gfc_syntax_error (ST_DATA
);
335 gfc_free_data_all (gfc_current_ns
);
341 match_data_constant (gfc_expr
**result
)
343 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
344 gfc_symbol
*sym
, *dt_sym
= NULL
;
349 m
= gfc_match_literal_constant (&expr
, 1);
356 if (m
== MATCH_ERROR
)
359 m
= gfc_match_null (result
);
363 old_loc
= gfc_current_locus
;
365 /* Should this be a structure component, try to match it
366 before matching a name. */
367 m
= gfc_match_rvalue (result
);
368 if (m
== MATCH_ERROR
)
371 if (m
== MATCH_YES
&& (*result
)->expr_type
== EXPR_STRUCTURE
)
373 if (!gfc_simplify_expr (*result
, 0))
377 else if (m
== MATCH_YES
)
378 gfc_free_expr (*result
);
380 gfc_current_locus
= old_loc
;
382 m
= gfc_match_name (name
);
386 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
389 if (sym
&& sym
->attr
.generic
)
390 dt_sym
= gfc_find_dt_in_generic (sym
);
393 || (sym
->attr
.flavor
!= FL_PARAMETER
394 && (!dt_sym
|| !gfc_fl_struct (dt_sym
->attr
.flavor
))))
396 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
401 else if (dt_sym
&& gfc_fl_struct (dt_sym
->attr
.flavor
))
402 return gfc_match_structure_constructor (dt_sym
, result
);
404 /* Check to see if the value is an initialization array expression. */
405 if (sym
->value
->expr_type
== EXPR_ARRAY
)
407 gfc_current_locus
= old_loc
;
409 m
= gfc_match_init_expr (result
);
410 if (m
== MATCH_ERROR
)
415 if (!gfc_simplify_expr (*result
, 0))
418 if ((*result
)->expr_type
== EXPR_CONSTANT
)
422 gfc_error ("Invalid initializer %s in Data statement at %C", name
);
428 *result
= gfc_copy_expr (sym
->value
);
433 /* Match a list of values in a DATA statement. The leading '/' has
434 already been seen at this point. */
437 top_val_list (gfc_data
*data
)
439 gfc_data_value
*new_val
, *tail
;
447 m
= match_data_constant (&expr
);
450 if (m
== MATCH_ERROR
)
453 new_val
= gfc_get_data_value ();
454 mpz_init (new_val
->repeat
);
457 data
->value
= new_val
;
459 tail
->next
= new_val
;
463 if (expr
->ts
.type
!= BT_INTEGER
|| gfc_match_char ('*') != MATCH_YES
)
466 mpz_set_ui (tail
->repeat
, 1);
470 mpz_set (tail
->repeat
, expr
->value
.integer
);
471 gfc_free_expr (expr
);
473 m
= match_data_constant (&tail
->expr
);
476 if (m
== MATCH_ERROR
)
480 if (gfc_match_char ('/') == MATCH_YES
)
482 if (gfc_match_char (',') == MATCH_NO
)
489 gfc_syntax_error (ST_DATA
);
490 gfc_free_data_all (gfc_current_ns
);
495 /* Matches an old style initialization. */
498 match_old_style_init (const char *name
)
505 /* Set up data structure to hold initializers. */
506 gfc_find_sym_tree (name
, NULL
, 0, &st
);
509 newdata
= gfc_get_data ();
510 newdata
->var
= gfc_get_data_variable ();
511 newdata
->var
->expr
= gfc_get_variable_expr (st
);
512 newdata
->where
= gfc_current_locus
;
514 /* Match initial value list. This also eats the terminal '/'. */
515 m
= top_val_list (newdata
);
524 gfc_error ("Initialization at %C is not allowed in a PURE procedure");
528 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
530 /* Mark the variable as having appeared in a data statement. */
531 if (!gfc_add_data (&sym
->attr
, sym
->name
, &sym
->declared_at
))
537 /* Chain in namespace list of DATA initializers. */
538 newdata
->next
= gfc_current_ns
->data
;
539 gfc_current_ns
->data
= newdata
;
545 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
546 we are matching a DATA statement and are therefore issuing an error
547 if we encounter something unexpected, if not, we're trying to match
548 an old-style initialization expression of the form INTEGER I /2/. */
551 gfc_match_data (void)
556 /* Before parsing the rest of a DATA statement, check F2008:c1206. */
557 if ((gfc_current_state () == COMP_FUNCTION
558 || gfc_current_state () == COMP_SUBROUTINE
)
559 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
561 gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
565 set_in_match_data (true);
569 new_data
= gfc_get_data ();
570 new_data
->where
= gfc_current_locus
;
572 m
= top_var_list (new_data
);
576 m
= top_val_list (new_data
);
580 new_data
->next
= gfc_current_ns
->data
;
581 gfc_current_ns
->data
= new_data
;
583 if (gfc_match_eos () == MATCH_YES
)
586 gfc_match_char (','); /* Optional comma */
589 set_in_match_data (false);
593 gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
596 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
601 set_in_match_data (false);
602 gfc_free_data (new_data
);
607 /************************ Declaration statements *********************/
610 /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
611 list). The difference here is the expression is a list of constants
612 and is surrounded by '/'.
613 The typespec ts must match the typespec of the variable which the
614 clist is initializing.
615 The arrayspec tells whether this should match a list of constants
616 corresponding to array elements or a scalar (as == NULL). */
619 match_clist_expr (gfc_expr
**result
, gfc_typespec
*ts
, gfc_array_spec
*as
)
621 gfc_constructor_base array_head
= NULL
;
622 gfc_expr
*expr
= NULL
;
631 mpz_init_set_ui (repeat
, 0);
633 scalar
= !as
|| !as
->rank
;
635 /* We have already matched '/' - now look for a constant list, as with
636 top_val_list from decl.c, but append the result to an array. */
637 if (gfc_match ("/") == MATCH_YES
)
639 gfc_error ("Empty old style initializer list at %C");
643 where
= gfc_current_locus
;
646 m
= match_data_constant (&expr
);
648 expr
= NULL
; /* match_data_constant may set expr to garbage */
651 if (m
== MATCH_ERROR
)
654 /* Found r in repeat spec r*c; look for the constant to repeat. */
655 if ( gfc_match_char ('*') == MATCH_YES
)
659 gfc_error ("Repeat spec invalid in scalar initializer at %C");
662 if (expr
->ts
.type
!= BT_INTEGER
)
664 gfc_error ("Repeat spec must be an integer at %C");
667 mpz_set (repeat
, expr
->value
.integer
);
668 gfc_free_expr (expr
);
671 m
= match_data_constant (&expr
);
673 gfc_error ("Expected data constant after repeat spec at %C");
677 /* No repeat spec, we matched the data constant itself. */
679 mpz_set_ui (repeat
, 1);
683 /* Add the constant initializer as many times as repeated. */
684 for (; mpz_cmp_ui (repeat
, 0) > 0; mpz_sub_ui (repeat
, repeat
, 1))
686 /* Make sure types of elements match */
687 if(ts
&& !gfc_compare_types (&expr
->ts
, ts
)
688 && !gfc_convert_type (expr
, ts
, 1))
691 gfc_constructor_append_expr (&array_head
,
692 gfc_copy_expr (expr
), &gfc_current_locus
);
695 gfc_free_expr (expr
);
699 /* For scalar initializers quit after one element. */
702 if(gfc_match_char ('/') != MATCH_YES
)
704 gfc_error ("End of scalar initializer expected at %C");
710 if (gfc_match_char ('/') == MATCH_YES
)
712 if (gfc_match_char (',') == MATCH_NO
)
716 /* Set up expr as an array constructor. */
719 expr
= gfc_get_array_expr (ts
->type
, ts
->kind
, &where
);
721 expr
->value
.constructor
= array_head
;
723 expr
->rank
= as
->rank
;
724 expr
->shape
= gfc_get_shape (expr
->rank
);
726 /* Validate sizes. */
727 gcc_assert (gfc_array_size (expr
, &size
));
728 gcc_assert (spec_size (as
, &repeat
));
729 cmp
= mpz_cmp (size
, repeat
);
731 gfc_error ("Not enough elements in array initializer at %C");
733 gfc_error ("Too many elements in array initializer at %C");
738 /* Make sure scalar types match. */
739 else if (!gfc_compare_types (&expr
->ts
, ts
)
740 && !gfc_convert_type (expr
, ts
, 1))
744 expr
->ts
.u
.cl
->length_from_typespec
= 1;
752 gfc_error ("Syntax error in old style initializer list at %C");
756 expr
->value
.constructor
= NULL
;
757 gfc_free_expr (expr
);
758 gfc_constructor_free (array_head
);
765 /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
768 merge_array_spec (gfc_array_spec
*from
, gfc_array_spec
*to
, bool copy
)
772 if ((from
->type
== AS_ASSUMED_RANK
&& to
->corank
)
773 || (to
->type
== AS_ASSUMED_RANK
&& from
->corank
))
775 gfc_error ("The assumed-rank array at %C shall not have a codimension");
779 if (to
->rank
== 0 && from
->rank
> 0)
781 to
->rank
= from
->rank
;
782 to
->type
= from
->type
;
783 to
->cray_pointee
= from
->cray_pointee
;
784 to
->cp_was_assumed
= from
->cp_was_assumed
;
786 for (i
= 0; i
< to
->corank
; i
++)
788 to
->lower
[from
->rank
+ i
] = to
->lower
[i
];
789 to
->upper
[from
->rank
+ i
] = to
->upper
[i
];
791 for (i
= 0; i
< from
->rank
; i
++)
795 to
->lower
[i
] = gfc_copy_expr (from
->lower
[i
]);
796 to
->upper
[i
] = gfc_copy_expr (from
->upper
[i
]);
800 to
->lower
[i
] = from
->lower
[i
];
801 to
->upper
[i
] = from
->upper
[i
];
805 else if (to
->corank
== 0 && from
->corank
> 0)
807 to
->corank
= from
->corank
;
808 to
->cotype
= from
->cotype
;
810 for (i
= 0; i
< from
->corank
; i
++)
814 to
->lower
[to
->rank
+ i
] = gfc_copy_expr (from
->lower
[i
]);
815 to
->upper
[to
->rank
+ i
] = gfc_copy_expr (from
->upper
[i
]);
819 to
->lower
[to
->rank
+ i
] = from
->lower
[i
];
820 to
->upper
[to
->rank
+ i
] = from
->upper
[i
];
829 /* Match an intent specification. Since this can only happen after an
830 INTENT word, a legal intent-spec must follow. */
833 match_intent_spec (void)
836 if (gfc_match (" ( in out )") == MATCH_YES
)
838 if (gfc_match (" ( in )") == MATCH_YES
)
840 if (gfc_match (" ( out )") == MATCH_YES
)
843 gfc_error ("Bad INTENT specification at %C");
844 return INTENT_UNKNOWN
;
848 /* Matches a character length specification, which is either a
849 specification expression, '*', or ':'. */
852 char_len_param_value (gfc_expr
**expr
, bool *deferred
)
859 if (gfc_match_char ('*') == MATCH_YES
)
862 if (gfc_match_char (':') == MATCH_YES
)
864 if (!gfc_notify_std (GFC_STD_F2003
, "deferred type parameter at %C"))
872 m
= gfc_match_expr (expr
);
874 if (m
== MATCH_NO
|| m
== MATCH_ERROR
)
877 if (!gfc_expr_check_typed (*expr
, gfc_current_ns
, false))
880 if ((*expr
)->expr_type
== EXPR_FUNCTION
)
882 if ((*expr
)->ts
.type
== BT_INTEGER
883 || ((*expr
)->ts
.type
== BT_UNKNOWN
884 && strcmp((*expr
)->symtree
->name
, "null") != 0))
889 else if ((*expr
)->expr_type
== EXPR_CONSTANT
)
891 /* F2008, 4.4.3.1: The length is a type parameter; its kind is
892 processor dependent and its value is greater than or equal to zero.
893 F2008, 4.4.3.2: If the character length parameter value evaluates
894 to a negative value, the length of character entities declared
897 if ((*expr
)->ts
.type
== BT_INTEGER
)
899 if (mpz_cmp_si ((*expr
)->value
.integer
, 0) < 0)
900 mpz_set_si ((*expr
)->value
.integer
, 0);
905 else if ((*expr
)->expr_type
== EXPR_ARRAY
)
907 else if ((*expr
)->expr_type
== EXPR_VARIABLE
)
912 e
= gfc_copy_expr (*expr
);
914 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
915 which causes an ICE if gfc_reduce_init_expr() is called. */
916 if (e
->ref
&& e
->ref
->type
== REF_ARRAY
917 && e
->ref
->u
.ar
.type
== AR_UNKNOWN
918 && e
->ref
->u
.ar
.dimen_type
[0] == DIMEN_RANGE
)
921 t
= gfc_reduce_init_expr (e
);
923 if (!t
&& e
->ts
.type
== BT_UNKNOWN
924 && e
->symtree
->n
.sym
->attr
.untyped
== 1
925 && (flag_implicit_none
926 || e
->symtree
->n
.sym
->ns
->seen_implicit_none
== 1
927 || e
->symtree
->n
.sym
->ns
->parent
->seen_implicit_none
== 1))
933 if ((e
->ref
&& e
->ref
->type
== REF_ARRAY
934 && e
->ref
->u
.ar
.type
!= AR_ELEMENT
)
935 || (!e
->ref
&& e
->expr_type
== EXPR_ARRAY
))
947 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr
)->where
);
952 /* A character length is a '*' followed by a literal integer or a
953 char_len_param_value in parenthesis. */
956 match_char_length (gfc_expr
**expr
, bool *deferred
, bool obsolescent_check
)
962 m
= gfc_match_char ('*');
966 m
= gfc_match_small_literal_int (&length
, NULL
);
967 if (m
== MATCH_ERROR
)
972 if (obsolescent_check
973 && !gfc_notify_std (GFC_STD_F95_OBS
, "Old-style character length at %C"))
975 *expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, length
);
979 if (gfc_match_char ('(') == MATCH_NO
)
982 m
= char_len_param_value (expr
, deferred
);
983 if (m
!= MATCH_YES
&& gfc_matching_function
)
989 if (m
== MATCH_ERROR
)
994 if (gfc_match_char (')') == MATCH_NO
)
996 gfc_free_expr (*expr
);
1004 gfc_error ("Syntax error in character length specification at %C");
1009 /* Special subroutine for finding a symbol. Check if the name is found
1010 in the current name space. If not, and we're compiling a function or
1011 subroutine and the parent compilation unit is an interface, then check
1012 to see if the name we've been given is the name of the interface
1013 (located in another namespace). */
1016 find_special (const char *name
, gfc_symbol
**result
, bool allow_subroutine
)
1022 i
= gfc_get_sym_tree (name
, NULL
, &st
, allow_subroutine
);
1025 *result
= st
? st
->n
.sym
: NULL
;
1029 if (gfc_current_state () != COMP_SUBROUTINE
1030 && gfc_current_state () != COMP_FUNCTION
)
1033 s
= gfc_state_stack
->previous
;
1037 if (s
->state
!= COMP_INTERFACE
)
1040 goto end
; /* Nameless interface. */
1042 if (strcmp (name
, s
->sym
->name
) == 0)
1053 /* Special subroutine for getting a symbol node associated with a
1054 procedure name, used in SUBROUTINE and FUNCTION statements. The
1055 symbol is created in the parent using with symtree node in the
1056 child unit pointing to the symbol. If the current namespace has no
1057 parent, then the symbol is just created in the current unit. */
1060 get_proc_name (const char *name
, gfc_symbol
**result
, bool module_fcn_entry
)
1066 /* Module functions have to be left in their own namespace because
1067 they have potentially (almost certainly!) already been referenced.
1068 In this sense, they are rather like external functions. This is
1069 fixed up in resolve.c(resolve_entries), where the symbol name-
1070 space is set to point to the master function, so that the fake
1071 result mechanism can work. */
1072 if (module_fcn_entry
)
1074 /* Present if entry is declared to be a module procedure. */
1075 rc
= gfc_find_symbol (name
, gfc_current_ns
->parent
, 0, result
);
1077 if (*result
== NULL
)
1078 rc
= gfc_get_symbol (name
, NULL
, result
);
1079 else if (!gfc_get_symbol (name
, NULL
, &sym
) && sym
1080 && (*result
)->ts
.type
== BT_UNKNOWN
1081 && sym
->attr
.flavor
== FL_UNKNOWN
)
1082 /* Pick up the typespec for the entry, if declared in the function
1083 body. Note that this symbol is FL_UNKNOWN because it will
1084 only have appeared in a type declaration. The local symtree
1085 is set to point to the module symbol and a unique symtree
1086 to the local version. This latter ensures a correct clearing
1089 /* If the ENTRY proceeds its specification, we need to ensure
1090 that this does not raise a "has no IMPLICIT type" error. */
1091 if (sym
->ts
.type
== BT_UNKNOWN
)
1092 sym
->attr
.untyped
= 1;
1094 (*result
)->ts
= sym
->ts
;
1096 /* Put the symbol in the procedure namespace so that, should
1097 the ENTRY precede its specification, the specification
1099 (*result
)->ns
= gfc_current_ns
;
1101 gfc_find_sym_tree (name
, gfc_current_ns
, 0, &st
);
1102 st
->n
.sym
= *result
;
1103 st
= gfc_get_unique_symtree (gfc_current_ns
);
1109 rc
= gfc_get_symbol (name
, gfc_current_ns
->parent
, result
);
1115 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1118 if (sym
->attr
.module_procedure
1119 && sym
->attr
.if_source
== IFSRC_IFBODY
)
1121 /* Create a partially populated interface symbol to carry the
1122 characteristics of the procedure and the result. */
1123 sym
->tlink
= gfc_new_symbol (name
, sym
->ns
);
1124 gfc_add_type (sym
->tlink
, &(sym
->ts
),
1125 &gfc_current_locus
);
1126 gfc_copy_attr (&sym
->tlink
->attr
, &sym
->attr
, NULL
);
1127 if (sym
->attr
.dimension
)
1128 sym
->tlink
->as
= gfc_copy_array_spec (sym
->as
);
1130 /* Ideally, at this point, a copy would be made of the formal
1131 arguments and their namespace. However, this does not appear
1132 to be necessary, albeit at the expense of not being able to
1133 use gfc_compare_interfaces directly. */
1135 if (sym
->result
&& sym
->result
!= sym
)
1137 sym
->tlink
->result
= sym
->result
;
1140 else if (sym
->result
)
1142 sym
->tlink
->result
= sym
->tlink
;
1145 else if (sym
&& !sym
->gfc_new
1146 && gfc_current_state () != COMP_INTERFACE
)
1148 /* Trap another encompassed procedure with the same name. All
1149 these conditions are necessary to avoid picking up an entry
1150 whose name clashes with that of the encompassing procedure;
1151 this is handled using gsymbols to register unique, globally
1152 accessible names. */
1153 if (sym
->attr
.flavor
!= 0
1154 && sym
->attr
.proc
!= 0
1155 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1156 && sym
->attr
.if_source
!= IFSRC_UNKNOWN
)
1157 gfc_error_now ("Procedure %qs at %C is already defined at %L",
1158 name
, &sym
->declared_at
);
1160 /* Trap a procedure with a name the same as interface in the
1161 encompassing scope. */
1162 if (sym
->attr
.generic
!= 0
1163 && (sym
->attr
.subroutine
|| sym
->attr
.function
)
1164 && !sym
->attr
.mod_proc
)
1165 gfc_error_now ("Name %qs at %C is already defined"
1166 " as a generic interface at %L",
1167 name
, &sym
->declared_at
);
1169 /* Trap declarations of attributes in encompassing scope. The
1170 signature for this is that ts.kind is set. Legitimate
1171 references only set ts.type. */
1172 if (sym
->ts
.kind
!= 0
1173 && !sym
->attr
.implicit_type
1174 && sym
->attr
.proc
== 0
1175 && gfc_current_ns
->parent
!= NULL
1176 && sym
->attr
.access
== 0
1177 && !module_fcn_entry
)
1178 gfc_error_now ("Procedure %qs at %C has an explicit interface "
1179 "and must not have attributes declared at %L",
1180 name
, &sym
->declared_at
);
1183 if (gfc_current_ns
->parent
== NULL
|| *result
== NULL
)
1186 /* Module function entries will already have a symtree in
1187 the current namespace but will need one at module level. */
1188 if (module_fcn_entry
)
1190 /* Present if entry is declared to be a module procedure. */
1191 rc
= gfc_find_sym_tree (name
, gfc_current_ns
->parent
, 0, &st
);
1193 st
= gfc_new_symtree (&gfc_current_ns
->parent
->sym_root
, name
);
1196 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
1201 /* See if the procedure should be a module procedure. */
1203 if (((sym
->ns
->proc_name
!= NULL
1204 && sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
1205 && sym
->attr
.proc
!= PROC_MODULE
)
1206 || (module_fcn_entry
&& sym
->attr
.proc
!= PROC_MODULE
))
1207 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
1214 /* Verify that the given symbol representing a parameter is C
1215 interoperable, by checking to see if it was marked as such after
1216 its declaration. If the given symbol is not interoperable, a
1217 warning is reported, thus removing the need to return the status to
1218 the calling function. The standard does not require the user use
1219 one of the iso_c_binding named constants to declare an
1220 interoperable parameter, but we can't be sure if the param is C
1221 interop or not if the user doesn't. For example, integer(4) may be
1222 legal Fortran, but doesn't have meaning in C. It may interop with
1223 a number of the C types, which causes a problem because the
1224 compiler can't know which one. This code is almost certainly not
1225 portable, and the user will get what they deserve if the C type
1226 across platforms isn't always interoperable with integer(4). If
1227 the user had used something like integer(c_int) or integer(c_long),
1228 the compiler could have automatically handled the varying sizes
1229 across platforms. */
1232 gfc_verify_c_interop_param (gfc_symbol
*sym
)
1234 int is_c_interop
= 0;
1237 /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
1238 Don't repeat the checks here. */
1239 if (sym
->attr
.implicit_type
)
1242 /* For subroutines or functions that are passed to a BIND(C) procedure,
1243 they're interoperable if they're BIND(C) and their params are all
1245 if (sym
->attr
.flavor
== FL_PROCEDURE
)
1247 if (sym
->attr
.is_bind_c
== 0)
1249 gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1250 "attribute to be C interoperable", sym
->name
,
1251 &(sym
->declared_at
));
1256 if (sym
->attr
.is_c_interop
== 1)
1257 /* We've already checked this procedure; don't check it again. */
1260 return verify_bind_c_sym (sym
, &(sym
->ts
), sym
->attr
.in_common
,
1265 /* See if we've stored a reference to a procedure that owns sym. */
1266 if (sym
->ns
!= NULL
&& sym
->ns
->proc_name
!= NULL
)
1268 if (sym
->ns
->proc_name
->attr
.is_bind_c
== 1)
1270 is_c_interop
= (gfc_verify_c_interop(&(sym
->ts
)) ? 1 : 0);
1272 if (is_c_interop
!= 1)
1274 /* Make personalized messages to give better feedback. */
1275 if (sym
->ts
.type
== BT_DERIVED
)
1276 gfc_error ("Variable %qs at %L is a dummy argument to the "
1277 "BIND(C) procedure %qs but is not C interoperable "
1278 "because derived type %qs is not C interoperable",
1279 sym
->name
, &(sym
->declared_at
),
1280 sym
->ns
->proc_name
->name
,
1281 sym
->ts
.u
.derived
->name
);
1282 else if (sym
->ts
.type
== BT_CLASS
)
1283 gfc_error ("Variable %qs at %L is a dummy argument to the "
1284 "BIND(C) procedure %qs but is not C interoperable "
1285 "because it is polymorphic",
1286 sym
->name
, &(sym
->declared_at
),
1287 sym
->ns
->proc_name
->name
);
1288 else if (warn_c_binding_type
)
1289 gfc_warning (OPT_Wc_binding_type
,
1290 "Variable %qs at %L is a dummy argument of the "
1291 "BIND(C) procedure %qs but may not be C "
1293 sym
->name
, &(sym
->declared_at
),
1294 sym
->ns
->proc_name
->name
);
1297 /* Character strings are only C interoperable if they have a
1299 if (sym
->ts
.type
== BT_CHARACTER
)
1301 gfc_charlen
*cl
= sym
->ts
.u
.cl
;
1302 if (!cl
|| !cl
->length
|| cl
->length
->expr_type
!= EXPR_CONSTANT
1303 || mpz_cmp_si (cl
->length
->value
.integer
, 1) != 0)
1305 gfc_error ("Character argument %qs at %L "
1306 "must be length 1 because "
1307 "procedure %qs is BIND(C)",
1308 sym
->name
, &sym
->declared_at
,
1309 sym
->ns
->proc_name
->name
);
1314 /* We have to make sure that any param to a bind(c) routine does
1315 not have the allocatable, pointer, or optional attributes,
1316 according to J3/04-007, section 5.1. */
1317 if (sym
->attr
.allocatable
== 1
1318 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1319 "ALLOCATABLE attribute in procedure %qs "
1320 "with BIND(C)", sym
->name
,
1321 &(sym
->declared_at
),
1322 sym
->ns
->proc_name
->name
))
1325 if (sym
->attr
.pointer
== 1
1326 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs at %L with "
1327 "POINTER attribute in procedure %qs "
1328 "with BIND(C)", sym
->name
,
1329 &(sym
->declared_at
),
1330 sym
->ns
->proc_name
->name
))
1333 if ((sym
->attr
.allocatable
|| sym
->attr
.pointer
) && !sym
->as
)
1335 gfc_error ("Scalar variable %qs at %L with POINTER or "
1336 "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
1337 " supported", sym
->name
, &(sym
->declared_at
),
1338 sym
->ns
->proc_name
->name
);
1342 if (sym
->attr
.optional
== 1 && sym
->attr
.value
)
1344 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1345 "and the VALUE attribute because procedure %qs "
1346 "is BIND(C)", sym
->name
, &(sym
->declared_at
),
1347 sym
->ns
->proc_name
->name
);
1350 else if (sym
->attr
.optional
== 1
1351 && !gfc_notify_std (GFC_STD_F2008_TS
, "Variable %qs "
1352 "at %L with OPTIONAL attribute in "
1353 "procedure %qs which is BIND(C)",
1354 sym
->name
, &(sym
->declared_at
),
1355 sym
->ns
->proc_name
->name
))
1358 /* Make sure that if it has the dimension attribute, that it is
1359 either assumed size or explicit shape. Deferred shape is already
1360 covered by the pointer/allocatable attribute. */
1361 if (sym
->as
!= NULL
&& sym
->as
->type
== AS_ASSUMED_SHAPE
1362 && !gfc_notify_std (GFC_STD_F2008_TS
, "Assumed-shape array %qs "
1363 "at %L as dummy argument to the BIND(C) "
1364 "procedure %qs at %L", sym
->name
,
1365 &(sym
->declared_at
),
1366 sym
->ns
->proc_name
->name
,
1367 &(sym
->ns
->proc_name
->declared_at
)))
1377 /* Function called by variable_decl() that adds a name to the symbol table. */
1380 build_sym (const char *name
, gfc_charlen
*cl
, bool cl_deferred
,
1381 gfc_array_spec
**as
, locus
*var_locus
)
1383 symbol_attribute attr
;
1388 /* Symbols in a submodule are host associated from the parent module or
1389 submodules. Therefore, they can be overridden by declarations in the
1390 submodule scope. Deal with this by attaching the existing symbol to
1391 a new symtree and recycling the old symtree with a new symbol... */
1392 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
1393 if (st
!= NULL
&& gfc_state_stack
->state
== COMP_SUBMODULE
1394 && st
->n
.sym
!= NULL
1395 && st
->n
.sym
->attr
.host_assoc
&& st
->n
.sym
->attr
.used_in_submodule
)
1397 gfc_symtree
*s
= gfc_get_unique_symtree (gfc_current_ns
);
1398 s
->n
.sym
= st
->n
.sym
;
1399 sym
= gfc_new_symbol (name
, gfc_current_ns
);
1404 gfc_set_sym_referenced (sym
);
1406 /* ...Otherwise generate a new symtree and new symbol. */
1407 else if (gfc_get_symbol (name
, NULL
, &sym
))
1410 /* Check if the name has already been defined as a type. The
1411 first letter of the symtree will be in upper case then. Of
1412 course, this is only necessary if the upper case letter is
1413 actually different. */
1415 upper
= TOUPPER(name
[0]);
1416 if (upper
!= name
[0])
1418 char u_name
[GFC_MAX_SYMBOL_LEN
+ 1];
1422 nlen
= strlen(name
);
1423 gcc_assert (nlen
<= GFC_MAX_SYMBOL_LEN
);
1424 strncpy (u_name
, name
, nlen
+ 1);
1427 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, u_name
);
1429 /* STRUCTURE types can alias symbol names */
1430 if (st
!= 0 && st
->n
.sym
->attr
.flavor
!= FL_STRUCT
)
1432 gfc_error ("Symbol %qs at %C also declared as a type at %L", name
,
1433 &st
->n
.sym
->declared_at
);
1438 /* Start updating the symbol table. Add basic type attribute if present. */
1439 if (current_ts
.type
!= BT_UNKNOWN
1440 && (sym
->attr
.implicit_type
== 0
1441 || !gfc_compare_types (&sym
->ts
, ¤t_ts
))
1442 && !gfc_add_type (sym
, ¤t_ts
, var_locus
))
1445 if (sym
->ts
.type
== BT_CHARACTER
)
1448 sym
->ts
.deferred
= cl_deferred
;
1451 /* Add dimension attribute if present. */
1452 if (!gfc_set_array_spec (sym
, *as
, var_locus
))
1456 /* Add attribute to symbol. The copy is so that we can reset the
1457 dimension attribute. */
1458 attr
= current_attr
;
1460 attr
.codimension
= 0;
1462 if (!gfc_copy_attr (&sym
->attr
, &attr
, var_locus
))
1465 /* Finish any work that may need to be done for the binding label,
1466 if it's a bind(c). The bind(c) attr is found before the symbol
1467 is made, and before the symbol name (for data decls), so the
1468 current_ts is holding the binding label, or nothing if the
1469 name= attr wasn't given. Therefore, test here if we're dealing
1470 with a bind(c) and make sure the binding label is set correctly. */
1471 if (sym
->attr
.is_bind_c
== 1)
1473 if (!sym
->binding_label
)
1475 /* Set the binding label and verify that if a NAME= was specified
1476 then only one identifier was in the entity-decl-list. */
1477 if (!set_binding_label (&sym
->binding_label
, sym
->name
,
1478 num_idents_on_line
))
1483 /* See if we know we're in a common block, and if it's a bind(c)
1484 common then we need to make sure we're an interoperable type. */
1485 if (sym
->attr
.in_common
== 1)
1487 /* Test the common block object. */
1488 if (sym
->common_block
!= NULL
&& sym
->common_block
->is_bind_c
== 1
1489 && sym
->ts
.is_c_interop
!= 1)
1491 gfc_error_now ("Variable %qs in common block %qs at %C "
1492 "must be declared with a C interoperable "
1493 "kind since common block %qs is BIND(C)",
1494 sym
->name
, sym
->common_block
->name
,
1495 sym
->common_block
->name
);
1500 sym
->attr
.implied_index
= 0;
1502 if (sym
->ts
.type
== BT_CLASS
)
1503 return gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
);
1509 /* Set character constant to the given length. The constant will be padded or
1510 truncated. If we're inside an array constructor without a typespec, we
1511 additionally check that all elements have the same length; check_len -1
1512 means no checking. */
1515 gfc_set_constant_character_len (int len
, gfc_expr
*expr
, int check_len
)
1520 if (expr
->ts
.type
!= BT_CHARACTER
)
1523 if (expr
->expr_type
!= EXPR_CONSTANT
)
1525 gfc_error_now ("CHARACTER length must be a constant at %L", &expr
->where
);
1529 slen
= expr
->value
.character
.length
;
1532 s
= gfc_get_wide_string (len
+ 1);
1533 memcpy (s
, expr
->value
.character
.string
,
1534 MIN (len
, slen
) * sizeof (gfc_char_t
));
1536 gfc_wide_memset (&s
[slen
], ' ', len
- slen
);
1538 if (warn_character_truncation
&& slen
> len
)
1539 gfc_warning_now (OPT_Wcharacter_truncation
,
1540 "CHARACTER expression at %L is being truncated "
1541 "(%d/%d)", &expr
->where
, slen
, len
);
1543 /* Apply the standard by 'hand' otherwise it gets cleared for
1545 if (check_len
!= -1 && slen
!= check_len
1546 && !(gfc_option
.allow_std
& GFC_STD_GNU
))
1547 gfc_error_now ("The CHARACTER elements of the array constructor "
1548 "at %L must have the same length (%d/%d)",
1549 &expr
->where
, slen
, check_len
);
1552 free (expr
->value
.character
.string
);
1553 expr
->value
.character
.string
= s
;
1554 expr
->value
.character
.length
= len
;
1559 /* Function to create and update the enumerator history
1560 using the information passed as arguments.
1561 Pointer "max_enum" is also updated, to point to
1562 enum history node containing largest initializer.
1564 SYM points to the symbol node of enumerator.
1565 INIT points to its enumerator value. */
1568 create_enum_history (gfc_symbol
*sym
, gfc_expr
*init
)
1570 enumerator_history
*new_enum_history
;
1571 gcc_assert (sym
!= NULL
&& init
!= NULL
);
1573 new_enum_history
= XCNEW (enumerator_history
);
1575 new_enum_history
->sym
= sym
;
1576 new_enum_history
->initializer
= init
;
1577 new_enum_history
->next
= NULL
;
1579 if (enum_history
== NULL
)
1581 enum_history
= new_enum_history
;
1582 max_enum
= enum_history
;
1586 new_enum_history
->next
= enum_history
;
1587 enum_history
= new_enum_history
;
1589 if (mpz_cmp (max_enum
->initializer
->value
.integer
,
1590 new_enum_history
->initializer
->value
.integer
) < 0)
1591 max_enum
= new_enum_history
;
1596 /* Function to free enum kind history. */
1599 gfc_free_enum_history (void)
1601 enumerator_history
*current
= enum_history
;
1602 enumerator_history
*next
;
1604 while (current
!= NULL
)
1606 next
= current
->next
;
1611 enum_history
= NULL
;
1615 /* Function called by variable_decl() that adds an initialization
1616 expression to a symbol. */
1619 add_init_expr_to_sym (const char *name
, gfc_expr
**initp
, locus
*var_locus
)
1621 symbol_attribute attr
;
1626 if (find_special (name
, &sym
, false))
1631 /* If this symbol is confirming an implicit parameter type,
1632 then an initialization expression is not allowed. */
1633 if (attr
.flavor
== FL_PARAMETER
1634 && sym
->value
!= NULL
1637 gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1644 /* An initializer is required for PARAMETER declarations. */
1645 if (attr
.flavor
== FL_PARAMETER
)
1647 gfc_error ("PARAMETER at %L is missing an initializer", var_locus
);
1653 /* If a variable appears in a DATA block, it cannot have an
1657 gfc_error ("Variable %qs at %C with an initializer already "
1658 "appears in a DATA statement", sym
->name
);
1662 /* Check if the assignment can happen. This has to be put off
1663 until later for derived type variables and procedure pointers. */
1664 if (!gfc_bt_struct (sym
->ts
.type
) && !gfc_bt_struct (init
->ts
.type
)
1665 && sym
->ts
.type
!= BT_CLASS
&& init
->ts
.type
!= BT_CLASS
1666 && !sym
->attr
.proc_pointer
1667 && !gfc_check_assign_symbol (sym
, NULL
, init
))
1670 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
1671 && init
->ts
.type
== BT_CHARACTER
)
1673 /* Update symbol character length according initializer. */
1674 if (!gfc_check_assign_symbol (sym
, NULL
, init
))
1677 if (sym
->ts
.u
.cl
->length
== NULL
)
1680 /* If there are multiple CHARACTER variables declared on the
1681 same line, we don't want them to share the same length. */
1682 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1684 if (sym
->attr
.flavor
== FL_PARAMETER
)
1686 if (init
->expr_type
== EXPR_CONSTANT
)
1688 clen
= init
->value
.character
.length
;
1689 sym
->ts
.u
.cl
->length
1690 = gfc_get_int_expr (gfc_default_integer_kind
,
1693 else if (init
->expr_type
== EXPR_ARRAY
)
1697 const gfc_expr
*length
= init
->ts
.u
.cl
->length
;
1698 if (length
->expr_type
!= EXPR_CONSTANT
)
1700 gfc_error ("Cannot initialize parameter array "
1702 "with variable length elements",
1706 clen
= mpz_get_si (length
->value
.integer
);
1708 else if (init
->value
.constructor
)
1711 c
= gfc_constructor_first (init
->value
.constructor
);
1712 clen
= c
->expr
->value
.character
.length
;
1716 sym
->ts
.u
.cl
->length
1717 = gfc_get_int_expr (gfc_default_integer_kind
,
1720 else if (init
->ts
.u
.cl
&& init
->ts
.u
.cl
->length
)
1721 sym
->ts
.u
.cl
->length
=
1722 gfc_copy_expr (sym
->value
->ts
.u
.cl
->length
);
1725 /* Update initializer character length according symbol. */
1726 else if (sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
1730 if (!gfc_specification_expr (sym
->ts
.u
.cl
->length
))
1733 len
= mpz_get_si (sym
->ts
.u
.cl
->length
->value
.integer
);
1735 if (init
->expr_type
== EXPR_CONSTANT
)
1736 gfc_set_constant_character_len (len
, init
, -1);
1737 else if (init
->expr_type
== EXPR_ARRAY
)
1741 /* Build a new charlen to prevent simplification from
1742 deleting the length before it is resolved. */
1743 init
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
1744 init
->ts
.u
.cl
->length
= gfc_copy_expr (sym
->ts
.u
.cl
->length
);
1746 for (c
= gfc_constructor_first (init
->value
.constructor
);
1747 c
; c
= gfc_constructor_next (c
))
1748 gfc_set_constant_character_len (len
, c
->expr
, -1);
1753 /* If sym is implied-shape, set its upper bounds from init. */
1754 if (sym
->attr
.flavor
== FL_PARAMETER
&& sym
->attr
.dimension
1755 && sym
->as
->type
== AS_IMPLIED_SHAPE
)
1759 if (init
->rank
== 0)
1761 gfc_error ("Can't initialize implied-shape array at %L"
1762 " with scalar", &sym
->declared_at
);
1766 /* Shape should be present, we get an initialization expression. */
1767 gcc_assert (init
->shape
);
1769 for (dim
= 0; dim
< sym
->as
->rank
; ++dim
)
1772 gfc_expr
*e
, *lower
;
1774 lower
= sym
->as
->lower
[dim
];
1776 /* If the lower bound is an array element from another
1777 parameterized array, then it is marked with EXPR_VARIABLE and
1778 is an initialization expression. Try to reduce it. */
1779 if (lower
->expr_type
== EXPR_VARIABLE
)
1780 gfc_reduce_init_expr (lower
);
1782 if (lower
->expr_type
== EXPR_CONSTANT
)
1784 /* All dimensions must be without upper bound. */
1785 gcc_assert (!sym
->as
->upper
[dim
]);
1788 e
= gfc_get_constant_expr (BT_INTEGER
, k
, &sym
->declared_at
);
1789 mpz_add (e
->value
.integer
, lower
->value
.integer
,
1791 mpz_sub_ui (e
->value
.integer
, e
->value
.integer
, 1);
1792 sym
->as
->upper
[dim
] = e
;
1796 gfc_error ("Non-constant lower bound in implied-shape"
1797 " declaration at %L", &lower
->where
);
1802 sym
->as
->type
= AS_EXPLICIT
;
1805 /* Need to check if the expression we initialized this
1806 to was one of the iso_c_binding named constants. If so,
1807 and we're a parameter (constant), let it be iso_c.
1809 integer(c_int), parameter :: my_int = c_int
1810 integer(my_int) :: my_int_2
1811 If we mark my_int as iso_c (since we can see it's value
1812 is equal to one of the named constants), then my_int_2
1813 will be considered C interoperable. */
1814 if (sym
->ts
.type
!= BT_CHARACTER
&& !gfc_bt_struct (sym
->ts
.type
))
1816 sym
->ts
.is_iso_c
|= init
->ts
.is_iso_c
;
1817 sym
->ts
.is_c_interop
|= init
->ts
.is_c_interop
;
1818 /* attr bits needed for module files. */
1819 sym
->attr
.is_iso_c
|= init
->ts
.is_iso_c
;
1820 sym
->attr
.is_c_interop
|= init
->ts
.is_c_interop
;
1821 if (init
->ts
.is_iso_c
)
1822 sym
->ts
.f90_type
= init
->ts
.f90_type
;
1825 /* Add initializer. Make sure we keep the ranks sane. */
1826 if (sym
->attr
.dimension
&& init
->rank
== 0)
1831 if (sym
->attr
.flavor
== FL_PARAMETER
1832 && init
->expr_type
== EXPR_CONSTANT
1833 && spec_size (sym
->as
, &size
)
1834 && mpz_cmp_si (size
, 0) > 0)
1836 array
= gfc_get_array_expr (init
->ts
.type
, init
->ts
.kind
,
1838 for (n
= 0; n
< (int)mpz_get_si (size
); n
++)
1839 gfc_constructor_append_expr (&array
->value
.constructor
,
1842 : gfc_copy_expr (init
),
1845 array
->shape
= gfc_get_shape (sym
->as
->rank
);
1846 for (n
= 0; n
< sym
->as
->rank
; n
++)
1847 spec_dimen_size (sym
->as
, n
, &array
->shape
[n
]);
1852 init
->rank
= sym
->as
->rank
;
1856 if (sym
->attr
.save
== SAVE_NONE
)
1857 sym
->attr
.save
= SAVE_IMPLICIT
;
1865 /* Function called by variable_decl() that adds a name to a structure
1869 build_struct (const char *name
, gfc_charlen
*cl
, gfc_expr
**init
,
1870 gfc_array_spec
**as
)
1875 /* F03:C438/C439. If the current symbol is of the same derived type that we're
1876 constructing, it must have the pointer attribute. */
1877 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
1878 && current_ts
.u
.derived
== gfc_current_block ()
1879 && current_attr
.pointer
== 0)
1881 if (current_attr
.allocatable
1882 && !gfc_notify_std(GFC_STD_F2008
, "Component at %C "
1883 "must have the POINTER attribute"))
1887 else if (current_attr
.allocatable
== 0)
1889 gfc_error ("Component at %C must have the POINTER attribute");
1895 if (current_ts
.type
== BT_CLASS
1896 && !(current_attr
.pointer
|| current_attr
.allocatable
))
1898 gfc_error ("Component %qs with CLASS at %C must be allocatable "
1899 "or pointer", name
);
1903 if (gfc_current_block ()->attr
.pointer
&& (*as
)->rank
!= 0)
1905 if ((*as
)->type
!= AS_DEFERRED
&& (*as
)->type
!= AS_EXPLICIT
)
1907 gfc_error ("Array component of structure at %C must have explicit "
1908 "or deferred shape");
1913 /* If we are in a nested union/map definition, gfc_add_component will not
1914 properly find repeated components because:
1915 (i) gfc_add_component does a flat search, where components of unions
1916 and maps are implicity chained so nested components may conflict.
1917 (ii) Unions and maps are not linked as components of their parent
1918 structures until after they are parsed.
1919 For (i) we use gfc_find_component which searches recursively, and for (ii)
1920 we search each block directly from the parse stack until we find the top
1923 s
= gfc_state_stack
;
1924 if (s
->state
== COMP_UNION
|| s
->state
== COMP_MAP
)
1926 while (s
->state
== COMP_UNION
|| gfc_comp_struct (s
->state
))
1928 c
= gfc_find_component (s
->sym
, name
, true, true, NULL
);
1931 gfc_error_now ("Component %qs at %C already declared at %L",
1935 /* Break after we've searched the entire chain. */
1936 if (s
->state
== COMP_DERIVED
|| s
->state
== COMP_STRUCTURE
)
1942 if (!gfc_add_component (gfc_current_block(), name
, &c
))
1946 if (c
->ts
.type
== BT_CHARACTER
)
1948 c
->attr
= current_attr
;
1950 c
->initializer
= *init
;
1957 c
->attr
.codimension
= 1;
1959 c
->attr
.dimension
= 1;
1963 gfc_apply_init (&c
->ts
, &c
->attr
, c
->initializer
);
1965 /* Check array components. */
1966 if (!c
->attr
.dimension
)
1969 if (c
->attr
.pointer
)
1971 if (c
->as
->type
!= AS_DEFERRED
)
1973 gfc_error ("Pointer array component of structure at %C must have a "
1978 else if (c
->attr
.allocatable
)
1980 if (c
->as
->type
!= AS_DEFERRED
)
1982 gfc_error ("Allocatable component of structure at %C must have a "
1989 if (c
->as
->type
!= AS_EXPLICIT
)
1991 gfc_error ("Array component of structure at %C must have an "
1998 if (c
->ts
.type
== BT_CLASS
)
1999 return gfc_build_class_symbol (&c
->ts
, &c
->attr
, &c
->as
);
2005 /* Match a 'NULL()', and possibly take care of some side effects. */
2008 gfc_match_null (gfc_expr
**result
)
2011 match m
, m2
= MATCH_NO
;
2013 if ((m
= gfc_match (" null ( )")) == MATCH_ERROR
)
2019 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2021 if ((m2
= gfc_match (" null (")) != MATCH_YES
)
2024 old_loc
= gfc_current_locus
;
2025 if ((m2
= gfc_match (" %n ) ", name
)) == MATCH_ERROR
)
2028 && ((m2
= gfc_match (" mold = %n )", name
)) == MATCH_ERROR
))
2032 gfc_current_locus
= old_loc
;
2037 /* The NULL symbol now has to be/become an intrinsic function. */
2038 if (gfc_get_symbol ("null", NULL
, &sym
))
2040 gfc_error ("NULL() initialization at %C is ambiguous");
2044 gfc_intrinsic_symbol (sym
);
2046 if (sym
->attr
.proc
!= PROC_INTRINSIC
2047 && !(sym
->attr
.use_assoc
&& sym
->attr
.intrinsic
)
2048 && (!gfc_add_procedure(&sym
->attr
, PROC_INTRINSIC
, sym
->name
, NULL
)
2049 || !gfc_add_function (&sym
->attr
, sym
->name
, NULL
)))
2052 *result
= gfc_get_null_expr (&gfc_current_locus
);
2054 /* Invalid per F2008, C512. */
2055 if (m2
== MATCH_YES
)
2057 gfc_error ("NULL() initialization at %C may not have MOLD");
2065 /* Match the initialization expr for a data pointer or procedure pointer. */
2068 match_pointer_init (gfc_expr
**init
, int procptr
)
2072 if (gfc_pure (NULL
) && !gfc_comp_struct (gfc_state_stack
->state
))
2074 gfc_error ("Initialization of pointer at %C is not allowed in "
2075 "a PURE procedure");
2078 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2080 /* Match NULL() initialization. */
2081 m
= gfc_match_null (init
);
2085 /* Match non-NULL initialization. */
2086 gfc_matching_ptr_assignment
= !procptr
;
2087 gfc_matching_procptr_assignment
= procptr
;
2088 m
= gfc_match_rvalue (init
);
2089 gfc_matching_ptr_assignment
= 0;
2090 gfc_matching_procptr_assignment
= 0;
2091 if (m
== MATCH_ERROR
)
2093 else if (m
== MATCH_NO
)
2095 gfc_error ("Error in pointer initialization at %C");
2099 if (!procptr
&& !gfc_resolve_expr (*init
))
2102 if (!gfc_notify_std (GFC_STD_F2008
, "non-NULL pointer "
2103 "initialization at %C"))
2111 check_function_name (char *name
)
2113 /* In functions that have a RESULT variable defined, the function name always
2114 refers to function calls. Therefore, the name is not allowed to appear in
2115 specification statements. When checking this, be careful about
2116 'hidden' procedure pointer results ('ppr@'). */
2118 if (gfc_current_state () == COMP_FUNCTION
)
2120 gfc_symbol
*block
= gfc_current_block ();
2121 if (block
&& block
->result
&& block
->result
!= block
2122 && strcmp (block
->result
->name
, "ppr@") != 0
2123 && strcmp (block
->name
, name
) == 0)
2125 gfc_error ("Function name %qs not allowed at %C", name
);
2134 /* Match a variable name with an optional initializer. When this
2135 subroutine is called, a variable is expected to be parsed next.
2136 Depending on what is happening at the moment, updates either the
2137 symbol table or the current interface. */
2140 variable_decl (int elem
)
2142 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2143 gfc_expr
*initializer
, *char_len
;
2145 gfc_array_spec
*cp_as
; /* Extra copy for Cray Pointees. */
2157 /* When we get here, we've just matched a list of attributes and
2158 maybe a type and a double colon. The next thing we expect to see
2159 is the name of the symbol. */
2160 m
= gfc_match_name (name
);
2164 var_locus
= gfc_current_locus
;
2166 /* Now we could see the optional array spec. or character length. */
2167 m
= gfc_match_array_spec (&as
, true, true);
2168 if (m
== MATCH_ERROR
)
2172 as
= gfc_copy_array_spec (current_as
);
2174 && !merge_array_spec (current_as
, as
, true))
2180 if (flag_cray_pointer
)
2181 cp_as
= gfc_copy_array_spec (as
);
2183 /* At this point, we know for sure if the symbol is PARAMETER and can thus
2184 determine (and check) whether it can be implied-shape. If it
2185 was parsed as assumed-size, change it because PARAMETERs can not
2189 if (as
->type
== AS_IMPLIED_SHAPE
&& current_attr
.flavor
!= FL_PARAMETER
)
2192 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
2197 if (as
->type
== AS_ASSUMED_SIZE
&& as
->rank
== 1
2198 && current_attr
.flavor
== FL_PARAMETER
)
2199 as
->type
= AS_IMPLIED_SHAPE
;
2201 if (as
->type
== AS_IMPLIED_SHAPE
2202 && !gfc_notify_std (GFC_STD_F2008
, "Implied-shape array at %L",
2212 cl_deferred
= false;
2214 if (current_ts
.type
== BT_CHARACTER
)
2216 switch (match_char_length (&char_len
, &cl_deferred
, false))
2219 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2221 cl
->length
= char_len
;
2224 /* Non-constant lengths need to be copied after the first
2225 element. Also copy assumed lengths. */
2228 && (current_ts
.u
.cl
->length
== NULL
2229 || current_ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
2231 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2232 cl
->length
= gfc_copy_expr (current_ts
.u
.cl
->length
);
2235 cl
= current_ts
.u
.cl
;
2237 cl_deferred
= current_ts
.deferred
;
2246 /* The dummy arguments and result of the abreviated form of MODULE
2247 PROCEDUREs, used in SUBMODULES should not be redefined. */
2248 if (gfc_current_ns
->proc_name
2249 && gfc_current_ns
->proc_name
->abr_modproc_decl
)
2251 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2252 if (sym
!= NULL
&& (sym
->attr
.dummy
|| sym
->attr
.result
))
2255 gfc_error ("%qs at %C is a redefinition of the declaration "
2256 "in the corresponding interface for MODULE "
2257 "PROCEDURE %qs", sym
->name
,
2258 gfc_current_ns
->proc_name
->name
);
2263 /* If this symbol has already shown up in a Cray Pointer declaration,
2264 and this is not a component declaration,
2265 then we want to set the type & bail out. */
2266 if (flag_cray_pointer
&& !gfc_comp_struct (gfc_current_state ()))
2268 gfc_find_symbol (name
, gfc_current_ns
, 1, &sym
);
2269 if (sym
!= NULL
&& sym
->attr
.cray_pointee
)
2271 sym
->ts
.type
= current_ts
.type
;
2272 sym
->ts
.kind
= current_ts
.kind
;
2274 sym
->ts
.u
.derived
= current_ts
.u
.derived
;
2275 sym
->ts
.is_c_interop
= current_ts
.is_c_interop
;
2276 sym
->ts
.is_iso_c
= current_ts
.is_iso_c
;
2279 /* Check to see if we have an array specification. */
2282 if (sym
->as
!= NULL
)
2284 gfc_error ("Duplicate array spec for Cray pointee at %C");
2285 gfc_free_array_spec (cp_as
);
2291 if (!gfc_set_array_spec (sym
, cp_as
, &var_locus
))
2292 gfc_internal_error ("Couldn't set pointee array spec.");
2294 /* Fix the array spec. */
2295 m
= gfc_mod_pointee_as (sym
->as
);
2296 if (m
== MATCH_ERROR
)
2304 gfc_free_array_spec (cp_as
);
2308 /* Procedure pointer as function result. */
2309 if (gfc_current_state () == COMP_FUNCTION
2310 && strcmp ("ppr@", gfc_current_block ()->name
) == 0
2311 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) == 0)
2312 strcpy (name
, "ppr@");
2314 if (gfc_current_state () == COMP_FUNCTION
2315 && strcmp (name
, gfc_current_block ()->name
) == 0
2316 && gfc_current_block ()->result
2317 && strcmp ("ppr@", gfc_current_block ()->result
->name
) == 0)
2318 strcpy (name
, "ppr@");
2320 /* OK, we've successfully matched the declaration. Now put the
2321 symbol in the current namespace, because it might be used in the
2322 optional initialization expression for this symbol, e.g. this is
2325 integer, parameter :: i = huge(i)
2327 This is only true for parameters or variables of a basic type.
2328 For components of derived types, it is not true, so we don't
2329 create a symbol for those yet. If we fail to create the symbol,
2331 if (!gfc_comp_struct (gfc_current_state ())
2332 && !build_sym (name
, cl
, cl_deferred
, &as
, &var_locus
))
2338 if (!check_function_name (name
))
2344 /* We allow old-style initializations of the form
2345 integer i /2/, j(4) /3*3, 1/
2346 (if no colon has been seen). These are different from data
2347 statements in that initializers are only allowed to apply to the
2348 variable immediately preceding, i.e.
2350 is not allowed. Therefore we have to do some work manually, that
2351 could otherwise be left to the matchers for DATA statements. */
2353 if (!colon_seen
&& gfc_match (" /") == MATCH_YES
)
2355 if (!gfc_notify_std (GFC_STD_GNU
, "Old-style "
2356 "initialization at %C"))
2359 /* Allow old style initializations for components of STRUCTUREs and MAPs
2360 but not components of derived types. */
2361 else if (gfc_current_state () == COMP_DERIVED
)
2363 gfc_error ("Invalid old style initialization for derived type "
2369 /* For structure components, read the initializer as a special
2370 expression and let the rest of this function apply the initializer
2372 else if (gfc_comp_struct (gfc_current_state ()))
2374 m
= match_clist_expr (&initializer
, ¤t_ts
, as
);
2376 gfc_error ("Syntax error in old style initialization of %s at %C",
2382 /* Otherwise we treat the old style initialization just like a
2383 DATA declaration for the current variable. */
2385 return match_old_style_init (name
);
2388 /* The double colon must be present in order to have initializers.
2389 Otherwise the statement is ambiguous with an assignment statement. */
2392 if (gfc_match (" =>") == MATCH_YES
)
2394 if (!current_attr
.pointer
)
2396 gfc_error ("Initialization at %C isn't for a pointer variable");
2401 m
= match_pointer_init (&initializer
, 0);
2405 else if (gfc_match_char ('=') == MATCH_YES
)
2407 if (current_attr
.pointer
)
2409 gfc_error ("Pointer initialization at %C requires %<=>%>, "
2415 m
= gfc_match_init_expr (&initializer
);
2418 gfc_error ("Expected an initialization expression at %C");
2422 if (current_attr
.flavor
!= FL_PARAMETER
&& gfc_pure (NULL
)
2423 && !gfc_comp_struct (gfc_state_stack
->state
))
2425 gfc_error ("Initialization of variable at %C is not allowed in "
2426 "a PURE procedure");
2430 if (current_attr
.flavor
!= FL_PARAMETER
2431 && !gfc_comp_struct (gfc_state_stack
->state
))
2432 gfc_unset_implicit_pure (gfc_current_ns
->proc_name
);
2439 if (initializer
!= NULL
&& current_attr
.allocatable
2440 && gfc_comp_struct (gfc_current_state ()))
2442 gfc_error ("Initialization of allocatable component at %C is not "
2448 /* Add the initializer. Note that it is fine if initializer is
2449 NULL here, because we sometimes also need to check if a
2450 declaration *must* have an initialization expression. */
2451 if (!gfc_comp_struct (gfc_current_state ()))
2452 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
2455 if (current_ts
.type
== BT_DERIVED
2456 && !current_attr
.pointer
&& !initializer
)
2457 initializer
= gfc_default_initializer (¤t_ts
);
2458 t
= build_struct (name
, cl
, &initializer
, &as
);
2460 /* If we match a nested structure definition we expect to see the
2461 * body even if the variable declarations blow up, so we need to keep
2462 * the structure declaration around. */
2463 if (gfc_new_block
&& gfc_new_block
->attr
.flavor
== FL_STRUCT
)
2464 gfc_commit_symbol (gfc_new_block
);
2467 m
= (t
) ? MATCH_YES
: MATCH_ERROR
;
2470 /* Free stuff up and return. */
2471 gfc_free_expr (initializer
);
2472 gfc_free_array_spec (as
);
2478 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2479 This assumes that the byte size is equal to the kind number for
2480 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
2483 gfc_match_old_kind_spec (gfc_typespec
*ts
)
2488 if (gfc_match_char ('*') != MATCH_YES
)
2491 m
= gfc_match_small_literal_int (&ts
->kind
, NULL
);
2495 original_kind
= ts
->kind
;
2497 /* Massage the kind numbers for complex types. */
2498 if (ts
->type
== BT_COMPLEX
)
2502 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2503 gfc_basic_typename (ts
->type
), original_kind
);
2510 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2513 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2517 if (flag_real4_kind
== 8)
2519 if (flag_real4_kind
== 10)
2521 if (flag_real4_kind
== 16)
2527 if (flag_real8_kind
== 4)
2529 if (flag_real8_kind
== 10)
2531 if (flag_real8_kind
== 16)
2536 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2538 gfc_error ("Old-style type declaration %s*%d not supported at %C",
2539 gfc_basic_typename (ts
->type
), original_kind
);
2543 if (!gfc_notify_std (GFC_STD_GNU
,
2544 "Nonstandard type declaration %s*%d at %C",
2545 gfc_basic_typename(ts
->type
), original_kind
))
2552 /* Match a kind specification. Since kinds are generally optional, we
2553 usually return MATCH_NO if something goes wrong. If a "kind="
2554 string is found, then we know we have an error. */
2557 gfc_match_kind_spec (gfc_typespec
*ts
, bool kind_expr_only
)
2568 where
= loc
= gfc_current_locus
;
2573 if (gfc_match_char ('(') == MATCH_NO
)
2576 /* Also gobbles optional text. */
2577 if (gfc_match (" kind = ") == MATCH_YES
)
2580 loc
= gfc_current_locus
;
2583 n
= gfc_match_init_expr (&e
);
2587 if (gfc_matching_function
)
2589 /* The function kind expression might include use associated or
2590 imported parameters and try again after the specification
2592 if (gfc_match_char (')') != MATCH_YES
)
2594 gfc_error ("Missing right parenthesis at %C");
2600 gfc_undo_symbols ();
2605 /* ....or else, the match is real. */
2607 gfc_error ("Expected initialization expression at %C");
2615 gfc_error ("Expected scalar initialization expression at %C");
2620 if (gfc_extract_int (e
, &ts
->kind
, 1))
2626 /* Before throwing away the expression, let's see if we had a
2627 C interoperable kind (and store the fact). */
2628 if (e
->ts
.is_c_interop
== 1)
2630 /* Mark this as C interoperable if being declared with one
2631 of the named constants from iso_c_binding. */
2632 ts
->is_c_interop
= e
->ts
.is_iso_c
;
2633 ts
->f90_type
= e
->ts
.f90_type
;
2635 ts
->interop_kind
= e
->symtree
->n
.sym
;
2641 /* Ignore errors to this point, if we've gotten here. This means
2642 we ignore the m=MATCH_ERROR from above. */
2643 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) < 0)
2645 gfc_error ("Kind %d not supported for type %s at %C", ts
->kind
,
2646 gfc_basic_typename (ts
->type
));
2647 gfc_current_locus
= where
;
2651 /* Warn if, e.g., c_int is used for a REAL variable, but not
2652 if, e.g., c_double is used for COMPLEX as the standard
2653 explicitly says that the kind type parameter for complex and real
2654 variable is the same, i.e. c_float == c_float_complex. */
2655 if (ts
->f90_type
!= BT_UNKNOWN
&& ts
->f90_type
!= ts
->type
2656 && !((ts
->f90_type
== BT_REAL
&& ts
->type
== BT_COMPLEX
)
2657 || (ts
->f90_type
== BT_COMPLEX
&& ts
->type
== BT_REAL
)))
2658 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
2659 "is %s", gfc_basic_typename (ts
->f90_type
), &where
,
2660 gfc_basic_typename (ts
->type
));
2662 gfc_gobble_whitespace ();
2663 if ((c
= gfc_next_ascii_char ()) != ')'
2664 && (ts
->type
!= BT_CHARACTER
|| c
!= ','))
2666 if (ts
->type
== BT_CHARACTER
)
2667 gfc_error ("Missing right parenthesis or comma at %C");
2669 gfc_error ("Missing right parenthesis at %C");
2673 /* All tests passed. */
2676 if(m
== MATCH_ERROR
)
2677 gfc_current_locus
= where
;
2679 if (ts
->type
== BT_INTEGER
&& ts
->kind
== 4 && flag_integer4_kind
== 8)
2682 if (ts
->type
== BT_REAL
|| ts
->type
== BT_COMPLEX
)
2686 if (flag_real4_kind
== 8)
2688 if (flag_real4_kind
== 10)
2690 if (flag_real4_kind
== 16)
2696 if (flag_real8_kind
== 4)
2698 if (flag_real8_kind
== 10)
2700 if (flag_real8_kind
== 16)
2705 /* Return what we know from the test(s). */
2710 gfc_current_locus
= where
;
2716 match_char_kind (int * kind
, int * is_iso_c
)
2725 where
= gfc_current_locus
;
2727 n
= gfc_match_init_expr (&e
);
2729 if (n
!= MATCH_YES
&& gfc_matching_function
)
2731 /* The expression might include use-associated or imported
2732 parameters and try again after the specification
2735 gfc_undo_symbols ();
2740 gfc_error ("Expected initialization expression at %C");
2746 gfc_error ("Expected scalar initialization expression at %C");
2751 fail
= gfc_extract_int (e
, kind
, 1);
2752 *is_iso_c
= e
->ts
.is_iso_c
;
2761 /* Ignore errors to this point, if we've gotten here. This means
2762 we ignore the m=MATCH_ERROR from above. */
2763 if (gfc_validate_kind (BT_CHARACTER
, *kind
, true) < 0)
2765 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind
);
2769 /* All tests passed. */
2772 if (m
== MATCH_ERROR
)
2773 gfc_current_locus
= where
;
2775 /* Return what we know from the test(s). */
2780 gfc_current_locus
= where
;
2785 /* Match the various kind/length specifications in a CHARACTER
2786 declaration. We don't return MATCH_NO. */
2789 gfc_match_char_spec (gfc_typespec
*ts
)
2791 int kind
, seen_length
, is_iso_c
;
2803 /* Try the old-style specification first. */
2804 old_char_selector
= 0;
2806 m
= match_char_length (&len
, &deferred
, true);
2810 old_char_selector
= 1;
2815 m
= gfc_match_char ('(');
2818 m
= MATCH_YES
; /* Character without length is a single char. */
2822 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
2823 if (gfc_match (" kind =") == MATCH_YES
)
2825 m
= match_char_kind (&kind
, &is_iso_c
);
2827 if (m
== MATCH_ERROR
)
2832 if (gfc_match (" , len =") == MATCH_NO
)
2835 m
= char_len_param_value (&len
, &deferred
);
2838 if (m
== MATCH_ERROR
)
2845 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
2846 if (gfc_match (" len =") == MATCH_YES
)
2848 m
= char_len_param_value (&len
, &deferred
);
2851 if (m
== MATCH_ERROR
)
2855 if (gfc_match_char (')') == MATCH_YES
)
2858 if (gfc_match (" , kind =") != MATCH_YES
)
2861 if (match_char_kind (&kind
, &is_iso_c
) == MATCH_ERROR
)
2867 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
2868 m
= char_len_param_value (&len
, &deferred
);
2871 if (m
== MATCH_ERROR
)
2875 m
= gfc_match_char (')');
2879 if (gfc_match_char (',') != MATCH_YES
)
2882 gfc_match (" kind ="); /* Gobble optional text. */
2884 m
= match_char_kind (&kind
, &is_iso_c
);
2885 if (m
== MATCH_ERROR
)
2891 /* Require a right-paren at this point. */
2892 m
= gfc_match_char (')');
2897 gfc_error ("Syntax error in CHARACTER declaration at %C");
2899 gfc_free_expr (len
);
2903 /* Deal with character functions after USE and IMPORT statements. */
2904 if (gfc_matching_function
)
2906 gfc_free_expr (len
);
2907 gfc_undo_symbols ();
2913 gfc_free_expr (len
);
2917 /* Do some final massaging of the length values. */
2918 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2920 if (seen_length
== 0)
2921 cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2926 ts
->kind
= kind
== 0 ? gfc_default_character_kind
: kind
;
2927 ts
->deferred
= deferred
;
2929 /* We have to know if it was a C interoperable kind so we can
2930 do accurate type checking of bind(c) procs, etc. */
2932 /* Mark this as C interoperable if being declared with one
2933 of the named constants from iso_c_binding. */
2934 ts
->is_c_interop
= is_iso_c
;
2935 else if (len
!= NULL
)
2936 /* Here, we might have parsed something such as: character(c_char)
2937 In this case, the parsing code above grabs the c_char when
2938 looking for the length (line 1690, roughly). it's the last
2939 testcase for parsing the kind params of a character variable.
2940 However, it's not actually the length. this seems like it
2942 To see if the user used a C interop kind, test the expr
2943 of the so called length, and see if it's C interoperable. */
2944 ts
->is_c_interop
= len
->ts
.is_iso_c
;
2950 /* Matches a RECORD declaration. */
2953 match_record_decl (char *name
)
2956 old_loc
= gfc_current_locus
;
2959 m
= gfc_match (" record /");
2962 if (!flag_dec_structure
)
2964 gfc_current_locus
= old_loc
;
2965 gfc_error ("RECORD at %C is an extension, enable it with "
2969 m
= gfc_match (" %n/", name
);
2974 gfc_current_locus
= old_loc
;
2975 if (flag_dec_structure
2976 && (gfc_match (" record% ") == MATCH_YES
2977 || gfc_match (" record%t") == MATCH_YES
))
2978 gfc_error ("Structure name expected after RECORD at %C");
2985 /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
2986 structure to the matched specification. This is necessary for FUNCTION and
2987 IMPLICIT statements.
2989 If implicit_flag is nonzero, then we don't check for the optional
2990 kind specification. Not doing so is needed for matching an IMPLICIT
2991 statement correctly. */
2994 gfc_match_decl_type_spec (gfc_typespec
*ts
, int implicit_flag
)
2996 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2997 gfc_symbol
*sym
, *dt_sym
;
3000 bool seen_deferred_kind
, matched_type
;
3001 const char *dt_name
;
3003 /* A belt and braces check that the typespec is correctly being treated
3004 as a deferred characteristic association. */
3005 seen_deferred_kind
= (gfc_current_state () == COMP_FUNCTION
)
3006 && (gfc_current_block ()->result
->ts
.kind
== -1)
3007 && (ts
->kind
== -1);
3009 if (seen_deferred_kind
)
3012 /* Clear the current binding label, in case one is given. */
3013 curr_binding_label
= NULL
;
3015 if (gfc_match (" byte") == MATCH_YES
)
3017 if (!gfc_notify_std (GFC_STD_GNU
, "BYTE type at %C"))
3020 if (gfc_validate_kind (BT_INTEGER
, 1, true) < 0)
3022 gfc_error ("BYTE type used at %C "
3023 "is not available on the target machine");
3027 ts
->type
= BT_INTEGER
;
3033 m
= gfc_match (" type (");
3034 matched_type
= (m
== MATCH_YES
);
3037 gfc_gobble_whitespace ();
3038 if (gfc_peek_ascii_char () == '*')
3040 if ((m
= gfc_match ("*)")) != MATCH_YES
)
3042 if (gfc_comp_struct (gfc_current_state ()))
3044 gfc_error ("Assumed type at %C is not allowed for components");
3047 if (!gfc_notify_std (GFC_STD_F2008_TS
, "Assumed type "
3050 ts
->type
= BT_ASSUMED
;
3054 m
= gfc_match ("%n", name
);
3055 matched_type
= (m
== MATCH_YES
);
3058 if ((matched_type
&& strcmp ("integer", name
) == 0)
3059 || (!matched_type
&& gfc_match (" integer") == MATCH_YES
))
3061 ts
->type
= BT_INTEGER
;
3062 ts
->kind
= gfc_default_integer_kind
;
3066 if ((matched_type
&& strcmp ("character", name
) == 0)
3067 || (!matched_type
&& gfc_match (" character") == MATCH_YES
))
3070 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3071 "intrinsic-type-spec at %C"))
3074 ts
->type
= BT_CHARACTER
;
3075 if (implicit_flag
== 0)
3076 m
= gfc_match_char_spec (ts
);
3080 if (matched_type
&& m
== MATCH_YES
&& gfc_match_char (')') != MATCH_YES
)
3086 if ((matched_type
&& strcmp ("real", name
) == 0)
3087 || (!matched_type
&& gfc_match (" real") == MATCH_YES
))
3090 ts
->kind
= gfc_default_real_kind
;
3095 && (strcmp ("doubleprecision", name
) == 0
3096 || (strcmp ("double", name
) == 0
3097 && gfc_match (" precision") == MATCH_YES
)))
3098 || (!matched_type
&& gfc_match (" double precision") == MATCH_YES
))
3101 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3102 "intrinsic-type-spec at %C"))
3104 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3108 ts
->kind
= gfc_default_double_kind
;
3112 if ((matched_type
&& strcmp ("complex", name
) == 0)
3113 || (!matched_type
&& gfc_match (" complex") == MATCH_YES
))
3115 ts
->type
= BT_COMPLEX
;
3116 ts
->kind
= gfc_default_complex_kind
;
3121 && (strcmp ("doublecomplex", name
) == 0
3122 || (strcmp ("double", name
) == 0
3123 && gfc_match (" complex") == MATCH_YES
)))
3124 || (!matched_type
&& gfc_match (" double complex") == MATCH_YES
))
3126 if (!gfc_notify_std (GFC_STD_GNU
, "DOUBLE COMPLEX at %C"))
3130 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3131 "intrinsic-type-spec at %C"))
3134 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3137 ts
->type
= BT_COMPLEX
;
3138 ts
->kind
= gfc_default_double_kind
;
3142 if ((matched_type
&& strcmp ("logical", name
) == 0)
3143 || (!matched_type
&& gfc_match (" logical") == MATCH_YES
))
3145 ts
->type
= BT_LOGICAL
;
3146 ts
->kind
= gfc_default_logical_kind
;
3151 m
= gfc_match_char (')');
3154 m
= match_record_decl (name
);
3156 if (matched_type
|| m
== MATCH_YES
)
3158 ts
->type
= BT_DERIVED
;
3159 /* We accept record/s/ or type(s) where s is a structure, but we
3160 * don't need all the extra derived-type stuff for structures. */
3161 if (gfc_find_symbol (gfc_dt_upper_string (name
), NULL
, 1, &sym
))
3163 gfc_error ("Type name %qs at %C is ambiguous", name
);
3166 if (sym
&& sym
->attr
.flavor
== FL_STRUCT
)
3168 ts
->u
.derived
= sym
;
3171 /* Actually a derived type. */
3176 /* Match nested STRUCTURE declarations; only valid within another
3177 structure declaration. */
3178 if (flag_dec_structure
3179 && (gfc_current_state () == COMP_STRUCTURE
3180 || gfc_current_state () == COMP_MAP
))
3182 m
= gfc_match (" structure");
3185 m
= gfc_match_structure_decl ();
3188 /* gfc_new_block is updated by match_structure_decl. */
3189 ts
->type
= BT_DERIVED
;
3190 ts
->u
.derived
= gfc_new_block
;
3194 if (m
== MATCH_ERROR
)
3198 /* Match CLASS declarations. */
3199 m
= gfc_match (" class ( * )");
3200 if (m
== MATCH_ERROR
)
3202 else if (m
== MATCH_YES
)
3206 ts
->type
= BT_CLASS
;
3207 gfc_find_symbol ("STAR", gfc_current_ns
, 1, &upe
);
3210 upe
= gfc_new_symbol ("STAR", gfc_current_ns
);
3211 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "STAR");
3213 gfc_set_sym_referenced (upe
);
3215 upe
->ts
.type
= BT_VOID
;
3216 upe
->attr
.unlimited_polymorphic
= 1;
3217 /* This is essential to force the construction of
3218 unlimited polymorphic component class containers. */
3219 upe
->attr
.zero_comp
= 1;
3220 if (!gfc_add_flavor (&upe
->attr
, FL_DERIVED
, NULL
,
3221 &gfc_current_locus
))
3226 st
= gfc_get_tbp_symtree (&gfc_current_ns
->sym_root
, "STAR");
3230 ts
->u
.derived
= upe
;
3234 m
= gfc_match (" class ( %n )", name
);
3237 ts
->type
= BT_CLASS
;
3239 if (!gfc_notify_std (GFC_STD_F2003
, "CLASS statement at %C"))
3243 /* Defer association of the derived type until the end of the
3244 specification block. However, if the derived type can be
3245 found, add it to the typespec. */
3246 if (gfc_matching_function
)
3248 ts
->u
.derived
= NULL
;
3249 if (gfc_current_state () != COMP_INTERFACE
3250 && !gfc_find_symbol (name
, NULL
, 1, &sym
) && sym
)
3252 sym
= gfc_find_dt_in_generic (sym
);
3253 ts
->u
.derived
= sym
;
3258 /* Search for the name but allow the components to be defined later. If
3259 type = -1, this typespec has been seen in a function declaration but
3260 the type could not be accessed at that point. The actual derived type is
3261 stored in a symtree with the first letter of the name capitalized; the
3262 symtree with the all lower-case name contains the associated
3263 generic function. */
3264 dt_name
= gfc_dt_upper_string (name
);
3269 gfc_get_ha_symbol (name
, &sym
);
3270 if (sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 0, &dt_sym
))
3272 gfc_error ("Type name %qs at %C is ambiguous", name
);
3275 if (sym
->generic
&& !dt_sym
)
3276 dt_sym
= gfc_find_dt_in_generic (sym
);
3278 else if (ts
->kind
== -1)
3280 int iface
= gfc_state_stack
->previous
->state
!= COMP_INTERFACE
3281 || gfc_current_ns
->has_import_set
;
3282 gfc_find_symbol (name
, NULL
, iface
, &sym
);
3283 if (sym
&& sym
->generic
&& gfc_find_symbol (dt_name
, NULL
, 1, &dt_sym
))
3285 gfc_error ("Type name %qs at %C is ambiguous", name
);
3288 if (sym
&& sym
->generic
&& !dt_sym
)
3289 dt_sym
= gfc_find_dt_in_generic (sym
);
3296 if ((sym
->attr
.flavor
!= FL_UNKNOWN
&& sym
->attr
.flavor
!= FL_STRUCT
3297 && !(sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
))
3298 || sym
->attr
.subroutine
)
3300 gfc_error ("Type name %qs at %C conflicts with previously declared "
3301 "entity at %L, which has the same name", name
,
3306 gfc_save_symbol_data (sym
);
3307 gfc_set_sym_referenced (sym
);
3308 if (!sym
->attr
.generic
3309 && !gfc_add_generic (&sym
->attr
, sym
->name
, NULL
))
3312 if (!sym
->attr
.function
3313 && !gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
3318 gfc_interface
*intr
, *head
;
3320 /* Use upper case to save the actual derived-type symbol. */
3321 gfc_get_symbol (dt_name
, NULL
, &dt_sym
);
3322 dt_sym
->name
= gfc_get_string ("%s", sym
->name
);
3323 head
= sym
->generic
;
3324 intr
= gfc_get_interface ();
3326 intr
->where
= gfc_current_locus
;
3328 sym
->generic
= intr
;
3329 sym
->attr
.if_source
= IFSRC_DECL
;
3332 gfc_save_symbol_data (dt_sym
);
3334 gfc_set_sym_referenced (dt_sym
);
3336 if (dt_sym
->attr
.flavor
!= FL_DERIVED
&& dt_sym
->attr
.flavor
!= FL_STRUCT
3337 && !gfc_add_flavor (&dt_sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
3340 ts
->u
.derived
= dt_sym
;
3346 && !gfc_notify_std (GFC_STD_F2008
, "TYPE with "
3347 "intrinsic-type-spec at %C"))
3350 /* For all types except double, derived and character, look for an
3351 optional kind specifier. MATCH_NO is actually OK at this point. */
3352 if (implicit_flag
== 1)
3354 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3360 if (gfc_current_form
== FORM_FREE
)
3362 c
= gfc_peek_ascii_char ();
3363 if (!gfc_is_whitespace (c
) && c
!= '*' && c
!= '('
3364 && c
!= ':' && c
!= ',')
3366 if (matched_type
&& c
== ')')
3368 gfc_next_ascii_char ();
3375 m
= gfc_match_kind_spec (ts
, false);
3376 if (m
== MATCH_NO
&& ts
->type
!= BT_CHARACTER
)
3378 m
= gfc_match_old_kind_spec (ts
);
3379 if (gfc_validate_kind (ts
->type
, ts
->kind
, true) == -1)
3383 if (matched_type
&& gfc_match_char (')') != MATCH_YES
)
3386 /* Defer association of the KIND expression of function results
3387 until after USE and IMPORT statements. */
3388 if ((gfc_current_state () == COMP_NONE
&& gfc_error_flag_test ())
3389 || gfc_matching_function
)
3393 m
= MATCH_YES
; /* No kind specifier found. */
3399 /* Match an IMPLICIT NONE statement. Actually, this statement is
3400 already matched in parse.c, or we would not end up here in the
3401 first place. So the only thing we need to check, is if there is
3402 trailing garbage. If not, the match is successful. */
3405 gfc_match_implicit_none (void)
3409 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3411 bool external
= false;
3412 locus cur_loc
= gfc_current_locus
;
3414 if (gfc_current_ns
->seen_implicit_none
3415 || gfc_current_ns
->has_implicit_none_export
)
3417 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
3421 gfc_gobble_whitespace ();
3422 c
= gfc_peek_ascii_char ();
3425 (void) gfc_next_ascii_char ();
3426 if (!gfc_notify_std (GFC_STD_F2015
, "IMPORT NONE with spec list at %C"))
3429 gfc_gobble_whitespace ();
3430 if (gfc_peek_ascii_char () == ')')
3432 (void) gfc_next_ascii_char ();
3438 m
= gfc_match (" %n", name
);
3442 if (strcmp (name
, "type") == 0)
3444 else if (strcmp (name
, "external") == 0)
3449 gfc_gobble_whitespace ();
3450 c
= gfc_next_ascii_char ();
3461 if (gfc_match_eos () != MATCH_YES
)
3464 gfc_set_implicit_none (type
, external
, &cur_loc
);
3470 /* Match the letter range(s) of an IMPLICIT statement. */
3473 match_implicit_range (void)
3479 cur_loc
= gfc_current_locus
;
3481 gfc_gobble_whitespace ();
3482 c
= gfc_next_ascii_char ();
3485 gfc_error ("Missing character range in IMPLICIT at %C");
3492 gfc_gobble_whitespace ();
3493 c1
= gfc_next_ascii_char ();
3497 gfc_gobble_whitespace ();
3498 c
= gfc_next_ascii_char ();
3503 inner
= 0; /* Fall through. */
3510 gfc_gobble_whitespace ();
3511 c2
= gfc_next_ascii_char ();
3515 gfc_gobble_whitespace ();
3516 c
= gfc_next_ascii_char ();
3518 if ((c
!= ',') && (c
!= ')'))
3531 gfc_error ("Letters must be in alphabetic order in "
3532 "IMPLICIT statement at %C");
3536 /* See if we can add the newly matched range to the pending
3537 implicits from this IMPLICIT statement. We do not check for
3538 conflicts with whatever earlier IMPLICIT statements may have
3539 set. This is done when we've successfully finished matching
3541 if (!gfc_add_new_implicit_range (c1
, c2
))
3548 gfc_syntax_error (ST_IMPLICIT
);
3550 gfc_current_locus
= cur_loc
;
3555 /* Match an IMPLICIT statement, storing the types for
3556 gfc_set_implicit() if the statement is accepted by the parser.
3557 There is a strange looking, but legal syntactic construction
3558 possible. It looks like:
3560 IMPLICIT INTEGER (a-b) (c-d)
3562 This is legal if "a-b" is a constant expression that happens to
3563 equal one of the legal kinds for integers. The real problem
3564 happens with an implicit specification that looks like:
3566 IMPLICIT INTEGER (a-b)
3568 In this case, a typespec matcher that is "greedy" (as most of the
3569 matchers are) gobbles the character range as a kindspec, leaving
3570 nothing left. We therefore have to go a bit more slowly in the
3571 matching process by inhibiting the kindspec checking during
3572 typespec matching and checking for a kind later. */
3575 gfc_match_implicit (void)
3582 if (gfc_current_ns
->seen_implicit_none
)
3584 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
3591 /* We don't allow empty implicit statements. */
3592 if (gfc_match_eos () == MATCH_YES
)
3594 gfc_error ("Empty IMPLICIT statement at %C");
3600 /* First cleanup. */
3601 gfc_clear_new_implicit ();
3603 /* A basic type is mandatory here. */
3604 m
= gfc_match_decl_type_spec (&ts
, 1);
3605 if (m
== MATCH_ERROR
)
3610 cur_loc
= gfc_current_locus
;
3611 m
= match_implicit_range ();
3615 /* We may have <TYPE> (<RANGE>). */
3616 gfc_gobble_whitespace ();
3617 c
= gfc_peek_ascii_char ();
3618 if (c
== ',' || c
== '\n' || c
== ';' || c
== '!')
3620 /* Check for CHARACTER with no length parameter. */
3621 if (ts
.type
== BT_CHARACTER
&& !ts
.u
.cl
)
3623 ts
.kind
= gfc_default_character_kind
;
3624 ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
3625 ts
.u
.cl
->length
= gfc_get_int_expr (gfc_default_integer_kind
,
3629 /* Record the Successful match. */
3630 if (!gfc_merge_new_implicit (&ts
))
3633 c
= gfc_next_ascii_char ();
3634 else if (gfc_match_eos () == MATCH_ERROR
)
3639 gfc_current_locus
= cur_loc
;
3642 /* Discard the (incorrectly) matched range. */
3643 gfc_clear_new_implicit ();
3645 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
3646 if (ts
.type
== BT_CHARACTER
)
3647 m
= gfc_match_char_spec (&ts
);
3650 m
= gfc_match_kind_spec (&ts
, false);
3653 m
= gfc_match_old_kind_spec (&ts
);
3654 if (m
== MATCH_ERROR
)
3660 if (m
== MATCH_ERROR
)
3663 m
= match_implicit_range ();
3664 if (m
== MATCH_ERROR
)
3669 gfc_gobble_whitespace ();
3670 c
= gfc_next_ascii_char ();
3671 if (c
!= ',' && gfc_match_eos () != MATCH_YES
)
3674 if (!gfc_merge_new_implicit (&ts
))
3682 gfc_syntax_error (ST_IMPLICIT
);
3690 gfc_match_import (void)
3692 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3697 if (gfc_current_ns
->proc_name
== NULL
3698 || gfc_current_ns
->proc_name
->attr
.if_source
!= IFSRC_IFBODY
)
3700 gfc_error ("IMPORT statement at %C only permitted in "
3701 "an INTERFACE body");
3705 if (gfc_current_ns
->proc_name
->attr
.module_procedure
)
3707 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
3708 "in a module procedure interface body");
3712 if (!gfc_notify_std (GFC_STD_F2003
, "IMPORT statement at %C"))
3715 if (gfc_match_eos () == MATCH_YES
)
3717 /* All host variables should be imported. */
3718 gfc_current_ns
->has_import_set
= 1;
3722 if (gfc_match (" ::") == MATCH_YES
)
3724 if (gfc_match_eos () == MATCH_YES
)
3726 gfc_error ("Expecting list of named entities at %C");
3734 m
= gfc_match (" %n", name
);
3738 if (gfc_current_ns
->parent
!= NULL
3739 && gfc_find_symbol (name
, gfc_current_ns
->parent
, 1, &sym
))
3741 gfc_error ("Type name %qs at %C is ambiguous", name
);
3744 else if (!sym
&& gfc_current_ns
->proc_name
->ns
->parent
!= NULL
3745 && gfc_find_symbol (name
,
3746 gfc_current_ns
->proc_name
->ns
->parent
,
3749 gfc_error ("Type name %qs at %C is ambiguous", name
);
3755 gfc_error ("Cannot IMPORT %qs from host scoping unit "
3756 "at %C - does not exist.", name
);
3760 if (gfc_find_symtree (gfc_current_ns
->sym_root
, name
))
3762 gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
3767 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, name
);
3770 sym
->attr
.imported
= 1;
3772 if (sym
->attr
.generic
&& (sym
= gfc_find_dt_in_generic (sym
)))
3774 /* The actual derived type is stored in a symtree with the first
3775 letter of the name capitalized; the symtree with the all
3776 lower-case name contains the associated generic function. */
3777 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
,
3778 gfc_dt_upper_string (name
));
3781 sym
->attr
.imported
= 1;
3794 if (gfc_match_eos () == MATCH_YES
)
3796 if (gfc_match_char (',') != MATCH_YES
)
3803 gfc_error ("Syntax error in IMPORT statement at %C");
3808 /* A minimal implementation of gfc_match without whitespace, escape
3809 characters or variable arguments. Returns true if the next
3810 characters match the TARGET template exactly. */
3813 match_string_p (const char *target
)
3817 for (p
= target
; *p
; p
++)
3818 if ((char) gfc_next_ascii_char () != *p
)
3823 /* Matches an attribute specification including array specs. If
3824 successful, leaves the variables current_attr and current_as
3825 holding the specification. Also sets the colon_seen variable for
3826 later use by matchers associated with initializations.
3828 This subroutine is a little tricky in the sense that we don't know
3829 if we really have an attr-spec until we hit the double colon.
3830 Until that time, we can only return MATCH_NO. This forces us to
3831 check for duplicate specification at this level. */
3834 match_attr_spec (void)
3836 /* Modifiers that can exist in a type statement. */
3838 { GFC_DECL_BEGIN
= 0,
3839 DECL_ALLOCATABLE
= GFC_DECL_BEGIN
, DECL_DIMENSION
, DECL_EXTERNAL
,
3840 DECL_IN
, DECL_OUT
, DECL_INOUT
, DECL_INTRINSIC
, DECL_OPTIONAL
,
3841 DECL_PARAMETER
, DECL_POINTER
, DECL_PROTECTED
, DECL_PRIVATE
,
3842 DECL_STATIC
, DECL_AUTOMATIC
,
3843 DECL_PUBLIC
, DECL_SAVE
, DECL_TARGET
, DECL_VALUE
, DECL_VOLATILE
,
3844 DECL_IS_BIND_C
, DECL_CODIMENSION
, DECL_ASYNCHRONOUS
, DECL_CONTIGUOUS
,
3845 DECL_NONE
, GFC_DECL_END
/* Sentinel */
3848 /* GFC_DECL_END is the sentinel, index starts at 0. */
3849 #define NUM_DECL GFC_DECL_END
3851 locus start
, seen_at
[NUM_DECL
];
3858 gfc_clear_attr (¤t_attr
);
3859 start
= gfc_current_locus
;
3864 /* See if we get all of the keywords up to the final double colon. */
3865 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
3873 gfc_gobble_whitespace ();
3875 ch
= gfc_next_ascii_char ();
3878 /* This is the successful exit condition for the loop. */
3879 if (gfc_next_ascii_char () == ':')
3884 gfc_gobble_whitespace ();
3885 switch (gfc_peek_ascii_char ())
3888 gfc_next_ascii_char ();
3889 switch (gfc_next_ascii_char ())
3892 if (match_string_p ("locatable"))
3894 /* Matched "allocatable". */
3895 d
= DECL_ALLOCATABLE
;
3900 if (match_string_p ("ynchronous"))
3902 /* Matched "asynchronous". */
3903 d
= DECL_ASYNCHRONOUS
;
3908 if (match_string_p ("tomatic"))
3910 /* Matched "automatic". */
3918 /* Try and match the bind(c). */
3919 m
= gfc_match_bind_c (NULL
, true);
3922 else if (m
== MATCH_ERROR
)
3927 gfc_next_ascii_char ();
3928 if ('o' != gfc_next_ascii_char ())
3930 switch (gfc_next_ascii_char ())
3933 if (match_string_p ("imension"))
3935 d
= DECL_CODIMENSION
;
3940 if (match_string_p ("tiguous"))
3942 d
= DECL_CONTIGUOUS
;
3949 if (match_string_p ("dimension"))
3954 if (match_string_p ("external"))
3959 if (match_string_p ("int"))
3961 ch
= gfc_next_ascii_char ();
3964 if (match_string_p ("nt"))
3966 /* Matched "intent". */
3967 /* TODO: Call match_intent_spec from here. */
3968 if (gfc_match (" ( in out )") == MATCH_YES
)
3970 else if (gfc_match (" ( in )") == MATCH_YES
)
3972 else if (gfc_match (" ( out )") == MATCH_YES
)
3978 if (match_string_p ("insic"))
3980 /* Matched "intrinsic". */
3988 if (match_string_p ("optional"))
3993 gfc_next_ascii_char ();
3994 switch (gfc_next_ascii_char ())
3997 if (match_string_p ("rameter"))
3999 /* Matched "parameter". */
4005 if (match_string_p ("inter"))
4007 /* Matched "pointer". */
4013 ch
= gfc_next_ascii_char ();
4016 if (match_string_p ("vate"))
4018 /* Matched "private". */
4024 if (match_string_p ("tected"))
4026 /* Matched "protected". */
4033 if (match_string_p ("blic"))
4035 /* Matched "public". */
4043 gfc_next_ascii_char ();
4044 switch (gfc_next_ascii_char ())
4047 if (match_string_p ("ve"))
4049 /* Matched "save". */
4055 if (match_string_p ("atic"))
4057 /* Matched "static". */
4065 if (match_string_p ("target"))
4070 gfc_next_ascii_char ();
4071 ch
= gfc_next_ascii_char ();
4074 if (match_string_p ("lue"))
4076 /* Matched "value". */
4082 if (match_string_p ("latile"))
4084 /* Matched "volatile". */
4092 /* No double colon and no recognizable decl_type, so assume that
4093 we've been looking at something else the whole time. */
4100 /* Check to make sure any parens are paired up correctly. */
4101 if (gfc_match_parens () == MATCH_ERROR
)
4108 seen_at
[d
] = gfc_current_locus
;
4110 if (d
== DECL_DIMENSION
|| d
== DECL_CODIMENSION
)
4112 gfc_array_spec
*as
= NULL
;
4114 m
= gfc_match_array_spec (&as
, d
== DECL_DIMENSION
,
4115 d
== DECL_CODIMENSION
);
4117 if (current_as
== NULL
)
4119 else if (m
== MATCH_YES
)
4121 if (!merge_array_spec (as
, current_as
, false))
4128 if (d
== DECL_CODIMENSION
)
4129 gfc_error ("Missing codimension specification at %C");
4131 gfc_error ("Missing dimension specification at %C");
4135 if (m
== MATCH_ERROR
)
4140 /* Since we've seen a double colon, we have to be looking at an
4141 attr-spec. This means that we can now issue errors. */
4142 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4147 case DECL_ALLOCATABLE
:
4148 attr
= "ALLOCATABLE";
4150 case DECL_ASYNCHRONOUS
:
4151 attr
= "ASYNCHRONOUS";
4153 case DECL_CODIMENSION
:
4154 attr
= "CODIMENSION";
4156 case DECL_CONTIGUOUS
:
4157 attr
= "CONTIGUOUS";
4159 case DECL_DIMENSION
:
4166 attr
= "INTENT (IN)";
4169 attr
= "INTENT (OUT)";
4172 attr
= "INTENT (IN OUT)";
4174 case DECL_INTRINSIC
:
4180 case DECL_PARAMETER
:
4186 case DECL_PROTECTED
:
4201 case DECL_AUTOMATIC
:
4207 case DECL_IS_BIND_C
:
4217 attr
= NULL
; /* This shouldn't happen. */
4220 gfc_error ("Duplicate %s attribute at %L", attr
, &seen_at
[d
]);
4225 /* Now that we've dealt with duplicate attributes, add the attributes
4226 to the current attribute. */
4227 for (d
= GFC_DECL_BEGIN
; d
!= GFC_DECL_END
; d
++)
4232 if ((d
== DECL_STATIC
|| d
== DECL_AUTOMATIC
)
4233 && !flag_dec_static
)
4235 gfc_error ("%s at %L is a DEC extension, enable with "
4237 d
== DECL_STATIC
? "STATIC" : "AUTOMATIC", &seen_at
[d
]);
4241 /* Allow SAVE with STATIC, but don't complain. */
4242 if (d
== DECL_STATIC
&& seen
[DECL_SAVE
])
4245 if (gfc_current_state () == COMP_DERIVED
4246 && d
!= DECL_DIMENSION
&& d
!= DECL_CODIMENSION
4247 && d
!= DECL_POINTER
&& d
!= DECL_PRIVATE
4248 && d
!= DECL_PUBLIC
&& d
!= DECL_CONTIGUOUS
&& d
!= DECL_NONE
)
4250 if (d
== DECL_ALLOCATABLE
)
4252 if (!gfc_notify_std (GFC_STD_F2003
, "ALLOCATABLE "
4253 "attribute at %C in a TYPE definition"))
4261 gfc_error ("Attribute at %L is not allowed in a TYPE definition",
4268 if ((d
== DECL_PRIVATE
|| d
== DECL_PUBLIC
)
4269 && gfc_current_state () != COMP_MODULE
)
4271 if (d
== DECL_PRIVATE
)
4275 if (gfc_current_state () == COMP_DERIVED
4276 && gfc_state_stack
->previous
4277 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
4279 if (!gfc_notify_std (GFC_STD_F2003
, "Attribute %s "
4280 "at %L in a TYPE definition", attr
,
4289 gfc_error ("%s attribute at %L is not allowed outside of the "
4290 "specification part of a module", attr
, &seen_at
[d
]);
4298 case DECL_ALLOCATABLE
:
4299 t
= gfc_add_allocatable (¤t_attr
, &seen_at
[d
]);
4302 case DECL_ASYNCHRONOUS
:
4303 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS attribute at %C"))
4306 t
= gfc_add_asynchronous (¤t_attr
, NULL
, &seen_at
[d
]);
4309 case DECL_CODIMENSION
:
4310 t
= gfc_add_codimension (¤t_attr
, NULL
, &seen_at
[d
]);
4313 case DECL_CONTIGUOUS
:
4314 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS attribute at %C"))
4317 t
= gfc_add_contiguous (¤t_attr
, NULL
, &seen_at
[d
]);
4320 case DECL_DIMENSION
:
4321 t
= gfc_add_dimension (¤t_attr
, NULL
, &seen_at
[d
]);
4325 t
= gfc_add_external (¤t_attr
, &seen_at
[d
]);
4329 t
= gfc_add_intent (¤t_attr
, INTENT_IN
, &seen_at
[d
]);
4333 t
= gfc_add_intent (¤t_attr
, INTENT_OUT
, &seen_at
[d
]);
4337 t
= gfc_add_intent (¤t_attr
, INTENT_INOUT
, &seen_at
[d
]);
4340 case DECL_INTRINSIC
:
4341 t
= gfc_add_intrinsic (¤t_attr
, &seen_at
[d
]);
4345 t
= gfc_add_optional (¤t_attr
, &seen_at
[d
]);
4348 case DECL_PARAMETER
:
4349 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, &seen_at
[d
]);
4353 t
= gfc_add_pointer (¤t_attr
, &seen_at
[d
]);
4356 case DECL_PROTECTED
:
4357 if (gfc_current_state () != COMP_MODULE
4358 || (gfc_current_ns
->proc_name
4359 && gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
))
4361 gfc_error ("PROTECTED at %C only allowed in specification "
4362 "part of a module");
4367 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED attribute at %C"))
4370 t
= gfc_add_protected (¤t_attr
, NULL
, &seen_at
[d
]);
4374 t
= gfc_add_access (¤t_attr
, ACCESS_PRIVATE
, NULL
,
4379 t
= gfc_add_access (¤t_attr
, ACCESS_PUBLIC
, NULL
,
4385 t
= gfc_add_save (¤t_attr
, SAVE_EXPLICIT
, NULL
, &seen_at
[d
]);
4388 case DECL_AUTOMATIC
:
4389 t
= gfc_add_automatic (¤t_attr
, NULL
, &seen_at
[d
]);
4393 t
= gfc_add_target (¤t_attr
, &seen_at
[d
]);
4396 case DECL_IS_BIND_C
:
4397 t
= gfc_add_is_bind_c(¤t_attr
, NULL
, &seen_at
[d
], 0);
4401 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE attribute at %C"))
4404 t
= gfc_add_value (¤t_attr
, NULL
, &seen_at
[d
]);
4408 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE attribute at %C"))
4411 t
= gfc_add_volatile (¤t_attr
, NULL
, &seen_at
[d
]);
4415 gfc_internal_error ("match_attr_spec(): Bad attribute");
4425 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
4426 if ((gfc_current_state () == COMP_MODULE
4427 || gfc_current_state () == COMP_SUBMODULE
)
4428 && !current_attr
.save
4429 && (gfc_option
.allow_std
& GFC_STD_F2008
) != 0)
4430 current_attr
.save
= SAVE_IMPLICIT
;
4436 gfc_current_locus
= start
;
4437 gfc_free_array_spec (current_as
);
4443 /* Set the binding label, dest_label, either with the binding label
4444 stored in the given gfc_typespec, ts, or if none was provided, it
4445 will be the symbol name in all lower case, as required by the draft
4446 (J3/04-007, section 15.4.1). If a binding label was given and
4447 there is more than one argument (num_idents), it is an error. */
4450 set_binding_label (const char **dest_label
, const char *sym_name
,
4453 if (num_idents
> 1 && has_name_equals
)
4455 gfc_error ("Multiple identifiers provided with "
4456 "single NAME= specifier at %C");
4460 if (curr_binding_label
)
4461 /* Binding label given; store in temp holder till have sym. */
4462 *dest_label
= curr_binding_label
;
4465 /* No binding label given, and the NAME= specifier did not exist,
4466 which means there was no NAME="". */
4467 if (sym_name
!= NULL
&& has_name_equals
== 0)
4468 *dest_label
= IDENTIFIER_POINTER (get_identifier (sym_name
));
4475 /* Set the status of the given common block as being BIND(C) or not,
4476 depending on the given parameter, is_bind_c. */
4479 set_com_block_bind_c (gfc_common_head
*com_block
, int is_bind_c
)
4481 com_block
->is_bind_c
= is_bind_c
;
4486 /* Verify that the given gfc_typespec is for a C interoperable type. */
4489 gfc_verify_c_interop (gfc_typespec
*ts
)
4491 if (ts
->type
== BT_DERIVED
&& ts
->u
.derived
!= NULL
)
4492 return (ts
->u
.derived
->ts
.is_c_interop
|| ts
->u
.derived
->attr
.is_bind_c
)
4494 else if (ts
->type
== BT_CLASS
)
4496 else if (ts
->is_c_interop
!= 1 && ts
->type
!= BT_ASSUMED
)
4503 /* Verify that the variables of a given common block, which has been
4504 defined with the attribute specifier bind(c), to be of a C
4505 interoperable type. Errors will be reported here, if
4509 verify_com_block_vars_c_interop (gfc_common_head
*com_block
)
4511 gfc_symbol
*curr_sym
= NULL
;
4514 curr_sym
= com_block
->head
;
4516 /* Make sure we have at least one symbol. */
4517 if (curr_sym
== NULL
)
4520 /* Here we know we have a symbol, so we'll execute this loop
4524 /* The second to last param, 1, says this is in a common block. */
4525 retval
= verify_bind_c_sym (curr_sym
, &(curr_sym
->ts
), 1, com_block
);
4526 curr_sym
= curr_sym
->common_next
;
4527 } while (curr_sym
!= NULL
);
4533 /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
4534 an appropriate error message is reported. */
4537 verify_bind_c_sym (gfc_symbol
*tmp_sym
, gfc_typespec
*ts
,
4538 int is_in_common
, gfc_common_head
*com_block
)
4540 bool bind_c_function
= false;
4543 if (tmp_sym
->attr
.function
&& tmp_sym
->attr
.is_bind_c
)
4544 bind_c_function
= true;
4546 if (tmp_sym
->attr
.function
&& tmp_sym
->result
!= NULL
)
4548 tmp_sym
= tmp_sym
->result
;
4549 /* Make sure it wasn't an implicitly typed result. */
4550 if (tmp_sym
->attr
.implicit_type
&& warn_c_binding_type
)
4552 gfc_warning (OPT_Wc_binding_type
,
4553 "Implicitly declared BIND(C) function %qs at "
4554 "%L may not be C interoperable", tmp_sym
->name
,
4555 &tmp_sym
->declared_at
);
4556 tmp_sym
->ts
.f90_type
= tmp_sym
->ts
.type
;
4557 /* Mark it as C interoperable to prevent duplicate warnings. */
4558 tmp_sym
->ts
.is_c_interop
= 1;
4559 tmp_sym
->attr
.is_c_interop
= 1;
4563 /* Here, we know we have the bind(c) attribute, so if we have
4564 enough type info, then verify that it's a C interop kind.
4565 The info could be in the symbol already, or possibly still in
4566 the given ts (current_ts), so look in both. */
4567 if (tmp_sym
->ts
.type
!= BT_UNKNOWN
|| ts
->type
!= BT_UNKNOWN
)
4569 if (!gfc_verify_c_interop (&(tmp_sym
->ts
)))
4571 /* See if we're dealing with a sym in a common block or not. */
4572 if (is_in_common
== 1 && warn_c_binding_type
)
4574 gfc_warning (OPT_Wc_binding_type
,
4575 "Variable %qs in common block %qs at %L "
4576 "may not be a C interoperable "
4577 "kind though common block %qs is BIND(C)",
4578 tmp_sym
->name
, com_block
->name
,
4579 &(tmp_sym
->declared_at
), com_block
->name
);
4583 if (tmp_sym
->ts
.type
== BT_DERIVED
|| ts
->type
== BT_DERIVED
)
4584 gfc_error ("Type declaration %qs at %L is not C "
4585 "interoperable but it is BIND(C)",
4586 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4587 else if (warn_c_binding_type
)
4588 gfc_warning (OPT_Wc_binding_type
, "Variable %qs at %L "
4589 "may not be a C interoperable "
4590 "kind but it is BIND(C)",
4591 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4595 /* Variables declared w/in a common block can't be bind(c)
4596 since there's no way for C to see these variables, so there's
4597 semantically no reason for the attribute. */
4598 if (is_in_common
== 1 && tmp_sym
->attr
.is_bind_c
== 1)
4600 gfc_error ("Variable %qs in common block %qs at "
4601 "%L cannot be declared with BIND(C) "
4602 "since it is not a global",
4603 tmp_sym
->name
, com_block
->name
,
4604 &(tmp_sym
->declared_at
));
4608 /* Scalar variables that are bind(c) can not have the pointer
4609 or allocatable attributes. */
4610 if (tmp_sym
->attr
.is_bind_c
== 1)
4612 if (tmp_sym
->attr
.pointer
== 1)
4614 gfc_error ("Variable %qs at %L cannot have both the "
4615 "POINTER and BIND(C) attributes",
4616 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4620 if (tmp_sym
->attr
.allocatable
== 1)
4622 gfc_error ("Variable %qs at %L cannot have both the "
4623 "ALLOCATABLE and BIND(C) attributes",
4624 tmp_sym
->name
, &(tmp_sym
->declared_at
));
4630 /* If it is a BIND(C) function, make sure the return value is a
4631 scalar value. The previous tests in this function made sure
4632 the type is interoperable. */
4633 if (bind_c_function
&& tmp_sym
->as
!= NULL
)
4634 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4635 "be an array", tmp_sym
->name
, &(tmp_sym
->declared_at
));
4637 /* BIND(C) functions can not return a character string. */
4638 if (bind_c_function
&& tmp_sym
->ts
.type
== BT_CHARACTER
)
4639 if (tmp_sym
->ts
.u
.cl
== NULL
|| tmp_sym
->ts
.u
.cl
->length
== NULL
4640 || tmp_sym
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
4641 || mpz_cmp_si (tmp_sym
->ts
.u
.cl
->length
->value
.integer
, 1) != 0)
4642 gfc_error ("Return type of BIND(C) function %qs at %L cannot "
4643 "be a character string", tmp_sym
->name
,
4644 &(tmp_sym
->declared_at
));
4647 /* See if the symbol has been marked as private. If it has, make sure
4648 there is no binding label and warn the user if there is one. */
4649 if (tmp_sym
->attr
.access
== ACCESS_PRIVATE
4650 && tmp_sym
->binding_label
)
4651 /* Use gfc_warning_now because we won't say that the symbol fails
4652 just because of this. */
4653 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
4654 "given the binding label %qs", tmp_sym
->name
,
4655 &(tmp_sym
->declared_at
), tmp_sym
->binding_label
);
4661 /* Set the appropriate fields for a symbol that's been declared as
4662 BIND(C) (the is_bind_c flag and the binding label), and verify that
4663 the type is C interoperable. Errors are reported by the functions
4664 used to set/test these fields. */
4667 set_verify_bind_c_sym (gfc_symbol
*tmp_sym
, int num_idents
)
4671 /* TODO: Do we need to make sure the vars aren't marked private? */
4673 /* Set the is_bind_c bit in symbol_attribute. */
4674 gfc_add_is_bind_c (&(tmp_sym
->attr
), tmp_sym
->name
, &gfc_current_locus
, 0);
4676 if (!set_binding_label (&tmp_sym
->binding_label
, tmp_sym
->name
, num_idents
))
4683 /* Set the fields marking the given common block as BIND(C), including
4684 a binding label, and report any errors encountered. */
4687 set_verify_bind_c_com_block (gfc_common_head
*com_block
, int num_idents
)
4691 /* destLabel, common name, typespec (which may have binding label). */
4692 if (!set_binding_label (&com_block
->binding_label
, com_block
->name
,
4696 /* Set the given common block (com_block) to being bind(c) (1). */
4697 set_com_block_bind_c (com_block
, 1);
4703 /* Retrieve the list of one or more identifiers that the given bind(c)
4704 attribute applies to. */
4707 get_bind_c_idents (void)
4709 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4711 gfc_symbol
*tmp_sym
= NULL
;
4713 gfc_common_head
*com_block
= NULL
;
4715 if (gfc_match_name (name
) == MATCH_YES
)
4717 found_id
= MATCH_YES
;
4718 gfc_get_ha_symbol (name
, &tmp_sym
);
4720 else if (match_common_name (name
) == MATCH_YES
)
4722 found_id
= MATCH_YES
;
4723 com_block
= gfc_get_common (name
, 0);
4727 gfc_error ("Need either entity or common block name for "
4728 "attribute specification statement at %C");
4732 /* Save the current identifier and look for more. */
4735 /* Increment the number of identifiers found for this spec stmt. */
4738 /* Make sure we have a sym or com block, and verify that it can
4739 be bind(c). Set the appropriate field(s) and look for more
4741 if (tmp_sym
!= NULL
|| com_block
!= NULL
)
4743 if (tmp_sym
!= NULL
)
4745 if (!set_verify_bind_c_sym (tmp_sym
, num_idents
))
4750 if (!set_verify_bind_c_com_block (com_block
, num_idents
))
4754 /* Look to see if we have another identifier. */
4756 if (gfc_match_eos () == MATCH_YES
)
4757 found_id
= MATCH_NO
;
4758 else if (gfc_match_char (',') != MATCH_YES
)
4759 found_id
= MATCH_NO
;
4760 else if (gfc_match_name (name
) == MATCH_YES
)
4762 found_id
= MATCH_YES
;
4763 gfc_get_ha_symbol (name
, &tmp_sym
);
4765 else if (match_common_name (name
) == MATCH_YES
)
4767 found_id
= MATCH_YES
;
4768 com_block
= gfc_get_common (name
, 0);
4772 gfc_error ("Missing entity or common block name for "
4773 "attribute specification statement at %C");
4779 gfc_internal_error ("Missing symbol");
4781 } while (found_id
== MATCH_YES
);
4783 /* if we get here we were successful */
4788 /* Try and match a BIND(C) attribute specification statement. */
4791 gfc_match_bind_c_stmt (void)
4793 match found_match
= MATCH_NO
;
4798 /* This may not be necessary. */
4800 /* Clear the temporary binding label holder. */
4801 curr_binding_label
= NULL
;
4803 /* Look for the bind(c). */
4804 found_match
= gfc_match_bind_c (NULL
, true);
4806 if (found_match
== MATCH_YES
)
4808 if (!gfc_notify_std (GFC_STD_F2003
, "BIND(C) statement at %C"))
4811 /* Look for the :: now, but it is not required. */
4814 /* Get the identifier(s) that needs to be updated. This may need to
4815 change to hand the flag(s) for the attr specified so all identifiers
4816 found can have all appropriate parts updated (assuming that the same
4817 spec stmt can have multiple attrs, such as both bind(c) and
4819 if (!get_bind_c_idents ())
4820 /* Error message should have printed already. */
4828 /* Match a data declaration statement. */
4831 gfc_match_data_decl (void)
4837 num_idents_on_line
= 0;
4839 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
4843 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4844 && !gfc_comp_struct (gfc_current_state ()))
4846 sym
= gfc_use_derived (current_ts
.u
.derived
);
4854 current_ts
.u
.derived
= sym
;
4857 m
= match_attr_spec ();
4858 if (m
== MATCH_ERROR
)
4864 if (current_ts
.type
== BT_CLASS
4865 && current_ts
.u
.derived
->attr
.unlimited_polymorphic
)
4868 if ((current_ts
.type
== BT_DERIVED
|| current_ts
.type
== BT_CLASS
)
4869 && current_ts
.u
.derived
->components
== NULL
4870 && !current_ts
.u
.derived
->attr
.zero_comp
)
4873 if (current_attr
.pointer
&& gfc_comp_struct (gfc_current_state ()))
4876 if (current_attr
.allocatable
&& gfc_current_state () == COMP_DERIVED
4877 && current_ts
.u
.derived
== gfc_current_block ())
4880 gfc_find_symbol (current_ts
.u
.derived
->name
,
4881 current_ts
.u
.derived
->ns
, 1, &sym
);
4883 /* Any symbol that we find had better be a type definition
4884 which has its components defined, or be a structure definition
4885 actively being parsed. */
4886 if (sym
!= NULL
&& gfc_fl_struct (sym
->attr
.flavor
)
4887 && (current_ts
.u
.derived
->components
!= NULL
4888 || current_ts
.u
.derived
->attr
.zero_comp
4889 || current_ts
.u
.derived
== gfc_new_block
))
4892 gfc_error ("Derived type at %C has not been previously defined "
4893 "and so cannot appear in a derived type definition");
4899 /* If we have an old-style character declaration, and no new-style
4900 attribute specifications, then there a comma is optional between
4901 the type specification and the variable list. */
4902 if (m
== MATCH_NO
&& current_ts
.type
== BT_CHARACTER
&& old_char_selector
)
4903 gfc_match_char (',');
4905 /* Give the types/attributes to symbols that follow. Give the element
4906 a number so that repeat character length expressions can be copied. */
4910 num_idents_on_line
++;
4911 m
= variable_decl (elem
++);
4912 if (m
== MATCH_ERROR
)
4917 if (gfc_match_eos () == MATCH_YES
)
4919 if (gfc_match_char (',') != MATCH_YES
)
4923 if (!gfc_error_flag_test ())
4925 /* An anonymous structure declaration is unambiguous; if we matched one
4926 according to gfc_match_structure_decl, we need to return MATCH_YES
4927 here to avoid confusing the remaining matchers, even if there was an
4928 error during variable_decl. We must flush any such errors. Note this
4929 causes the parser to gracefully continue parsing the remaining input
4930 as a structure body, which likely follows. */
4931 if (current_ts
.type
== BT_DERIVED
&& current_ts
.u
.derived
4932 && gfc_fl_struct (current_ts
.u
.derived
->attr
.flavor
))
4934 gfc_error_now ("Syntax error in anonymous structure declaration"
4936 /* Skip the bad variable_decl and line up for the start of the
4938 gfc_error_recovery ();
4943 gfc_error ("Syntax error in data declaration at %C");
4948 gfc_free_data_all (gfc_current_ns
);
4951 gfc_free_array_spec (current_as
);
4957 /* Match a prefix associated with a function or subroutine
4958 declaration. If the typespec pointer is nonnull, then a typespec
4959 can be matched. Note that if nothing matches, MATCH_YES is
4960 returned (the null string was matched). */
4963 gfc_match_prefix (gfc_typespec
*ts
)
4969 gfc_clear_attr (¤t_attr
);
4971 seen_impure
= false;
4973 gcc_assert (!gfc_matching_prefix
);
4974 gfc_matching_prefix
= true;
4978 found_prefix
= false;
4980 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
4981 corresponding attribute seems natural and distinguishes these
4982 procedures from procedure types of PROC_MODULE, which these are
4984 if (gfc_match ("module% ") == MATCH_YES
)
4986 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE prefix at %C"))
4989 current_attr
.module_procedure
= 1;
4990 found_prefix
= true;
4993 if (!seen_type
&& ts
!= NULL
4994 && gfc_match_decl_type_spec (ts
, 0) == MATCH_YES
4995 && gfc_match_space () == MATCH_YES
)
4999 found_prefix
= true;
5002 if (gfc_match ("elemental% ") == MATCH_YES
)
5004 if (!gfc_add_elemental (¤t_attr
, NULL
))
5007 found_prefix
= true;
5010 if (gfc_match ("pure% ") == MATCH_YES
)
5012 if (!gfc_add_pure (¤t_attr
, NULL
))
5015 found_prefix
= true;
5018 if (gfc_match ("recursive% ") == MATCH_YES
)
5020 if (!gfc_add_recursive (¤t_attr
, NULL
))
5023 found_prefix
= true;
5026 /* IMPURE is a somewhat special case, as it needs not set an actual
5027 attribute but rather only prevents ELEMENTAL routines from being
5028 automatically PURE. */
5029 if (gfc_match ("impure% ") == MATCH_YES
)
5031 if (!gfc_notify_std (GFC_STD_F2008
, "IMPURE procedure at %C"))
5035 found_prefix
= true;
5038 while (found_prefix
);
5040 /* IMPURE and PURE must not both appear, of course. */
5041 if (seen_impure
&& current_attr
.pure
)
5043 gfc_error ("PURE and IMPURE must not appear both at %C");
5047 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
5048 if (!seen_impure
&& current_attr
.elemental
&& !current_attr
.pure
)
5050 if (!gfc_add_pure (¤t_attr
, NULL
))
5054 /* At this point, the next item is not a prefix. */
5055 gcc_assert (gfc_matching_prefix
);
5057 gfc_matching_prefix
= false;
5061 gcc_assert (gfc_matching_prefix
);
5062 gfc_matching_prefix
= false;
5067 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
5070 copy_prefix (symbol_attribute
*dest
, locus
*where
)
5072 if (dest
->module_procedure
)
5074 if (current_attr
.elemental
)
5075 dest
->elemental
= 1;
5077 if (current_attr
.pure
)
5080 if (current_attr
.recursive
)
5081 dest
->recursive
= 1;
5083 /* Module procedures are unusual in that the 'dest' is copied from
5084 the interface declaration. However, this is an oportunity to
5085 check that the submodule declaration is compliant with the
5087 if (dest
->elemental
&& !current_attr
.elemental
)
5089 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
5090 "missing at %L", where
);
5094 if (dest
->pure
&& !current_attr
.pure
)
5096 gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
5097 "missing at %L", where
);
5101 if (dest
->recursive
&& !current_attr
.recursive
)
5103 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
5104 "missing at %L", where
);
5111 if (current_attr
.elemental
&& !gfc_add_elemental (dest
, where
))
5114 if (current_attr
.pure
&& !gfc_add_pure (dest
, where
))
5117 if (current_attr
.recursive
&& !gfc_add_recursive (dest
, where
))
5124 /* Match a formal argument list. */
5127 gfc_match_formal_arglist (gfc_symbol
*progname
, int st_flag
, int null_flag
)
5129 gfc_formal_arglist
*head
, *tail
, *p
, *q
;
5130 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5133 gfc_formal_arglist
*formal
= NULL
;
5137 /* Keep the interface formal argument list and null it so that the
5138 matching for the new declaration can be done. The numbers and
5139 names of the arguments are checked here. The interface formal
5140 arguments are retained in formal_arglist and the characteristics
5141 are compared in resolve.c(resolve_fl_procedure). See the remark
5142 in get_proc_name about the eventual need to copy the formal_arglist
5143 and populate the formal namespace of the interface symbol. */
5144 if (progname
->attr
.module_procedure
5145 && progname
->attr
.host_assoc
)
5147 formal
= progname
->formal
;
5148 progname
->formal
= NULL
;
5151 if (gfc_match_char ('(') != MATCH_YES
)
5158 if (gfc_match_char (')') == MATCH_YES
)
5163 if (gfc_match_char ('*') == MATCH_YES
)
5166 if (!gfc_notify_std (GFC_STD_F95_OBS
, "Alternate-return argument "
5175 m
= gfc_match_name (name
);
5179 if (gfc_get_symbol (name
, NULL
, &sym
))
5183 p
= gfc_get_formal_arglist ();
5195 /* We don't add the VARIABLE flavor because the name could be a
5196 dummy procedure. We don't apply these attributes to formal
5197 arguments of statement functions. */
5198 if (sym
!= NULL
&& !st_flag
5199 && (!gfc_add_dummy(&sym
->attr
, sym
->name
, NULL
)
5200 || !gfc_missing_attr (&sym
->attr
, NULL
)))
5206 /* The name of a program unit can be in a different namespace,
5207 so check for it explicitly. After the statement is accepted,
5208 the name is checked for especially in gfc_get_symbol(). */
5209 if (gfc_new_block
!= NULL
&& sym
!= NULL
5210 && strcmp (sym
->name
, gfc_new_block
->name
) == 0)
5212 gfc_error ("Name %qs at %C is the name of the procedure",
5218 if (gfc_match_char (')') == MATCH_YES
)
5221 m
= gfc_match_char (',');
5224 gfc_error ("Unexpected junk in formal argument list at %C");
5230 /* Check for duplicate symbols in the formal argument list. */
5233 for (p
= head
; p
->next
; p
= p
->next
)
5238 for (q
= p
->next
; q
; q
= q
->next
)
5239 if (p
->sym
== q
->sym
)
5241 gfc_error ("Duplicate symbol %qs in formal argument list "
5242 "at %C", p
->sym
->name
);
5250 if (!gfc_add_explicit_interface (progname
, IFSRC_DECL
, head
, NULL
))
5256 /* gfc_error_now used in following and return with MATCH_YES because
5257 doing otherwise results in a cascade of extraneous errors and in
5258 some cases an ICE in symbol.c(gfc_release_symbol). */
5259 if (progname
->attr
.module_procedure
&& progname
->attr
.host_assoc
)
5261 bool arg_count_mismatch
= false;
5263 if (!formal
&& head
)
5264 arg_count_mismatch
= true;
5266 /* Abbreviated module procedure declaration is not meant to have any
5267 formal arguments! */
5268 if (!progname
->abr_modproc_decl
&& formal
&& !head
)
5269 arg_count_mismatch
= true;
5271 for (p
= formal
, q
= head
; p
&& q
; p
= p
->next
, q
= q
->next
)
5273 if ((p
->next
!= NULL
&& q
->next
== NULL
)
5274 || (p
->next
== NULL
&& q
->next
!= NULL
))
5275 arg_count_mismatch
= true;
5276 else if ((p
->sym
== NULL
&& q
->sym
== NULL
)
5277 || strcmp (p
->sym
->name
, q
->sym
->name
) == 0)
5280 gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
5281 "argument names (%s/%s) at %C",
5282 p
->sym
->name
, q
->sym
->name
);
5285 if (arg_count_mismatch
)
5286 gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
5287 "formal arguments at %C");
5293 gfc_free_formal_arglist (head
);
5298 /* Match a RESULT specification following a function declaration or
5299 ENTRY statement. Also matches the end-of-statement. */
5302 match_result (gfc_symbol
*function
, gfc_symbol
**result
)
5304 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5308 if (gfc_match (" result (") != MATCH_YES
)
5311 m
= gfc_match_name (name
);
5315 /* Get the right paren, and that's it because there could be the
5316 bind(c) attribute after the result clause. */
5317 if (gfc_match_char (')') != MATCH_YES
)
5319 /* TODO: should report the missing right paren here. */
5323 if (strcmp (function
->name
, name
) == 0)
5325 gfc_error ("RESULT variable at %C must be different than function name");
5329 if (gfc_get_symbol (name
, NULL
, &r
))
5332 if (!gfc_add_result (&r
->attr
, r
->name
, NULL
))
5341 /* Match a function suffix, which could be a combination of a result
5342 clause and BIND(C), either one, or neither. The draft does not
5343 require them to come in a specific order. */
5346 gfc_match_suffix (gfc_symbol
*sym
, gfc_symbol
**result
)
5348 match is_bind_c
; /* Found bind(c). */
5349 match is_result
; /* Found result clause. */
5350 match found_match
; /* Status of whether we've found a good match. */
5351 char peek_char
; /* Character we're going to peek at. */
5352 bool allow_binding_name
;
5354 /* Initialize to having found nothing. */
5355 found_match
= MATCH_NO
;
5356 is_bind_c
= MATCH_NO
;
5357 is_result
= MATCH_NO
;
5359 /* Get the next char to narrow between result and bind(c). */
5360 gfc_gobble_whitespace ();
5361 peek_char
= gfc_peek_ascii_char ();
5363 /* C binding names are not allowed for internal procedures. */
5364 if (gfc_current_state () == COMP_CONTAINS
5365 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5366 allow_binding_name
= false;
5368 allow_binding_name
= true;
5373 /* Look for result clause. */
5374 is_result
= match_result (sym
, result
);
5375 if (is_result
== MATCH_YES
)
5377 /* Now see if there is a bind(c) after it. */
5378 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5379 /* We've found the result clause and possibly bind(c). */
5380 found_match
= MATCH_YES
;
5383 /* This should only be MATCH_ERROR. */
5384 found_match
= is_result
;
5387 /* Look for bind(c) first. */
5388 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
5389 if (is_bind_c
== MATCH_YES
)
5391 /* Now see if a result clause followed it. */
5392 is_result
= match_result (sym
, result
);
5393 found_match
= MATCH_YES
;
5397 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
5398 found_match
= MATCH_ERROR
;
5402 gfc_error ("Unexpected junk after function declaration at %C");
5403 found_match
= MATCH_ERROR
;
5407 if (is_bind_c
== MATCH_YES
)
5409 /* Fortran 2008 draft allows BIND(C) for internal procedures. */
5410 if (gfc_current_state () == COMP_CONTAINS
5411 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
5412 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
5413 "at %L may not be specified for an internal "
5414 "procedure", &gfc_current_locus
))
5417 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
, &gfc_current_locus
, 1))
5425 /* Procedure pointer return value without RESULT statement:
5426 Add "hidden" result variable named "ppr@". */
5429 add_hidden_procptr_result (gfc_symbol
*sym
)
5433 if (gfc_notification_std (GFC_STD_F2003
) == ERROR
)
5436 /* First usage case: PROCEDURE and EXTERNAL statements. */
5437 case1
= gfc_current_state () == COMP_FUNCTION
&& gfc_current_block ()
5438 && strcmp (gfc_current_block ()->name
, sym
->name
) == 0
5439 && sym
->attr
.external
;
5440 /* Second usage case: INTERFACE statements. */
5441 case2
= gfc_current_state () == COMP_INTERFACE
&& gfc_state_stack
->previous
5442 && gfc_state_stack
->previous
->state
== COMP_FUNCTION
5443 && strcmp (gfc_state_stack
->previous
->sym
->name
, sym
->name
) == 0;
5449 gfc_get_sym_tree ("ppr@", gfc_current_ns
, &stree
, false);
5453 gfc_get_sym_tree ("ppr@", gfc_current_ns
->parent
, &stree
, false);
5454 st2
= gfc_new_symtree (&gfc_current_ns
->sym_root
, "ppr@");
5455 st2
->n
.sym
= stree
->n
.sym
;
5456 stree
->n
.sym
->refs
++;
5458 sym
->result
= stree
->n
.sym
;
5460 sym
->result
->attr
.proc_pointer
= sym
->attr
.proc_pointer
;
5461 sym
->result
->attr
.pointer
= sym
->attr
.pointer
;
5462 sym
->result
->attr
.external
= sym
->attr
.external
;
5463 sym
->result
->attr
.referenced
= sym
->attr
.referenced
;
5464 sym
->result
->ts
= sym
->ts
;
5465 sym
->attr
.proc_pointer
= 0;
5466 sym
->attr
.pointer
= 0;
5467 sym
->attr
.external
= 0;
5468 if (sym
->result
->attr
.external
&& sym
->result
->attr
.pointer
)
5470 sym
->result
->attr
.pointer
= 0;
5471 sym
->result
->attr
.proc_pointer
= 1;
5474 return gfc_add_result (&sym
->result
->attr
, sym
->result
->name
, NULL
);
5476 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
5477 else if (sym
->attr
.function
&& !sym
->attr
.external
&& sym
->attr
.pointer
5478 && sym
->result
&& sym
->result
!= sym
&& sym
->result
->attr
.external
5479 && sym
== gfc_current_ns
->proc_name
5480 && sym
== sym
->result
->ns
->proc_name
5481 && strcmp ("ppr@", sym
->result
->name
) == 0)
5483 sym
->result
->attr
.proc_pointer
= 1;
5484 sym
->attr
.pointer
= 0;
5492 /* Match the interface for a PROCEDURE declaration,
5493 including brackets (R1212). */
5496 match_procedure_interface (gfc_symbol
**proc_if
)
5500 locus old_loc
, entry_loc
;
5501 gfc_namespace
*old_ns
= gfc_current_ns
;
5502 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5504 old_loc
= entry_loc
= gfc_current_locus
;
5505 gfc_clear_ts (¤t_ts
);
5507 if (gfc_match (" (") != MATCH_YES
)
5509 gfc_current_locus
= entry_loc
;
5513 /* Get the type spec. for the procedure interface. */
5514 old_loc
= gfc_current_locus
;
5515 m
= gfc_match_decl_type_spec (¤t_ts
, 0);
5516 gfc_gobble_whitespace ();
5517 if (m
== MATCH_YES
|| (m
== MATCH_NO
&& gfc_peek_ascii_char () == ')'))
5520 if (m
== MATCH_ERROR
)
5523 /* Procedure interface is itself a procedure. */
5524 gfc_current_locus
= old_loc
;
5525 m
= gfc_match_name (name
);
5527 /* First look to see if it is already accessible in the current
5528 namespace because it is use associated or contained. */
5530 if (gfc_find_sym_tree (name
, NULL
, 0, &st
))
5533 /* If it is still not found, then try the parent namespace, if it
5534 exists and create the symbol there if it is still not found. */
5535 if (gfc_current_ns
->parent
)
5536 gfc_current_ns
= gfc_current_ns
->parent
;
5537 if (st
== NULL
&& gfc_get_ha_sym_tree (name
, &st
))
5540 gfc_current_ns
= old_ns
;
5541 *proc_if
= st
->n
.sym
;
5546 /* Resolve interface if possible. That way, attr.procedure is only set
5547 if it is declared by a later procedure-declaration-stmt, which is
5548 invalid per F08:C1216 (cf. resolve_procedure_interface). */
5549 while ((*proc_if
)->ts
.interface
5550 && *proc_if
!= (*proc_if
)->ts
.interface
)
5551 *proc_if
= (*proc_if
)->ts
.interface
;
5553 if ((*proc_if
)->attr
.flavor
== FL_UNKNOWN
5554 && (*proc_if
)->ts
.type
== BT_UNKNOWN
5555 && !gfc_add_flavor (&(*proc_if
)->attr
, FL_PROCEDURE
,
5556 (*proc_if
)->name
, NULL
))
5561 if (gfc_match (" )") != MATCH_YES
)
5563 gfc_current_locus
= entry_loc
;
5571 /* Match a PROCEDURE declaration (R1211). */
5574 match_procedure_decl (void)
5577 gfc_symbol
*sym
, *proc_if
= NULL
;
5579 gfc_expr
*initializer
= NULL
;
5581 /* Parse interface (with brackets). */
5582 m
= match_procedure_interface (&proc_if
);
5586 /* Parse attributes (with colons). */
5587 m
= match_attr_spec();
5588 if (m
== MATCH_ERROR
)
5591 if (proc_if
&& proc_if
->attr
.is_bind_c
&& !current_attr
.is_bind_c
)
5593 current_attr
.is_bind_c
= 1;
5594 has_name_equals
= 0;
5595 curr_binding_label
= NULL
;
5598 /* Get procedure symbols. */
5601 m
= gfc_match_symbol (&sym
, 0);
5604 else if (m
== MATCH_ERROR
)
5607 /* Add current_attr to the symbol attributes. */
5608 if (!gfc_copy_attr (&sym
->attr
, ¤t_attr
, NULL
))
5611 if (sym
->attr
.is_bind_c
)
5613 /* Check for C1218. */
5614 if (!proc_if
|| !proc_if
->attr
.is_bind_c
)
5616 gfc_error ("BIND(C) attribute at %C requires "
5617 "an interface with BIND(C)");
5620 /* Check for C1217. */
5621 if (has_name_equals
&& sym
->attr
.pointer
)
5623 gfc_error ("BIND(C) procedure with NAME may not have "
5624 "POINTER attribute at %C");
5627 if (has_name_equals
&& sym
->attr
.dummy
)
5629 gfc_error ("Dummy procedure at %C may not have "
5630 "BIND(C) attribute with NAME");
5633 /* Set binding label for BIND(C). */
5634 if (!set_binding_label (&sym
->binding_label
, sym
->name
, num
))
5638 if (!gfc_add_external (&sym
->attr
, NULL
))
5641 if (add_hidden_procptr_result (sym
))
5644 if (!gfc_add_proc (&sym
->attr
, sym
->name
, NULL
))
5647 /* Set interface. */
5648 if (proc_if
!= NULL
)
5650 if (sym
->ts
.type
!= BT_UNKNOWN
)
5652 gfc_error ("Procedure %qs at %L already has basic type of %s",
5653 sym
->name
, &gfc_current_locus
,
5654 gfc_basic_typename (sym
->ts
.type
));
5657 sym
->ts
.interface
= proc_if
;
5658 sym
->attr
.untyped
= 1;
5659 sym
->attr
.if_source
= IFSRC_IFBODY
;
5661 else if (current_ts
.type
!= BT_UNKNOWN
)
5663 if (!gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
5665 sym
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5666 sym
->ts
.interface
->ts
= current_ts
;
5667 sym
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5668 sym
->ts
.interface
->attr
.function
= 1;
5669 sym
->attr
.function
= 1;
5670 sym
->attr
.if_source
= IFSRC_UNKNOWN
;
5673 if (gfc_match (" =>") == MATCH_YES
)
5675 if (!current_attr
.pointer
)
5677 gfc_error ("Initialization at %C isn't for a pointer variable");
5682 m
= match_pointer_init (&initializer
, 1);
5686 if (!add_init_expr_to_sym (sym
->name
, &initializer
, &gfc_current_locus
))
5691 if (gfc_match_eos () == MATCH_YES
)
5693 if (gfc_match_char (',') != MATCH_YES
)
5698 gfc_error ("Syntax error in PROCEDURE statement at %C");
5702 /* Free stuff up and return. */
5703 gfc_free_expr (initializer
);
5709 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
);
5712 /* Match a procedure pointer component declaration (R445). */
5715 match_ppc_decl (void)
5718 gfc_symbol
*proc_if
= NULL
;
5722 gfc_expr
*initializer
= NULL
;
5723 gfc_typebound_proc
* tb
;
5724 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5726 /* Parse interface (with brackets). */
5727 m
= match_procedure_interface (&proc_if
);
5731 /* Parse attributes. */
5732 tb
= XCNEW (gfc_typebound_proc
);
5733 tb
->where
= gfc_current_locus
;
5734 m
= match_binding_attributes (tb
, false, true);
5735 if (m
== MATCH_ERROR
)
5738 gfc_clear_attr (¤t_attr
);
5739 current_attr
.procedure
= 1;
5740 current_attr
.proc_pointer
= 1;
5741 current_attr
.access
= tb
->access
;
5742 current_attr
.flavor
= FL_PROCEDURE
;
5744 /* Match the colons (required). */
5745 if (gfc_match (" ::") != MATCH_YES
)
5747 gfc_error ("Expected %<::%> after binding-attributes at %C");
5751 /* Check for C450. */
5752 if (!tb
->nopass
&& proc_if
== NULL
)
5754 gfc_error("NOPASS or explicit interface required at %C");
5758 if (!gfc_notify_std (GFC_STD_F2003
, "Procedure pointer component at %C"))
5761 /* Match PPC names. */
5765 m
= gfc_match_name (name
);
5768 else if (m
== MATCH_ERROR
)
5771 if (!gfc_add_component (gfc_current_block(), name
, &c
))
5774 /* Add current_attr to the symbol attributes. */
5775 if (!gfc_copy_attr (&c
->attr
, ¤t_attr
, NULL
))
5778 if (!gfc_add_external (&c
->attr
, NULL
))
5781 if (!gfc_add_proc (&c
->attr
, name
, NULL
))
5788 c
->tb
= XCNEW (gfc_typebound_proc
);
5789 c
->tb
->where
= gfc_current_locus
;
5793 /* Set interface. */
5794 if (proc_if
!= NULL
)
5796 c
->ts
.interface
= proc_if
;
5797 c
->attr
.untyped
= 1;
5798 c
->attr
.if_source
= IFSRC_IFBODY
;
5800 else if (ts
.type
!= BT_UNKNOWN
)
5803 c
->ts
.interface
= gfc_new_symbol ("", gfc_current_ns
);
5804 c
->ts
.interface
->result
= c
->ts
.interface
;
5805 c
->ts
.interface
->ts
= ts
;
5806 c
->ts
.interface
->attr
.flavor
= FL_PROCEDURE
;
5807 c
->ts
.interface
->attr
.function
= 1;
5808 c
->attr
.function
= 1;
5809 c
->attr
.if_source
= IFSRC_UNKNOWN
;
5812 if (gfc_match (" =>") == MATCH_YES
)
5814 m
= match_pointer_init (&initializer
, 1);
5817 gfc_free_expr (initializer
);
5820 c
->initializer
= initializer
;
5823 if (gfc_match_eos () == MATCH_YES
)
5825 if (gfc_match_char (',') != MATCH_YES
)
5830 gfc_error ("Syntax error in procedure pointer component at %C");
5835 /* Match a PROCEDURE declaration inside an interface (R1206). */
5838 match_procedure_in_interface (void)
5842 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5845 if (current_interface
.type
== INTERFACE_NAMELESS
5846 || current_interface
.type
== INTERFACE_ABSTRACT
)
5848 gfc_error ("PROCEDURE at %C must be in a generic interface");
5852 /* Check if the F2008 optional double colon appears. */
5853 gfc_gobble_whitespace ();
5854 old_locus
= gfc_current_locus
;
5855 if (gfc_match ("::") == MATCH_YES
)
5857 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
5858 "MODULE PROCEDURE statement at %L", &old_locus
))
5862 gfc_current_locus
= old_locus
;
5866 m
= gfc_match_name (name
);
5869 else if (m
== MATCH_ERROR
)
5871 if (gfc_get_symbol (name
, gfc_current_ns
->parent
, &sym
))
5874 if (!gfc_add_interface (sym
))
5877 if (gfc_match_eos () == MATCH_YES
)
5879 if (gfc_match_char (',') != MATCH_YES
)
5886 gfc_error ("Syntax error in PROCEDURE statement at %C");
5891 /* General matcher for PROCEDURE declarations. */
5893 static match
match_procedure_in_type (void);
5896 gfc_match_procedure (void)
5900 switch (gfc_current_state ())
5905 case COMP_SUBMODULE
:
5906 case COMP_SUBROUTINE
:
5909 m
= match_procedure_decl ();
5911 case COMP_INTERFACE
:
5912 m
= match_procedure_in_interface ();
5915 m
= match_ppc_decl ();
5917 case COMP_DERIVED_CONTAINS
:
5918 m
= match_procedure_in_type ();
5927 if (!gfc_notify_std (GFC_STD_F2003
, "PROCEDURE statement at %C"))
5934 /* Warn if a matched procedure has the same name as an intrinsic; this is
5935 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
5936 parser-state-stack to find out whether we're in a module. */
5939 do_warn_intrinsic_shadow (const gfc_symbol
* sym
, bool func
)
5943 in_module
= (gfc_state_stack
->previous
5944 && (gfc_state_stack
->previous
->state
== COMP_MODULE
5945 || gfc_state_stack
->previous
->state
== COMP_SUBMODULE
));
5947 gfc_warn_intrinsic_shadow (sym
, in_module
, func
);
5951 /* Match a function declaration. */
5954 gfc_match_function_decl (void)
5956 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5957 gfc_symbol
*sym
, *result
;
5961 match found_match
; /* Status returned by match func. */
5963 if (gfc_current_state () != COMP_NONE
5964 && gfc_current_state () != COMP_INTERFACE
5965 && gfc_current_state () != COMP_CONTAINS
)
5968 gfc_clear_ts (¤t_ts
);
5970 old_loc
= gfc_current_locus
;
5972 m
= gfc_match_prefix (¤t_ts
);
5975 gfc_current_locus
= old_loc
;
5979 if (gfc_match ("function% %n", name
) != MATCH_YES
)
5981 gfc_current_locus
= old_loc
;
5985 if (get_proc_name (name
, &sym
, false))
5988 if (add_hidden_procptr_result (sym
))
5991 if (current_attr
.module_procedure
)
5992 sym
->attr
.module_procedure
= 1;
5994 gfc_new_block
= sym
;
5996 m
= gfc_match_formal_arglist (sym
, 0, 0);
5999 gfc_error ("Expected formal argument list in function "
6000 "definition at %C");
6004 else if (m
== MATCH_ERROR
)
6009 /* According to the draft, the bind(c) and result clause can
6010 come in either order after the formal_arg_list (i.e., either
6011 can be first, both can exist together or by themselves or neither
6012 one). Therefore, the match_result can't match the end of the
6013 string, and check for the bind(c) or result clause in either order. */
6014 found_match
= gfc_match_eos ();
6016 /* Make sure that it isn't already declared as BIND(C). If it is, it
6017 must have been marked BIND(C) with a BIND(C) attribute and that is
6018 not allowed for procedures. */
6019 if (sym
->attr
.is_bind_c
== 1)
6021 sym
->attr
.is_bind_c
= 0;
6022 if (sym
->old_symbol
!= NULL
)
6023 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6024 "variables or common blocks",
6025 &(sym
->old_symbol
->declared_at
));
6027 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6028 "variables or common blocks", &gfc_current_locus
);
6031 if (found_match
!= MATCH_YES
)
6033 /* If we haven't found the end-of-statement, look for a suffix. */
6034 suffix_match
= gfc_match_suffix (sym
, &result
);
6035 if (suffix_match
== MATCH_YES
)
6036 /* Need to get the eos now. */
6037 found_match
= gfc_match_eos ();
6039 found_match
= suffix_match
;
6042 if(found_match
!= MATCH_YES
)
6046 /* Make changes to the symbol. */
6049 if (!gfc_add_function (&sym
->attr
, sym
->name
, NULL
))
6052 if (!gfc_missing_attr (&sym
->attr
, NULL
))
6055 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6057 if(!sym
->attr
.module_procedure
)
6063 /* Delay matching the function characteristics until after the
6064 specification block by signalling kind=-1. */
6065 sym
->declared_at
= old_loc
;
6066 if (current_ts
.type
!= BT_UNKNOWN
)
6067 current_ts
.kind
= -1;
6069 current_ts
.kind
= 0;
6073 if (current_ts
.type
!= BT_UNKNOWN
6074 && !gfc_add_type (sym
, ¤t_ts
, &gfc_current_locus
))
6080 if (current_ts
.type
!= BT_UNKNOWN
6081 && !gfc_add_type (result
, ¤t_ts
, &gfc_current_locus
))
6083 sym
->result
= result
;
6086 /* Warn if this procedure has the same name as an intrinsic. */
6087 do_warn_intrinsic_shadow (sym
, true);
6093 gfc_current_locus
= old_loc
;
6098 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
6099 pass the name of the entry, rather than the gfc_current_block name, and
6100 to return false upon finding an existing global entry. */
6103 add_global_entry (const char *name
, const char *binding_label
, bool sub
,
6107 enum gfc_symbol_type type
;
6109 type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6111 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6112 name is a global identifier. */
6113 if (!binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6115 s
= gfc_get_gsymbol (name
);
6117 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6119 gfc_global_used (s
, where
);
6128 s
->ns
= gfc_current_ns
;
6132 /* Don't add the symbol multiple times. */
6134 && (!gfc_notification_std (GFC_STD_F2008
)
6135 || strcmp (name
, binding_label
) != 0))
6137 s
= gfc_get_gsymbol (binding_label
);
6139 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= type
))
6141 gfc_global_used (s
, where
);
6148 s
->binding_label
= binding_label
;
6151 s
->ns
= gfc_current_ns
;
6159 /* Match an ENTRY statement. */
6162 gfc_match_entry (void)
6167 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6168 gfc_compile_state state
;
6172 bool module_procedure
;
6176 m
= gfc_match_name (name
);
6180 if (!gfc_notify_std (GFC_STD_F2008_OBS
, "ENTRY statement at %C"))
6183 state
= gfc_current_state ();
6184 if (state
!= COMP_SUBROUTINE
&& state
!= COMP_FUNCTION
)
6189 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
6192 gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
6194 case COMP_SUBMODULE
:
6195 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
6197 case COMP_BLOCK_DATA
:
6198 gfc_error ("ENTRY statement at %C cannot appear within "
6201 case COMP_INTERFACE
:
6202 gfc_error ("ENTRY statement at %C cannot appear within "
6205 case COMP_STRUCTURE
:
6206 gfc_error ("ENTRY statement at %C cannot appear within "
6207 "a STRUCTURE block");
6210 gfc_error ("ENTRY statement at %C cannot appear within "
6211 "a DERIVED TYPE block");
6214 gfc_error ("ENTRY statement at %C cannot appear within "
6215 "an IF-THEN block");
6218 case COMP_DO_CONCURRENT
:
6219 gfc_error ("ENTRY statement at %C cannot appear within "
6223 gfc_error ("ENTRY statement at %C cannot appear within "
6227 gfc_error ("ENTRY statement at %C cannot appear within "
6231 gfc_error ("ENTRY statement at %C cannot appear within "
6235 gfc_error ("ENTRY statement at %C cannot appear within "
6236 "a contained subprogram");
6239 gfc_error ("Unexpected ENTRY statement at %C");
6244 if ((state
== COMP_SUBROUTINE
|| state
== COMP_FUNCTION
)
6245 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
6247 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
6251 module_procedure
= gfc_current_ns
->parent
!= NULL
6252 && gfc_current_ns
->parent
->proc_name
6253 && gfc_current_ns
->parent
->proc_name
->attr
.flavor
6256 if (gfc_current_ns
->parent
!= NULL
6257 && gfc_current_ns
->parent
->proc_name
6258 && !module_procedure
)
6260 gfc_error("ENTRY statement at %C cannot appear in a "
6261 "contained procedure");
6265 /* Module function entries need special care in get_proc_name
6266 because previous references within the function will have
6267 created symbols attached to the current namespace. */
6268 if (get_proc_name (name
, &entry
,
6269 gfc_current_ns
->parent
!= NULL
6270 && module_procedure
))
6273 proc
= gfc_current_block ();
6275 /* Make sure that it isn't already declared as BIND(C). If it is, it
6276 must have been marked BIND(C) with a BIND(C) attribute and that is
6277 not allowed for procedures. */
6278 if (entry
->attr
.is_bind_c
== 1)
6280 entry
->attr
.is_bind_c
= 0;
6281 if (entry
->old_symbol
!= NULL
)
6282 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6283 "variables or common blocks",
6284 &(entry
->old_symbol
->declared_at
));
6286 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6287 "variables or common blocks", &gfc_current_locus
);
6290 /* Check what next non-whitespace character is so we can tell if there
6291 is the required parens if we have a BIND(C). */
6292 old_loc
= gfc_current_locus
;
6293 gfc_gobble_whitespace ();
6294 peek_char
= gfc_peek_ascii_char ();
6296 if (state
== COMP_SUBROUTINE
)
6298 m
= gfc_match_formal_arglist (entry
, 0, 1);
6302 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
6303 never be an internal procedure. */
6304 is_bind_c
= gfc_match_bind_c (entry
, true);
6305 if (is_bind_c
== MATCH_ERROR
)
6307 if (is_bind_c
== MATCH_YES
)
6309 if (peek_char
!= '(')
6311 gfc_error ("Missing required parentheses before BIND(C) at %C");
6314 if (!gfc_add_is_bind_c (&(entry
->attr
), entry
->name
,
6315 &(entry
->declared_at
), 1))
6319 if (!gfc_current_ns
->parent
6320 && !add_global_entry (name
, entry
->binding_label
, true,
6324 /* An entry in a subroutine. */
6325 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6326 || !gfc_add_subroutine (&entry
->attr
, entry
->name
, NULL
))
6331 /* An entry in a function.
6332 We need to take special care because writing
6337 ENTRY f() RESULT (r)
6339 ENTRY f RESULT (r). */
6340 if (gfc_match_eos () == MATCH_YES
)
6342 gfc_current_locus
= old_loc
;
6343 /* Match the empty argument list, and add the interface to
6345 m
= gfc_match_formal_arglist (entry
, 0, 1);
6348 m
= gfc_match_formal_arglist (entry
, 0, 0);
6355 if (gfc_match_eos () == MATCH_YES
)
6357 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6358 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6361 entry
->result
= entry
;
6365 m
= gfc_match_suffix (entry
, &result
);
6367 gfc_syntax_error (ST_ENTRY
);
6373 if (!gfc_add_result (&result
->attr
, result
->name
, NULL
)
6374 || !gfc_add_entry (&entry
->attr
, result
->name
, NULL
)
6375 || !gfc_add_function (&entry
->attr
, result
->name
, NULL
))
6377 entry
->result
= result
;
6381 if (!gfc_add_entry (&entry
->attr
, entry
->name
, NULL
)
6382 || !gfc_add_function (&entry
->attr
, entry
->name
, NULL
))
6384 entry
->result
= entry
;
6388 if (!gfc_current_ns
->parent
6389 && !add_global_entry (name
, entry
->binding_label
, false,
6394 if (gfc_match_eos () != MATCH_YES
)
6396 gfc_syntax_error (ST_ENTRY
);
6400 entry
->attr
.recursive
= proc
->attr
.recursive
;
6401 entry
->attr
.elemental
= proc
->attr
.elemental
;
6402 entry
->attr
.pure
= proc
->attr
.pure
;
6404 el
= gfc_get_entry_list ();
6406 el
->next
= gfc_current_ns
->entries
;
6407 gfc_current_ns
->entries
= el
;
6409 el
->id
= el
->next
->id
+ 1;
6413 new_st
.op
= EXEC_ENTRY
;
6414 new_st
.ext
.entry
= el
;
6420 /* Match a subroutine statement, including optional prefixes. */
6423 gfc_match_subroutine (void)
6425 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6430 bool allow_binding_name
;
6432 if (gfc_current_state () != COMP_NONE
6433 && gfc_current_state () != COMP_INTERFACE
6434 && gfc_current_state () != COMP_CONTAINS
)
6437 m
= gfc_match_prefix (NULL
);
6441 m
= gfc_match ("subroutine% %n", name
);
6445 if (get_proc_name (name
, &sym
, false))
6448 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
6449 the symbol existed before. */
6450 sym
->declared_at
= gfc_current_locus
;
6452 if (current_attr
.module_procedure
)
6453 sym
->attr
.module_procedure
= 1;
6455 if (add_hidden_procptr_result (sym
))
6458 gfc_new_block
= sym
;
6460 /* Check what next non-whitespace character is so we can tell if there
6461 is the required parens if we have a BIND(C). */
6462 gfc_gobble_whitespace ();
6463 peek_char
= gfc_peek_ascii_char ();
6465 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
6468 if (gfc_match_formal_arglist (sym
, 0, 1) != MATCH_YES
)
6471 /* Make sure that it isn't already declared as BIND(C). If it is, it
6472 must have been marked BIND(C) with a BIND(C) attribute and that is
6473 not allowed for procedures. */
6474 if (sym
->attr
.is_bind_c
== 1)
6476 sym
->attr
.is_bind_c
= 0;
6477 if (sym
->old_symbol
!= NULL
)
6478 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6479 "variables or common blocks",
6480 &(sym
->old_symbol
->declared_at
));
6482 gfc_error_now ("BIND(C) attribute at %L can only be used for "
6483 "variables or common blocks", &gfc_current_locus
);
6486 /* C binding names are not allowed for internal procedures. */
6487 if (gfc_current_state () == COMP_CONTAINS
6488 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6489 allow_binding_name
= false;
6491 allow_binding_name
= true;
6493 /* Here, we are just checking if it has the bind(c) attribute, and if
6494 so, then we need to make sure it's all correct. If it doesn't,
6495 we still need to continue matching the rest of the subroutine line. */
6496 is_bind_c
= gfc_match_bind_c (sym
, allow_binding_name
);
6497 if (is_bind_c
== MATCH_ERROR
)
6499 /* There was an attempt at the bind(c), but it was wrong. An
6500 error message should have been printed w/in the gfc_match_bind_c
6501 so here we'll just return the MATCH_ERROR. */
6505 if (is_bind_c
== MATCH_YES
)
6507 /* The following is allowed in the Fortran 2008 draft. */
6508 if (gfc_current_state () == COMP_CONTAINS
6509 && sym
->ns
->proc_name
->attr
.flavor
!= FL_MODULE
6510 && !gfc_notify_std (GFC_STD_F2008
, "BIND(C) attribute "
6511 "at %L may not be specified for an internal "
6512 "procedure", &gfc_current_locus
))
6515 if (peek_char
!= '(')
6517 gfc_error ("Missing required parentheses before BIND(C) at %C");
6520 if (!gfc_add_is_bind_c (&(sym
->attr
), sym
->name
,
6521 &(sym
->declared_at
), 1))
6525 if (gfc_match_eos () != MATCH_YES
)
6527 gfc_syntax_error (ST_SUBROUTINE
);
6531 if (!copy_prefix (&sym
->attr
, &sym
->declared_at
))
6533 if(!sym
->attr
.module_procedure
)
6539 /* Warn if it has the same name as an intrinsic. */
6540 do_warn_intrinsic_shadow (sym
, false);
6546 /* Check that the NAME identifier in a BIND attribute or statement
6547 is conform to C identifier rules. */
6550 check_bind_name_identifier (char **name
)
6552 char *n
= *name
, *p
;
6554 /* Remove leading spaces. */
6558 /* On an empty string, free memory and set name to NULL. */
6566 /* Remove trailing spaces. */
6567 p
= n
+ strlen(n
) - 1;
6571 /* Insert the identifier into the symbol table. */
6576 /* Now check that identifier is valid under C rules. */
6579 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6584 if (!(ISALNUM (*p
) || *p
== '_' || *p
== '$'))
6586 gfc_error ("Invalid C identifier in NAME= specifier at %C");
6594 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
6595 given, and set the binding label in either the given symbol (if not
6596 NULL), or in the current_ts. The symbol may be NULL because we may
6597 encounter the BIND(C) before the declaration itself. Return
6598 MATCH_NO if what we're looking at isn't a BIND(C) specifier,
6599 MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
6600 or MATCH_YES if the specifier was correct and the binding label and
6601 bind(c) fields were set correctly for the given symbol or the
6602 current_ts. If allow_binding_name is false, no binding name may be
6606 gfc_match_bind_c (gfc_symbol
*sym
, bool allow_binding_name
)
6608 char *binding_label
= NULL
;
6611 /* Initialize the flag that specifies whether we encountered a NAME=
6612 specifier or not. */
6613 has_name_equals
= 0;
6615 /* This much we have to be able to match, in this order, if
6616 there is a bind(c) label. */
6617 if (gfc_match (" bind ( c ") != MATCH_YES
)
6620 /* Now see if there is a binding label, or if we've reached the
6621 end of the bind(c) attribute without one. */
6622 if (gfc_match_char (',') == MATCH_YES
)
6624 if (gfc_match (" name = ") != MATCH_YES
)
6626 gfc_error ("Syntax error in NAME= specifier for binding label "
6628 /* should give an error message here */
6632 has_name_equals
= 1;
6634 if (gfc_match_init_expr (&e
) != MATCH_YES
)
6640 if (!gfc_simplify_expr(e
, 0))
6642 gfc_error ("NAME= specifier at %C should be a constant expression");
6647 if (e
->expr_type
!= EXPR_CONSTANT
|| e
->ts
.type
!= BT_CHARACTER
6648 || e
->ts
.kind
!= gfc_default_character_kind
|| e
->rank
!= 0)
6650 gfc_error ("NAME= specifier at %C should be a scalar of "
6651 "default character kind");
6656 // Get a C string from the Fortran string constant
6657 binding_label
= gfc_widechar_to_char (e
->value
.character
.string
,
6658 e
->value
.character
.length
);
6661 // Check that it is valid (old gfc_match_name_C)
6662 if (check_bind_name_identifier (&binding_label
) != MATCH_YES
)
6666 /* Get the required right paren. */
6667 if (gfc_match_char (')') != MATCH_YES
)
6669 gfc_error ("Missing closing paren for binding label at %C");
6673 if (has_name_equals
&& !allow_binding_name
)
6675 gfc_error ("No binding name is allowed in BIND(C) at %C");
6679 if (has_name_equals
&& sym
!= NULL
&& sym
->attr
.dummy
)
6681 gfc_error ("For dummy procedure %s, no binding name is "
6682 "allowed in BIND(C) at %C", sym
->name
);
6687 /* Save the binding label to the symbol. If sym is null, we're
6688 probably matching the typespec attributes of a declaration and
6689 haven't gotten the name yet, and therefore, no symbol yet. */
6693 sym
->binding_label
= binding_label
;
6695 curr_binding_label
= binding_label
;
6697 else if (allow_binding_name
)
6699 /* No binding label, but if symbol isn't null, we
6700 can set the label for it here.
6701 If name="" or allow_binding_name is false, no C binding name is
6703 if (sym
!= NULL
&& sym
->name
!= NULL
&& has_name_equals
== 0)
6704 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier (sym
->name
));
6707 if (has_name_equals
&& gfc_current_state () == COMP_INTERFACE
6708 && current_interface
.type
== INTERFACE_ABSTRACT
)
6710 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
6718 /* Return nonzero if we're currently compiling a contained procedure. */
6721 contained_procedure (void)
6723 gfc_state_data
*s
= gfc_state_stack
;
6725 if ((s
->state
== COMP_SUBROUTINE
|| s
->state
== COMP_FUNCTION
)
6726 && s
->previous
!= NULL
&& s
->previous
->state
== COMP_CONTAINS
)
6732 /* Set the kind of each enumerator. The kind is selected such that it is
6733 interoperable with the corresponding C enumeration type, making
6734 sure that -fshort-enums is honored. */
6739 enumerator_history
*current_history
= NULL
;
6743 if (max_enum
== NULL
|| enum_history
== NULL
)
6746 if (!flag_short_enums
)
6752 kind
= gfc_integer_kinds
[i
++].kind
;
6754 while (kind
< gfc_c_int_kind
6755 && gfc_check_integer_range (max_enum
->initializer
->value
.integer
,
6758 current_history
= enum_history
;
6759 while (current_history
!= NULL
)
6761 current_history
->sym
->ts
.kind
= kind
;
6762 current_history
= current_history
->next
;
6767 /* Match any of the various end-block statements. Returns the type of
6768 END to the caller. The END INTERFACE, END IF, END DO, END SELECT
6769 and END BLOCK statements cannot be replaced by a single END statement. */
6772 gfc_match_end (gfc_statement
*st
)
6774 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
6775 gfc_compile_state state
;
6777 const char *block_name
;
6781 gfc_namespace
*parent_ns
, *ns
, *prev_ns
;
6782 gfc_namespace
**nsp
;
6783 bool abreviated_modproc_decl
= false;
6784 bool got_matching_end
= false;
6786 old_loc
= gfc_current_locus
;
6787 if (gfc_match ("end") != MATCH_YES
)
6790 state
= gfc_current_state ();
6791 block_name
= gfc_current_block () == NULL
6792 ? NULL
: gfc_current_block ()->name
;
6796 case COMP_ASSOCIATE
:
6798 if (!strncmp (block_name
, "block@", strlen("block@")))
6803 case COMP_DERIVED_CONTAINS
:
6804 state
= gfc_state_stack
->previous
->state
;
6805 block_name
= gfc_state_stack
->previous
->sym
== NULL
6806 ? NULL
: gfc_state_stack
->previous
->sym
->name
;
6807 abreviated_modproc_decl
= gfc_state_stack
->previous
->sym
6808 && gfc_state_stack
->previous
->sym
->abr_modproc_decl
;
6815 if (!abreviated_modproc_decl
)
6816 abreviated_modproc_decl
= gfc_current_block ()
6817 && gfc_current_block ()->abr_modproc_decl
;
6823 *st
= ST_END_PROGRAM
;
6824 target
= " program";
6828 case COMP_SUBROUTINE
:
6829 *st
= ST_END_SUBROUTINE
;
6830 if (!abreviated_modproc_decl
)
6831 target
= " subroutine";
6833 target
= " procedure";
6834 eos_ok
= !contained_procedure ();
6838 *st
= ST_END_FUNCTION
;
6839 if (!abreviated_modproc_decl
)
6840 target
= " function";
6842 target
= " procedure";
6843 eos_ok
= !contained_procedure ();
6846 case COMP_BLOCK_DATA
:
6847 *st
= ST_END_BLOCK_DATA
;
6848 target
= " block data";
6853 *st
= ST_END_MODULE
;
6858 case COMP_SUBMODULE
:
6859 *st
= ST_END_SUBMODULE
;
6860 target
= " submodule";
6864 case COMP_INTERFACE
:
6865 *st
= ST_END_INTERFACE
;
6866 target
= " interface";
6882 case COMP_STRUCTURE
:
6883 *st
= ST_END_STRUCTURE
;
6884 target
= " structure";
6889 case COMP_DERIVED_CONTAINS
:
6895 case COMP_ASSOCIATE
:
6896 *st
= ST_END_ASSOCIATE
;
6897 target
= " associate";
6914 case COMP_DO_CONCURRENT
:
6921 *st
= ST_END_CRITICAL
;
6922 target
= " critical";
6927 case COMP_SELECT_TYPE
:
6928 *st
= ST_END_SELECT
;
6934 *st
= ST_END_FORALL
;
6949 last_initializer
= NULL
;
6951 gfc_free_enum_history ();
6955 gfc_error ("Unexpected END statement at %C");
6959 old_loc
= gfc_current_locus
;
6960 if (gfc_match_eos () == MATCH_YES
)
6962 if (!eos_ok
&& (*st
== ST_END_SUBROUTINE
|| *st
== ST_END_FUNCTION
))
6964 if (!gfc_notify_std (GFC_STD_F2008
, "END statement "
6965 "instead of %s statement at %L",
6966 abreviated_modproc_decl
? "END PROCEDURE"
6967 : gfc_ascii_statement(*st
), &old_loc
))
6972 /* We would have required END [something]. */
6973 gfc_error ("%s statement expected at %L",
6974 gfc_ascii_statement (*st
), &old_loc
);
6981 /* Verify that we've got the sort of end-block that we're expecting. */
6982 if (gfc_match (target
) != MATCH_YES
)
6984 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl
6985 ? "END PROCEDURE" : gfc_ascii_statement(*st
), &old_loc
);
6989 got_matching_end
= true;
6991 old_loc
= gfc_current_locus
;
6992 /* If we're at the end, make sure a block name wasn't required. */
6993 if (gfc_match_eos () == MATCH_YES
)
6996 if (*st
!= ST_ENDDO
&& *st
!= ST_ENDIF
&& *st
!= ST_END_SELECT
6997 && *st
!= ST_END_FORALL
&& *st
!= ST_END_WHERE
&& *st
!= ST_END_BLOCK
6998 && *st
!= ST_END_ASSOCIATE
&& *st
!= ST_END_CRITICAL
)
7004 gfc_error ("Expected block name of %qs in %s statement at %L",
7005 block_name
, gfc_ascii_statement (*st
), &old_loc
);
7010 /* END INTERFACE has a special handler for its several possible endings. */
7011 if (*st
== ST_END_INTERFACE
)
7012 return gfc_match_end_interface ();
7014 /* We haven't hit the end of statement, so what is left must be an
7016 m
= gfc_match_space ();
7018 m
= gfc_match_name (name
);
7021 gfc_error ("Expected terminating name at %C");
7025 if (block_name
== NULL
)
7028 /* We have to pick out the declared submodule name from the composite
7029 required by F2008:11.2.3 para 2, which ends in the declared name. */
7030 if (state
== COMP_SUBMODULE
)
7031 block_name
= strchr (block_name
, '.') + 1;
7033 if (strcmp (name
, block_name
) != 0 && strcmp (block_name
, "ppr@") != 0)
7035 gfc_error ("Expected label %qs for %s statement at %C", block_name
,
7036 gfc_ascii_statement (*st
));
7039 /* Procedure pointer as function result. */
7040 else if (strcmp (block_name
, "ppr@") == 0
7041 && strcmp (name
, gfc_current_block ()->ns
->proc_name
->name
) != 0)
7043 gfc_error ("Expected label %qs for %s statement at %C",
7044 gfc_current_block ()->ns
->proc_name
->name
,
7045 gfc_ascii_statement (*st
));
7049 if (gfc_match_eos () == MATCH_YES
)
7053 gfc_syntax_error (*st
);
7056 gfc_current_locus
= old_loc
;
7058 /* If we are missing an END BLOCK, we created a half-ready namespace.
7059 Remove it from the parent namespace's sibling list. */
7061 while (state
== COMP_BLOCK
&& !got_matching_end
)
7063 parent_ns
= gfc_current_ns
->parent
;
7065 nsp
= &(gfc_state_stack
->previous
->tail
->ext
.block
.ns
);
7071 if (ns
== gfc_current_ns
)
7073 if (prev_ns
== NULL
)
7076 prev_ns
->sibling
= ns
->sibling
;
7082 gfc_free_namespace (gfc_current_ns
);
7083 gfc_current_ns
= parent_ns
;
7084 gfc_state_stack
= gfc_state_stack
->previous
;
7085 state
= gfc_current_state ();
7093 /***************** Attribute declaration statements ****************/
7095 /* Set the attribute of a single variable. */
7100 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7103 /* Workaround -Wmaybe-uninitialized false positive during
7104 profiledbootstrap by initializing them. */
7105 gfc_symbol
*sym
= NULL
;
7111 m
= gfc_match_name (name
);
7115 if (find_special (name
, &sym
, false))
7118 if (!check_function_name (name
))
7124 var_locus
= gfc_current_locus
;
7126 /* Deal with possible array specification for certain attributes. */
7127 if (current_attr
.dimension
7128 || current_attr
.codimension
7129 || current_attr
.allocatable
7130 || current_attr
.pointer
7131 || current_attr
.target
)
7133 m
= gfc_match_array_spec (&as
, !current_attr
.codimension
,
7134 !current_attr
.dimension
7135 && !current_attr
.pointer
7136 && !current_attr
.target
);
7137 if (m
== MATCH_ERROR
)
7140 if (current_attr
.dimension
&& m
== MATCH_NO
)
7142 gfc_error ("Missing array specification at %L in DIMENSION "
7143 "statement", &var_locus
);
7148 if (current_attr
.dimension
&& sym
->value
)
7150 gfc_error ("Dimensions specified for %s at %L after its "
7151 "initialization", sym
->name
, &var_locus
);
7156 if (current_attr
.codimension
&& m
== MATCH_NO
)
7158 gfc_error ("Missing array specification at %L in CODIMENSION "
7159 "statement", &var_locus
);
7164 if ((current_attr
.allocatable
|| current_attr
.pointer
)
7165 && (m
== MATCH_YES
) && (as
->type
!= AS_DEFERRED
))
7167 gfc_error ("Array specification must be deferred at %L", &var_locus
);
7173 /* Update symbol table. DIMENSION attribute is set in
7174 gfc_set_array_spec(). For CLASS variables, this must be applied
7175 to the first component, or '_data' field. */
7176 if (sym
->ts
.type
== BT_CLASS
&& sym
->ts
.u
.derived
->attr
.is_class
)
7178 if (!gfc_copy_attr (&CLASS_DATA(sym
)->attr
, ¤t_attr
, &var_locus
))
7186 if (current_attr
.dimension
== 0 && current_attr
.codimension
== 0
7187 && !gfc_copy_attr (&sym
->attr
, ¤t_attr
, &var_locus
))
7194 if (sym
->ts
.type
== BT_CLASS
7195 && !gfc_build_class_symbol (&sym
->ts
, &sym
->attr
, &sym
->as
))
7201 if (!gfc_set_array_spec (sym
, as
, &var_locus
))
7207 if (sym
->attr
.cray_pointee
&& sym
->as
!= NULL
)
7209 /* Fix the array spec. */
7210 m
= gfc_mod_pointee_as (sym
->as
);
7211 if (m
== MATCH_ERROR
)
7215 if (!gfc_add_attribute (&sym
->attr
, &var_locus
))
7221 if ((current_attr
.external
|| current_attr
.intrinsic
)
7222 && sym
->attr
.flavor
!= FL_PROCEDURE
7223 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
, sym
->name
, NULL
))
7229 add_hidden_procptr_result (sym
);
7234 gfc_free_array_spec (as
);
7239 /* Generic attribute declaration subroutine. Used for attributes that
7240 just have a list of names. */
7247 /* Gobble the optional double colon, by simply ignoring the result
7257 if (gfc_match_eos () == MATCH_YES
)
7263 if (gfc_match_char (',') != MATCH_YES
)
7265 gfc_error ("Unexpected character in variable list at %C");
7275 /* This routine matches Cray Pointer declarations of the form:
7276 pointer ( <pointer>, <pointee> )
7278 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
7279 The pointer, if already declared, should be an integer. Otherwise, we
7280 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
7281 be either a scalar, or an array declaration. No space is allocated for
7282 the pointee. For the statement
7283 pointer (ipt, ar(10))
7284 any subsequent uses of ar will be translated (in C-notation) as
7285 ar(i) => ((<type> *) ipt)(i)
7286 After gimplification, pointee variable will disappear in the code. */
7289 cray_pointer_decl (void)
7292 gfc_array_spec
*as
= NULL
;
7293 gfc_symbol
*cptr
; /* Pointer symbol. */
7294 gfc_symbol
*cpte
; /* Pointee symbol. */
7300 if (gfc_match_char ('(') != MATCH_YES
)
7302 gfc_error ("Expected %<(%> at %C");
7306 /* Match pointer. */
7307 var_locus
= gfc_current_locus
;
7308 gfc_clear_attr (¤t_attr
);
7309 gfc_add_cray_pointer (¤t_attr
, &var_locus
);
7310 current_ts
.type
= BT_INTEGER
;
7311 current_ts
.kind
= gfc_index_integer_kind
;
7313 m
= gfc_match_symbol (&cptr
, 0);
7316 gfc_error ("Expected variable name at %C");
7320 if (!gfc_add_cray_pointer (&cptr
->attr
, &var_locus
))
7323 gfc_set_sym_referenced (cptr
);
7325 if (cptr
->ts
.type
== BT_UNKNOWN
) /* Override the type, if necessary. */
7327 cptr
->ts
.type
= BT_INTEGER
;
7328 cptr
->ts
.kind
= gfc_index_integer_kind
;
7330 else if (cptr
->ts
.type
!= BT_INTEGER
)
7332 gfc_error ("Cray pointer at %C must be an integer");
7335 else if (cptr
->ts
.kind
< gfc_index_integer_kind
)
7336 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
7337 " memory addresses require %d bytes",
7338 cptr
->ts
.kind
, gfc_index_integer_kind
);
7340 if (gfc_match_char (',') != MATCH_YES
)
7342 gfc_error ("Expected \",\" at %C");
7346 /* Match Pointee. */
7347 var_locus
= gfc_current_locus
;
7348 gfc_clear_attr (¤t_attr
);
7349 gfc_add_cray_pointee (¤t_attr
, &var_locus
);
7350 current_ts
.type
= BT_UNKNOWN
;
7351 current_ts
.kind
= 0;
7353 m
= gfc_match_symbol (&cpte
, 0);
7356 gfc_error ("Expected variable name at %C");
7360 /* Check for an optional array spec. */
7361 m
= gfc_match_array_spec (&as
, true, false);
7362 if (m
== MATCH_ERROR
)
7364 gfc_free_array_spec (as
);
7367 else if (m
== MATCH_NO
)
7369 gfc_free_array_spec (as
);
7373 if (!gfc_add_cray_pointee (&cpte
->attr
, &var_locus
))
7376 gfc_set_sym_referenced (cpte
);
7378 if (cpte
->as
== NULL
)
7380 if (!gfc_set_array_spec (cpte
, as
, &var_locus
))
7381 gfc_internal_error ("Couldn't set Cray pointee array spec.");
7383 else if (as
!= NULL
)
7385 gfc_error ("Duplicate array spec for Cray pointee at %C");
7386 gfc_free_array_spec (as
);
7392 if (cpte
->as
!= NULL
)
7394 /* Fix array spec. */
7395 m
= gfc_mod_pointee_as (cpte
->as
);
7396 if (m
== MATCH_ERROR
)
7400 /* Point the Pointee at the Pointer. */
7401 cpte
->cp_pointer
= cptr
;
7403 if (gfc_match_char (')') != MATCH_YES
)
7405 gfc_error ("Expected \")\" at %C");
7408 m
= gfc_match_char (',');
7410 done
= true; /* Stop searching for more declarations. */
7414 if (m
== MATCH_ERROR
/* Failed when trying to find ',' above. */
7415 || gfc_match_eos () != MATCH_YES
)
7417 gfc_error ("Expected %<,%> or end of statement at %C");
7425 gfc_match_external (void)
7428 gfc_clear_attr (¤t_attr
);
7429 current_attr
.external
= 1;
7431 return attr_decl ();
7436 gfc_match_intent (void)
7440 /* This is not allowed within a BLOCK construct! */
7441 if (gfc_current_state () == COMP_BLOCK
)
7443 gfc_error ("INTENT is not allowed inside of BLOCK at %C");
7447 intent
= match_intent_spec ();
7448 if (intent
== INTENT_UNKNOWN
)
7451 gfc_clear_attr (¤t_attr
);
7452 current_attr
.intent
= intent
;
7454 return attr_decl ();
7459 gfc_match_intrinsic (void)
7462 gfc_clear_attr (¤t_attr
);
7463 current_attr
.intrinsic
= 1;
7465 return attr_decl ();
7470 gfc_match_optional (void)
7472 /* This is not allowed within a BLOCK construct! */
7473 if (gfc_current_state () == COMP_BLOCK
)
7475 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
7479 gfc_clear_attr (¤t_attr
);
7480 current_attr
.optional
= 1;
7482 return attr_decl ();
7487 gfc_match_pointer (void)
7489 gfc_gobble_whitespace ();
7490 if (gfc_peek_ascii_char () == '(')
7492 if (!flag_cray_pointer
)
7494 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
7498 return cray_pointer_decl ();
7502 gfc_clear_attr (¤t_attr
);
7503 current_attr
.pointer
= 1;
7505 return attr_decl ();
7511 gfc_match_allocatable (void)
7513 gfc_clear_attr (¤t_attr
);
7514 current_attr
.allocatable
= 1;
7516 return attr_decl ();
7521 gfc_match_codimension (void)
7523 gfc_clear_attr (¤t_attr
);
7524 current_attr
.codimension
= 1;
7526 return attr_decl ();
7531 gfc_match_contiguous (void)
7533 if (!gfc_notify_std (GFC_STD_F2008
, "CONTIGUOUS statement at %C"))
7536 gfc_clear_attr (¤t_attr
);
7537 current_attr
.contiguous
= 1;
7539 return attr_decl ();
7544 gfc_match_dimension (void)
7546 gfc_clear_attr (¤t_attr
);
7547 current_attr
.dimension
= 1;
7549 return attr_decl ();
7554 gfc_match_target (void)
7556 gfc_clear_attr (¤t_attr
);
7557 current_attr
.target
= 1;
7559 return attr_decl ();
7563 /* Match the list of entities being specified in a PUBLIC or PRIVATE
7567 access_attr_decl (gfc_statement st
)
7569 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
7570 interface_type type
;
7572 gfc_symbol
*sym
, *dt_sym
;
7573 gfc_intrinsic_op op
;
7576 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7581 m
= gfc_match_generic_spec (&type
, name
, &op
);
7584 if (m
== MATCH_ERROR
)
7589 case INTERFACE_NAMELESS
:
7590 case INTERFACE_ABSTRACT
:
7593 case INTERFACE_GENERIC
:
7594 case INTERFACE_DTIO
:
7596 if (gfc_get_symbol (name
, NULL
, &sym
))
7599 if (type
== INTERFACE_DTIO
7600 && gfc_current_ns
->proc_name
7601 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
7602 && sym
->attr
.flavor
== FL_UNKNOWN
)
7603 sym
->attr
.flavor
= FL_PROCEDURE
;
7605 if (!gfc_add_access (&sym
->attr
,
7607 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7611 if (sym
->attr
.generic
&& (dt_sym
= gfc_find_dt_in_generic (sym
))
7612 && !gfc_add_access (&dt_sym
->attr
,
7614 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
,
7620 case INTERFACE_INTRINSIC_OP
:
7621 if (gfc_current_ns
->operator_access
[op
] == ACCESS_UNKNOWN
)
7623 gfc_intrinsic_op other_op
;
7625 gfc_current_ns
->operator_access
[op
] =
7626 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7628 /* Handle the case if there is another op with the same
7629 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
7630 other_op
= gfc_equivalent_op (op
);
7632 if (other_op
!= INTRINSIC_NONE
)
7633 gfc_current_ns
->operator_access
[other_op
] =
7634 (st
== ST_PUBLIC
) ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7639 gfc_error ("Access specification of the %s operator at %C has "
7640 "already been specified", gfc_op2string (op
));
7646 case INTERFACE_USER_OP
:
7647 uop
= gfc_get_uop (name
);
7649 if (uop
->access
== ACCESS_UNKNOWN
)
7651 uop
->access
= (st
== ST_PUBLIC
)
7652 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
7656 gfc_error ("Access specification of the .%s. operator at %C "
7657 "has already been specified", sym
->name
);
7664 if (gfc_match_char (',') == MATCH_NO
)
7668 if (gfc_match_eos () != MATCH_YES
)
7673 gfc_syntax_error (st
);
7681 gfc_match_protected (void)
7686 if (!gfc_current_ns
->proc_name
7687 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7689 gfc_error ("PROTECTED at %C only allowed in specification "
7690 "part of a module");
7695 if (!gfc_notify_std (GFC_STD_F2003
, "PROTECTED statement at %C"))
7698 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
7703 if (gfc_match_eos () == MATCH_YES
)
7708 m
= gfc_match_symbol (&sym
, 0);
7712 if (!gfc_add_protected (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7724 if (gfc_match_eos () == MATCH_YES
)
7726 if (gfc_match_char (',') != MATCH_YES
)
7733 gfc_error ("Syntax error in PROTECTED statement at %C");
7738 /* The PRIVATE statement is a bit weird in that it can be an attribute
7739 declaration, but also works as a standalone statement inside of a
7740 type declaration or a module. */
7743 gfc_match_private (gfc_statement
*st
)
7746 if (gfc_match ("private") != MATCH_YES
)
7749 if (gfc_current_state () != COMP_MODULE
7750 && !(gfc_current_state () == COMP_DERIVED
7751 && gfc_state_stack
->previous
7752 && gfc_state_stack
->previous
->state
== COMP_MODULE
)
7753 && !(gfc_current_state () == COMP_DERIVED_CONTAINS
7754 && gfc_state_stack
->previous
&& gfc_state_stack
->previous
->previous
7755 && gfc_state_stack
->previous
->previous
->state
== COMP_MODULE
))
7757 gfc_error ("PRIVATE statement at %C is only allowed in the "
7758 "specification part of a module");
7762 if (gfc_current_state () == COMP_DERIVED
)
7764 if (gfc_match_eos () == MATCH_YES
)
7770 gfc_syntax_error (ST_PRIVATE
);
7774 if (gfc_match_eos () == MATCH_YES
)
7781 return access_attr_decl (ST_PRIVATE
);
7786 gfc_match_public (gfc_statement
*st
)
7789 if (gfc_match ("public") != MATCH_YES
)
7792 if (gfc_current_state () != COMP_MODULE
)
7794 gfc_error ("PUBLIC statement at %C is only allowed in the "
7795 "specification part of a module");
7799 if (gfc_match_eos () == MATCH_YES
)
7806 return access_attr_decl (ST_PUBLIC
);
7810 /* Workhorse for gfc_match_parameter. */
7820 m
= gfc_match_symbol (&sym
, 0);
7822 gfc_error ("Expected variable name at %C in PARAMETER statement");
7827 if (gfc_match_char ('=') == MATCH_NO
)
7829 gfc_error ("Expected = sign in PARAMETER statement at %C");
7833 m
= gfc_match_init_expr (&init
);
7835 gfc_error ("Expected expression at %C in PARAMETER statement");
7839 if (sym
->ts
.type
== BT_UNKNOWN
7840 && !gfc_set_default_type (sym
, 1, NULL
))
7846 if (!gfc_check_assign_symbol (sym
, NULL
, init
)
7847 || !gfc_add_flavor (&sym
->attr
, FL_PARAMETER
, sym
->name
, NULL
))
7855 gfc_error ("Initializing already initialized variable at %C");
7860 t
= add_init_expr_to_sym (sym
->name
, &init
, &gfc_current_locus
);
7861 return (t
) ? MATCH_YES
: MATCH_ERROR
;
7864 gfc_free_expr (init
);
7869 /* Match a parameter statement, with the weird syntax that these have. */
7872 gfc_match_parameter (void)
7874 const char *term
= " )%t";
7877 if (gfc_match_char ('(') == MATCH_NO
)
7879 /* With legacy PARAMETER statements, don't expect a terminating ')'. */
7880 if (!gfc_notify_std (GFC_STD_LEGACY
, "PARAMETER without '()' at %C"))
7891 if (gfc_match (term
) == MATCH_YES
)
7894 if (gfc_match_char (',') != MATCH_YES
)
7896 gfc_error ("Unexpected characters in PARAMETER statement at %C");
7907 gfc_match_automatic (void)
7911 bool seen_symbol
= false;
7913 if (!flag_dec_static
)
7915 gfc_error ("%s at %C is a DEC extension, enable with "
7926 m
= gfc_match_symbol (&sym
, 0);
7936 if (!gfc_add_automatic (&sym
->attr
, sym
->name
, &gfc_current_locus
))
7942 if (gfc_match_eos () == MATCH_YES
)
7944 if (gfc_match_char (',') != MATCH_YES
)
7950 gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
7957 gfc_error ("Syntax error in AUTOMATIC statement at %C");
7963 gfc_match_static (void)
7967 bool seen_symbol
= false;
7969 if (!flag_dec_static
)
7971 gfc_error ("%s at %C is a DEC extension, enable with "
7981 m
= gfc_match_symbol (&sym
, 0);
7991 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
7992 &gfc_current_locus
))
7998 if (gfc_match_eos () == MATCH_YES
)
8000 if (gfc_match_char (',') != MATCH_YES
)
8006 gfc_error ("Expected entity-list in STATIC statement at %C");
8013 gfc_error ("Syntax error in STATIC statement at %C");
8018 /* Save statements have a special syntax. */
8021 gfc_match_save (void)
8023 char n
[GFC_MAX_SYMBOL_LEN
+1];
8028 if (gfc_match_eos () == MATCH_YES
)
8030 if (gfc_current_ns
->seen_save
)
8032 if (!gfc_notify_std (GFC_STD_LEGACY
, "Blanket SAVE statement at %C "
8033 "follows previous SAVE statement"))
8037 gfc_current_ns
->save_all
= gfc_current_ns
->seen_save
= 1;
8041 if (gfc_current_ns
->save_all
)
8043 if (!gfc_notify_std (GFC_STD_LEGACY
, "SAVE statement at %C follows "
8044 "blanket SAVE statement"))
8052 m
= gfc_match_symbol (&sym
, 0);
8056 if (!gfc_add_save (&sym
->attr
, SAVE_EXPLICIT
, sym
->name
,
8057 &gfc_current_locus
))
8068 m
= gfc_match (" / %n /", &n
);
8069 if (m
== MATCH_ERROR
)
8074 c
= gfc_get_common (n
, 0);
8077 gfc_current_ns
->seen_save
= 1;
8080 if (gfc_match_eos () == MATCH_YES
)
8082 if (gfc_match_char (',') != MATCH_YES
)
8089 gfc_error ("Syntax error in SAVE statement at %C");
8095 gfc_match_value (void)
8100 /* This is not allowed within a BLOCK construct! */
8101 if (gfc_current_state () == COMP_BLOCK
)
8103 gfc_error ("VALUE is not allowed inside of BLOCK at %C");
8107 if (!gfc_notify_std (GFC_STD_F2003
, "VALUE statement at %C"))
8110 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8115 if (gfc_match_eos () == MATCH_YES
)
8120 m
= gfc_match_symbol (&sym
, 0);
8124 if (!gfc_add_value (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8136 if (gfc_match_eos () == MATCH_YES
)
8138 if (gfc_match_char (',') != MATCH_YES
)
8145 gfc_error ("Syntax error in VALUE statement at %C");
8151 gfc_match_volatile (void)
8156 if (!gfc_notify_std (GFC_STD_F2003
, "VOLATILE statement at %C"))
8159 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8164 if (gfc_match_eos () == MATCH_YES
)
8169 /* VOLATILE is special because it can be added to host-associated
8170 symbols locally. Except for coarrays. */
8171 m
= gfc_match_symbol (&sym
, 1);
8175 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
8176 for variable in a BLOCK which is defined outside of the BLOCK. */
8177 if (sym
->ns
!= gfc_current_ns
&& sym
->attr
.codimension
)
8179 gfc_error ("Specifying VOLATILE for coarray variable %qs at "
8180 "%C, which is use-/host-associated", sym
->name
);
8183 if (!gfc_add_volatile (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8195 if (gfc_match_eos () == MATCH_YES
)
8197 if (gfc_match_char (',') != MATCH_YES
)
8204 gfc_error ("Syntax error in VOLATILE statement at %C");
8210 gfc_match_asynchronous (void)
8215 if (!gfc_notify_std (GFC_STD_F2003
, "ASYNCHRONOUS statement at %C"))
8218 if (gfc_match (" ::") == MATCH_NO
&& gfc_match_space () == MATCH_NO
)
8223 if (gfc_match_eos () == MATCH_YES
)
8228 /* ASYNCHRONOUS is special because it can be added to host-associated
8230 m
= gfc_match_symbol (&sym
, 1);
8234 if (!gfc_add_asynchronous (&sym
->attr
, sym
->name
, &gfc_current_locus
))
8246 if (gfc_match_eos () == MATCH_YES
)
8248 if (gfc_match_char (',') != MATCH_YES
)
8255 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
8260 /* Match a module procedure statement in a submodule. */
8263 gfc_match_submod_proc (void)
8265 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8266 gfc_symbol
*sym
, *fsym
;
8268 gfc_formal_arglist
*formal
, *head
, *tail
;
8270 if (gfc_current_state () != COMP_CONTAINS
8271 || !(gfc_state_stack
->previous
8272 && (gfc_state_stack
->previous
->state
== COMP_SUBMODULE
8273 || gfc_state_stack
->previous
->state
== COMP_MODULE
)))
8276 m
= gfc_match (" module% procedure% %n", name
);
8280 if (!gfc_notify_std (GFC_STD_F2008
, "MODULE PROCEDURE declaration "
8284 if (get_proc_name (name
, &sym
, false))
8287 /* Make sure that the result field is appropriately filled, even though
8288 the result symbol will be replaced later on. */
8289 if (sym
->tlink
&& sym
->tlink
->attr
.function
)
8291 if (sym
->tlink
->result
8292 && sym
->tlink
->result
!= sym
->tlink
)
8293 sym
->result
= sym
->tlink
->result
;
8298 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8299 the symbol existed before. */
8300 sym
->declared_at
= gfc_current_locus
;
8302 if (!sym
->attr
.module_procedure
)
8305 /* Signal match_end to expect "end procedure". */
8306 sym
->abr_modproc_decl
= 1;
8308 /* Change from IFSRC_IFBODY coming from the interface declaration. */
8309 sym
->attr
.if_source
= IFSRC_DECL
;
8311 gfc_new_block
= sym
;
8313 /* Make a new formal arglist with the symbols in the procedure
8316 for (formal
= sym
->formal
; formal
&& formal
->sym
; formal
= formal
->next
)
8318 if (formal
== sym
->formal
)
8319 head
= tail
= gfc_get_formal_arglist ();
8322 tail
->next
= gfc_get_formal_arglist ();
8326 if (gfc_copy_dummy_sym (&fsym
, formal
->sym
, 0))
8330 gfc_set_sym_referenced (fsym
);
8333 /* The dummy symbols get cleaned up, when the formal_namespace of the
8334 interface declaration is cleared. This allows us to add the
8335 explicit interface as is done for other type of procedure. */
8336 if (!gfc_add_explicit_interface (sym
, IFSRC_DECL
, head
,
8337 &gfc_current_locus
))
8340 if (gfc_match_eos () != MATCH_YES
)
8342 gfc_syntax_error (ST_MODULE_PROC
);
8349 gfc_free_formal_arglist (head
);
8354 /* Match a module procedure statement. Note that we have to modify
8355 symbols in the parent's namespace because the current one was there
8356 to receive symbols that are in an interface's formal argument list. */
8359 gfc_match_modproc (void)
8361 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8365 gfc_namespace
*module_ns
;
8366 gfc_interface
*old_interface_head
, *interface
;
8368 if (gfc_state_stack
->state
!= COMP_INTERFACE
8369 || gfc_state_stack
->previous
== NULL
8370 || current_interface
.type
== INTERFACE_NAMELESS
8371 || current_interface
.type
== INTERFACE_ABSTRACT
)
8373 gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
8378 module_ns
= gfc_current_ns
->parent
;
8379 for (; module_ns
; module_ns
= module_ns
->parent
)
8380 if (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
8381 || module_ns
->proc_name
->attr
.flavor
== FL_PROGRAM
8382 || (module_ns
->proc_name
->attr
.flavor
== FL_PROCEDURE
8383 && !module_ns
->proc_name
->attr
.contained
))
8386 if (module_ns
== NULL
)
8389 /* Store the current state of the interface. We will need it if we
8390 end up with a syntax error and need to recover. */
8391 old_interface_head
= gfc_current_interface_head ();
8393 /* Check if the F2008 optional double colon appears. */
8394 gfc_gobble_whitespace ();
8395 old_locus
= gfc_current_locus
;
8396 if (gfc_match ("::") == MATCH_YES
)
8398 if (!gfc_notify_std (GFC_STD_F2008
, "double colon in "
8399 "MODULE PROCEDURE statement at %L", &old_locus
))
8403 gfc_current_locus
= old_locus
;
8408 old_locus
= gfc_current_locus
;
8410 m
= gfc_match_name (name
);
8416 /* Check for syntax error before starting to add symbols to the
8417 current namespace. */
8418 if (gfc_match_eos () == MATCH_YES
)
8421 if (!last
&& gfc_match_char (',') != MATCH_YES
)
8424 /* Now we're sure the syntax is valid, we process this item
8426 if (gfc_get_symbol (name
, module_ns
, &sym
))
8429 if (sym
->attr
.intrinsic
)
8431 gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
8432 "PROCEDURE", &old_locus
);
8436 if (sym
->attr
.proc
!= PROC_MODULE
8437 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
8440 if (!gfc_add_interface (sym
))
8443 sym
->attr
.mod_proc
= 1;
8444 sym
->declared_at
= old_locus
;
8453 /* Restore the previous state of the interface. */
8454 interface
= gfc_current_interface_head ();
8455 gfc_set_current_interface_head (old_interface_head
);
8457 /* Free the new interfaces. */
8458 while (interface
!= old_interface_head
)
8460 gfc_interface
*i
= interface
->next
;
8465 /* And issue a syntax error. */
8466 gfc_syntax_error (ST_MODULE_PROC
);
8471 /* Check a derived type that is being extended. */
8474 check_extended_derived_type (char *name
)
8476 gfc_symbol
*extended
;
8478 if (gfc_find_symbol (name
, gfc_current_ns
, 1, &extended
))
8480 gfc_error ("Ambiguous symbol in TYPE definition at %C");
8484 extended
= gfc_find_dt_in_generic (extended
);
8489 gfc_error ("Symbol %qs at %C has not been previously defined", name
);
8493 if (extended
->attr
.flavor
!= FL_DERIVED
)
8495 gfc_error ("%qs in EXTENDS expression at %C is not a "
8496 "derived type", name
);
8500 if (extended
->attr
.is_bind_c
)
8502 gfc_error ("%qs cannot be extended at %C because it "
8503 "is BIND(C)", extended
->name
);
8507 if (extended
->attr
.sequence
)
8509 gfc_error ("%qs cannot be extended at %C because it "
8510 "is a SEQUENCE type", extended
->name
);
8518 /* Match the optional attribute specifiers for a type declaration.
8519 Return MATCH_ERROR if an error is encountered in one of the handled
8520 attributes (public, private, bind(c)), MATCH_NO if what's found is
8521 not a handled attribute, and MATCH_YES otherwise. TODO: More error
8522 checking on attribute conflicts needs to be done. */
8525 gfc_get_type_attr_spec (symbol_attribute
*attr
, char *name
)
8527 /* See if the derived type is marked as private. */
8528 if (gfc_match (" , private") == MATCH_YES
)
8530 if (gfc_current_state () != COMP_MODULE
)
8532 gfc_error ("Derived type at %C can only be PRIVATE in the "
8533 "specification part of a module");
8537 if (!gfc_add_access (attr
, ACCESS_PRIVATE
, NULL
, NULL
))
8540 else if (gfc_match (" , public") == MATCH_YES
)
8542 if (gfc_current_state () != COMP_MODULE
)
8544 gfc_error ("Derived type at %C can only be PUBLIC in the "
8545 "specification part of a module");
8549 if (!gfc_add_access (attr
, ACCESS_PUBLIC
, NULL
, NULL
))
8552 else if (gfc_match (" , bind ( c )") == MATCH_YES
)
8554 /* If the type is defined to be bind(c) it then needs to make
8555 sure that all fields are interoperable. This will
8556 need to be a semantic check on the finished derived type.
8557 See 15.2.3 (lines 9-12) of F2003 draft. */
8558 if (!gfc_add_is_bind_c (attr
, NULL
, &gfc_current_locus
, 0))
8561 /* TODO: attr conflicts need to be checked, probably in symbol.c. */
8563 else if (gfc_match (" , abstract") == MATCH_YES
)
8565 if (!gfc_notify_std (GFC_STD_F2003
, "ABSTRACT type at %C"))
8568 if (!gfc_add_abstract (attr
, &gfc_current_locus
))
8571 else if (name
&& gfc_match (" , extends ( %n )", name
) == MATCH_YES
)
8573 if (!gfc_add_extension (attr
, &gfc_current_locus
))
8579 /* If we get here, something matched. */
8584 /* Common function for type declaration blocks similar to derived types, such
8585 as STRUCTURES and MAPs. Unlike derived types, a structure type
8586 does NOT have a generic symbol matching the name given by the user.
8587 STRUCTUREs can share names with variables and PARAMETERs so we must allow
8588 for the creation of an independent symbol.
8589 Other parameters are a message to prefix errors with, the name of the new
8590 type to be created, and the flavor to add to the resulting symbol. */
8593 get_struct_decl (const char *name
, sym_flavor fl
, locus
*decl
,
8594 gfc_symbol
**result
)
8599 gcc_assert (name
[0] == (char) TOUPPER (name
[0]));
8604 where
= gfc_current_locus
;
8606 if (gfc_get_symbol (name
, NULL
, &sym
))
8611 gfc_internal_error ("Failed to create structure type '%s' at %C", name
);
8615 if (sym
->components
!= NULL
|| sym
->attr
.zero_comp
)
8617 gfc_error ("Type definition of %qs at %C was already defined at %L",
8618 sym
->name
, &sym
->declared_at
);
8622 sym
->declared_at
= where
;
8624 if (sym
->attr
.flavor
!= fl
8625 && !gfc_add_flavor (&sym
->attr
, fl
, sym
->name
, NULL
))
8628 if (!sym
->hash_value
)
8629 /* Set the hash for the compound name for this type. */
8630 sym
->hash_value
= gfc_hash_value (sym
);
8632 /* Normally the type is expected to have been completely parsed by the time
8633 a field declaration with this type is seen. For unions, maps, and nested
8634 structure declarations, we need to indicate that it is okay that we
8635 haven't seen any components yet. This will be updated after the structure
8637 sym
->attr
.zero_comp
= 0;
8639 /* Structures always act like derived-types with the SEQUENCE attribute */
8640 gfc_add_sequence (&sym
->attr
, sym
->name
, NULL
);
8642 if (result
) *result
= sym
;
8648 /* Match the opening of a MAP block. Like a struct within a union in C;
8649 behaves identical to STRUCTURE blocks. */
8652 gfc_match_map (void)
8654 /* Counter used to give unique internal names to map structures. */
8655 static unsigned int gfc_map_id
= 0;
8656 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8660 old_loc
= gfc_current_locus
;
8662 if (gfc_match_eos () != MATCH_YES
)
8664 gfc_error ("Junk after MAP statement at %C");
8665 gfc_current_locus
= old_loc
;
8669 /* Map blocks are anonymous so we make up unique names for the symbol table
8670 which are invalid Fortran identifiers. */
8671 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "MM$%u", gfc_map_id
++);
8673 if (!get_struct_decl (name
, FL_STRUCT
, &old_loc
, &sym
))
8676 gfc_new_block
= sym
;
8682 /* Match the opening of a UNION block. */
8685 gfc_match_union (void)
8687 /* Counter used to give unique internal names to union types. */
8688 static unsigned int gfc_union_id
= 0;
8689 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8693 old_loc
= gfc_current_locus
;
8695 if (gfc_match_eos () != MATCH_YES
)
8697 gfc_error ("Junk after UNION statement at %C");
8698 gfc_current_locus
= old_loc
;
8702 /* Unions are anonymous so we make up unique names for the symbol table
8703 which are invalid Fortran identifiers. */
8704 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "UU$%u", gfc_union_id
++);
8706 if (!get_struct_decl (name
, FL_UNION
, &old_loc
, &sym
))
8709 gfc_new_block
= sym
;
8715 /* Match the beginning of a STRUCTURE declaration. This is similar to
8716 matching the beginning of a derived type declaration with a few
8717 twists. The resulting type symbol has no access control or other
8718 interesting attributes. */
8721 gfc_match_structure_decl (void)
8723 /* Counter used to give unique internal names to anonymous structures. */
8724 static unsigned int gfc_structure_id
= 0;
8725 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8730 if (!flag_dec_structure
)
8732 gfc_error ("%s at %C is a DEC extension, enable with "
8733 "%<-fdec-structure%>",
8740 m
= gfc_match (" /%n/", name
);
8743 /* Non-nested structure declarations require a structure name. */
8744 if (!gfc_comp_struct (gfc_current_state ()))
8746 gfc_error ("Structure name expected in non-nested structure "
8747 "declaration at %C");
8750 /* This is an anonymous structure; make up a unique name for it
8751 (upper-case letters never make it to symbol names from the source).
8752 The important thing is initializing the type variable
8753 and setting gfc_new_symbol, which is immediately used by
8754 parse_structure () and variable_decl () to add components of
8756 snprintf (name
, GFC_MAX_SYMBOL_LEN
+ 1, "SS$%u", gfc_structure_id
++);
8759 where
= gfc_current_locus
;
8760 /* No field list allowed after non-nested structure declaration. */
8761 if (!gfc_comp_struct (gfc_current_state ())
8762 && gfc_match_eos () != MATCH_YES
)
8764 gfc_error ("Junk after non-nested STRUCTURE statement at %C");
8768 /* Make sure the name is not the name of an intrinsic type. */
8769 if (gfc_is_intrinsic_typename (name
))
8771 gfc_error ("Structure name %qs at %C cannot be the same as an"
8772 " intrinsic type", name
);
8776 /* Store the actual type symbol for the structure with an upper-case first
8777 letter (an invalid Fortran identifier). */
8779 if (!get_struct_decl (gfc_dt_upper_string (name
), FL_STRUCT
, &where
, &sym
))
8782 gfc_new_block
= sym
;
8787 /* This function does some work to determine which matcher should be used to
8788 * match a statement beginning with "TYPE". This is used to disambiguate TYPE
8789 * as an alias for PRINT from derived type declarations, TYPE IS statements,
8790 * and derived type data declarations. */
8793 gfc_match_type (gfc_statement
*st
)
8795 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8799 /* Requires -fdec. */
8803 m
= gfc_match ("type");
8806 /* If we already have an error in the buffer, it is probably from failing to
8807 * match a derived type data declaration. Let it happen. */
8808 else if (gfc_error_flag_test ())
8811 old_loc
= gfc_current_locus
;
8814 /* If we see an attribute list before anything else it's definitely a derived
8815 * type declaration. */
8816 if (gfc_match (" ,") == MATCH_YES
|| gfc_match (" ::") == MATCH_YES
)
8818 gfc_current_locus
= old_loc
;
8819 *st
= ST_DERIVED_DECL
;
8820 return gfc_match_derived_decl ();
8823 /* By now "TYPE" has already been matched. If we do not see a name, this may
8824 * be something like "TYPE *" or "TYPE <fmt>". */
8825 m
= gfc_match_name (name
);
8828 /* Let print match if it can, otherwise throw an error from
8829 * gfc_match_derived_decl. */
8830 gfc_current_locus
= old_loc
;
8831 if (gfc_match_print () == MATCH_YES
)
8836 gfc_current_locus
= old_loc
;
8837 *st
= ST_DERIVED_DECL
;
8838 return gfc_match_derived_decl ();
8841 /* A derived type declaration requires an EOS. Without it, assume print. */
8842 m
= gfc_match_eos ();
8845 /* Check manually for TYPE IS (... - this is invalid print syntax. */
8846 if (strncmp ("is", name
, 3) == 0
8847 && gfc_match (" (", name
) == MATCH_YES
)
8849 gfc_current_locus
= old_loc
;
8850 gcc_assert (gfc_match (" is") == MATCH_YES
);
8852 return gfc_match_type_is ();
8854 gfc_current_locus
= old_loc
;
8856 return gfc_match_print ();
8860 /* By now we have "TYPE <name> <EOS>". Check first if the name is an
8861 * intrinsic typename - if so let gfc_match_derived_decl dump an error.
8862 * Otherwise if gfc_match_derived_decl fails it's probably an existing
8863 * symbol which can be printed. */
8864 gfc_current_locus
= old_loc
;
8865 m
= gfc_match_derived_decl ();
8866 if (gfc_is_intrinsic_typename (name
) || m
== MATCH_YES
)
8868 *st
= ST_DERIVED_DECL
;
8871 gfc_current_locus
= old_loc
;
8873 return gfc_match_print ();
8880 /* Match the beginning of a derived type declaration. If a type name
8881 was the result of a function, then it is possible to have a symbol
8882 already to be known as a derived type yet have no components. */
8885 gfc_match_derived_decl (void)
8887 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
8888 char parent
[GFC_MAX_SYMBOL_LEN
+ 1];
8889 symbol_attribute attr
;
8890 gfc_symbol
*sym
, *gensym
;
8891 gfc_symbol
*extended
;
8893 match is_type_attr_spec
= MATCH_NO
;
8894 bool seen_attr
= false;
8895 gfc_interface
*intr
= NULL
, *head
;
8897 if (gfc_comp_struct (gfc_current_state ()))
8902 gfc_clear_attr (&attr
);
8907 is_type_attr_spec
= gfc_get_type_attr_spec (&attr
, parent
);
8908 if (is_type_attr_spec
== MATCH_ERROR
)
8910 if (is_type_attr_spec
== MATCH_YES
)
8912 } while (is_type_attr_spec
== MATCH_YES
);
8914 /* Deal with derived type extensions. The extension attribute has
8915 been added to 'attr' but now the parent type must be found and
8918 extended
= check_extended_derived_type (parent
);
8920 if (parent
[0] && !extended
)
8923 if (gfc_match (" ::") != MATCH_YES
&& seen_attr
)
8925 gfc_error ("Expected :: in TYPE definition at %C");
8929 m
= gfc_match (" %n%t", name
);
8933 /* Make sure the name is not the name of an intrinsic type. */
8934 if (gfc_is_intrinsic_typename (name
))
8936 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
8941 if (gfc_get_symbol (name
, NULL
, &gensym
))
8944 if (!gensym
->attr
.generic
&& gensym
->ts
.type
!= BT_UNKNOWN
)
8946 gfc_error ("Derived type name %qs at %C already has a basic type "
8947 "of %s", gensym
->name
, gfc_typename (&gensym
->ts
));
8951 if (!gensym
->attr
.generic
8952 && !gfc_add_generic (&gensym
->attr
, gensym
->name
, NULL
))
8955 if (!gensym
->attr
.function
8956 && !gfc_add_function (&gensym
->attr
, gensym
->name
, NULL
))
8959 sym
= gfc_find_dt_in_generic (gensym
);
8961 if (sym
&& (sym
->components
!= NULL
|| sym
->attr
.zero_comp
))
8963 gfc_error ("Derived type definition of %qs at %C has already been "
8964 "defined", sym
->name
);
8970 /* Use upper case to save the actual derived-type symbol. */
8971 gfc_get_symbol (gfc_dt_upper_string (gensym
->name
), NULL
, &sym
);
8972 sym
->name
= gfc_get_string ("%s", gensym
->name
);
8973 head
= gensym
->generic
;
8974 intr
= gfc_get_interface ();
8976 intr
->where
= gfc_current_locus
;
8977 intr
->sym
->declared_at
= gfc_current_locus
;
8979 gensym
->generic
= intr
;
8980 gensym
->attr
.if_source
= IFSRC_DECL
;
8983 /* The symbol may already have the derived attribute without the
8984 components. The ways this can happen is via a function
8985 definition, an INTRINSIC statement or a subtype in another
8986 derived type that is a pointer. The first part of the AND clause
8987 is true if the symbol is not the return value of a function. */
8988 if (sym
->attr
.flavor
!= FL_DERIVED
8989 && !gfc_add_flavor (&sym
->attr
, FL_DERIVED
, sym
->name
, NULL
))
8992 if (attr
.access
!= ACCESS_UNKNOWN
8993 && !gfc_add_access (&sym
->attr
, attr
.access
, sym
->name
, NULL
))
8995 else if (sym
->attr
.access
== ACCESS_UNKNOWN
8996 && gensym
->attr
.access
!= ACCESS_UNKNOWN
8997 && !gfc_add_access (&sym
->attr
, gensym
->attr
.access
,
9001 if (sym
->attr
.access
!= ACCESS_UNKNOWN
9002 && gensym
->attr
.access
== ACCESS_UNKNOWN
)
9003 gensym
->attr
.access
= sym
->attr
.access
;
9005 /* See if the derived type was labeled as bind(c). */
9006 if (attr
.is_bind_c
!= 0)
9007 sym
->attr
.is_bind_c
= attr
.is_bind_c
;
9009 /* Construct the f2k_derived namespace if it is not yet there. */
9010 if (!sym
->f2k_derived
)
9011 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9013 if (extended
&& !sym
->components
)
9017 /* Add the extended derived type as the first component. */
9018 gfc_add_component (sym
, parent
, &p
);
9020 gfc_set_sym_referenced (extended
);
9022 p
->ts
.type
= BT_DERIVED
;
9023 p
->ts
.u
.derived
= extended
;
9024 p
->initializer
= gfc_default_initializer (&p
->ts
);
9026 /* Set extension level. */
9027 if (extended
->attr
.extension
== 255)
9029 /* Since the extension field is 8 bit wide, we can only have
9030 up to 255 extension levels. */
9031 gfc_error ("Maximum extension level reached with type %qs at %L",
9032 extended
->name
, &extended
->declared_at
);
9035 sym
->attr
.extension
= extended
->attr
.extension
+ 1;
9037 /* Provide the links between the extended type and its extension. */
9038 if (!extended
->f2k_derived
)
9039 extended
->f2k_derived
= gfc_get_namespace (NULL
, 0);
9042 if (!sym
->hash_value
)
9043 /* Set the hash for the compound name for this type. */
9044 sym
->hash_value
= gfc_hash_value (sym
);
9046 /* Take over the ABSTRACT attribute. */
9047 sym
->attr
.abstract
= attr
.abstract
;
9049 gfc_new_block
= sym
;
9055 /* Cray Pointees can be declared as:
9056 pointer (ipt, a (n,m,...,*)) */
9059 gfc_mod_pointee_as (gfc_array_spec
*as
)
9061 as
->cray_pointee
= true; /* This will be useful to know later. */
9062 if (as
->type
== AS_ASSUMED_SIZE
)
9063 as
->cp_was_assumed
= true;
9064 else if (as
->type
== AS_ASSUMED_SHAPE
)
9066 gfc_error ("Cray Pointee at %C cannot be assumed shape array");
9073 /* Match the enum definition statement, here we are trying to match
9074 the first line of enum definition statement.
9075 Returns MATCH_YES if match is found. */
9078 gfc_match_enum (void)
9082 m
= gfc_match_eos ();
9086 if (!gfc_notify_std (GFC_STD_F2003
, "ENUM and ENUMERATOR at %C"))
9093 /* Returns an initializer whose value is one higher than the value of the
9094 LAST_INITIALIZER argument. If the argument is NULL, the
9095 initializers value will be set to zero. The initializer's kind
9096 will be set to gfc_c_int_kind.
9098 If -fshort-enums is given, the appropriate kind will be selected
9099 later after all enumerators have been parsed. A warning is issued
9100 here if an initializer exceeds gfc_c_int_kind. */
9103 enum_initializer (gfc_expr
*last_initializer
, locus where
)
9106 result
= gfc_get_constant_expr (BT_INTEGER
, gfc_c_int_kind
, &where
);
9108 mpz_init (result
->value
.integer
);
9110 if (last_initializer
!= NULL
)
9112 mpz_add_ui (result
->value
.integer
, last_initializer
->value
.integer
, 1);
9113 result
->where
= last_initializer
->where
;
9115 if (gfc_check_integer_range (result
->value
.integer
,
9116 gfc_c_int_kind
) != ARITH_OK
)
9118 gfc_error ("Enumerator exceeds the C integer type at %C");
9124 /* Control comes here, if it's the very first enumerator and no
9125 initializer has been given. It will be initialized to zero. */
9126 mpz_set_si (result
->value
.integer
, 0);
9133 /* Match a variable name with an optional initializer. When this
9134 subroutine is called, a variable is expected to be parsed next.
9135 Depending on what is happening at the moment, updates either the
9136 symbol table or the current interface. */
9139 enumerator_decl (void)
9141 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9142 gfc_expr
*initializer
;
9143 gfc_array_spec
*as
= NULL
;
9151 old_locus
= gfc_current_locus
;
9153 /* When we get here, we've just matched a list of attributes and
9154 maybe a type and a double colon. The next thing we expect to see
9155 is the name of the symbol. */
9156 m
= gfc_match_name (name
);
9160 var_locus
= gfc_current_locus
;
9162 /* OK, we've successfully matched the declaration. Now put the
9163 symbol in the current namespace. If we fail to create the symbol,
9165 if (!build_sym (name
, NULL
, false, &as
, &var_locus
))
9171 /* The double colon must be present in order to have initializers.
9172 Otherwise the statement is ambiguous with an assignment statement. */
9175 if (gfc_match_char ('=') == MATCH_YES
)
9177 m
= gfc_match_init_expr (&initializer
);
9180 gfc_error ("Expected an initialization expression at %C");
9189 /* If we do not have an initializer, the initialization value of the
9190 previous enumerator (stored in last_initializer) is incremented
9191 by 1 and is used to initialize the current enumerator. */
9192 if (initializer
== NULL
)
9193 initializer
= enum_initializer (last_initializer
, old_locus
);
9195 if (initializer
== NULL
|| initializer
->ts
.type
!= BT_INTEGER
)
9197 gfc_error ("ENUMERATOR %L not initialized with integer expression",
9203 /* Store this current initializer, for the next enumerator variable
9204 to be parsed. add_init_expr_to_sym() zeros initializer, so we
9205 use last_initializer below. */
9206 last_initializer
= initializer
;
9207 t
= add_init_expr_to_sym (name
, &initializer
, &var_locus
);
9209 /* Maintain enumerator history. */
9210 gfc_find_symbol (name
, NULL
, 0, &sym
);
9211 create_enum_history (sym
, last_initializer
);
9213 return (t
) ? MATCH_YES
: MATCH_ERROR
;
9216 /* Free stuff up and return. */
9217 gfc_free_expr (initializer
);
9223 /* Match the enumerator definition statement. */
9226 gfc_match_enumerator_def (void)
9231 gfc_clear_ts (¤t_ts
);
9233 m
= gfc_match (" enumerator");
9237 m
= gfc_match (" :: ");
9238 if (m
== MATCH_ERROR
)
9241 colon_seen
= (m
== MATCH_YES
);
9243 if (gfc_current_state () != COMP_ENUM
)
9245 gfc_error ("ENUM definition statement expected before %C");
9246 gfc_free_enum_history ();
9250 (¤t_ts
)->type
= BT_INTEGER
;
9251 (¤t_ts
)->kind
= gfc_c_int_kind
;
9253 gfc_clear_attr (¤t_attr
);
9254 t
= gfc_add_flavor (¤t_attr
, FL_PARAMETER
, NULL
, NULL
);
9263 m
= enumerator_decl ();
9264 if (m
== MATCH_ERROR
)
9266 gfc_free_enum_history ();
9272 if (gfc_match_eos () == MATCH_YES
)
9274 if (gfc_match_char (',') != MATCH_YES
)
9278 if (gfc_current_state () == COMP_ENUM
)
9280 gfc_free_enum_history ();
9281 gfc_error ("Syntax error in ENUMERATOR definition at %C");
9286 gfc_free_array_spec (current_as
);
9293 /* Match binding attributes. */
9296 match_binding_attributes (gfc_typebound_proc
* ba
, bool generic
, bool ppc
)
9298 bool found_passing
= false;
9299 bool seen_ptr
= false;
9300 match m
= MATCH_YES
;
9302 /* Initialize to defaults. Do so even before the MATCH_NO check so that in
9303 this case the defaults are in there. */
9304 ba
->access
= ACCESS_UNKNOWN
;
9305 ba
->pass_arg
= NULL
;
9306 ba
->pass_arg_num
= 0;
9308 ba
->non_overridable
= 0;
9312 /* If we find a comma, we believe there are binding attributes. */
9313 m
= gfc_match_char (',');
9319 /* Access specifier. */
9321 m
= gfc_match (" public");
9322 if (m
== MATCH_ERROR
)
9326 if (ba
->access
!= ACCESS_UNKNOWN
)
9328 gfc_error ("Duplicate access-specifier at %C");
9332 ba
->access
= ACCESS_PUBLIC
;
9336 m
= gfc_match (" private");
9337 if (m
== MATCH_ERROR
)
9341 if (ba
->access
!= ACCESS_UNKNOWN
)
9343 gfc_error ("Duplicate access-specifier at %C");
9347 ba
->access
= ACCESS_PRIVATE
;
9351 /* If inside GENERIC, the following is not allowed. */
9356 m
= gfc_match (" nopass");
9357 if (m
== MATCH_ERROR
)
9363 gfc_error ("Binding attributes already specify passing,"
9364 " illegal NOPASS at %C");
9368 found_passing
= true;
9373 /* PASS possibly including argument. */
9374 m
= gfc_match (" pass");
9375 if (m
== MATCH_ERROR
)
9379 char arg
[GFC_MAX_SYMBOL_LEN
+ 1];
9383 gfc_error ("Binding attributes already specify passing,"
9384 " illegal PASS at %C");
9388 m
= gfc_match (" ( %n )", arg
);
9389 if (m
== MATCH_ERROR
)
9392 ba
->pass_arg
= gfc_get_string ("%s", arg
);
9393 gcc_assert ((m
== MATCH_YES
) == (ba
->pass_arg
!= NULL
));
9395 found_passing
= true;
9403 m
= gfc_match (" pointer");
9404 if (m
== MATCH_ERROR
)
9410 gfc_error ("Duplicate POINTER attribute at %C");
9420 /* NON_OVERRIDABLE flag. */
9421 m
= gfc_match (" non_overridable");
9422 if (m
== MATCH_ERROR
)
9426 if (ba
->non_overridable
)
9428 gfc_error ("Duplicate NON_OVERRIDABLE at %C");
9432 ba
->non_overridable
= 1;
9436 /* DEFERRED flag. */
9437 m
= gfc_match (" deferred");
9438 if (m
== MATCH_ERROR
)
9444 gfc_error ("Duplicate DEFERRED at %C");
9455 /* Nothing matching found. */
9457 gfc_error ("Expected access-specifier at %C");
9459 gfc_error ("Expected binding attribute at %C");
9462 while (gfc_match_char (',') == MATCH_YES
);
9464 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
9465 if (ba
->non_overridable
&& ba
->deferred
)
9467 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
9474 if (ba
->access
== ACCESS_UNKNOWN
)
9475 ba
->access
= gfc_typebound_default_access
;
9477 if (ppc
&& !seen_ptr
)
9479 gfc_error ("POINTER attribute is required for procedure pointer component"
9491 /* Match a PROCEDURE specific binding inside a derived type. */
9494 match_procedure_in_type (void)
9496 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9497 char target_buf
[GFC_MAX_SYMBOL_LEN
+ 1];
9498 char* target
= NULL
, *ifc
= NULL
;
9499 gfc_typebound_proc tb
;
9508 /* Check current state. */
9509 gcc_assert (gfc_state_stack
->state
== COMP_DERIVED_CONTAINS
);
9510 block
= gfc_state_stack
->previous
->sym
;
9513 /* Try to match PROCEDURE(interface). */
9514 if (gfc_match (" (") == MATCH_YES
)
9516 m
= gfc_match_name (target_buf
);
9517 if (m
== MATCH_ERROR
)
9521 gfc_error ("Interface-name expected after %<(%> at %C");
9525 if (gfc_match (" )") != MATCH_YES
)
9527 gfc_error ("%<)%> expected at %C");
9534 /* Construct the data structure. */
9535 memset (&tb
, 0, sizeof (tb
));
9536 tb
.where
= gfc_current_locus
;
9538 /* Match binding attributes. */
9539 m
= match_binding_attributes (&tb
, false, false);
9540 if (m
== MATCH_ERROR
)
9542 seen_attrs
= (m
== MATCH_YES
);
9544 /* Check that attribute DEFERRED is given if an interface is specified. */
9545 if (tb
.deferred
&& !ifc
)
9547 gfc_error ("Interface must be specified for DEFERRED binding at %C");
9550 if (ifc
&& !tb
.deferred
)
9552 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
9556 /* Match the colons. */
9557 m
= gfc_match (" ::");
9558 if (m
== MATCH_ERROR
)
9560 seen_colons
= (m
== MATCH_YES
);
9561 if (seen_attrs
&& !seen_colons
)
9563 gfc_error ("Expected %<::%> after binding-attributes at %C");
9567 /* Match the binding names. */
9570 m
= gfc_match_name (name
);
9571 if (m
== MATCH_ERROR
)
9575 gfc_error ("Expected binding name at %C");
9579 if (num
>1 && !gfc_notify_std (GFC_STD_F2008
, "PROCEDURE list at %C"))
9582 /* Try to match the '=> target', if it's there. */
9584 m
= gfc_match (" =>");
9585 if (m
== MATCH_ERROR
)
9591 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
9597 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
9602 m
= gfc_match_name (target_buf
);
9603 if (m
== MATCH_ERROR
)
9607 gfc_error ("Expected binding target after %<=>%> at %C");
9610 target
= target_buf
;
9613 /* If no target was found, it has the same name as the binding. */
9617 /* Get the namespace to insert the symbols into. */
9618 ns
= block
->f2k_derived
;
9621 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
9622 if (tb
.deferred
&& !block
->attr
.abstract
)
9624 gfc_error ("Type %qs containing DEFERRED binding at %C "
9625 "is not ABSTRACT", block
->name
);
9629 /* See if we already have a binding with this name in the symtree which
9630 would be an error. If a GENERIC already targeted this binding, it may
9631 be already there but then typebound is still NULL. */
9632 stree
= gfc_find_symtree (ns
->tb_sym_root
, name
);
9633 if (stree
&& stree
->n
.tb
)
9635 gfc_error ("There is already a procedure with binding name %qs for "
9636 "the derived type %qs at %C", name
, block
->name
);
9640 /* Insert it and set attributes. */
9644 stree
= gfc_new_symtree (&ns
->tb_sym_root
, name
);
9647 stree
->n
.tb
= gfc_get_typebound_proc (&tb
);
9649 if (gfc_get_sym_tree (target
, gfc_current_ns
, &stree
->n
.tb
->u
.specific
,
9652 gfc_set_sym_referenced (stree
->n
.tb
->u
.specific
->n
.sym
);
9653 gfc_add_flavor(&stree
->n
.tb
->u
.specific
->n
.sym
->attr
, FL_PROCEDURE
,
9654 target
, &stree
->n
.tb
->u
.specific
->n
.sym
->declared_at
);
9656 if (gfc_match_eos () == MATCH_YES
)
9658 if (gfc_match_char (',') != MATCH_YES
)
9663 gfc_error ("Syntax error in PROCEDURE statement at %C");
9668 /* Match a GENERIC procedure binding inside a derived type. */
9671 gfc_match_generic (void)
9673 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9674 char bind_name
[GFC_MAX_SYMBOL_LEN
+ 16]; /* Allow space for OPERATOR(...). */
9676 gfc_typebound_proc tbattr
; /* Used for match_binding_attributes. */
9677 gfc_typebound_proc
* tb
;
9679 interface_type op_type
;
9680 gfc_intrinsic_op op
;
9683 /* Check current state. */
9684 if (gfc_current_state () == COMP_DERIVED
)
9686 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
9689 if (gfc_current_state () != COMP_DERIVED_CONTAINS
)
9691 block
= gfc_state_stack
->previous
->sym
;
9692 ns
= block
->f2k_derived
;
9693 gcc_assert (block
&& ns
);
9695 memset (&tbattr
, 0, sizeof (tbattr
));
9696 tbattr
.where
= gfc_current_locus
;
9698 /* See if we get an access-specifier. */
9699 m
= match_binding_attributes (&tbattr
, true, false);
9700 if (m
== MATCH_ERROR
)
9703 /* Now the colons, those are required. */
9704 if (gfc_match (" ::") != MATCH_YES
)
9706 gfc_error ("Expected %<::%> at %C");
9710 /* Match the binding name; depending on type (operator / generic) format
9711 it for future error messages into bind_name. */
9713 m
= gfc_match_generic_spec (&op_type
, name
, &op
);
9714 if (m
== MATCH_ERROR
)
9718 gfc_error ("Expected generic name or operator descriptor at %C");
9724 case INTERFACE_GENERIC
:
9725 case INTERFACE_DTIO
:
9726 snprintf (bind_name
, sizeof (bind_name
), "%s", name
);
9729 case INTERFACE_USER_OP
:
9730 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(.%s.)", name
);
9733 case INTERFACE_INTRINSIC_OP
:
9734 snprintf (bind_name
, sizeof (bind_name
), "OPERATOR(%s)",
9735 gfc_op2string (op
));
9738 case INTERFACE_NAMELESS
:
9739 gfc_error ("Malformed GENERIC statement at %C");
9747 /* Match the required =>. */
9748 if (gfc_match (" =>") != MATCH_YES
)
9750 gfc_error ("Expected %<=>%> at %C");
9754 /* Try to find existing GENERIC binding with this name / for this operator;
9755 if there is something, check that it is another GENERIC and then extend
9756 it rather than building a new node. Otherwise, create it and put it
9757 at the right position. */
9761 case INTERFACE_DTIO
:
9762 case INTERFACE_USER_OP
:
9763 case INTERFACE_GENERIC
:
9765 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9768 st
= gfc_find_symtree (is_op
? ns
->tb_uop_root
: ns
->tb_sym_root
, name
);
9769 tb
= st
? st
->n
.tb
: NULL
;
9773 case INTERFACE_INTRINSIC_OP
:
9783 if (!tb
->is_generic
)
9785 gcc_assert (op_type
== INTERFACE_GENERIC
);
9786 gfc_error ("There's already a non-generic procedure with binding name"
9787 " %qs for the derived type %qs at %C",
9788 bind_name
, block
->name
);
9792 if (tb
->access
!= tbattr
.access
)
9794 gfc_error ("Binding at %C must have the same access as already"
9795 " defined binding %qs", bind_name
);
9801 tb
= gfc_get_typebound_proc (NULL
);
9802 tb
->where
= gfc_current_locus
;
9803 tb
->access
= tbattr
.access
;
9805 tb
->u
.generic
= NULL
;
9809 case INTERFACE_DTIO
:
9810 case INTERFACE_GENERIC
:
9811 case INTERFACE_USER_OP
:
9813 const bool is_op
= (op_type
== INTERFACE_USER_OP
);
9814 gfc_symtree
* st
= gfc_get_tbp_symtree (is_op
? &ns
->tb_uop_root
:
9815 &ns
->tb_sym_root
, name
);
9822 case INTERFACE_INTRINSIC_OP
:
9831 /* Now, match all following names as specific targets. */
9834 gfc_symtree
* target_st
;
9835 gfc_tbp_generic
* target
;
9837 m
= gfc_match_name (name
);
9838 if (m
== MATCH_ERROR
)
9842 gfc_error ("Expected specific binding name at %C");
9846 target_st
= gfc_get_tbp_symtree (&ns
->tb_sym_root
, name
);
9848 /* See if this is a duplicate specification. */
9849 for (target
= tb
->u
.generic
; target
; target
= target
->next
)
9850 if (target_st
== target
->specific_st
)
9852 gfc_error ("%qs already defined as specific binding for the"
9853 " generic %qs at %C", name
, bind_name
);
9857 target
= gfc_get_tbp_generic ();
9858 target
->specific_st
= target_st
;
9859 target
->specific
= NULL
;
9860 target
->next
= tb
->u
.generic
;
9861 target
->is_operator
= ((op_type
== INTERFACE_USER_OP
)
9862 || (op_type
== INTERFACE_INTRINSIC_OP
));
9863 tb
->u
.generic
= target
;
9865 while (gfc_match (" ,") == MATCH_YES
);
9867 /* Here should be the end. */
9868 if (gfc_match_eos () != MATCH_YES
)
9870 gfc_error ("Junk after GENERIC binding at %C");
9881 /* Match a FINAL declaration inside a derived type. */
9884 gfc_match_final_decl (void)
9886 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
9889 gfc_namespace
* module_ns
;
9893 if (gfc_current_form
== FORM_FREE
)
9895 char c
= gfc_peek_ascii_char ();
9896 if (!gfc_is_whitespace (c
) && c
!= ':')
9900 if (gfc_state_stack
->state
!= COMP_DERIVED_CONTAINS
)
9902 if (gfc_current_form
== FORM_FIXED
)
9905 gfc_error ("FINAL declaration at %C must be inside a derived type "
9906 "CONTAINS section");
9910 block
= gfc_state_stack
->previous
->sym
;
9913 if (!gfc_state_stack
->previous
|| !gfc_state_stack
->previous
->previous
9914 || gfc_state_stack
->previous
->previous
->state
!= COMP_MODULE
)
9916 gfc_error ("Derived type declaration with FINAL at %C must be in the"
9917 " specification part of a MODULE");
9921 module_ns
= gfc_current_ns
;
9922 gcc_assert (module_ns
);
9923 gcc_assert (module_ns
->proc_name
->attr
.flavor
== FL_MODULE
);
9925 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
9926 if (gfc_match (" ::") == MATCH_ERROR
)
9929 /* Match the sequence of procedure names. */
9936 if (first
&& gfc_match_eos () == MATCH_YES
)
9938 gfc_error ("Empty FINAL at %C");
9942 m
= gfc_match_name (name
);
9945 gfc_error ("Expected module procedure name at %C");
9948 else if (m
!= MATCH_YES
)
9951 if (gfc_match_eos () == MATCH_YES
)
9953 if (!last
&& gfc_match_char (',') != MATCH_YES
)
9955 gfc_error ("Expected %<,%> at %C");
9959 if (gfc_get_symbol (name
, module_ns
, &sym
))
9961 gfc_error ("Unknown procedure name %qs at %C", name
);
9965 /* Mark the symbol as module procedure. */
9966 if (sym
->attr
.proc
!= PROC_MODULE
9967 && !gfc_add_procedure (&sym
->attr
, PROC_MODULE
, sym
->name
, NULL
))
9970 /* Check if we already have this symbol in the list, this is an error. */
9971 for (f
= block
->f2k_derived
->finalizers
; f
; f
= f
->next
)
9972 if (f
->proc_sym
== sym
)
9974 gfc_error ("%qs at %C is already defined as FINAL procedure",
9979 /* Add this symbol to the list of finalizers. */
9980 gcc_assert (block
->f2k_derived
);
9982 f
= XCNEW (gfc_finalizer
);
9984 f
->proc_tree
= NULL
;
9985 f
->where
= gfc_current_locus
;
9986 f
->next
= block
->f2k_derived
->finalizers
;
9987 block
->f2k_derived
->finalizers
= f
;
9997 const ext_attr_t ext_attr_list
[] = {
9998 { "dllimport", EXT_ATTR_DLLIMPORT
, "dllimport" },
9999 { "dllexport", EXT_ATTR_DLLEXPORT
, "dllexport" },
10000 { "cdecl", EXT_ATTR_CDECL
, "cdecl" },
10001 { "stdcall", EXT_ATTR_STDCALL
, "stdcall" },
10002 { "fastcall", EXT_ATTR_FASTCALL
, "fastcall" },
10003 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK
, NULL
},
10004 { NULL
, EXT_ATTR_LAST
, NULL
}
10007 /* Match a !GCC$ ATTRIBUTES statement of the form:
10008 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
10009 When we come here, we have already matched the !GCC$ ATTRIBUTES string.
10011 TODO: We should support all GCC attributes using the same syntax for
10012 the attribute list, i.e. the list in C
10013 __attributes(( attribute-list ))
10015 !GCC$ ATTRIBUTES attribute-list ::
10016 Cf. c-parser.c's c_parser_attributes; the data can then directly be
10019 As there is absolutely no risk of confusion, we should never return
10022 gfc_match_gcc_attributes (void)
10024 symbol_attribute attr
;
10025 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
10030 gfc_clear_attr (&attr
);
10035 if (gfc_match_name (name
) != MATCH_YES
)
10036 return MATCH_ERROR
;
10038 for (id
= 0; id
< EXT_ATTR_LAST
; id
++)
10039 if (strcmp (name
, ext_attr_list
[id
].name
) == 0)
10042 if (id
== EXT_ATTR_LAST
)
10044 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
10045 return MATCH_ERROR
;
10048 if (!gfc_add_ext_attribute (&attr
, (ext_attr_id_t
)id
, &gfc_current_locus
))
10049 return MATCH_ERROR
;
10051 gfc_gobble_whitespace ();
10052 ch
= gfc_next_ascii_char ();
10055 /* This is the successful exit condition for the loop. */
10056 if (gfc_next_ascii_char () == ':')
10066 if (gfc_match_eos () == MATCH_YES
)
10071 m
= gfc_match_name (name
);
10072 if (m
!= MATCH_YES
)
10075 if (find_special (name
, &sym
, true))
10076 return MATCH_ERROR
;
10078 sym
->attr
.ext_attr
|= attr
.ext_attr
;
10080 if (gfc_match_eos () == MATCH_YES
)
10083 if (gfc_match_char (',') != MATCH_YES
)
10090 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
10091 return MATCH_ERROR
;